packages feed

streamly 0.7.3.2 → 0.8.0

raw patch · 352 files changed

+70872/−40853 lines, 352 filesdep +Win32dep −QuickCheckdep −SDLdep −clockdep ~basedep ~ghc-primdep ~primitivebinary-added

Dependencies added: Win32

Dependencies removed: QuickCheck, SDL, clock, fusion-plugin, ghc, hashable, hspec, http-conduit, random, semigroups, streamly, unliftio-core, unordered-containers, vector

Dependency ranges changed: base, ghc-prim, primitive

Files

+ .circleci/config.yml view
@@ -0,0 +1,417 @@+version: 2.1++#-----------------------------------------------------------------------------+# packcheck-0.4.2+# Packcheck global environment variables+#-----------------------------------------------------------------------------++env: &env+    environment:+      # ------------------------------------------------------------------------+      # Common options+      # ------------------------------------------------------------------------+      # GHC_OPTIONS: "-Werror"+      CABAL_REINIT_CONFIG: "y"+      LC_ALL: "C.UTF-8"++      # ------------------------------------------------------------------------+      # What to build+      # ------------------------------------------------------------------------+      # DISABLE_TEST: "y"+      # DISABLE_BENCH: "y"+      # DISABLE_DOCS: "y"+      # DISABLE_SDIST_BUILD: "y"+      # DISABLE_DIST_CHECKS: "y"+      ENABLE_INSTALL: "y"++      # ------------------------------------------------------------------------+      # stack options+      # ------------------------------------------------------------------------+      # Note requiring a specific version of stack using STACKVER may fail due to+      # github API limit while checking and upgrading/downgrading to the specific+      # version.+      #STACKVER: "1.6.5"+      STACK_UPGRADE: "y"+      #RESOLVER: "lts-12"++      # ------------------------------------------------------------------------+      # cabal options+      # ------------------------------------------------------------------------+      CABAL_CHECK_RELAX: "y"+      CABAL_NO_SANDBOX: "y"+      CABAL_HACKAGE_MIRROR: "hackage.haskell.org:http://hackage.fpcomplete.com"+      CABAL_BUILD_OPTIONS: "--flag limit-build-mem"++      # ------------------------------------------------------------------------+      # Where to find the required tools+      # ------------------------------------------------------------------------+      PATH: /opt/ghc/bin:/opt/ghcjs/bin:/sbin:/usr/sbin:/bin:/usr/bin+      TOOLS_DIR: /opt++      # ------------------------------------------------------------------------+      # Location of packcheck.sh (the shell script invoked to perform CI tests ).+      # ------------------------------------------------------------------------+      # You can either commit the packcheck.sh script at this path in your repo or+      # you can use it by specifying the PACKCHECK_REPO_URL option below in which+      # case it will be automatically copied from the packcheck repo to this path+      # during CI tests. In any case it is finally invoked from this path.+      PACKCHECK: "./packcheck.sh"+      # If you have not committed packcheck.sh in your repo at PACKCHECK+      # then it is automatically pulled from this URL.+      PACKCHECK_GITHUB_URL: "https://raw.githubusercontent.com/composewell/packcheck"+      PACKCHECK_GITHUB_COMMIT: "35efa99b2082d13722b8a0183ac6455df98e91b9"++executors:+  amd64-executor:+    docker:+      - image: ubuntu:xenial+  x86-executor:+    docker:+      - image: i386/ubuntu:eoan++#-----------------------------------------------------------------------------+# Common utility stuff, not to be modified usually+#-----------------------------------------------------------------------------++preinstall: &preinstall+  run: |+        apt-get update+        # required for https/cache save and restore+        apt-get install -y ca-certificates++        # required to (re)generate the configure script+        apt-get install -y autoconf++        # For ghc and cabal-install packages from hvr's ppa+        # gnupg is required for apt-key to work+        apt-get install -y gnupg+        apt-get install -y apt-transport-https+        apt-key adv --keyserver keyserver.ubuntu.com  --recv-keys BA3CBA3FFE22B574+        apt-get install -y software-properties-common+        add-apt-repository -y ppa:hvr/ghc+        # echo "deb http://downloads.haskell.org/debian stretch main" >> /etc/apt/sources.list+        echo "deb-src http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main" >> /etc/apt/sources.list+        apt-get update++        # required for packcheck+        apt-get install -y curl++        # required for circleci.+        apt-get install -y libcurl4-gnutls-dev+        apt-get install -y git+        apt-get install -y libtinfo-dev++        # required for outbound https for stack and for stack setup+        apt-get install -y netbase xz-utils make++project-preinstall: &project-preinstall+  run: |+        # Get packcheck if needed+        CURL=$(which curl)+        PACKCHECK_URL=${PACKCHECK_GITHUB_URL}/${PACKCHECK_GITHUB_COMMIT}/packcheck.sh+        if test ! -e "$PACKCHECK"; then $CURL -sL -o "$PACKCHECK" $PACKCHECK_URL; fi;+        chmod +x $PACKCHECK++restore: &restore+  # Needs to happen after installing ca-certificates+  restore_cache:+    keys:+      - v1-{{ .Environment.CIRCLE_JOB }}-{{ .Branch }}+      # Fallback to master branch's cache.+      - v1-{{ .Environment.CIRCLE_JOB }}-master+      # Fallback to any branch's cache.+      - v1-{{ .Environment.CIRCLE_JOB }}-++save: &save+  save_cache:+      key: v1-{{ .Environment.CIRCLE_JOB }}-{{ .Branch }}+      paths:+        - ~/.cabal+        - ~/.ghc+        - ~/.local+        - ~/.stack++#-----------------------------------------------------------------------------+# Build matrix+#-----------------------------------------------------------------------------++jobs:+  cabal-ghc-8_10_4:+      <<: *env+      executor: amd64-executor+      steps:+        - *preinstall+        - checkout+        - *project-preinstall+        - *restore+        - run:+            environment:+              DISABLE_TEST: "yes"+              DISABLE_BENCH: "yes"+              DISABLE_DIST_CHECKS: "yes"+            command: |+              apt-get install -y ghc-8.10.4+              apt-get install -y cabal-install-3.4+              bash -c "$PACKCHECK cabal"+        - *save+  stack-ghc-8_8:+      <<: *env+      executor: amd64-executor+      steps:+        - *preinstall+        - checkout+        - *project-preinstall+        - *restore+        - run:+            name: GHC 8.8 + stack lts-16.12+            environment:+              BUILD: "stack"+              RESOLVER: "lts-16.12"+              SDIST_OPTIONS: "--ignore-check"+              STACK_BUILD_OPTIONS: "--flag streamly-benchmarks:-opt"+            command: |+              apt-get build-dep -y ghc-8.8.4+              apt-get install -y cabal-install-3.2+              bash -c "$PACKCHECK $BUILD"+        - *save+  cabal-ghc-8_6_5:+      <<: *env+      executor: amd64-executor+      steps:+        - *preinstall+        - checkout+        - *project-preinstall+        - *restore+        - run: |+              apt-get install -y ghc-8.6.3+              apt-get install -y cabal-install-2.4+              bash -c "$PACKCHECK cabal-v2"+        - *save+  cabal-ghc-8_4_4:+      <<: *env+      executor: x86-executor+      steps:+        - *preinstall+        - checkout+        - *project-preinstall+        - *restore+        - run:+           name: GHC 8.4.4 + x86 + debug+           environment:+             BUILD: "cabal-v2"+             GHCVER: "8.4.4"+             CABAL_BUILD_OPTIONS: "--flag debug --flag limit-build-mem"+           command: |+              apt-get install -y ghc-8.4.4+              apt-get install -y cabal-install-3.2+              bash -c "$PACKCHECK $BUILD"+        - *save+  cabal-ghc-8_2_2:+      <<: *env+      executor: amd64-executor+      steps:+        - *preinstall+        - checkout+        - *project-preinstall+        - *restore+        - run:+            environment:+              BUILD: "cabal-v2"+              DISABLE_TEST: "yes"+              DISABLE_BENCH: "yes"+              DISABLE_DOCS: "yes"+              DISABLE_SDIST_BUILD: "yes"+              DISABLE_DIST_CHECKS: "yes"+            command: |+              apt-get install -y ghc-8.2.2+              apt-get install -y cabal-install-3.2+              bash -c "$PACKCHECK $BUILD"+        - *save+  cabal-ghc-8_0_2:+      <<: *env+      executor: amd64-executor+      steps:+        - *preinstall+        - checkout+        - *project-preinstall+        - *restore+        - run:+            environment:+              BUILD: "cabal-v2"+              DISABLE_TEST: "yes"+              DISABLE_BENCH: "yes"+              DISABLE_DOCS: "yes"+              DISABLE_SDIST_BUILD: "yes"+              DISABLE_DIST_CHECKS: "yes"+            command: |+              apt-get install -y ghc-8.0.2+              apt-get install -y cabal-install-3.2+              bash -c "$PACKCHECK $BUILD"+        - *save+  cabal-ghc-7_10_3:+      <<: *env+      executor: amd64-executor+      steps:+        - *preinstall+        - checkout+        - *project-preinstall+        - *restore+        - run: |+              apt-get install -y ghc-7.10.3+              apt-get install -y cabal-install-2.4+              bash -c "$PACKCHECK cabal-v2"+        - *save+  stack-ghc-8_4:+      <<: *env+      executor: amd64-executor+      steps:+        - *preinstall+        - checkout+        - *project-preinstall+        - *restore+        - run: |+            bash -c "$PACKCHECK stack RESOLVER=lts-12"+        - *save+  stack-ghc-8_2:+      <<: *env+      executor: amd64-executor+      steps:+        - *preinstall+        - checkout+        - *project-preinstall+        - *restore+        - run: |+            bash -c "$PACKCHECK stack RESOLVER=lts-11"+        - *save+  cabal-ghcjs-8_4:+      <<: *env+      executor: amd64-executor+      steps:+        - *preinstall+        - checkout+        - *project-preinstall+        - *restore+        - run:+            name: GHCJS 8.4+no-test+no-docs+            environment:+              BUILD: cabal-v2+              ENABLE_GHCJS: "yes"+              DISABLE_TEST: "yes"+              ENABLE_INSTALL: ""+              DISABLE_DOCS: "yes"+              DISABLE_SDIST_BUILD: "yes"+            command: |+              add-apt-repository -y ppa:hvr/ghcjs+              add-apt-repository -y 'deb https://deb.nodesource.com/node_11.x xenial main'+              curl -sSL https://deb.nodesource.com/gpgkey/nodesource.gpg.key | apt-key add -+              apt-get update+              apt-get install -y cabal-install-3.2+              apt-get install -y nodejs+              apt-get install -y ghcjs-8.4+              cabal user-config update -a "jobs: 1"+              bash -c "$PACKCHECK $BUILD"+        - *save+  coveralls-ghc-8_2_2:+      <<: *env+      executor: amd64-executor+      steps:+        - *preinstall+        - checkout+        - *project-preinstall+        - *restore+        - run:+            environment:+              BUILD: cabal+              COVERALLS_OPTIONS: "--repo-token=\"$REPO_TOKEN\" --coverage-mode=StrictlyFullLines --exclude-dir=test test"+              GHC_OPTIONS: "-DCOVERAGE_BUILD"+            command: |+              apt-get install -y ghc-8.2.2+              apt-get install -y cabal-install-2.4+              bash -c "$PACKCHECK cabal-v1"+        - *save+  coveralls-ghc-8_8_3:+      <<: *env+      executor: amd64-executor+      steps:+        - *preinstall+        - checkout+        - *project-preinstall+        - *restore+        - run:+            environment:+              BUILD: cabal-v2+              COVERALLS_OPTIONS: "--repo-token=\"$REPO_TOKEN\" --coverage-mode=StrictlyFullLines --exclude-dir=test"+              CABAL_PROJECT: "cabal.project.coverage"+              CABAL_BUILD_TARGETS: ""+            command: |+              apt-get install -y ghc-8.8.3+              apt-get install -y cabal-install-3.0+              bash -c "$PACKCHECK cabal-v2"+            no_output_timeout: 25m+        - *save+  coveralls-ghc-8_10_2:+      <<: *env+      executor: amd64-executor+      steps:+        - *preinstall+        - checkout+        - *project-preinstall+        - *restore+        - run:+            name: Build and test with inspection, coverage, Werror+            command: |+              apt-get install -y ghc-8.10.2+              apt-get install -y cabal-install-3.2+              # Run tests with coverage+              cabal update+              cabal user-config update -a "jobs: 1"+              bin/test.sh --coverage --raw+              # Upload results to coveralls.io+              PATH=$HOME/.cabal/bin:$PATH+              export PATH+              which hpc-coveralls 2>/dev/null || cabal install --project-file cabal.project.hpc-coveralls hpc-coveralls+              hpc-coveralls --repo-token="$REPO_TOKEN" --coverage-mode=StrictlyFullLines+            no_output_timeout: 25m+        - *save+  hlint-src:+      <<: *env+      executor: amd64-executor+      steps:+        - *preinstall+        - checkout+        - *project-preinstall+        - *restore+        - run:+            name: Hlint src+            environment:+              BUILD: cabal-v2+              HLINT_OPTIONS: lint --cpp-include=src --cpp-include=test+              HLINT_TARGETS: src test benchmark+            command: |+              bash -c "$PACKCHECK $BUILD"+        - *save++workflows:+  version: 2+  build:+    jobs:+      - cabal-ghc-8_10_4:+          name: GHC 8.10.4 + sdist+      #- cabal-ghc-8.6.5+      #- cabal-ghc-8_4_4:+      #    name: GHC 8.4.4 + x86 + debug+      - cabal-ghc-8_2_2:+          name: GHC 8.2.2 + no-test + no-bench + no-docs+      - cabal-ghc-8_0_2:+          name: GHC 8.0.2 + no-test + no-bench + no-docs+      #- cabal-ghc-7.10.3+      - cabal-ghcjs-8_4:+          name: GHCJS 8.4 + no-test + no-docs+      #- stack-ghc-8.4+      #- stack-ghc-8.2+      #- coveralls-ghc-8.2.2+      #- coveralls-ghc-8.8.3+      #- coveralls-ghc-8_10_2:+      #    name: GHC 8.10.2 + inspection + coverage + Werror+      - hlint-src:+          name: Hlint src
+ .ghci view
@@ -0,0 +1,1 @@+:set -fobject-code
+ .github/workflows/haskell.yml view
@@ -0,0 +1,160 @@+name: Haskell CI++on:+  push:+    branches:+      - master+  pull_request:++jobs:+  build:+    name: GHC ${{ matrix.name }}+    env:+      # packcheck environment variables+      LC_ALL: C.UTF-8+      BUILD: ${{ matrix.build }}+      GHCVER: ${{ matrix.ghc_version }}+      DISABLE_DOCS: ${{ matrix.disable_docs }}+      DISABLE_TEST: ${{ matrix.disable_test }}+      DISABLE_DIST_CHECKS: ${{ matrix.disable_dist_checks }}+      SDIST_OPTIONS: ${{ matrix.sdist_options }}+      DISABLE_SDIST_BUILD: ${{ matrix.disable_sdist_build }}++      # Cabal options+      CABAL_REINIT_CONFIG: y+      # Github has machines with 2 CPUS and 6GB memory so the cabal jobs+      # default (ncpus) is good, this can be checked from the packcheck+      # output in case it changes.+      CABAL_BUILD_OPTIONS: ${{ matrix.cabal_build_options }} --flag limit-build-mem+      CABAL_BUILD_TARGETS: ${{ matrix.cabal_build_targets }}+      CABAL_PROJECT: ${{ matrix.cabal_project }}+      CABAL_CHECK_RELAX: y++      # Stack options+      STACK_UPGRADE: "y"+      RESOLVER: ${{ matrix.resolver }}+      STACK_YAML: ${{ matrix.stack_yaml }}+      STACK_BUILD_OPTIONS: ${{ matrix.stack_build_options }}++      # packcheck location and revision+      PACKCHECK_LOCAL_PATH: "./packcheck.sh"+      PACKCHECK_GITHUB_URL: "https://raw.githubusercontent.com/composewell/packcheck"+      PACKCHECK_GITHUB_COMMIT: "35efa99b2082d13722b8a0183ac6455df98e91b9"++      # Pull token from "secrets" setting of the github repo+      COVERALLS_TOKEN: ${{ secrets.COVERALLS_TOKEN }}+      COVERAGE: ${{ matrix.coverage }}++    runs-on: ${{ matrix.runner }}+    strategy:+      fail-fast: false+      matrix:+        name:+          - 9.0.1+          - 8.10.4+stack+          - 8.10.4+macOS+          - 8.10.4+linux+coverage+cabal+          - 8.8.4+          - 8.8.4+inspection+fusion-plugin+Werror+          - 8.6.5+fusion-plugin+          - 8.6.5+streamk+          - 8.4.4+debug+        cabal_version: ["3.4"]+        include:+          - name: 9.0.1+            ghc_version: 9.0.1+            build: cabal-v2+            cabal_build_options: "--allow-newer=hsc2hs"+            disable_sdist_build: "y"+            runner: ubuntu-latest+          - name: 8.10.4+stack+            build: stack+            resolver: lts-18.0+            stack_yaml: stack.yaml+            sdist_options: "--ignore-check"+            stack_build_options: "--flag streamly-benchmarks:-opt"+            runner: ubuntu-latest+          - name: 8.10.4+macOS+            ghc_version: 8.10.4+            build: cabal-v2+            disable_sdist_build: "y"+            runner: macos-latest+          - name: 8.10.4+linux+coverage+cabal+            ghc_version: 8.10.4+            coverage: "y"+            runner: ubuntu-latest+          - name: 8.8.4+inspection+fusion-plugin+Werror+            ghc_version: 8.8.4+            build: cabal-v2+            cabal_project: cabal.project.Werror+            cabal_build_options: "--flag fusion-plugin --flag inspection"+            runner: ubuntu-latest+          - name: 8.8.4+            ghc_version: 8.8.4+            build: cabal+            cabal_project: cabal.project+            cabal_build_options: "--flag -opt"+            runner: ubuntu-latest+          - name: 8.6.5+streamk+            ghc_version: 8.6.5+            build: cabal-v2+            cabal_project: cabal.project+            cabal_build_options: "--flag streamk --flag -opt"+            runner: ubuntu-latest+          - name: 8.6.5+fusion-plugin+            ghc_version: 8.6.5+            build: cabal-v2+            cabal_project: cabal.project+            cabal_build_options: "--flag fusion-plugin"+            # haddock generation does not work with 8.6.5+fusion-plugin+            disable_docs: "y"+            runner: ubuntu-latest+          - name: 8.4.4+debug+            ghc_version: 8.4.4+            build: cabal-v2+            cabal_project: cabal.project+            cabal_build_options: "--flag debug --flag -opt"+            runner: ubuntu-latest++    steps:+    - uses: actions/checkout@v2++    - uses: haskell/actions/setup@v1+      with:+        ghc-version: ${{ matrix.ghc_version }}+        cabal-version: ${{ matrix.cabal_version }}++    - uses: actions/cache@v1+      name: Cache ~/.cabal+      with:+        path: ~/.cabal+        # Bump the key version to clear the cache+        key: ${{ runner.os }}-${{ matrix.ghc_version }}-cabal-v1++    - name: Download packcheck+      run: |+        # Get packcheck if needed+        CURL=$(which curl)+        PACKCHECK_URL=${PACKCHECK_GITHUB_URL}/${PACKCHECK_GITHUB_COMMIT}/packcheck.sh+        if test ! -e "$PACKCHECK_LOCAL_PATH"; then $CURL -sL -o "$PACKCHECK_LOCAL_PATH" $PACKCHECK_URL; fi;+        chmod +x $PACKCHECK_LOCAL_PATH++    - name: Run tests+      run: |+        if test -z "$COVERAGE"+        then+          export TOOLS_DIR=/opt+          # /usr/local/opt/curl/bin for macOS+          export PATH=$HOME/.local/bin:$HOME/.ghcup/bin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin:/usr/local/opt/curl/bin+          bash -c "$PACKCHECK_LOCAL_PATH $BUILD"+        else+          # Run tests with coverage+          cabal update+          # Build hpc-coveralls if needed+          sudo apt-get install -y libcurl4-gnutls-dev+          export PATH=$HOME/.cabal/bin:$PATH+          which hpc-coveralls 2>/dev/null || cabal install --project-file cabal.project.hpc-coveralls hpc-coveralls+          # Run tests and upload results to coveralls.io+          bin/test.sh --coverage --raw+          hpc-coveralls --repo-token="$COVERALLS_TOKEN" --coverage-mode=StrictlyFullLines+        fi
+ .gitignore view
@@ -0,0 +1,17 @@+# Build files/directories+/.stack-work/+/dist/+/dist-newstyle*/++# Local GHC and Cabal related files+.ghc.environment*+cabal.project.local++# Temp files created by Vim/Neovim+*.swp+*.swo+*~++# Other+.log+_doctests/
+ .hlint.ignore view
@@ -0,0 +1,66 @@+src/Streamly/Internal/Data/Stream/SVar.hs+src/Streamly/Internal/Data/Stream/Serial.hs+src/Streamly/Internal/Data/Stream/Zip.hs+src/Streamly/Internal/Data/Stream/Parallel.hs+src/Streamly/Internal/Data/Stream/Async.hs+src/Streamly/Internal/Data/Stream/StreamDK.hs+src/Streamly/Internal/Data/Stream/StreamK.hs+src/Streamly/Internal/Data/Stream/StreamK/Type.hs+src/Streamly/Internal/Data/Stream/Ahead.hs+src/Streamly/Internal/Data/Stream/StreamD/Type.hs+src/Streamly/Internal/Data/Stream/StreamDK/Type.hs+src/Streamly/Internal/Data/Stream/StreamD.hs+src/Streamly/Internal/Data/Stream/StreamD/Generate.hs+src/Streamly/Internal/Data/Stream/StreamD/Eliminate.hs+src/Streamly/Internal/Data/Stream/StreamD/Transform.hs+src/Streamly/Internal/Data/Stream/StreamD/Exception.hs+src/Streamly/Internal/Data/Stream/StreamD/Lift.hs+src/Streamly/Internal/Data/Stream/StreamD/Nesting.hs+src/Streamly/Internal/Data/Pipe/Type.hs+src/Streamly/Internal/Data/SmallArray/Type.hs+src/Streamly/Internal/Unicode/Stream.hs+src/Streamly/Internal/Data/IORef/Prim.hs+src/Streamly/Internal/Data/Array/Prim/Type.hs+src/Streamly/Internal/Data/Array/Prim/Mut/Type.hs+src/Streamly/Internal/Data/Array/Prim/MutTypesInclude.hs+src/Streamly/Internal/Data/Array/Prim/Pinned/Mut/Type.hs+src/Streamly/Internal/Data/Array/Prim/Pinned/Type.hs+src/Streamly/Internal/Data/Array/Prim/TypesInclude.hs+test/Streamly/Test/Common/Array.hs+test/Streamly/Test/Data/Array.hs+test/Streamly/Test/Data/Array/Prim.hs+test/Streamly/Test/Data/Array/Prim/Pinned.hs+test/Streamly/Test/Data/Array/Foreign.hs+test/Streamly/Test/Data/Parser.hs+test/Streamly/Test/Data/Parser/ParserD.hs+test/Streamly/Test/Data/SmallArray.hs+test/Streamly/Test/Data/Unfold.hs+test/Streamly/Test/FileSystem/Event.hs+test/Streamly/Test/Prelude/Concurrent.hs+test/Streamly/Test/Prelude/Fold.hs+test/Streamly/Test/Prelude/Rate.hs+test/Streamly/Test/Prelude/Serial.hs+test/Streamly/Test/Unicode/Stream.hs+benchmark/lib/Streamly/Benchmark/Common.hs+benchmark/lib/Streamly/Benchmark/Common/Handle.hs+benchmark/lib/Streamly/Benchmark/Prelude.hs+benchmark/NanoBenchmarks.hs+benchmark/Streamly/Benchmark/Data/Array.hs+benchmark/Streamly/Benchmark/Data/ArrayOps.hs+benchmark/Streamly/Benchmark/Data/NestedUnfoldOps.hs+benchmark/Streamly/Benchmark/Data/Parser.hs+benchmark/Streamly/Benchmark/Data/Parser/ParserD.hs+benchmark/Streamly/Benchmark/Data/Stream/StreamDK.hs+benchmark/Streamly/Benchmark/Data/Stream/StreamK.hs+benchmark/Streamly/Benchmark/Data/Unfold.hs+benchmark/Streamly/Benchmark/FileSystem/Handle.hs+benchmark/Streamly/Benchmark/Prelude/Async.hs+benchmark/Streamly/Benchmark/Prelude/Parallel.hs+benchmark/Streamly/Benchmark/Prelude/Rate.hs+benchmark/Streamly/Benchmark/Prelude/Serial/Exceptions.hs+benchmark/Streamly/Benchmark/Prelude/Serial/Nested.hs+benchmark/Streamly/Benchmark/Prelude/Serial/Split.hs+benchmark/Streamly/Benchmark/Prelude/Serial/Transformation1.hs+benchmark/Streamly/Benchmark/Prelude/WAsync.hs+benchmark/Streamly/Benchmark/Prelude/ZipAsync.hs+benchmark/Streamly/Benchmark/Prelude/ZipSerial.hs
+ .hlint.yaml view
@@ -0,0 +1,78 @@+# HLint configuration file+# https://github.com/ndmitchell/hlint+##########################++# This file contains a template configuration file, which is typically+# placed as .hlint.yaml in the root of your project+++# Warnings currently triggered by your code+- suggest: {name: "Unused LANGUAGE pragma"}+- suggest: {name: "Eta reduce"}+- suggest: {name: "Reduce duplication"}+- ignore: {name: "Use list literal pattern"}+- ignore: {name: "Use tuple-section"} # requires GHC extension+- ignore: {name: "Use fromMaybe"} # may want to use this suggestion, but it didn't match the common idiom of the library+- ignore: {name: "Use unless"} # low power-to-weight+- ignore: {name: "Reduce duplication"}+- ignore: {name: "Use <>"}+- ignore: {name: "Use fewer imports"}+- ignore: {name: "Use camelCase"}+- ignore: {name: "Use <$>"}+- ignore: {name: "Use uncurry"}+- ignore: {name: "Redundant $!"}+- ignore: {name: "Use fmap"}+++# Specify additional command line arguments+#+# - arguments: [--color, --cpp-simple, -XQuasiQuotes]+++# Control which extensions/flags/modules/functions can be used+#+# - extensions:+#   - default: false # all extension are banned by default+#   - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used+#   - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module+#+# - flags:+#   - {name: -w, within: []} # -w is allowed nowhere+#+# - modules:+#   - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set'+#   - {name: Control.Arrow, within: []} # Certain modules are banned entirely+#+# - functions:+#   - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules+++# Add custom hints for this project+#+# Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar"+# - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x}+++# Turn on hints that are off by default+#+# Ban "module X(module X) where", to require a real export list+# - warn: {name: Use explicit module export list}+#+# Replace a $ b $ c with a . b $ c+# - group: {name: dollar, enabled: true}+#+# Generalise map to fmap, ++ to <>+- group: {name: generalise, enabled: true}+++# Ignore some builtin hints+# - ignore: {name: Use let}+# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules+++# Define some custom infix operators+# - fixity: infixr 3 ~^#^~+++# To generate a suitable file for HLint do:+# $ hlint --default > .hlint.yaml
+ CONTRIBUTING.md view
@@ -0,0 +1,252 @@+# Contributors' Guide++## Bug Reports++Please feel free to [open an+issue](https://github.com/composewell/streamly/issues) for any questions,+suggestions, issues or bugs in the library. In case you are reporting a bug+we will appreciate if you provide as much detail as possible to reproduce or+understand the problem, but nevertheless you are encouraged to open an issue+for any problem that you may encounter.++## Picking Issues to Work on++Beginners are encouraged to pick up issues that are marked `help wanted`. It is+a good idea to update the issue expressing your intent so that others do not+duplicate the effort and people with a background on the issue can help.++## Contributing A Change++If the feature makes significant changes to design, we encourage you to open an+issue as early as possible so that you do not have to redo much work because of+changes in design decisions. However, if you are confident, you can still go+ahead and take that risk as the maintainers are supposed to be reasonable+people.++### Pull Requests (PR)++Please feel free to [send a pull+request (PR)](https://github.com/composewell/streamly/pulls) whether it is a+single letter typo fix or a complex change.  We will accept any PR that makes a+net positive change to the package. We encourage you to provide a complete,+consistent change with test, documentation and benchmarks. You can contact the+[maintainers](https://gitter.im/composewell/streamly) for any help or+collaboration needed in that regard. However, if due to lack of time you are+not able to complete the PR, you are still welcome to submit it, maintainers+will try their best to actively contribute and pick up your change as long as+the change is approved.++### Pull Request (PR) Checklist++Here is a quick checklist for a PR, for details please see the next section:++* PR contains one logical changeset+* Each commit in the PR consists of a logical change+* Commits are rebased/squashed/fixup/reordered as needed+* Stylistic changes to irrelevant parts of the code are separated in+  independent commits.+* Code is formatted as per the style of the file or that of other files+* Compiler warnings are fixed+* Reasonable hlint suggestions are accepted+* Tests are added to cover the changed parts+* All [tests](test) pass+* [Performance benchmarks](benchmark) are added, where applicable+* No significant regressions are reported by [performance benchmarks](benchmark/README.md)+* Haddock documentation is added to user visible APIs and data types+* Tutorial module, [README](README.md), and [guides](docs) are updated if+  necessary.+* [Changelog](Changelog.md) is updated if needed+* The code conforms to the license, it is not stolen, credit is given,+  copyright notices are retained, original license is included if needed.++### Structuring Pull Requests++__Lean PR:__ Please keep the reviewer in mind when sending pull+requests. Use one PR for each logical changeset. A lean and thin+PR with one independent logical change is more likely to be reviewed and+merged quickly than a big monolithic PR with several unrelated changes.++__PR Dependencies:__ If your change depends on an earlier PR you can+create a branch from the old PR's branch, and raise a new PR targeting+to merge into the old PR branch. Do not push the commits to the same PR+just because the commit depends on that PR.++__Commits:__ You are encouraged to group a logically related set of+changes into a single commit.  When the overall changeset is largish you+can divide it into multiple smaller commits, with each commit having+a logically grouped changeset and the title summarizing the logical+grouping.  Always keep in mind a logical division helps reviewers+understand and review your code quickly, easier history tracking and+when required clean reversal changes.++__Functional Changes:__ Keep the reviewer in mind when making+changes.  Please resist the temptation to make style related changes to+surrounding code unless you are changing that code anyway . Whenever+possible, try to separate unrelated refactoring changes which do not+affect functionality in separate commits so that it is easier for the+reviewer to verify functional changes.++__Style Changes:__ Make sure that your IDE/Editor is not automatically+making sweeping style changes to all the files you are editing. That+makes separating the signal from the noise very difficult and makes+everything harder. If you would like to make style related changes+then please send a separate PR with just those changes and no other+functionality changes.++__Rebasing:__ If your commits reflect how you fixed intermediate+problems during testing or made random changes at different times you+may have to squash your changes (`git rebase -i`) into a single commit+or logically related set of commits.++### Resolving Conflicts++If during the course of development or before you send the PR you find that+your changes are conflicting with the master branch then use `git rebase+master` to rebase your changes on top of master. DO NOT MERGE MASTER INTO YOUR+BRANCH.++### Testing++It is a good idea to include tests for the changes where applicable. See the+existing tests [here](test).++### Documentation++For user visible APIs, it is a good idea to provide haddock documentation that+is easily understood by the end programmer and does not sound highfalutin,+and preferably with examples. If your change affects the tutorial or needs to+be mentioned in the tutorial then please update the tutorial. Check if the+additional [guides](docs) are affected or need to updated.++### Performance Benchmarks++It is a good idea to run performance benchmarks to see if your change affects+any of the existing performance benchmarks. If you introduced something new+then you may want to add benchmarks to check if it performs as well as expected+by the programmers to deem it usable.++See the [README](benchmark/README) file in the `benchmark` directory for more+details on how to run the benchmarks.++The first level of check is the regression in "allocations", this is+the most stable measure of regression. "bytesCopied" is another stable+measure, it gives an idea of the amount of long lived data being copied+across generations of GC. ++The next measure to look at is "cpuTime" this may have some variance+from run to run because of factors like cpu frequency scaling, load on+the system or the number of context switches etc. However, the variance+would usually be within 5-10%, anything more than that is likely to be a+red flag.++Quite often an increase in "cpuTime" would correspond to an increase+in "allocations". Increase in "allocations" indicates an inefficiency+in computing due to too much GC activity e.g. due to lack of+fusion. However, it is also possible for the cpu time to go up without+the allocations going up, this indicates an inefficiency in processing+in general or more CPU being used for the same task. It could be because+of inefficient code generation, branch mis-predictions or lack of cache+locality etc.++For concurrent benchmarks we can compare "cpuTime" and "time" to check+the degree of concurrency and total efficiency.++### Changelog++Any new changes that affect the user of the library in some way must be+documented under `Unreleased` section at the top of the `Changelog`.  The+changes in the changelog must be organized in the following categories, in that+order:++* Breaking Changes+* Enhancements+* Bug Fixes+* Deprecations++If there are very few changes then you can just prefix a bullet with these+annotations. If there are many changes make sections to group them. A section+can be absent if there is nothing to add in it.++If you make changes that are incompatible with the released versions+of the library please indicate that in the `Changelog` as `Breaking Changes`+and also write short notes regarding what the programmers need to do to adapt+their existing code to the new change.++### Licensing++If you have copied code from elsewhere you need to conform to the+licensing terms of the original code. Usually you would need to add a+copyright notice in the source header, and include the license of the+original code as per the terms of the license. If the code you are+copying does not have an associated license please do not use it.++## Developer documentation++To build haddock documentation:++```+$ cabal haddock+```++Open the link printed at the end of the output of this command, in+your browser.++For general library developer documentation see the `dev` directory.++## Coding Guidelines++### Coding Style++Please see [the Haskell coding style guide](https://github.com/composewell/haskell-dev/blob/master/coding-style.rst).++### StreamD coding style++Some conventions that we follow in the StreamD code are illustrated by the+following example:++```+mapM f (Stream step1 state1) = Stream step state+    where++    step gst st = do+        r <- step1 (adaptState gst) st+        case r of+            Yield x s -> f x >>= \a -> return $ Yield a s+            Skip s    -> return $ Skip s+            Stop      -> return Stop+```++* For the input streams use numbering for `step` and `state` e.g.+  step1/state1. For the output stream use `step` and `state`.+* For state argument of `step`, use `st`.+* For result of executing a `step` use `r` or `res`+* For the yielded element use `x`+* For the yielded state use `s`++In general, the rule is - the shorter the scope of a variable the shorter its+name can be. For example, `s` has the shortest scope in the above code, `st`+has a bigger scope and `state` has the biggest scope.++## Design guides++See [the design directory](design) for design guidelines and documents.++### Tricky Parts++The state-passing through each API is currently fragile. Every time we run a+stream we need to be careful about the state we are passing to it. In case of+folds where there is no incoming state, we start with the initial state+`defState`. When we have an incoming state passed to us there are two cases:++1. When we are building a concurrent stream that needs to share the same `SVar`+   we pass the incoming state as is.+2. In all other cases we must not share the SVar and every time we pass on the+   state to run a stream we must use `adaptState` to reset the `SVar` in the+   state.++When in doubt just use `adaptState` on the state before passing it on, we will at+most lose concurrency but the behavior will be correct.++There is no type level enforcement about this as of now, and therefore we need+to be careful when coding. There are specific tests to detect and report any+problems due to this, all transform operations must be added to those tests.
Changelog.md view
@@ -1,15 +1,91 @@-## 0.7.3.1+# Changelog -* Fix compilation with ghc-9.2.5+<!-- See rendered changelog at https://streamly.composewell.com --> -## 0.7.3+## 0.8.0 +See [API Changelog](docs/API-changelog.txt) for a complete list of signature+changes and new APIs introduced.++### Breaking changes++* `Streamly.Prelude`+    * `fold`: this function may now terminate early without consuming+      the entire stream. For example, `fold Fold.head stream` would+      now terminate immediately after consuming the head element from+      `stream`. This may result in change of behavior in existing programs+      if the program relies on the evaluation of the full stream.+* `Streamly.Data.Unicode.Stream`+    * The following APIs no longer throw errors on invalid input, use new+      APIs suffixed with a prime for strict behavior:+        * decodeUtf8+        * encodeLatin1+        * encodeUtf8+* `Streamly.Data.Fold`:+    * Several instances have been moved to the `Streamly.Data.Fold.Tee`+      module, please use the `Tee` type to adapt to the changes.++### Bug Fixes++* Concurrent Streams: The monadic state for the stream is now propagated across+  threads. Please refer to+  [#369](https://github.com/composewell/streamly/issues/369) for more info.+* `Streamly.Prelude`:+    * `bracket`, `handle`, and `finally` now also work correctly on streams+      that aren't fully drained. Also, the resource acquisition and release is+      atomic with respect to async exceptions.+    * `iterate`, `iterateM` now consume O(1) space instead of O(n).+    * `fromFoldableM` is fixed to be concurrent.+* `Streamly.Network.Inet.TCP`: `accept` and `connect` APIs now close the socket+  if an exception is thrown.+* `Streamly.Network.Socket`: `accept` now closes the socket if an exception is+  thrown.++### Enhancements++* See [API Changelog](docs/API-changelog.txt) for a complete list of new+  modules and APIs introduced.+* The Fold type is now more powerful, the new termination behavior allows+  to express basic parsing of streams using folds.+* Many new Fold and Unfold APIs are added.+* A new module for console IO APIs is added.+* Experimental modules for the following are added:+    * Parsing+    * Deserialization+    * File system event handling (fsnotify/inotify)+    * Folds for streams of arrays+* Experimental `use-c-malloc` build flag to use the c library `malloc` for+  array allocations. This could be useful to avoid pinned memory fragmentation.+++### Notable Internal/Pre-release API Changes++Breaking changes:++* The `Fold` type has changed to accommodate terminating folds.+* Rename: `Streamly.Internal.Prelude` => `Streamly.Internal.Data.Stream.IsStream`+* Several other internal modules have been renamed and re-factored.++Bug fixes:++* A bug was fixed in the conversion of `MicroSecond64` and `MilliSecond64`+  (commit e5119626)+* Bug fix: `classifySessionsBy` now flushes sessions at the end and terminates.++### Miscellaneous++* Drop support for GHC 7.10.3.+* The examples in this package are moved to a new github repo+  [streamly-examples](https://github.com/composewell/streamly-examples)++## 0.7.3 (February 2021)+ ### Build Issues -* Fix build issues with `primitive` package version >= 0.7.1.+* Fix build issues with primitive package version >= 0.7.1. * Fix build issues on armv7. -## 0.7.2+## 0.7.2 (April 2020)  ### Bug Fixes @@ -25,7 +101,7 @@ * Now builds with newer `QuickCheck` package version >= 2.14 && < 2.15. * Now builds with GHC 8.10. -## 0.7.1+## 0.7.1 (February 2020)  ### Bug Fixes @@ -54,7 +130,7 @@ * Significant improvement in performance of concurrent stream operations. * Improved space and time performance of `Foldable` instance. -## 0.7.0+## 0.7.0 (November 2019)  ### Breaking changes @@ -168,7 +244,7 @@       effects     * `tap` redirects a copy of the stream to a `Fold` -## 0.6.1+## 0.6.1 (March 2019)  ### Bug Fixes @@ -180,7 +256,7 @@ * Add GHCJS support * Remove dependency on "clock" package -## 0.6.0+## 0.6.0 (December 2018)  ### Breaking changes @@ -208,7 +284,7 @@ * Performance improvements * Add benchmarks to measure composed and iterated operations -## 0.5.2+## 0.5.2 (October 2018)  ### Bug Fixes @@ -223,12 +299,12 @@   used in a stateful monad e.g. `StateT`. Particularly, this bug cannot affect   `ReaderT`. -## 0.5.1+## 0.5.1 (September 2018)  * Performance improvements, especially space consumption, for concurrent   streams -## 0.5.0+## 0.5.0 (September 2018)  ### Bug Fixes @@ -254,13 +330,13 @@ * The `Streamly.Time` module is now deprecated, its functionality is subsumed   by the new rate limiting combinators. -## 0.4.1+## 0.4.1 (July 2018)  ### Bug Fixes  * foldxM was not fully strict, fixed. -## 0.4.0+## 0.4.0 (July 2018)  ### Breaking changes @@ -287,7 +363,7 @@ * Add `takeWhileM` and `dropWhileM` * Add `filterM` -## 0.3.0+## 0.3.0 (June 2018)  ### Breaking changes @@ -315,14 +391,14 @@   stream processing function application pipeline concurrently. * Added `mapMaybe` and `mapMaybeM`. -## 0.2.1+## 0.2.1 (June 2018)  ### Bug Fixes * Fixed a bug that caused some transformation ops to return incorrect results   when used with concurrent streams. The affected ops are `take`, `filter`,   `takeWhile`, `drop`, `dropWhile`, and `reverse`. -## 0.2.0+## 0.2.0 (May 2018)  ### Breaking changes * Changed the semantics of the Semigroup instance for `InterleavedT`, `AsyncT`@@ -400,7 +476,7 @@ * Put a bound (1500) on the output buffer used for asynchronous tasks * Put a limit (1500) on the number of threads used for Async and WAsync types -## 0.1.2+## 0.1.2 (March 2018)  ### Enhancements * Add `iterate`, `iterateM` stream operations@@ -409,7 +485,7 @@ * Fixed a bug that caused unexpected behavior when `pure` was used to inject   values in Applicative composition of `ZipStream` and `ZipAsync` types. -## 0.1.1+## 0.1.1 (March 2018)  ### Enhancements * Make `cons` right associative and provide an operator form `.:` for it@@ -420,6 +496,6 @@ * Fix the `product` operation. Earlier, it always returned 0 due to a bug * Fix the `last` operation, which returned `Nothing` for singleton streams -## 0.1.0+## 0.1.0 (December 2017)  * Initial release
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2017, Harendra Kumar+Copyright (c) 2017, Composewell Technologies All rights reserved.  Redistribution and use in source and binary forms, with or without
README.md view
@@ -1,607 +1,648 @@-# Streamly+# [Streamly][]: Idiomatic Haskell with the Performance of C  [![Gitter chat](https://badges.gitter.im/composewell/gitter.svg)](https://gitter.im/composewell/streamly)+[![Hackage](https://img.shields.io/hackage/v/streamly.svg?style=flat)](https://hackage.haskell.org/package/streamly) -## Learning Materials+<!--+Link References.+--> -* Documentation: [Quick](#streaming-concurrently) | [Tutorial](https://hackage.haskell.org/package/streamly/docs/Streamly-Tutorial.html) | [Reference (Hackage)](https://hackage.haskell.org/package/streamly) | [Reference (Latest)](https://composewell.github.io/streamly) | [Guides](docs)-* Installing: [Installing](./INSTALL.md) | [Building for optimal performance](docs/Build.md)-* Examples: [streamly](examples) | [streamly-examples](https://github.com/composewell/streamly-examples)-* Benchmarks: [Streaming](https://github.com/composewell/streaming-benchmarks) | [Concurrency](https://github.com/composewell/concurrency-benchmarks)-* Talks: [Functional Conf 2019 Video](https://www.youtube.com/watch?v=uzsqgdMMgtk) | [Functional Conf 2019 Slides](https://www.slideshare.net/HarendraKumar10/streamly-concurrent-data-flow-programming)+[Streamly]: https://streamly.composewell.com/+[streamly-examples]: https://github.com/composewell/streamly-examples+[streaming-benchmarks]: https://github.com/composewell/streaming-benchmarks+[concurrency-benchmarks]: https://github.com/composewell/concurrency-benchmarks -## Streaming Concurrently+<!--+Keep all the unstable links here so that they can be updated to stable+links (for online docs) before we release.+--> -Haskell lists express pure computations using composable stream operations like-`:`, `unfold`, `map`, `filter`, `zip` and `fold`.  Streamly is exactly like-lists except that it can express sequences of pure as well as monadic-computations aka streams. More importantly, it can express monadic sequences-with concurrent execution semantics without introducing any additional APIs.+<!-- examples -->+[WordCountModular.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/WordCountModular.hs+[WordCount.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/WordCount.hs+[WordCount.c]: https://github.com/composewell/streamly-examples/blob/master/examples/WordCount.c+[WordCountParallel.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/WordCountParallel.hs+[WordCountUTF8.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/WordCountUTF8.hs+[WordServer.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/WordServer.hs+[MergeServer.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/MergeServer.hs+[ListDir.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/ListDir.hs+[Rate.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/Rate.hs+[AcidRain.hs]: https://github.com/composewell/streamly-examples/tree/master/examples/AcidRain.hs+[CirclingSquare.hs]: https://github.com/composewell/streamly-examples/tree/master/examples/CirclingSquare.hs -Streamly expresses concurrency using standard, well known abstractions.-Concurrency semantics are defined for list operations, semigroup, applicative-and monadic compositions. Programmer does not need to know any low level-notions of concurrency like threads, locking or synchronization.  Concurrent-and non-concurrent programs are fundamentally the same.  A chosen segment of-the program can be made concurrent by annotating it with an appropriate-combinator.  We can choose a combinator for lookahead style or asynchronous-concurrency.  Concurrency is automatically scaled up or down based on the-demand from the consumer application, we can finally say goodbye to managing-thread pools and associated sizing issues.  The result is truly fearless-and declarative monadic concurrency.+<!-- local files -->+[LICENSE]: LICENSE+[CONTRIBUTING.md]: CONTRIBUTING.md+[docs]: docs/ -## Where to use streamly?+Streamly is a Haskell library that provides the building blocks to build+safe, scalable, modular and high performance software.  Streamly offers: -Streamly is a general purpose programming framework.  It can be used equally-efficiently from a simple `Hello World!` program to a massively concurrent-application. The answer to the question, "where to use streamly?" - would be-similar to the answer to - "Where to use Haskell lists or the IO monad?".+* The type safety of Haskell.+* The performance of C programs.+* Powerful abstractions for structuring your code.+* Idiomatic functional programming.+* Declarative concurrency for the seamless use of multiprocessing hardware. -Streamly simplifies streaming and makes it as intuitive as plain lists. Unlike-other streaming libraries, no fancy types are required.  Streamly is simply a-generalization of Haskell lists to monadic streaming optionally with concurrent-composition. The basic stream type in streamly `SerialT m a` can be considered-as a list type `[a]` parameterized by the monad `m`. For example, `SerialT IO-a` is a moral equivalent of `[a]` in the IO monad. `SerialT Identity a`, is-equivalent to pure lists.  Streams are constructed very much like lists, except-that they use `nil` and `cons` instead of `[]` and `:`.  Unlike lists, streams-can be constructed from monadic effects, not just pure elements.  Streams are-processed just like lists, with list like combinators, except that they are-monadic and work in a streaming fashion. In other words streamly just completes-what lists lack, you do not need to learn anything new. Please see [streamly vs-lists](docs/streamly-vs-lists.md) for a detailed comparison.+## About This Document -Not surprisingly, the monad instance of streamly is a list transformer, with-concurrency capability.+This guide introduces programming with [Streamly][] using a few practical+examples: -## Why data flow programming?+*  We will start with a simple program that [counts the number of words+   in a text](#modular-word-counting). We will then transform this program+   into a [concurrent](#concurrent-word-counting) program that can efficiently+   use multiprocessing hardware.+*  Next, we will create a [concurrent network+   server](#a-concurrent-network-server). We then show+   how to write a network server that [merges multiple+   streams](#merging-incoming-streams) concurrently.+*  Our third example shows how to list a directory tree concurrently,+   by reading [multiple directories in+   parallel](#listing-directories-recursivelyconcurrently).+*  Finally, we will look at how to [rate limit](#rate-limiting) stream+   processing. -If you need some convincing for using streaming or data flow programming-paradigm itself then try to answer this question - why do we use lists in-Haskell? It boils down to why we use functional programming in the first place.-Haskell is successful in enforcing the functional data flow paradigm for pure-computations using lists, but not for monadic computations. In the absence of a-standard and easy to use data flow programming paradigm for monadic-computations, and the IO monad providing an escape hatch to an imperative-model, we just love to fall into the imperative trap, and start asking the same-fundamental question again - why do we have to use the streaming data model?+The guide then looks at how Streamly achieves its+[performance](#performance).  It [concludes](#notes) with a brief+discussion about Streamly's design philosophy, and with suggestions for+further reading. -## Comparative Performance+## Getting Started -High performance and simplicity are the two primary goals of streamly.-`Streamly` employs two different stream representations (CPS and direct style)-and interconverts between the two to get the best of both worlds on different-operations. It uses both foldr/build (for CPS style) and stream fusion (for-direct style) techniques to fuse operations. In terms of performance,-Streamly's goal is to compete with equivalent C programs. Streamly redefines-"blazing fast" for streaming libraries, it competes with lists and `vector`.-Other streaming libraries like "streaming", "pipes" and "conduit" are orders of-magnitude slower on most microbenchmarks.  See [streaming-benchmarks](https://github.com/composewell/streaming-benchmarks) for detailed-comparison.+### Installing Streamly -The following chart shows a comparison of those streamly and list operations-where performance of the two differs by more than 10%. Positive y-axis displays-how many times worse is a list operation compared to the same streamly-operation, negative y-axis shows where streamly is worse compared to lists.+If you wish to follow along with this guide, you will need to have+[Streamly][] installed. -![Streamly vs Lists (time) comparison](charts-0/streamly-vs-list-time.svg)+Please see the [Getting Started With The Streamly Package](docs/getting-started.md)+guide for instructions on how to install [Streamly][]. -Streamly uses lock-free synchronization for concurrent operations. It employs-auto-scaling of the degree of concurrency based on demand. For CPU bound tasks-it tries to keep the threads close to the number of CPUs available whereas for-IO bound tasks more threads can be utilized. Parallelism can be utilized with-little overhead even if the task size is very small.  See [concurrency-benchmarks](https://github.com/composewell/concurrency-benchmarks) for detailed-performance results and a comparison with the `async` package.+If you wish to run benchmarks, please be sure to build your+application using the instructions in the [Build Guide](docs/building.md). -## Installing and using+### An overview of the types used in these examples -Please see [INSTALL.md](./INSTALL.md) for instructions on how to use streamly-with your Haskell build tool or package manager. You may want to go through it-before jumping to run the examples below.+As an expository device, we have indicated the types at the intermediate+stages of stream computations as comments in the examples below.+The meaning of these types are: -The module `Streamly` provides just the core stream types, type casting and-concurrency control combinators.  Stream construction, transformation, folding,-merging, zipping combinators are found in `Streamly.Prelude`.+* A `SerialT IO a` is a serial stream of values of type `a` in the IO Monad.+* An `AsyncT IO a` is a concurrent (asynchronous) stream of values of type+  `a` in the IO Monad.+* An `Unfold IO a b` is a representation of a function that converts a seed+  value of type `a` into a stream of values of type `b` in the IO Monad.+* A `Fold IO a b` is a representation of a function that converts a stream of+  type `a` to a final accumulator of type `b` in the IO Monad. -## Streaming Pipelines+### A Note on Module Naming -The following snippet provides a simple stream composition example that reads-numbers from stdin, prints the squares of even numbers and exits if an even-number more than 9 is entered.+Some of the examples below use modules from the `Internal` Streamly package+hierarchy.  These are not really internal to the library.  We classify+`Streamly` modules into two categories: -``` haskell-import Streamly-import qualified Streamly.Prelude as S-import Data.Function ((&))+* _Released modules and APIs_: These modules and APIs are+  stable. Significant changes to these modules and APIs will cause+  Streamly's version number to change according to the package versioning+  policy.+* _Pre-release modules and APIs_: These modules and APIs have not been+  formally released yet.  They may change in the near future, and such+  changes will not necessarily be reflected in Streamly's package+  version number.  As yet unreleased modules and APIs reside in the+  `Internal` namespace. -main = S.drain $-       S.repeatM getLine-     & fmap read-     & S.filter even-     & S.takeWhile (<= 9)-     & fmap (\x -> x * x)-     & S.mapM print-```+## The Examples -Unlike `pipes` or `conduit` and like `vector` and `streaming`, `streamly`-composes stream data instead of stream processors (functions).  A stream is-just like a list and is explicitly passed around to functions that process the-stream.  Therefore, no special operator is needed to join stages in a streaming-pipeline, just the standard function application (`$`) or reverse function-application (`&`) operator is enough.+### Modular Word Counting -## Concurrent Stream Generation+A `Fold` in Streamly is a composable stream consumer.  For our first+example, we will use `Fold`s to count the number of bytes, words and lines+present in a file.  We will then compose individual `Fold`s together to+count words, bytes and lines at the same time. -`consM` or its operator form `|:` can be used to construct a stream from-monadic actions. A stream constructed with `consM` can run the monadic actions-in the stream concurrently when used with appropriate stream type combinator-(e.g. `asyncly`, `aheadly` or `parallely`).+Please see the file [WordCountModular.hs][] for the complete example+program, including the imports that we have omitted here. -The following code finishes in 3 seconds (6 seconds when serial), note the-order of elements in the resulting output, the outputs are consumed as soon as-each action is finished (asyncly):+#### Count Bytes (wc -c) -``` haskell-> let p n = threadDelay (n * 1000000) >> return n-> S.toList $ asyncly $ p 3 |: p 2 |: p 1 |: S.nil-[1,2,3]-```+We start with a code fragment that counts the number of bytes in a file: -Use `aheadly` if you want speculative concurrency i.e. execute the actions in-the stream concurrently but consume the results in the specified order:+```haskell+import qualified Streamly.Data.Fold as Fold+import qualified Streamly.Internal.FileSystem.File as File+import qualified Streamly.Prelude as Stream -``` haskell-> S.toList $ aheadly $ p 3 |: p 2 |: p 1 |: S.nil-[3,2,1]+wcb :: String -> IO Int+wcb file =+    File.toBytes file        -- SerialT IO Word8+  & Stream.fold Fold.length  -- IO Int ``` -Monadic stream generation functions e.g. `unfoldrM`, `replicateM`, `repeatM`,-`iterateM` and `fromFoldableM` etc. can work concurrently.+### Count Lines (wc -l) -The following finishes in 10 seconds (100 seconds when serial):+The next code fragment shows how to count the number of lines in a file: -``` haskell-S.drain $ asyncly $ S.replicateM 10 $ p 10+```haskell+-- ASCII character 10 is a newline.+countl :: Int -> Word8 -> Int+countl n ch = if ch == 10 then n + 1 else n++-- The fold accepts a stream of `Word8` and returns a line count (`Int`).+nlines :: Monad m => Fold m Word8 Int+nlines = Fold.foldl' countl 0++wcl :: String -> IO Int+wcl file =+    File.toBytes file  -- SerialT IO Word8+  & Stream.fold nlines -- IO Int ``` -## Concurrency Auto Scaling+### Count Words (wc -w) -Concurrency is auto-scaled i.e. more actions are executed concurrently if the-consumer is consuming the stream at a higher speed. How many tasks are executed-concurrently can be controlled by `maxThreads` and how many results are-buffered ahead of consumption can be controlled by `maxBuffer`. See the-documentation in the `Streamly` module.+Our final code fragment counts the number of whitespace-separated words+in a stream: -## Concurrent Streaming Pipelines+```haskell+countw :: (Int, Bool) -> Word8 -> (Int, Bool)+countw (n, wasSpace) ch =+    if isSpace $ chr $ fromIntegral ch+    then (n, True)+    else (if wasSpace then n + 1 else n, False) -Use `|&` or `|$` to apply stream processing functions concurrently. The-following example prints a "hello" every second; if you use `&` instead of-`|&` you will see that the delay doubles to 2 seconds instead because of serial-application.+-- The fold accepts a stream of `Word8` and returns a word count (`Int`).+nwords :: Monad m => Fold m Word8 Int+nwords = fst <$> Fold.foldl' countw (0, True) -``` haskell-main = S.drain $-      S.repeatM (threadDelay 1000000 >> return "hello")-   |& S.mapM (\x -> threadDelay 1000000 >> putStrLn x)+wcw :: String -> IO Int+wcw file =+    File.toBytes file   -- SerialT IO Word8+  & Stream.fold nwords  -- IO Int ``` -## Mapping Concurrently+### Counting Bytes, Words and Lines Together -We can use `mapM` or `sequence` functions concurrently on a stream.+By using the `Tee` combinator we can compose the three folds that count+bytes, lines and words individually into a single fold that counts all+three at once.  The applicative instance of `Tee` distributes its input+to all the supplied folds (`Fold.length`, `nlines`, and `nwords`) and+then combines the outputs from the folds using the supplied combiner+function (`(,,)`). -``` haskell-> let p n = threadDelay (n * 1000000) >> return n-> S.drain $ aheadly $ S.mapM (\x -> p 1 >> print x) (serially $ repeatM (p 1))-```+```haskell+import qualified Streamly.Internal.Data.Fold.Tee as Tee -## Serial and Concurrent Merging+-- The fold accepts a stream of `Word8` and returns the three counts.+countAll :: Fold IO Word8 (Int, Int, Int)+countAll = Tee.toFold $ (,,) <$> Tee Fold.length <*> Tee nlines <*> Tee nwords -Semigroup and Monoid instances can be used to fold streams serially or-concurrently. In the following example we compose ten actions in the-stream, each with a delay of 1 to 10 seconds, respectively. Since all the-actions are concurrent we see one output printed every second:+wc :: String -> IO (Int, Int, Int)+wc file =+    File.toBytes file    -- SerialT IO Word8+  & Stream.fold countAll -- IO (Int, Int, Int)+``` -``` haskell-import Streamly-import qualified Streamly.Prelude as S-import Control.Concurrent (threadDelay)+This example demonstrates the excellent modularity offered by+[Streamly][]'s simple and concise API.  Experienced Haskellers will+notice that we have not used bytestrings&mdash;we instead used a stream of+`Word8` values, simplifying our program. -main = S.toList $ parallely $ foldMap delay [1..10]- where delay n = S.yieldM $ threadDelay (n * 1000000) >> print n-```+### The Performance of Word Counting -Streams can be combined together in many ways. We provide some examples-below, see the tutorial for more ways. We use the following `delay`-function in the examples to demonstrate the concurrency aspects:+We compare two equivalent implementations: one using [Streamly][],+and the other using C. -``` haskell-import Streamly-import qualified Streamly.Prelude as S-import Control.Concurrent+The performance of the [Streamly word counting+implementation][WordCount.hs] is: -delay n = S.yieldM $ do-    threadDelay (n * 1000000)-    tid <- myThreadId-    putStrLn (show tid ++ ": Delay " ++ show n) ```-### Serial+$ time WordCount-hs gutenberg-500MB.txt+11242220 97050938 574714449 gutenberg-500MB.txt -``` haskell-main = S.drain $ delay 3 <> delay 2 <> delay 1-```-```-ThreadId 36: Delay 3-ThreadId 36: Delay 2-ThreadId 36: Delay 1+real    0m1.825s+user    0m1.697s+sys     0m0.128s ``` -### Parallel+The performance of an equivalent [wc implementation in C][WordCount.c] is: -``` haskell-main = S.drain . parallely $ delay 3 <> delay 2 <> delay 1 ```-```-ThreadId 42: Delay 1-ThreadId 41: Delay 2-ThreadId 40: Delay 3+$ time WordCount-c gutenberg-500MB.txt+11242220 97050938 574714449 gutenberg-500MB.txt++real    0m2.100s+user    0m1.935s+sys     0m0.165s ``` -## Nested Loops (aka List Transformer)+### Concurrent Word Counting -The monad instance composes like a list monad.+In our next example we show how the task of counting words, lines,+and bytes could be done in parallel on multiprocessor hardware. -``` haskell-import Streamly-import qualified Streamly.Prelude as S+To count words in parallel we first divide the stream into chunks+(arrays), do the counting within each chunk, and then add all the+counts across chunks.  We use the same code as above except that we use+arrays for our input data. -loops = do-    x <- S.fromFoldable [1,2]-    y <- S.fromFoldable [3,4]-    S.yieldM $ putStrLn $ show (x, y)+Please see the file [WordCountParallel.hs][] for the complete working+code for this example, including the imports that we have omitted below. -main = S.drain loops-```-```-(1,3)-(1,4)-(2,3)-(2,4)+The `countArray` function counts the line, word, char counts in one chunk:++```haskell+import qualified Streamly.Data.Array.Foreign as Array++countArray :: Array Word8 -> IO Counts+countArray arr =+      Stream.unfold Array.read arr            -- SerialT IO Word8+    & Stream.decodeLatin1                     -- SerialT IO Char+    & Stream.foldl' count (Counts 0 0 0 True) -- IO Counts ``` -## Concurrent Nested Loops+Here the function `count` and the `Counts` data type are defined in the+`WordCount` helper module defined in [WordCount.hs][]. -To run the above code with speculative concurrency i.e. each iteration in the-loop can run concurrently but the results are presented to the consumer of the-output in the same order as serial execution:+When combining the counts in two contiguous chunks, we need to check+whether the first element of the next chunk is a whitespace character+in order to determine if the same word continues in the next chunk or+whether the chunk starts with a new word. The `partialCounts` function+adds a `Bool` flag to `Counts` returned by `countArray` to indicate+whether the first character in the chunk is a space. -``` haskell-main = S.drain $ aheadly $ loops+```haskell+partialCounts :: Array Word8 -> IO (Bool, Counts)+partialCounts arr = do+    let r = Array.getIndex arr 0+    case r of+        Just x -> do+            counts <- countArray arr+            return (isSpace (chr (fromIntegral x)), counts)+        Nothing -> return (False, Counts 0 0 0 True) ``` -Different stream types execute the loop iterations in different ways. For-example, `wSerially` interleaves the loop iterations. There are several-concurrent stream styles to execute the loop iterations concurrently in-different ways, see the `Streamly.Tutorial` module for a detailed treatment.+`addCounts` then adds the counts from two consecutive chunks: -## Magical Concurrency+```haskell+addCounts :: (Bool, Counts) -> (Bool, Counts) -> (Bool, Counts)+addCounts (sp1, Counts l1 w1 c1 ws1) (sp2, Counts l2 w2 c2 ws2) =+    let wcount =+            if not ws1 && not sp2 -- No space between two chunks.+            then w1 + w2 - 1+            else w1 + w2+     in (sp1, Counts (l1 + l2) wcount (c1 + c2) ws2)+``` -Streams can perform semigroup (<>) and monadic bind (>>=) operations-concurrently using combinators like `asyncly`, `parallelly`. For example,-to concurrently generate squares of a stream of numbers and then concurrently-sum the square roots of all combinations of two streams:+To count in parallel we now only need to divide the stream into arrays,+apply our counting function to each array, and then combine the counts+from each chunk. -``` haskell-import Streamly-import qualified Streamly.Prelude as S+```haskell+wc :: String -> IO (Bool, Counts)+wc file = do+      Stream.unfold File.readChunks file -- AheadT IO (Array Word8)+    & Stream.mapM partialCounts          -- AheadT IO (Bool, Counts)+    & Stream.maxThreads numCapabilities  -- AheadT IO (Bool, Counts)+    & Stream.fromAhead                   -- SerialT IO (Bool, Counts)+    & Stream.foldl' addCounts (False, Counts 0 0 0 True) -- IO (Bool, Counts)+``` -main = do-    s <- S.sum $ asyncly $ do-        -- Each square is performed concurrently, (<>) is concurrent-        x2 <- foldMap (\x -> return $ x * x) [1..100]-        y2 <- foldMap (\y -> return $ y * y) [1..100]-        -- Each addition is performed concurrently, monadic bind is concurrent-        return $ sqrt (x2 + y2)-    print s+Please note that the only difference between a concurrent and a+non-concurrent program lies in the use of the `Stream.fromAhead`+combinator.  If we remove the call to `Stream.fromAhead`, we would+still have a perfectly valid and performant serial program. Notice+how succinctly and idiomatically we have expressed the concurrent word+counting problem.++A benchmark with 2 CPUs:+ ```+$ time WordCount-hs-parallel gutenberg-500MB.txt+11242220 97050938 574714449 gutenberg-500MB.txt -The concurrency facilities provided by streamly can be compared with-[OpenMP](https://en.wikipedia.org/wiki/OpenMP) and-[Cilk](https://en.wikipedia.org/wiki/Cilk) but with a more declarative-expression.+real    0m1.284s+user    0m1.952s+sys     0m0.140s+``` -## Example: Listing Directories Recursively/Concurrently+These example programs have assumed ASCII encoded input data.  For UTF-8+streams, we have a [concurrent wc implementation][WordCountUTF8.hs]+with UTF-8 decoding.  This concurrent implementation performs as well+as the standard `wc` program in serial benchmarks. In concurrent mode+[Streamly][]'s implementation can utilise multiple processing cores if+these are present, and can thereby run much faster than the standard+binary. -The following code snippet lists a directory tree recursively, reading multiple-directories concurrently:+Streamly provides concurrency facilities similar+to [OpenMP](https://en.wikipedia.org/wiki/OpenMP) and+[Cilk](https://en.wikipedia.org/wiki/Cilk) but with a more declarative+style of expression.  With Streamly you can write concurrent programs+with ease, with support for different types of concurrent scheduling. -```haskell-import Control.Monad.IO.Class (liftIO)-import Path.IO (listDir, getCurrentDir) -- from path-io package-import Streamly (AsyncT, adapt)-import qualified Streamly.Prelude as S+### A Concurrent Network Server -listDirRecursive :: AsyncT IO ()-listDirRecursive = getCurrentDir >>= readdir >>= liftIO . mapM_ putStrLn-  where-    readdir dir = do-      (dirs, files) <- listDir dir-      S.yield (map show dirs ++ map show files) <> foldMap readdir dirs+We now move to a slightly more complicated example: we simulate a+dictionary lookup server which can serve word meanings to multiple+clients concurrently.  This example demonstrates the use of the concurrent+`mapM` combinator. -main :: IO ()-main = S.drain $ adapt $ listDirRecursive-```+Please see the file [WordServer.hs][] for the complete code for this+example, including the imports that we have omitted below. -`AsyncT` is a stream monad transformer. If you are familiar with a list-transformer, it is nothing but `ListT` with concurrency semantics. For example,-the semigroup operation `<>` is concurrent. This makes `foldMap` concurrent-too. You can replace `AsyncT` with `SerialT` and the above code will become-serial, exactly equivalent to a `ListT`.+```haskell+import qualified Streamly.Data.Fold as Fold+import qualified Streamly.Network.Inet.TCP as TCP+import qualified Streamly.Network.Socket as Socket+import qualified Streamly.Unicode.Stream as Unicode -## Rate Limiting+-- Simulate network/db query by adding a delay.+fetch :: String -> IO (String, String)+fetch w = threadDelay 1000000 >> return (w,w) -For bounded concurrent streams, stream yield rate can be specified. For-example, to print hello once every second you can simply write this:+-- Read lines of whitespace separated list of words from a socket, fetch the+-- meanings of each word concurrently and return the meanings separated by+-- newlines, in same order as the words were received. Repeat until the+-- connection is closed.+lookupWords :: Socket -> IO ()+lookupWords sk =+      Stream.unfold Socket.read sk               -- SerialT IO Word8+    & Unicode.decodeLatin1                       -- SerialT IO Char+    & Stream.wordsBy isSpace Fold.toList         -- SerialT IO String+    & Stream.fromSerial                          -- AheadT  IO String+    & Stream.mapM fetch                          -- AheadT  IO (String, String)+    & Stream.fromAhead                           -- SerialT IO (String, String)+    & Stream.map show                            -- SerialT IO String+    & Stream.intersperse "\n"                    -- SerialT IO String+    & Unicode.encodeStrings Unicode.encodeLatin1 -- SerialT IO (Array Word8)+    & Stream.fold (Socket.writeChunks sk)        -- IO () -``` haskell-import Streamly-import Streamly.Prelude as S+serve :: Socket -> IO ()+serve sk = finally (lookupWords sk) (close sk) -main = S.drain $ asyncly $ avgRate 1 $ S.repeatM $ putStrLn "hello"+-- | Run a server on port 8091. Accept and handle connections concurrently. The+-- connection handler is "serve" (i.e. lookupWords).  You can use "telnet" or+-- "nc" as a client to try it out.+main :: IO ()+main =+      Stream.unfold TCP.acceptOnPort 8091 -- SerialT IO Socket+    & Stream.fromSerial                   -- AsyncT IO ()+    & Stream.mapM serve                   -- AsyncT IO ()+    & Stream.fromAsync                    -- SerialT IO ()+    & Stream.drain                        -- IO () ``` -For some practical uses of rate control, see-[AcidRain.hs](https://github.com/composewell/streamly/tree/master/examples/AcidRain.hs)-and-[CirclingSquare.hs](https://github.com/composewell/streamly/tree/master/examples/CirclingSquare.hs)-.-Concurrency of the stream is automatically controlled to match the specified-rate. Rate control works precisely even at throughputs as high as millions of-yields per second. For more sophisticated rate control see the haddock-documentation.+### Merging Incoming Streams -## Arrays+In the next example, we show how to merge logs coming from multiple+nodes in your network.  These logs are merged at line boundaries and+the merged logs are written to a file or to a network destination.+This example uses the `concatMapWith` combinator to merge multiple+streams concurrently. -The `Streamly.Memory.Array` module provides immutable arrays.  Arrays are the-computing duals of streams. Streams are good at sequential access and immutable-transformations of in-transit data whereas arrays are good at random access and-in-place transformations of buffered data. Unlike streams which are potentially-infinite, arrays are necessarily finite. Arrays can be used as an efficient-interface between streams and external storage systems like memory, files and-network. Streams and arrays complete each other to provide a general purpose-computing system. The design of streamly as a general purpose computing-framework is centered around these two fundamental aspects of computing and-storage.+Please see the file [MergeServer.hs][] for the complete working code,+including the imports that we have omitted below. -`Streamly.Memory.Array` uses pinned memory outside GC and therefore avoid any-GC overhead for the storage in arrays. Streamly allows efficient-transformations over arrays using streams. It uses arrays to transfer data to-and from the operating system and to store data in memory.+```haskell+import qualified Streamly.Data.Unfold as Unfold+import qualified Streamly.Network.Socket as Socket -## Folds+-- | Read a line stream from a socket.+-- Note: lines are buffered, and we could add a limit to the+-- buffering for safety.+readLines :: Socket -> SerialT IO (Array Char)+readLines sk =+    Stream.unfold Socket.read sk                 -- SerialT IO Word8+  & Unicode.decodeLatin1                         -- SerialT IO Char+  & Stream.splitWithSuffix (== '\n') Array.write -- SerialT IO String -Folds are consumers of streams.  `Streamly.Data.Fold` module provides a `Fold`-type that represents a `foldl'`.  Such folds can be efficiently composed-allowing the compiler to perform stream fusion and therefore implement high-performance combinators for consuming streams. A stream can be distributed to-multiple folds, or it can be partitioned across multiple folds, or-demultiplexed over multiple folds, or unzipped to two folds. We can also use-folds to fold segments of stream generating a stream of the folded results.+recv :: Socket -> SerialT IO (Array Char)+recv sk = Stream.finally (liftIO $ close sk) (readLines sk) -If you are familiar with the `foldl` library, these are the same composable-left folds but simpler and better integrated with streamly, and with many more-powerful ways of composing and applying them.+-- | Starts a server at port 8091 listening for lines with space separated+-- words. Multiple clients can connect to the server and send streams of lines.+-- The server handles all the connections concurrently, merges the incoming+-- streams at line boundaries and writes the merged stream to a file.+server :: Handle -> IO ()+server file =+      Stream.unfold TCP.acceptOnPort 8090        -- SerialT IO Socket+    & Stream.concatMapWith Stream.parallel recv  -- SerialT IO (Array Char)+    & Stream.unfoldMany Array.read               -- SerialT IO Char+    & Unicode.encodeLatin1                       -- SerialT IO Word8+    & Stream.fold (Handle.write file)            -- IO () -## Unfolds+main :: IO ()+main = withFile "output.txt" AppendMode server+``` -Unfolds are duals of folds. Folds help us compose consumers of streams-efficiently and unfolds help us compose producers of streams efficiently.-`Streamly.Data.Unfold` provides an `Unfold` type that represents an `unfoldr`-or a stream generator. Such generators can be combined together efficiently-allowing the compiler to perform stream fusion and implement high performance-stream merging combinators.+### Listing Directories Recursively/Concurrently -## File IO+Our next example lists a directory tree recursively, reading+multiple directories concurrently. -The following code snippets implement some common Unix command line utilities-using streamly.  You can compile these with `ghc -O2 -fspec-constr-recursive=16--fmax-worker-args=16` and compare the performance with regular GNU coreutils-available on your system.  Though many of these are not most optimal solutions-to keep them short and elegant. Source file-[HandleIO.hs](https://github.com/composewell/streamly/tree/master/examples/HandleIO.hs)-in the examples directory includes these examples.+This example uses the tree traversing combinator `iterateMapLeftsWith`.+This combinator maps a stream generator on the `Left` values in its+input stream (directory names in this case), feeding the resulting `Left`+values back to the input, while it lets the `Right` values (file names+in this case) pass through to the output. The `Stream.ahead` stream+joining combinator then makes it iterate on the directories concurrently. -``` haskell-module Main where+Please see the file [ListDir.hs][] for the complete working code,+including the imports that we have omitted below. -import qualified Streamly.Prelude as S-import qualified Streamly.Data.Fold as FL-import qualified Streamly.Memory.Array as A-import qualified Streamly.FileSystem.Handle as FH-import qualified System.IO as FH+```haskell+import Streamly.Internal.Data.Stream.IsStream (iterateMapLeftsWith) -import Data.Char (ord)-import System.Environment (getArgs)-import System.IO (openFile, IOMode(..), stdout)+import qualified Streamly.Prelude as Stream+import qualified Streamly.Internal.FileSystem.Dir as Dir (toEither) -withArg f = do-    (name : _) <- getArgs-    src <- openFile name ReadMode-    f src+-- Lists a directory as a stream of (Either Dir File).+listDir :: String -> SerialT IO (Either String String)+listDir dir =+      Dir.toEither dir               -- SerialT IO (Either String String)+    & Stream.map (bimap mkAbs mkAbs) -- SerialT IO (Either String String) -withArg2 f = do-    (sname : dname : _) <- getArgs-    src <- openFile sname ReadMode-    dst <- openFile dname WriteMode-    f src dst+    where mkAbs x = dir ++ "/" ++ x++-- | List the current directory recursively using concurrent processing.+main :: IO ()+main = do+    hSetBuffering stdout LineBuffering+    let start = Stream.fromPure (Left ".")+    Stream.iterateMapLeftsWith Stream.ahead listDir start+        & Stream.mapM_ print ``` -### cat+### Rate Limiting -``` haskell-cat = S.fold (FH.writeChunks stdout) . S.unfold FH.readChunks-main = withArg cat+For bounded concurrent streams, a stream yield rate can be specified+easily.  For example, to print "tick" once every second you can simply+write:++```haskell+main :: IO ()+main =+      Stream.repeatM (pure "tick")  -- AsyncT IO String+    & Stream.timestamped            -- AsyncT IO (AbsTime, String)+    & Stream.avgRate 1              -- AsyncT IO (AbsTime, String)+    & Stream.fromAsync              -- SerialT IO (AbsTime, String)+    & Stream.mapM_ print            -- IO () ``` -### cp+Please see the file [Rate.hs][] for the complete working code. -``` haskell-cp src dst = S.fold (FH.writeChunks dst) $ S.unfold FH.readChunks src-main = withArg2 cp-```+The concurrency of the stream is automatically controlled to match the+specified rate. [Streamly][]'s rate control works precisely even at+throughputs as high as millions of yields per second. -### wc -l+For more sophisticated rate control needs please see the Streamly [reference+documentation][Streamly]. -``` haskell-wcl = S.length . S.splitOn (== 10) FL.drain . S.unfold FH.read-main = withArg wcl >>= print-```+### Reactive Programming -### Average Line Length+Streamly supports reactive (time domain) programming because of its+support for declarative concurrency. Please see the `Streamly.Prelude`+module for time-specific combinators like `intervalsOf`, and+folds like `takeInterval` in `Streamly.Internal.Data.Fold`.+Please also see the pre-release sampling combinators in the+`Streamly.Internal.Data.Stream.IsStream.Top` module for `throttle` and+`debounce` like operations. -``` haskell-avgll =-      S.fold avg-    . S.splitOn (== 10) FL.length-    . S.unfold FH.read+The examples [AcidRain.hs][] and [CirclingSquare.hs][] demonstrate+reactive programming using [Streamly][]. -    where avg      = (/) <$> toDouble FL.sum <*> toDouble FL.length-          toDouble = fmap (fromIntegral :: Int -> Double)+### More Examples -main = withArg avgll >>= print-```+If you would like to view more examples, please visit the [Streamly+Examples][streamly-examples] web page. -### Line Length Histogram+### Further Reading -`classify` is not released yet, and is available in-`Streamly.Internal.Data.Fold`+* [Streaming Benchmarks][streaming-benchmarks]+* [Concurrency Benchmarks][concurrency-benchmarks]+* Functional Conf 2019 [Video](https://www.youtube.com/watch?v=uzsqgdMMgtk) | [Slides](https://www.slideshare.net/HarendraKumar10/streamly-concurrent-data-flow-programming)+* [Other Guides](docs/)+* [Streamly Homepage][Streamly] -``` haskell-llhisto =-      S.fold (FL.classify FL.length)-    . S.map bucket-    . S.splitOn (== 10) FL.length-    . S.unfold FH.read+## Performance -    where-    bucket n = let i = n `mod` 10 in if i > 9 then (9,n) else (i,n)+As you have seen in the word count example above, [Streamly][] offers+highly modular abstractions for building programs while also offering+the performance close to an equivalent (imperative) C program. -main = withArg llhisto >>= print-```+Streamly offers excellent performance even for byte-at-a-time stream+operations using efficient abstractions like `Unfold`s and terminating+`Fold`s.  Byte-at-a-time stream operations can simplify programming+because the developer does not have to deal explicitly with chunking+and re-combining data. -## Socket IO+Streamly exploits GHC's stream fusion optimizations (`case-of-case` and+`spec-constr`) aggressively to achieve C-like speed, while also offering+highly modular abstractions to developers. -Its easy to build concurrent client and server programs using streamly.-`Streamly.Network.*` modules provide easy combinators to build network servers-and client programs using streamly. See-[FromFileClient.hs](https://github.com/composewell/streamly/tree/master/examples/FromFileClient.hs),-[EchoServer.hs](https://github.com/composewell/streamly/tree/master/examples/EchoServer.hs),-[FileSinkServer.hs](https://github.com/composewell/streamly/tree/master/examples/FileSinkServer.hs)-in the examples directory.+[Streamly][] will usually perform very well without any+compiler plugins.  However, we have fixed some deficiencies+that we had noticed in GHC's optimizer using a [compiler+plugin](https://github.com/composewell/fusion-plugin).  We hope to fold+these optimizations into GHC in the future; until then we recommend that+you use this plugin for applications that are performance sensitive. -## Exceptions+### Benchmarks -Exceptions can be thrown at any point using the `MonadThrow` instance. Standard-exception handling combinators like `bracket`, `finally`, `handle`,-`onException` are provided in `Streamly.Prelude` module.+We measured several Haskell streaming implementations+using various micro-benchmarks. Please see the [streaming+benchmarks][streaming-benchmarks] page for a detailed comparison of+Streamly against other streaming libraries. -In presence of concurrency, synchronous exceptions work just the way they are-supposed to work in non-concurrent code. When concurrent streams-are combined together, exceptions from the constituent streams are propagated-to the consumer stream. When an exception occurs in any of the constituent-streams other concurrent streams are promptly terminated.+Our results show that [Streamly][] is the fastest effectful streaming+implementation on almost all the measured microbenchmarks. In many cases+it runs up to 100x faster, and in some cases even 1000x faster than+some of the tested alternatives. In some composite operation benchmarks+[Streamly][] turns out to be significantly faster than Haskell's list+implementation. -There is no notion of explicit threads in streamly, therefore, no-asynchronous exceptions to deal with. You can just ignore the zillions of-blogs, talks, caveats about async exceptions. Async exceptions just don't-exist.  Please don't use things like `myThreadId` and `throwTo` just for fun!+*Note*: If you can write a program in some other way or with some other+language that runs significantly faster than what [Streamly][] offers,+please let us know and we will improve. -## Reactive Programming (FRP)+## Notes -Streamly is a foundation for first class reactive programming as well by virtue-of integrating concurrency and streaming. See-[AcidRain.hs](https://github.com/composewell/streamly/tree/master/examples/AcidRain.hs)-for a console based FRP game example and-[CirclingSquare.hs](https://github.com/composewell/streamly/tree/master/examples/CirclingSquare.hs)-for an SDL based animation example.+Streamly comes equipped with a very powerful set of abstractions to+accomplish many kinds of programming tasks: it provides support for+programming with streams and arrays, for reading and writing from the+file system and from the network, for time domain programming (reactive+programming), and for reacting to file system events using `fsnotify`. -## Conclusion+Please view [Streamly's documentation][Streamly] for more information+about Streamly's features. -Streamly, short for streaming concurrently, provides monadic streams, with a-simple API, almost identical to standard lists, and an in-built-support for concurrency.  By using stream-style combinators on stream-composition, streams can be generated, merged, chained, mapped, zipped, and-consumed concurrently – providing a generalized high level programming-framework unifying streaming and concurrency. Controlled concurrency allows-even infinite streams to be evaluated concurrently.  Concurrency is auto scaled-based on feedback from the stream consumer.  The programmer does not have to be-aware of threads, locking or synchronization to write scalable concurrent-programs.+### Concurrency -Streamly is a programmer first library, designed to be useful and friendly to-programmers for solving practical problems in a simple and concise manner. Some-key points in favor of streamly are:+Streamly uses lock-free synchronization for achieving concurrent+operation with low overheads.  The number of tasks performed concurrently+are determined automatically based on the rate at which a consumer+is consuming the results. In other words, you do not need to manage+thread pools or decide how many threads to use for a particular task.+For CPU-bound tasks Streamly will try to keep the number of threads+close to the number of CPUs available; for IO-bound tasks it will utilize+more threads. -  * _Simplicity_: Simple list like streaming API, if you know how to use lists-    then you know how to use streamly. This library is built with simplicity-    and ease of use as a design goal.-  * _Concurrency_: Simple, powerful, and scalable concurrency.  Concurrency is-    built-in, and not intrusive, concurrent programs are written exactly the-    same way as non-concurrent ones.-  * _Generality_: Unifies functionality provided by several disparate packages-    (streaming, concurrency, list transformer, logic programming, reactive-    programming) in a concise API.-  * _Performance_: Streamly is designed for high performance. It employs stream-    fusion optimizations for best possible performance. Serial peformance is-    equivalent to the venerable `vector` library in most cases and even better-    in some cases.  Concurrent performance is unbeatable.  See-    [streaming-benchmarks](https://github.com/composewell/streaming-benchmarks)-    for a comparison of popular streaming libraries on micro-benchmarks.+The parallelism available during program execution can be utilized with+very little overhead even where the task size is very+small, because Streamly will automatically switch between+serial or batched execution of tasks on the same CPU depending+on whichever is more efficient.  Please see our [concurrency+benchmarks][concurrency-benchmarks] for more detailed performance+measurements, and for a comparison with the `async` package. -The basic streaming functionality of streamly is equivalent to that provided by-streaming libraries like-[vector](https://hackage.haskell.org/package/vector),-[streaming](https://hackage.haskell.org/package/streaming),-[pipes](https://hackage.haskell.org/package/pipes), and-[conduit](https://hackage.haskell.org/package/conduit).-In addition to providing streaming functionality, streamly subsumes-the functionality of list transformer libraries like `pipes` or-[list-t](https://hackage.haskell.org/package/list-t), and also the logic-programming library [logict](https://hackage.haskell.org/package/logict). On-the concurrency side, it subsumes the functionality of the-[async](https://hackage.haskell.org/package/async) package, and provides even-higher level concurrent composition. Because it supports-streaming with concurrency we can write FRP applications similar in concept to-[Yampa](https://hackage.haskell.org/package/Yampa) or-[reflex](https://hackage.haskell.org/package/reflex).+### Design Goals -See the `Comparison with existing packages` section at the end of the-[tutorial](https://hackage.haskell.org/package/streamly/docs/Streamly-Tutorial.html).+Our goals for [Streamly][] from the very beginning have been: -## Support+1. To achieve simplicity by unifying abstractions.+2. To offer high performance. -Please feel free to ask questions on the-[streamly gitter channel](https://gitter.im/composewell/streamly).-If you require professional support, consulting, training or timely-enhancements to the library please contact-[support@composewell.com](mailto:support@composewell.com).+These goals are hard to achieve simultaneously because they are usually+inversely related.  We have spent many years trying to get the abstractions+right without compromising performance. +`Unfold` is an example of an abstraction that we have created to achieve+high performance when mapping streams on streams.  `Unfold` allows stream+generation to be optimized well by the compiler through stream fusion.+A `Fold` with termination capability is another example which modularizes+stream elimination operations through stream fusion.  Terminating folds+can perform many simple parsing tasks that do not require backtracking.+In Streamly, `Parser`s are a natural extension to terminating `Fold`s;+`Parser`s add the ability to backtrack to `Fold`s.  Unification leads+to simpler abstractions and lower cognitive overheads while also not+compromising performance.+ ## Credits  The following authors/libraries have influenced or inspired this library in a significant way: -  * Roman Leshchinskiy (vector)-  * Gabriel Gonzalez (foldl)-  * Alberto G. Corona (transient)+  * Roman Leshchinskiy ([vector](http://hackage.haskell.org/package/vector))+  * Gabriel Gonzalez ([foldl](https://hackage.haskell.org/package/foldl))+  * Alberto G. Corona ([transient](https://hackage.haskell.org/package/transient)) -See the `credits` directory for full list of contributors, credits and licenses.+Please see the [`credits`](./credits/README.md) directory for a full+list of contributors, credits and licenses. -## Contributing+## Licensing -The code is available under BSD-3 license-[on github](https://github.com/composewell/streamly). Join the [gitter-chat](https://gitter.im/composewell/streamly) channel for discussions.  Please-ask any questions on the gitter channel or [contact the maintainer-directly](mailto:streamly@composewell.com). All contributions are welcome!+Streamly is an [open source](https://github.com/composewell/streamly)+project available under a liberal [BSD-3-Clause license][LICENSE]++## Contributing to Streamly++As an open project we welcome contributions:++* [Streamly Contributor's Guide][CONTRIBUTING.md]+* [Contact the streamly development team](mailto:streamly@composewell.com)++## Getting Support++Professional support is available for [Streamly][]: please contact+[support@composewell.com](mailto:support@composewell.com).++You can also join our [community chat+channel](https://gitter.im/composewell/streamly) on Gitter.
+ appveyor.yml view
@@ -0,0 +1,92 @@+# packcheck-0.4.2+# You can use any of the options supported by packcheck as environment+# variables here.  See https://github.com/harendra-kumar/packcheck for all+# options and their explanation.+branches:+  only:+    - master++environment:+    # ------------------------------------------------------------------------+    # Global options, you can use these per build as well+    # ------------------------------------------------------------------------+  global:+    # ------------------------------------------------------------------------+    # Common options+    # ------------------------------------------------------------------------+    GHC_OPTIONS: "-Werror"+    CABAL_REINIT_CONFIG: "y"+    LC_ALL: "C.UTF-8"++    # ------------------------------------------------------------------------+    # What to build+    # ------------------------------------------------------------------------+    # DISABLE_TEST: "y"+    # DISABLE_BENCH: "y"+    # DISABLE_DOCS: "y"+    DISABLE_SDIST_BUILD: "y"+    DISABLE_DIST_CHECKS: "y"+    ENABLE_INSTALL: "y"++    # ------------------------------------------------------------------------+    # stack options+    # ------------------------------------------------------------------------+    # Note requiring a specific version of stack using STACKVER may fail due to+    # github API limit while checking and upgrading/downgrading to the specific+    # version.+    #STACKVER: "1.6.5"+    STACK_UPGRADE: "y"+    RESOLVER: "lts-18.0"+    STACK_ROOT: "c:\\sr"+    STACK_BUILD_OPTIONS: "--flag streamly-benchmarks:-opt"++    # ------------------------------------------------------------------------+    # cabal options+    # ------------------------------------------------------------------------+    CABAL_CHECK_RELAX: "y"++    # ------------------------------------------------------------------------+    # Where to find the required tools+    # ------------------------------------------------------------------------+    PATH: "%PATH%;%APPDATA%\\local\\bin"+    LOCAL_BIN: "%APPDATA%\\local\\bin"++    # ------------------------------------------------------------------------+    # Location of packcheck.sh (the shell script invoked to perform CI tests ).+    # ------------------------------------------------------------------------+    # You can either commit the packcheck.sh script at this path in your repo or+    # you can use it by specifying the PACKCHECK_REPO_URL option below in which+    # case it will be automatically copied from the packcheck repo to this path+    # during CI tests. In any case it is finally invoked from this path.+    PACKCHECK_LOCAL_PATH: "./packcheck.sh"+    # If you have not committed packcheck.sh in your repo at PACKCHECK_LOCAL_PATH+    # then it is automatically pulled from this URL.+    PACKCHECK_GITHUB_URL: "https://raw.githubusercontent.com/composewell/packcheck"+    PACKCHECK_GITHUB_COMMIT: "35efa99b2082d13722b8a0183ac6455df98e91b9"++    # Override the temp directory to avoid sed escaping issues+    # See https://github.com/haskell/cabal/issues/5386+    TMP: "c:\\tmp"++cache:+  - "%STACK_ROOT%"+  - "%LOCAL_BIN%"+  - "%APPDATA%\\cabal"+  - "%APPDATA%\\ghc"+# - "%LOCALAPPDATA%\\Programs\\stack"++clone_folder: "c:\\pkg"+build: off++before_test:+- if not exist %PACKCHECK_LOCAL_PATH% curl -sSkL -o%PACKCHECK_LOCAL_PATH% %PACKCHECK_GITHUB_URL%/%PACKCHECK_GITHUB_COMMIT%/packcheck.sh+- if not exist %LOCAL_BIN% mkdir %LOCAL_BIN%+- where stack.exe || curl -sSkL -ostack.zip http://www.stackage.org/stack/windows-x86_64 && 7z x stack.zip stack.exe && move stack.exe %LOCAL_BIN%+- if defined STACKVER (stack upgrade --binary-only --binary-version %STACKVER%) else (stack upgrade --binary-only || ver > nul)+- stack --version++test_script:+- stack setup > nul+- for /f "usebackq tokens=*" %%i in (`where 7z.exe`) do set PATH7Z=%%i\..+- for /f "usebackq tokens=*" %%i in (`where git.exe`) do set PATHGIT=%%i\..+- chcp 65001 && stack exec bash -- -c "chmod +x %PACKCHECK_LOCAL_PATH%; %PACKCHECK_LOCAL_PATH% stack PATH=/usr/bin:\"%PATH7Z%\":\"%PATHGIT%\""
− bench.sh 
@@ -1,504 +0,0 @@-#!/bin/bash--SERIAL_O_1="linear base"-SERIAL_O_n="serial-o-n-heap serial-o-n-stack serial-o-n-space \-  base-o-n-heap base-o-n-stack base-o-n-space"-FOLD_BENCHMARKS="fold-o-1-space fold-o-n-heap"-UNFOLD_BENCHMARKS="unfold-o-1-space unfold-o-n-space"--SERIAL_BENCHMARKS="$SERIAL_O_1 $SERIAL_O_n $FOLD_BENCHMARKS"-# parallel benchmark-suite is separated because we run it with a higher-# heap size limit.-CONCURRENT_BENCHMARKS="linear-async linear-rate nested-concurrent parallel concurrent adaptive"-ARRAY_BENCHMARKS="array unpinned-array prim-array small-array"--# XXX We can include SERIAL_O_1 here once "base" also supports --stream-size-INFINITE_BENCHMARKS="linear linear-async linear-rate nested-concurrent"-FINITE_BENCHMARKS="$SERIAL_O_n $ARRAY_BENCHMARKS fileio parallel concurrent adaptive"--# Benchmarks that take long time per iteration must run fewer iterations to-# finish in reasonable time.-QUICK_BENCHMARKS="linear-rate concurrent adaptive fileio"-VIRTUAL_BENCHMARKS="array-cmp"--ALL_BENCHMARKS="$SERIAL_BENCHMARKS $CONCURRENT_BENCHMARKS $ARRAY_BENCHMARKS $VIRTUAL_BENCHMARKS"--# RTS options that go inside +RTS and -RTS while running the benchmark.-bench_rts_opts () {-  case "$1" in-    "fold-o-1-space") echo -n "-T -K36K -M16M" ;;-    "fold-o-n-heap") echo -n "-T -K36K -M128M" ;;-    "unfold-o-1-space") echo -n "-T -K36K -M16M" ;;-    "unfold-o-n-space") echo -n "-T -K32M -M64M" ;;-    *) echo -n "" ;;-  esac-}--# The correct executable for the given benchmark name.-bench_exec () {-  case "$1" in-    "fold-o-1-space") echo -n "fold" ;;-    "fold-o-n-heap") echo -n "fold" ;;-    "unfold-o-1-space") echo -n "unfold" ;;-    "unfold-o-n-space") echo -n "unfold" ;;-    *) echo -n "$1" ;;-  esac-}--# Specific gauge options for the given benchmark.-bench_gauge_opts () {-  case "$1" in-    "fold-o-1-space") echo -n "-m prefix o-1-space" ;;-    "fold-o-n-heap") echo -n "-m prefix o-n-heap" ;;-    "unfold-o-1-space") echo -n "-m prefix o-1-space" ;;-    "unfold-o-n-space") echo -n "-m prefix o-n-space" ;;-    *) echo -n "" ;;-  esac-}--list_benches ()  {-  for i in $ALL_BENCHMARKS-  do-    echo -n "|$i"-  done-}--print_help () {-  echo "Usage: $0 "-  echo "       [--benchmarks <ALL|SERIAL|CONCURRENT|ARRAY|INFINITE|FINITE|DEV$(list_benches)>]"-  echo "       [--group-diff]"-  echo "       [--graphs]"-  echo "       [--no-measure]"-  echo "       [--append]"-  echo "       [--long]"-  echo "       [--slow]"-  echo "       [--quick]"-  echo "       [--compare] [--base commit] [--candidate commit]"-  echo "       [--cabal-build-flags]"-  echo "       -- <gauge options or benchmarks>"-  echo-  echo "Multiple benchmarks can be specified as a space separated list"-  echo " e.g. --benchmarks \"linear nested\""-  echo-  echo "--group-diff is used to compare groups within a single benchmark"-  echo " e.g. StreamD vs StreamK in base benchmark."-  echo-  echo "When using --compare, by default comparative chart of HEAD^ vs HEAD"-  echo "commit is generated, in the 'charts' directory."-  echo "Use --base and --candidate to select the commits to compare."-  echo-  echo "Any arguments after a '--' are passed directly to gauge"-  exit-}--# $1: message-die () {-  >&2 echo -e "Error: $1"-  exit 1-}--set_benchmarks() {-  if test -z "$BENCHMARKS"-  then-    echo $DEFAULT_BENCHMARKS-  else-    for i in $(echo $BENCHMARKS)-    do-        case $i in-          ALL) echo -n $ALL_BENCHMARKS ;;-          SERIAL) echo -n $SERIAL_BENCHMARKS ;;-          CONCURRENT) echo -n $CONCURRENT_BENCHMARKS ;;-          ARRAY) echo -n $ARRAY_BENCHMARKS ;;-          INFINITE) echo -n $INFINITE_BENCHMARKS ;;-          FINITE) echo -n $FINITE_BENCHMARKS ;;-          array-cmp) echo -n "$ARRAY_BENCHMARKS array-cmp" ;;-          *) echo -n $i ;;-        esac-        echo -n " "-    done-  fi-}--# $1: benchmark name (linear, nested, base)-find_report_prog() {-    local prog_name="chart"-    hash -r-    local prog_path=$($WHICH_COMMAND $prog_name)-    if test -x "$prog_path"-    then-      echo $prog_path-    else-      return 1-    fi-}--# $1: benchmark name (linear, nested, base)-build_report_prog() {-    local prog_name="chart"-    local prog_path=$($WHICH_COMMAND $prog_name)--    hash -r-    if test ! -x "$prog_path" -a "$BUILD_ONCE" = "0"-    then-      echo "Building bench-graph executables"-      BUILD_ONCE=1-      $BUILD_CHART_EXE || die "build failed"-    elif test ! -x "$prog_path"-    then-      return 1-    fi-    return 0-}--build_report_progs() {-  if test "$RAW" = "0"-  then-      build_report_prog || exit 1-      local prog-      prog=$(find_report_prog) || \-          die "Cannot find bench-graph executable"-      echo "Using bench-graph executable [$prog]"-  fi-}--# We run the benchmarks in isolation in a separate process so that different-# benchmarks do not interfere with other. To enable that we need to pass the-# benchmark exe path to gauge as an argument. Unfortunately it cannot find its-# own path currently.--# The path is dependent on the architecture and cabal version.-# Use this command to find the exe if this script fails with an error:-# find .stack-work/ -type f -name "benchmarks"--stack_bench_prog () {-  local bench_name=$1-  local bench_prog=`stack path --dist-dir`/build/$bench_name/$bench_name-  if test -x "$bench_prog"-  then-    echo $bench_prog-  else-    return 1-  fi-}--cabal_bench_prog () {-  local bench_name=$1-  local bench_prog=`$WHICH_COMMAND $1`-  if test -x "$bench_prog"-  then-    echo $bench_prog-  else-    return 1-  fi-}--bench_output_file() {-    local bench_name=$1-    echo "charts/$bench_name/results.csv"-}--# --min-duration 0 means exactly one iteration per sample. We use a million-# iterations in the benchmarking code explicitly and do not use the iterations-# done by the benchmarking tool.-#-# Benchmarking tool by default discards the first iteration to remove-# aberrations due to initial evaluations etc. We do not discard it because we-# are anyway doing iterations in the benchmarking code and many of them so that-# any constant factor gets amortized and anyway it is a cost that we pay in-# real life.-#-# We can pass --min-samples value from the command line as second argument-# after the benchmark name in case we want to use more than one sample.--run_bench () {-  local bench_name=$1-  local bench_exe=$(bench_exec $bench_name)-  local output_file=$(bench_output_file $bench_name)-  local bench_prog-  local quick_bench=0-  bench_prog=$($GET_BENCH_PROG $bench_exe) || \-    die "Cannot find benchmark executable for benchmark $bench_name"--  mkdir -p `dirname $output_file`--  echo "Running benchmark $bench_name ..."--  for i in $QUICK_BENCHMARKS-  do-    if test "$(has_benchmark $i)" = "$bench_name"-    then-      quick_bench=1-    fi-  done--  local QUICK_OPTS="--quick --time-limit 1 --min-duration 0"-  local SPEED_OPTIONS-  if test "$LONG" -eq 0-  then-    if test "$SLOW" -eq 0-    then-        if test "$QUICK" -eq 0 -a "$quick_bench" -eq 0-        then-          # reasonably quick-          SPEED_OPTIONS="$QUICK_OPTS --min-samples 10"-        else-          # super quick but less accurate-          SPEED_OPTIONS="$QUICK_OPTS --include-first-iter"-        fi-    else-      SPEED_OPTIONS="--min-duration 0"-    fi-  else-      SPEED_OPTIONS="--stream-size 10000000 $QUICK_OPTS --include-first-iter"-  fi--  $bench_prog $SPEED_OPTIONS \-    +RTS $(bench_rts_opts $bench_name) -RTS \-    --csvraw=$output_file \-    -v 2 \-    --measure-with $bench_prog $GAUGE_ARGS \-    $(bench_gauge_opts $bench_name) || die "Benchmarking failed"-}--run_benches() {-    for i in $1-    do-      run_bench $i-    done-}--run_benches_comparing() {-    local bench_list=$1--    if test -z "$CANDIDATE"-    then-      CANDIDATE=$(git rev-parse HEAD)-    fi-    if test -z "$BASE"-    then-      # XXX Should be where the current branch is forked from master-      BASE="$CANDIDATE^"-    fi-    echo "Comparing baseline commit [$BASE] with candidate [$CANDIDATE]"-    echo "Checking out base commit [$BASE] for benchmarking"-    git checkout "$BASE" || die "Checkout of base commit [$BASE] failed"--    $BUILD_BENCH || die "build failed"-    run_benches "$bench_list"--    echo "Checking out candidate commit [$CANDIDATE] for benchmarking"-    git checkout "$CANDIDATE" || \-        die "Checkout of candidate [$CANDIDATE] commit failed"--    $BUILD_BENCH || die "build failed"-    run_benches "$bench_list"-    # XXX reset back to the original commit-}--backup_output_file() {-  local bench_name=$1-  local output_file=$(bench_output_file $bench_name)--  if test -e $output_file -a "$APPEND" != 1-  then-      mv -f -v $output_file ${output_file}.prev-  fi-}--run_measurements() {-  local bench_list=$1--  for i in $bench_list-  do-      backup_output_file $i-  done--  if test "$COMPARE" = "0"-  then-    run_benches "$bench_list"-  else-    run_benches_comparing "$bench_list"-  fi-}--run_reports() {-    local prog-    prog=$(find_report_prog) || \-      die "Cannot find bench-graph executable"-    echo--    for i in $1-    do-        echo "Generating reports for ${i}..."-        $prog $(test "$GRAPH" = 1 && echo "--graphs") \-              $(test "$GROUP_DIFF" = 1 && echo "--group-diff") \-              --benchmark $i-    done-}--#------------------------------------------------------------------------------# Execution starts here-#-------------------------------------------------------------------------------DEFAULT_BENCHMARKS="linear"-GROUP_DIFF=0--COMPARE=0-BASE=-CANDIDATE=--APPEND=0-SLOW=0-QUICK=0-LONG=0-RAW=0-GRAPH=0-MEASURE=1--GAUGE_ARGS=-BUILD_ONCE=0-USE_STACK=0-CABAL_BUILD_FLAGS=""--GHC_VERSION=$(ghc --numeric-version)--cabal_which() {-  find dist-newstyle -type f -path "*${GHC_VERSION}*/$1"-}--#------------------------------------------------------------------------------# Read command line-#-------------------------------------------------------------------------------while test -n "$1"-do-  case $1 in-    -h|--help|help) print_help ;;-    # options with arguments-    --benchmarks) shift; BENCHMARKS=$1; shift ;;-    --base) shift; BASE=$1; shift ;;-    --candidate) shift; CANDIDATE=$1; shift ;;-    --cabal-build-flags) shift; CABAL_BUILD_FLAGS=$1; shift ;;-    # flags-    --slow) SLOW=1; shift ;;-    --quick) QUICK=1; shift ;;-    --compare) COMPARE=1; shift ;;-    --raw) RAW=1; shift ;;-    --append) APPEND=1; shift ;;-    --long) LONG=1; shift ;;-    --group-diff) GROUP_DIFF=1; shift ;;-    --graphs) GRAPH=1; shift ;;-    --no-measure) MEASURE=0; shift ;;-    --) shift; break ;;-    -*|--*) print_help ;;-    *) break ;;-  esac-done-GAUGE_ARGS=$*--BENCHMARKS=$(set_benchmarks)-if test "$LONG" -ne 0-then-  BENCHMARKS=$INFINITE_BENCHMARKS-fi--only_real_benchmarks () {-  for i in $BENCHMARKS-  do-    local SKIP=0-    for j in $VIRTUAL_BENCHMARKS-    do-      if test $i == $j-      then-        SKIP=1-      fi-    done-    if test "$SKIP" -eq 0-    then-      echo -n "$i "-    fi-  done-}--proper_executables () {-  for i in $BENCHMARKS-  do-    echo -n "$(bench_exec $i) "-  done-}---BENCHMARKS_ORIG=$BENCHMARKS-BENCHMARKS=$(only_real_benchmarks)-EXECUTABLES=$(proper_executables)-echo "Using benchmark suites [$BENCHMARKS]"--has_benchmark () {-  for i in $BENCHMARKS_ORIG-  do-    if test "$i" = "$1"-    then-      echo "$i"-      break-    fi-  done-}--if test "$USE_STACK" = "1"-then-  WHICH_COMMAND="stack exec which"-  BUILD_CHART_EXE="stack build --flag streamly:dev"-  GET_BENCH_PROG=stack_bench_prog-  BUILD_BENCH="stack build $STACK_BUILD_FLAGS --bench --no-run-benchmarks"-else-  # XXX cabal issue "cabal v2-exec which" cannot find benchmark/test executables-  #WHICH_COMMAND="cabal v2-exec which"-  WHICH_COMMAND=cabal_which-  BUILD_CHART_EXE="cabal v2-build --flags dev chart"-  GET_BENCH_PROG=cabal_bench_prog-  BUILD_BENCH="cabal v2-build $CABAL_BUILD_FLAGS --enable-benchmarks"-fi--#------------------------------------------------------------------------------# Build stuff-#-------------------------------------------------------------------------------# We need to build the report progs first at the current (latest) commit before-# checking out any other commit for benchmarking.-build_report_progs "$BENCHMARKS"--#------------------------------------------------------------------------------# Run benchmarks-#-------------------------------------------------------------------------------if test "$MEASURE" = "1"-then-  echo $BUILD_BENCH-  if test "$USE_STACK" = "1"-  then-    $BUILD_BENCH || die "build failed"-  else-    $BUILD_BENCH $EXECUTABLES || die "build failed"-  fi-  run_measurements "$BENCHMARKS"-fi--#------------------------------------------------------------------------------# Run reports-#-------------------------------------------------------------------------------VIRTUAL_REPORTS=""-if test "$(has_benchmark 'array-cmp')" = "array-cmp"-then-  VIRTUAL_REPORTS="$VIRTUAL_REPORTS array-cmp"-  mkdir -p "charts/array-cmp"-  cat "charts/array/results.csv" \-      "charts/prim-array/results.csv" \-      "charts/unpinned-array/results.csv" > "charts/array-cmp/results.csv"-fi--if test "$RAW" = "0"-then-  run_reports "$BENCHMARKS"-  run_reports "$VIRTUAL_REPORTS"-fi
− benchmark/Chart.hs 
@@ -1,446 +0,0 @@-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Main where--import Control.Exception (handle, catch, SomeException, ErrorCall(..))-import Control.Monad.Trans.State-import Control.Monad.Trans.Maybe-import Data.Char (toLower)-import Data.Function (on, (&))-import Data.List-import Data.List.Split-import Data.Maybe (mapMaybe)-import Data.Ord (comparing)-import System.Environment (getArgs)-import Control.Monad.IO.Class (liftIO)-import Control.Monad (mzero)--import BenchShow----------------------------------------------------------------------------------- Command line parsing---------------------------------------------------------------------------------data BenchType-    = Linear-    | LinearAsync-    | LinearRate-    | NestedConcurrent-    | Parser-    | Base-    | FileIO-    | Array-    | ArrayCmp-    | UnpinnedArray-    | SmallArray-    | PrimArray-    | Concurrent-    | Parallel-    | Adaptive-    | FoldO1Space-    | FoldOnHeap-    | UnfoldO1Space-    | UnfoldOnSpace-    deriving Show--data Options = Options-    { genGraphs :: Bool-    , groupDiff :: Bool-    , benchType :: BenchType-    } deriving Show--defaultOptions = Options False False Linear--setGenGraphs val = do-    (args, opts) <- get-    put (args, opts { genGraphs = val })--setGroupDiff val = do-    (args, opts) <- get-    put (args, opts { groupDiff = val })--setBenchType val = do-    (args, opts) <- get-    put (args, opts { benchType = val })---- Like the shell "shift" to shift the command line arguments-shift :: StateT ([String], Options) (MaybeT IO) (Maybe String)-shift = do-    s <- get-    case s of-        ([], _) -> return Nothing-        (x : xs, opts) -> put (xs, opts) >> return (Just x)--parseBench :: StateT ([String], Options) (MaybeT IO) ()-parseBench = do-    x <- shift-    case x of-        Just "linear" -> setBenchType Linear-        Just "linear-async" -> setBenchType LinearAsync-        Just "linear-rate" -> setBenchType LinearRate-        Just "nested-concurrent" -> setBenchType NestedConcurrent-        Just "parser" -> setBenchType Parser-        Just "base" -> setBenchType Base-        Just "fileio" -> setBenchType FileIO-        Just "array-cmp" -> setBenchType ArrayCmp-        Just "array" -> setBenchType Array-        Just "unpinned-array" -> setBenchType UnpinnedArray-        Just "small-array" -> setBenchType SmallArray-        Just "prim-array" -> setBenchType PrimArray-        Just "concurrent" -> setBenchType Concurrent-        Just "parallel" -> setBenchType Parallel-        Just "adaptive" -> setBenchType Adaptive-        Just "fold-o-1-space" -> setBenchType FoldO1Space-        Just "fold-o-n-heap" -> setBenchType FoldOnHeap-        Just "unfold-o-1-space" -> setBenchType UnfoldO1Space-        Just "unfold-o-n-space" -> setBenchType UnfoldOnSpace-        Just str -> do-                liftIO $ putStrLn $ "unrecognized benchmark type " <> str-                mzero-        Nothing -> do-                liftIO $ putStrLn "please provide a benchmark type "-                mzero---- totally imperative style option parsing-parseOptions :: IO (Maybe Options)-parseOptions = do-    args <- getArgs-    runMaybeT $ flip evalStateT (args, defaultOptions) $ do-        parseLoop-        fmap snd get--    where--    parseOpt opt =-        case opt of-            "--graphs"     -> setGenGraphs True-            "--group-diff" -> setGroupDiff True-            "--benchmark"  -> parseBench-            str -> do-                liftIO $ putStrLn $ "Unrecognized option " <> str-                mzero--    parseLoop = do-        next <- shift-        case next of-            Just opt -> parseOpt opt >> parseLoop-            Nothing -> return ()--ignoringErr a = catch a (\(ErrorCall err :: ErrorCall) ->-    putStrLn $ "Failed with error:\n" <> err <> "\nSkipping.")----------------------------------------------------------------------------------- Linear composition charts---------------------------------------------------------------------------------makeLinearGraphs :: Config -> String -> IO ()-makeLinearGraphs cfg@Config{..} inputFile = do-    ignoringErr $ graph inputFile "generation" $ cfg-        { title = (++) <$> title <*> Just " generation"-        , classifyBenchmark =-            fmap ("Streamly",) . stripPrefix "serially/generation/"-        }--    ignoringErr $ graph inputFile "elimination" $ cfg-        { title = (++) <$> title <*> Just " Elimination"-        , classifyBenchmark =-            fmap ("Streamly",) . stripPrefix "serially/elimination/"-        }--    ignoringErr $ graph inputFile "transformation-zip" $ cfg-        { title = (++) <$> title <*> Just " Transformation & Zip"-        , classifyBenchmark = \b ->-                if    "serially/transformation/" `isPrefixOf` b-                   || "serially/zipping" `isPrefixOf` b-                then Just ("Streamly", last $ splitOn "/" b)-                else Nothing-        }--    ignoringErr $ graph inputFile "filtering" $ cfg-        { title = (++) <$> title <*> Just " Filtering"-        , classifyBenchmark =-            fmap ("Streamly",) . stripPrefix "serially/filtering/"-        }--    ignoringErr $ graph inputFile "transformationX4" $ cfg-        { title = (++) <$> title <*> Just " Transformation x 4"-        , classifyBenchmark =-            fmap ("Streamly",) . stripPrefix "serially/transformationX4/"-        }--    ignoringErr $ graph inputFile "filteringX4"-        $ cfg-        { title = (++) <$> title <*> Just " Filtering x 4"-        , classifyBenchmark =-            fmap ("Streamly",) . stripPrefix "serially/filteringX4/"-        }--    ignoringErr $ graph inputFile "mixedX4"-        $ cfg-        { title = (++) <$> title <*> Just " Mixed x 4"-        , classifyBenchmark =-            fmap ("Streamly",) . stripPrefix "serially/mixedX4/"-        }--    ignoringErr $ graph inputFile "iterated"-        $ cfg-        { title = Just "iterate 10,000 times over 10 elems"-        , classifyBenchmark =-            fmap ("Streamly",) . stripPrefix "serially/iterated/"-        }----------------------------------------------------------------------------------- Stream type based comparison charts---------------------------------------------------------------------------------makeStreamComparisonGraphs :: String -> [String] -> Config -> String -> IO ()-makeStreamComparisonGraphs outputPrefix benchPrefixes cfg inputFile =-    ignoringErr $ graph inputFile outputPrefix $ cfg-        { presentation = Groups Absolute-        , classifyBenchmark = classifyNested-        , selectGroups = \gs ->-            groupBy ((==) `on` snd) gs-            & fmap (\xs -> mapMaybe (\x -> (x,) <$> lookup x xs) benchPrefixes)-            & concat-        }--    where--    classifyNested b-        | "serially/" `isPrefixOf` b =-            ("serially",) <$> stripPrefix "serially/" b-        | "asyncly/" `isPrefixOf` b =-            ("asyncly",) <$> stripPrefix "asyncly/" b-        | "wAsyncly/" `isPrefixOf` b =-            ("wAsyncly",) <$> stripPrefix "wAsyncly/" b-        | "aheadly/" `isPrefixOf` b =-            ("aheadly",) <$> stripPrefix "aheadly/" b-        | "parallely/" `isPrefixOf` b =-            ("parallely",) <$> stripPrefix "parallely/" b-        | otherwise = Nothing--linearAsyncPrefixes = ["asyncly", "wAsyncly", "aheadly", "parallely"]-nestedBenchPrefixes = ["serially"] ++ linearAsyncPrefixes----------------------------------------------------------------------------------- Generic---------------------------------------------------------------------------------makeGraphs :: String -> Config -> String -> IO ()-makeGraphs name cfg@Config{..} inputFile =-    ignoringErr $ graph inputFile name cfg----------------------------------------------------------------------------------- Arrays---------------------------------------------------------------------------------showArrayComparisons Options{..} cfg inp out =-    let cfg' = cfg { classifyBenchmark = classifyArray }-    in if genGraphs-       then ignoringErr $ graph inp "Arrays Comparison"-                cfg' { outputDir = Just out-                     , presentation = Groups Absolute-                     }-       else ignoringErr $ report inp Nothing cfg'--    where--    classifyArray b-        -- SmallArray uses a small number of elements therefore cannot be-        -- compared-        -- | "SmallArray/" `isPrefixOf` b = ("SmallArray",) <$> stripPrefix "SmallArray/" b-        | "Data.Prim.Array/" `isPrefixOf` b = ("Data.Prim.Array",) <$> stripPrefix "Data.Prim.Array/" b-        | "Data.Array/" `isPrefixOf` b = ("Data.Array",) <$> stripPrefix "Data.Array/" b-        | "array/" `isPrefixOf` b = ("array",) <$> stripPrefix "array/" b-        | otherwise = Nothing----------------------------------------------------------------------------------- Reports/Charts for base streams---------------------------------------------------------------------------------showStreamDVsK Options{..} cfg inp out =-    let cfg' = cfg { classifyBenchmark = classifyBase }-    in if genGraphs-       then ignoringErr $ graph inp "streamD-vs-streamK"-                cfg' { outputDir = Just out-                     , presentation = Groups Absolute-                     }-       else ignoringErr $ report inp Nothing cfg'--    where--    classifyBase b-        | "streamD/" `isPrefixOf` b = ("streamD",) <$> stripPrefix "streamD/" b-        | "streamK/" `isPrefixOf` b = ("streamK",) <$> stripPrefix "streamK/" b-        | otherwise = Nothing--showStreamD Options{..} cfg inp out =-    let cfg' = cfg { classifyBenchmark = classifyStreamD }-    in if genGraphs-       then ignoringErr $ graph inp "streamD"-                cfg' {outputDir = Just out}-       else ignoringErr $ report inp Nothing cfg'--    where--    classifyStreamD b-        | "streamD/" `isPrefixOf` b = ("streamD",) <$> stripPrefix "streamD/" b-        | otherwise = Nothing--showStreamK Options{..} cfg inp out =-    let cfg' = cfg { classifyBenchmark = classifyStreamK }-    in if genGraphs-       then ignoringErr $ graph inp "streamK"-                cfg' {outputDir = Just out}-       else ignoringErr $ report inp Nothing cfg'--    where--    classifyStreamK b-        | "streamK/" `isPrefixOf` b = ("streamK",) <$> stripPrefix "streamK/" b-        | otherwise = Nothing----------------------------------------------------------------------------------- text reports---------------------------------------------------------------------------------selectBench-    :: (SortColumn -> Maybe GroupStyle -> Either String [(String, Double)])-    -> [String]-selectBench f =-    reverse-    $ fmap fst-    $ either-      (const $ either error (sortOn snd) $ f (ColumnIndex 0) (Just PercentDiff))-      (sortOn snd)-      $ f (ColumnIndex 1) (Just PercentDiff)--benchShow Options{..} cfg func inp out =-    if genGraphs-    then func cfg {outputDir = Just out} inp-    else ignoringErr $ report inp Nothing cfg--main :: IO ()-main = do-    let cfg = defaultConfig-            { presentation = Groups PercentDiff-            , selectBenchmarks = selectBench-            , selectFields = filter-                ( flip elem ["time" , "mean"-                            , "maxrss", "cputime"-                            ]-                . map toLower-                )-            }-    res <- parseOptions--    case res of-        Nothing -> do-            putStrLn "cannot parse options"-            return ()-        Just opts@Options{..} ->-            case benchType of-                Linear -> benchShow opts cfg-                            { title = Just "Linear" }-                            makeLinearGraphs-                            "charts/linear/results.csv"-                            "charts/linear"-                LinearRate -> benchShow opts cfg-                            { title = Just "Linear Rate" }-                            (makeGraphs "linear-rate")-                            "charts/linear-rate/results.csv"-                            "charts/linear-rate"-                LinearAsync -> benchShow opts cfg-                            { title = Just "Linear Async" }-                            (makeStreamComparisonGraphs "linear-async" linearAsyncPrefixes)-                            "charts/linear-async/results.csv"-                            "charts/linear-async"-                NestedConcurrent -> benchShow opts cfg-                            { title = Just "Nested concurrent loops" }-                            (makeStreamComparisonGraphs "nested-concurrent" nestedBenchPrefixes)-                            "charts/nested-concurrent/results.csv"-                            "charts/nested-concurrent"-                Parser -> benchShow opts cfg-                            { title = Just "Parsers" }-                            (makeGraphs "parser")-                            "charts/parser/results.csv"-                            "charts/parser"-                FileIO -> benchShow opts cfg-                            { title = Just "File IO" }-                            (makeGraphs "fileIO")-                            "charts/fileio/results.csv"-                            "charts/fileio"-                Array -> benchShow opts cfg-                            { title = Just "Array" }-                            (makeGraphs "array")-                            "charts/array/results.csv"-                            "charts/array"-                UnpinnedArray -> benchShow opts cfg-                            { title = Just "Unpinned Array" }-                            (makeGraphs "unpinned-array")-                            "charts/unpinned-array/results.csv"-                            "charts/unpinned-array"-                SmallArray -> benchShow opts cfg-                            { title = Just "Small Array" }-                            (makeGraphs "small-array")-                            "charts/small-array/results.csv"-                            "charts/small-array"-                PrimArray -> benchShow opts cfg-                            { title = Just "Prim Array" }-                            (makeGraphs "prim-array")-                            "charts/prim-array/results.csv"-                            "charts/prim-array"-                ArrayCmp -> showArrayComparisons opts cfg-                            { title = Just "Arrays Comparison" }-                            "charts/array-cmp/results.csv"-                            "charts/array-cmp"-                Concurrent -> benchShow opts cfg-                            { title = Just "Concurrent Ops" }-                            (makeGraphs "Concurrent")-                            "charts/concurrent/results.csv"-                            "charts/concurrent"-                Parallel -> benchShow opts cfg-                            { title = Just "Parallel" }-                            (makeGraphs "parallel")-                            "charts/parallel/results.csv"-                            "charts/parallel"-                Adaptive -> benchShow opts cfg-                            { title = Just "Adaptive" }-                            (makeGraphs "adaptive")-                            "charts/adaptive/results.csv"-                            "charts/adaptive"-                Base -> do-                    let cfg' = cfg { title = Just "Base stream" }-                    if groupDiff-                    then showStreamDVsK opts cfg'-                                "charts/base/results.csv"-                                "charts/base"-                    else do-                        showStreamD opts cfg'-                                "charts/base/results.csv"-                                "charts/base"-                        showStreamK opts cfg'-                                "charts/base/results.csv"-                                "charts/base"-                FoldO1Space -> benchShow opts cfg-                            { title = Just "Fold O(1) Space" }-                            (makeGraphs "fold-o-1-space")-                            "charts/fold-o-1-space/results.csv"-                            "charts/fold-o-1-space"-                FoldOnHeap -> benchShow opts cfg-                            { title = Just "Fold O(n) Heap" }-                            (makeGraphs "fold-o-n-heap")-                            "charts/fold-o-n-heap/results.csv"-                            "charts/fold-o-n-heap"-                UnfoldO1Space -> benchShow opts cfg-                            { title = Just "Unfold O(1) Space" }-                            (makeGraphs "unfold-o-1-space")-                            "charts/unfold-o-1-space/results.csv"-                            "charts/unfold-o-1-space"-                UnfoldOnSpace -> benchShow opts cfg-                            { title = Just "Unfold O(n) Space" }-                            (makeGraphs "unfold-o-n-space")-                            "charts/unfold-o-n-space/results.csv"-                            "charts/unfold-o-n-space"
− benchmark/FileIO.hs 
@@ -1,349 +0,0 @@--- |--- Module      : Main--- Copyright   : (c) 2019 Harendra Kumar------ License     : BSD3--- Maintainer  : streamly@composewell.com--{-# LANGUAGE CPP #-}--import Control.DeepSeq (NFData)-import System.IO (openFile, IOMode(..), Handle, hClose)-import System.Process.Typed (shell, runProcess_)--import Data.IORef-import Gauge--import qualified Streamly.Benchmark.FileIO.Stream as BFS-import qualified Streamly.Benchmark.FileIO.Array as BFA---- Input and output file handles-data Handles = Handles Handle Handle--scratchDir :: String-scratchDir = "benchmark/scratch/"--outfile :: String-outfile = scratchDir ++ "out.txt"--blockSize, blockCount :: Int-blockSize = 32768-blockCount = 3200--fileSize :: Int-fileSize = blockSize * blockCount--#ifdef DEVBUILD--- This is a 500MB text file for text processing benchmarks.  We cannot--- have it in the repo, therefore we use it locally with DEVBUILD--- conditional (enabled by "dev" cabal flag). Some tests that depend on--- this file are available only in DEVBUILD mode.-infile :: String-infile = "benchmark/text-processing/gutenberg-500.txt"--#else-infile :: String-infile = scratchDir ++ "in-100MB.txt"-#endif--main :: IO ()-main = do-#ifndef DEVBUILD-    -- XXX will this work on windows/msys?-    let cmd = "mkdir -p " ++ scratchDir-                ++ "; test -e " ++ infile-                ++ " || { echo \"creating input file " ++ infile-                ++ "\" && dd if=/dev/random of=" ++ infile-                ++ " bs=" ++ show blockSize-                ++ " count=" ++ show blockCount-                ++ ";}"--    runProcess_ (shell cmd)-#endif-    inHandle <- openFile infile ReadMode-    outHandle <- openFile outfile WriteMode-    href <- newIORef $ Handles inHandle outHandle-    devNull <- openFile "/dev/null" WriteMode--    defaultMain-        [ bgroup "readArray"-            [ mkBench "last" href $ do-                Handles inh _ <- readIORef href-                BFA.last inh-            -- Note: this cannot be fairly compared with GNU wc -c or wc -m as-            -- wc uses lseek to just determine the file size rather than reading-            -- and counting characters.-            , mkBench "length (bytecount)" href $ do-                Handles inh _ <- readIORef href-                BFA.countBytes inh-            , mkBench "linecount" href $ do-                Handles inh _ <- readIORef href-                BFA.countLines inh-            , mkBench "wordcount" href $ do-                Handles inh _ <- readIORef href-                BFA.countWords inh-            , mkBench "sum" href $ do-                Handles inh _ <- readIORef href-                BFA.sumBytes inh-            , mkBench "cat" href $ do-                Handles inh _ <- readIORef href-                BFA.cat devNull inh-           , mkBench "catBracket" href $ do-               Handles inh _ <- readIORef href-               BFA.catBracket devNull inh-           , mkBench "catBracketIO" href $ do-               Handles inh _ <- readIORef href-               BFA.catBracketIO devNull inh-           , mkBench "catBracketStream" href $ do-               Handles inh _ <- readIORef href-               BFA.catBracketStream devNull inh-           , mkBench "catBracketStreamIO" href $ do-               Handles inh _ <- readIORef href-               BFA.catBracketStreamIO devNull inh-           , mkBench "catOnException" href $ do-               Handles inh _ <- readIORef href-               BFA.catOnException devNull inh-           , mkBench "read-utf8" href $ do-               Handles inh _ <- readIORef href-               BFA.decodeUtf8Lenient inh-            ]-        , bgroup "readStream"-            [ mkBench "last" href $ do-                Handles inh _ <- readIORef href-                BFS.last inh-            , mkBench "length (bytecount)" href $ do-                Handles inh _ <- readIORef href-                BFS.countBytes inh-            , mkBench "linecount" href $ do-                Handles inh _ <- readIORef href-                BFS.countLines inh-            , mkBench "linecountU" href $ do-                Handles inh _ <- readIORef href-                BFS.countLinesU inh-            , mkBench "wordcount" href $ do-                Handles inh _ <- readIORef href-                BFS.countWords inh-            , mkBench "sum" href $ do-                Handles inh _ <- readIORef href-                BFS.sumBytes inh-            , mkBench "cat" href $ do-                Handles inh _ <- readIORef href-                BFS.cat devNull inh-            , mkBench "catStream" href $ do-                Handles inh _ <- readIORef href-                BFS.catStreamWrite devNull inh-#ifdef DEVBUILD-           , mkBench "catOnException" href $ do-               Handles inh _ <- readIORef href-               BFS.catOnException devNull inh-           , mkBench "catOnExceptionStream" href $ do-               Handles inh _ <- readIORef href-               BFS.catOnExceptionStream devNull inh-           , mkBench "catHandle" href $ do-               Handles inh _ <- readIORef href-               BFS.catHandle devNull inh-           , mkBench "catHandleStream" href $ do-               Handles inh _ <- readIORef href-               BFS.catHandleStream devNull inh-           , mkBench "catFinally" href $ do-               Handles inh _ <- readIORef href-               BFS.catFinally devNull inh-           , mkBench "catFinallyIO" href $ do-               Handles inh _ <- readIORef href-               BFS.catFinallyIO devNull inh-           , mkBench "catFinallyStream" href $ do-               Handles inh _ <- readIORef href-               BFS.catFinallyStream devNull inh-           , mkBench "catFinallyStreamIO" href $ do-               Handles inh _ <- readIORef href-               BFS.catFinallyStreamIO devNull inh-           , mkBench "catBracketStream" href $ do-               Handles inh _ <- readIORef href-               BFS.catBracketStream devNull inh-           , mkBench "catBracketStreamIO" href $ do-               Handles inh _ <- readIORef href-               BFS.catBracketStreamIO devNull inh-           , mkBench "catBracket" href $ do-               Handles inh _ <- readIORef href-               BFS.catBracket devNull inh-           , mkBench "catBracketIO" href $ do-               Handles inh _ <- readIORef href-               BFS.catBracketIO devNull inh-#endif-           , mkBench "read-word8" href $ do-               Handles inh _ <- readIORef href-               BFS.readWord8 inh-           , mkBench "read-latin1" href $ do-               Handles inh _ <- readIORef href-               BFS.decodeLatin1 inh-           , mkBench "read-utf8" href $ do-               Handles inh _ <- readIORef href-               BFS.decodeUtf8Lax inh-            ]-        , bgroup "copyArray"-            [ mkBench "copy" href $ do-                Handles inh outh <- readIORef href-                BFA.copy inh outh-            ]-#ifdef DEVBUILD-        -- This takes a little longer therefore put under the dev conditional-        , bgroup "copyStream"-            [ mkBench "fromToHandle" href $ do-                Handles inh outh <- readIORef href-                BFS.copy inh outh-            ]-        -- This needs an ascii file, as decode just errors out.-        , bgroup "decode-encode"-           [ mkBench "latin1" href $ do-               Handles inh outh <- readIORef href-               BFS.copyCodecChar8 inh outh-           , mkBench "utf8-arrays" href $ do-               Handles inh outh <- readIORef href-               BFA.copyCodecUtf8Lenient inh outh-           , mkBench "utf8" href $ do-               Handles inh outh <- readIORef href-               BFS.copyCodecUtf8Lenient inh outh-           ]-#endif-        , bgroup "grouping-chunks"-            [ mkBench "sumChunksOf (single chunk)" href $ do-                Handles inh _ <- readIORef href-                BFS.chunksOfSum fileSize inh-            , mkBench "sumChunksOf 1" href $ do-                Handles inh _ <- readIORef href-                BFS.chunksOfSum 1 inh-            , mkBench "sumChunksOf (single chunk) (splitParse)" href $ do-                Handles inh _ <- readIORef href-                BFS.splitParseChunksOfSum fileSize inh-            , mkBench "sumChunksOf 1 (splitParse)" href $ do-                Handles inh _ <- readIORef href-                BFS.splitParseChunksOfSum 1 inh--            , mkBench "arraysOf 1" href $ do-                Handles inh _ <- readIORef href-                BFS.chunksOf 1 inh-            , mkBench "arraysOf 10" href $ do-                Handles inh _ <- readIORef href-                BFS.chunksOf 10 inh-            , mkBench "arraysOf 1000" href $ do-                Handles inh _ <- readIORef href-                BFS.chunksOf 1000 inh-            ]-#ifdef DEVBUILD-        , bgroup "group-ungroup-stream"-            [ mkBench "lines-unlines-[Char]" href $ do-                Handles inh outh <- readIORef href-                BFS.linesUnlinesCopy inh outh-            , mkBench "lines-unlines-Word8Array" href $ do-                Handles inh outh <- readIORef href-                BFS.linesUnlinesArrayWord8Copy inh outh-            , mkBench "lines-unlines-CharArray" href $ do-                Handles inh outh <- readIORef href-                BFS.linesUnlinesArrayCharCopy inh outh-            , mkBench "words-unwords-[Word8]" href $ do-                Handles inh outh <- readIORef href-                BFS.wordsUnwordsCopyWord8 inh outh-            , mkBench "words-unwords-[Char]" href $ do-                Handles inh outh <- readIORef href-                BFS.wordsUnwordsCopy inh outh-            , mkBench "words-unwords-CharArray" href $ do-                Handles inh outh <- readIORef href-                BFS.wordsUnwordsCharArrayCopy inh outh-            ]--        , bgroup "group-ungroup-array-stream"-            [ mkBench "lines-unlines-Word8Array" href $ do-                Handles inh outh <- readIORef href-                BFA.linesUnlinesCopy inh outh-            , mkBench "words-unwords-Word8Array" href $ do-                Handles inh outh <- readIORef href-                BFA.wordsUnwordsCopy inh outh-            ]--        , bgroup "splitting"-            [ bgroup "predicate"-                [ mkBench "splitOn \\n (line count)" href $ do-                    Handles inh _ <- readIORef href-                    BFS.splitOn inh-                , mkBench "splitOnSuffix \\n (line count)" href $ do-                    Handles inh _ <- readIORef href-                    BFS.splitOnSuffix inh-                , mkBench "splitOn \\n (line count) (splitParse)" href $ do-                    Handles inh _ <- readIORef href-                    BFS.splitParseSepBy inh-                , mkBench "wordsBy isSpace (word count)" href $ do-                    Handles inh _ <- readIORef href-                    BFS.wordsBy inh-                ]--            , bgroup "empty-pattern"-                [ mkBench "splitOnSeq \"\"" href $ do-                    Handles inh _ <- readIORef href-                    BFS.splitOnSeq "" inh-                , mkBench "splitOnSuffixSeq \"\"" href $ do-                    Handles inh _ <- readIORef href-                    BFS.splitOnSuffixSeq "" inh-                ]-            , bgroup "short-pattern"-                [ mkBench "splitOnSeq \\n (line count)" href $ do-                    Handles inh _ <- readIORef href-                    BFS.splitOnSeq "\n" inh-                , mkBench "splitOnSuffixSeq \\n (line count)" href $ do-                    Handles inh _ <- readIORef href-                    BFS.splitOnSuffixSeq "\n" inh-                , mkBench "splitOnSeq a" href $ do-                    Handles inh _ <- readIORef href-                    BFS.splitOnSeq "a" inh-                , mkBench "splitOnSeq \\r\\n" href $ do-                    Handles inh _ <- readIORef href-                    BFS.splitOnSeq "\r\n" inh-                , mkBench "splitOnSuffixSeq \\r\\n)" href $ do-                    Handles inh _ <- readIORef href-                    BFS.splitOnSuffixSeq "\r\n" inh-                , mkBench "splitOnSeq aa" href $ do-                    Handles inh _ <- readIORef href-                    BFS.splitOnSeq "aa" inh-                , mkBench "splitOnSeq aaaa" href $ do-                    Handles inh _ <- readIORef href-                    BFS.splitOnSeq "aaaa" inh-                , mkBench "splitOnSeq abcdefgh" href $ do-                    Handles inh _ <- readIORef href-                    BFS.splitOnSeq "abcdefgh" inh-                , mkBench "splitOnSeqUtf8 abcdefgh" href $ do-                    Handles inh _ <- readIORef href-                    BFS.splitOnSeqUtf8 "abcdefgh" inh-                ]-            , bgroup "long-pattern"-                [ mkBench "splitOnSeq abcdefghi" href $ do-                    Handles inh _ <- readIORef href-                    BFS.splitOnSeq "abcdefghi" inh-                , mkBench "splitOnSeq catcatcatcatcat" href $ do-                    Handles inh _ <- readIORef href-                    BFS.splitOnSeq "catcatcatcatcat" inh-                , mkBench "splitOnSeq abc...xyz" href $ do-                    Handles inh _ <- readIORef href-                    BFS.splitOnSeq "abcdefghijklmnopqrstuvwxyz" inh-                , mkBench "splitOnSuffixSeq abc...xyz" href $ do-                    Handles inh _ <- readIORef href-                    BFS.splitOnSuffixSeq "abcdefghijklmnopqrstuvwxyz" inh-                , mkBench "splitOnSeqUtf8 abc...xyz" href $ do-                    Handles inh _ <- readIORef href-                    BFS.splitOnSeqUtf8 "abcdefghijklmnopqrstuvwxyz" inh-                ]-            ]-#endif-        ]--    where--    mkBench :: NFData b => String -> IORef Handles -> IO b -> Benchmark-    mkBench name ref action =-        bench name $ perRunEnv (do-                (Handles inh outh) <- readIORef ref-                hClose inh-                hClose outh-                inHandle <- openFile infile ReadMode-                outHandle <- openFile outfile WriteMode-                writeIORef ref (Handles inHandle outHandle)-            )-            (\_ -> action)
benchmark/NanoBenchmarks.hs view
@@ -6,14 +6,14 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -import Streamly (SerialT)+import Streamly.Prelude (SerialT) import Streamly.Internal.Data.SVar (MonadAsync) -import qualified Streamly.Memory.Array as A+import qualified Streamly.Data.Array.Foreign as A import qualified Streamly.FileSystem.Handle as FH import qualified Streamly.Internal.FileSystem.Handle as IFH import qualified Streamly.Data.Fold as FL-import qualified Streamly.Internal.Prelude as Internal+import qualified Streamly.Internal.Data.Stream.IsStream as Internal import qualified Streamly.Prelude as S import qualified Streamly.Internal.Data.Stream.StreamK as K
benchmark/README.md view
@@ -1,102 +1,313 @@-## Running Benchmarks+# Benchmarking -`bench.sh` script at the root of the repo is the top level driver for running-benchmarks. It runs the requested benchmarks and then creates a report from the-results using the `bench-show` package. Try `bench.sh --help` for available-options to run it.+## Benchmark Drivers -## Quick start+Two benchmark drivers are supported: -Run these commands from the root of the repo.+* `tasty-bench` (default)+* `gauge` (enabled by `--use-gauge` build flag) -To run the default benchmarks:+## Build and run benchmarks directly +The benchmark executables are `tasty-bench` executables unless you have+passed `--use-gauge` cabal flag when building in which case it is a+`gauge` executable.+ ```-$ ./bench.sh+$ cabal run bench:Prelude.Serial  # run selected+$ cabal run bench:Prelude.Serial -- --help # help on arguments+$ cabal run bench:Prelude.Serial -- --stdev 100000 # specify arguments+$ cabal run bench:Prelude.Serial --flag fusion-plugin # with fusion-plugin++$ cabal build bench:Prelude.Serial # build selected+$ cabal build --enable-benchmarks streamly-benchmarks # build all+$ cabal build --enable-benchmarks all # build all, alternate method++$ cabal build --flag "-opt" ... # disable optimization, faster build ``` -To run all benchmarks:+## Building and Running Benchmarks with bench.sh +`<streamly repo>/bin/bench.sh` script is the top level driver for+running benchmarks. It runs the requested benchmarks and then creates a+report from the results using the `bench-show` package.++IMPORTANT NOTE:  The first time you run this script it may take a long+time because it has to build the `bench-report` executable which has a+lot of dependencies.  If you are using nix then use `--use-nix` flag+for the first time so that the `bench-report` executable is built using+nix. That can save a lot of time compiling it. However, once it is built+it will be cached in the `bin` directory of the repo and used from+there every time. You can also build it manually from the cabal file in+`benchmark/bench-report` and install it in the `bin` directory.++## bench.sh: Quick start++Useful commands:+ ```-$ ./bench.sh --benchmarks all+$ bin/bench.sh --help+$ bin/bench.sh --quick # run all the benchmark suites+$ bin/bench.sh --benchmarks help # Show available benchmark suites+$ bin/bench.sh --benchmarks serial_grp # Run all serial benchmark suites+$ bin/bench.sh --benchmarks "Prelude.Serial Data.Parser" # run selected suites+$ bin/bench.sh --no-measure # don't run benchmarks just show previous results++# Run all O(1) space complexity benchmarks in `Prelude.Serial` suite+$ bin/bench.sh --benchmarks Prelude.Serial --prefix Prelude.Serial/o-1-space++# Run a specific benchmark in `Prelude.Serial` suite+$ bin/bench.sh --benchmarks Prelude.Serial --prefix Prelude.Serial/o-1-space.generation.unfoldr ``` -To run `linear` and `linear-async` benchmarks:+Note: `bench.sh` enables fusion-plugin by default. +## Comparing results with baseline+ ```-$ ./bench.sh --benchmarks "linear linear-async"+# Checkout baseline commit+$ bin/bench.sh --quick++# Checkout commit with new changes+$ bin/bench.sh --quick --append++# To add another result to comparisons just repeat the above command on+# desired commit ``` -To run only the base benchmark and only the benchmarks prefixed with-`StreamD` in that (anything after a `--` is passed to gauge):+## Comparing benchmark suites +First see the available benchmark suites:+ ```-$ ./bench.sh --benchmarks base -- StreamD+$ bin/bench.sh --benchmarks help ``` -## Comparing benchmarks+You will see some benchmark suites end with `_cmp`, these are comparison+groups. If you run a comparison group benchmark, comparison of all the+benchmark suites in that group will be shown in the end. For example to compare+all array benchmark suites: -To compare two sets of results, first run the benchmarks at the baseline-commit:+```+$ bin/bench.sh --benchmarks array_cmp+``` +## Reporting without measuring++You can use the `--no-measure` option to report the already measured results in+the benchmarks results file. A results file may collect an arbitrary number of+results by running with `--append` multiple times. Each benchmark has its own+results file, for example the `Prelude.Serial` benchmark has the results file at+`charts/Prelude.Serial/results.csv`.++You can also manually edit the file to remove a set of results if you like or+to append results from previously saved results or from some other results+file. After editing you can run `bench.sh` with the `--no-measure` option to+see the reports corresponding to the results.++## Additional benchmark configuration++### Stream size++You can specify the stream size (default is 100000) to be used for+benchmarking:+ ```-$ ./bench.sh+$ cabal run bench:Prelude.Serial -- --stream-size 1000000 ``` -And then run with the `--append` option at the commit that you want to compare-with the baseline. It will show the comparison with the baseline:+### External input file +In the `FileSystem.Handle` benchmark you can specify the input file as an+environment variable:+ ```-$ ./bench.sh --append+$ export Benchmark_FileSystem_Handle_InputFile=./gutenberg-500.txt+$ cabal run FileSystem.Handle -- FileSystem.Handle/o-1-space/reduce/read/S.splitOnSeq ``` -Append just adds the next set of results in the same results file. You can keep-appending more results and all of them will be compared with the baseline.+The automatic tests do not test unicode input, this option is useful to specify+a unicode text file manually. -You can use `--compare` to compare the previous commit with the head commit:+## Benchmarking notes +We run each benchmark in an isolated process to minimize interference+of benchmarks and to be able to control the RTS memory restrictions per+benchmark.++### Gotchas++Gauge forces a GC before and after the measurement. However, we have observed+that sometimes the GC stats may not be accurate when the number of iterations+in the measurement is small (e.g. 1 iteration).  In such cases usually the+number of GCs and GC times would also be 0.++## Diagnosing Performance Issues++### Reproducible comparison++When comparing different compilers we need to make sure that we are+using exactly the same versions of the libraries for apples to apples+comparison. We have seen cases where a change in the "random" library+caused allocations regressions in the new version of compiler because of+the way in which the benchmark code was generated due to the change.++When it is required to reproduce benchmark results precisely across+different systems, it is recommended that you create and use a cabal+freeze file so that the versions of all libraries are pinned.++### Identifying issues++There are two ways to find problematic code:++1. Run performance benchmarks using `bench.sh`, select the benchmarks+   that are taking more than expected time.+2. When making a new change, compare with the baseline and select benchmarks+   with the most regression reported by `bench.sh`.++Number of allocations are the most stable measure that do not vary from+run to run. `cpuTime` and `bytesCopied` may vary. When comparing two+runs for regression the first thing to look at is the difference in+allocations. Also note that allocations may vary from run to run for+concurrent benchmarks.++The next thing to look at is cpuTime. Please note that cpuTime may+fluctuate quite a bit, you may want to run the relevant benchmarks+without the --quick mode for confirming and make sure no other load is+running on the system when measuring.++Usually the increase is cpuTime is proportional to the increase in+allocations but sometimes it may increase independently because more cpu+instructions are being executed. TBD - we should count the instructions+instead.++### Inspection Testing++Before you proceed make sure have to run the benchmarks with+`inspection` flag on. It may catch any obvious issues or regressions.+ ```-$ ./bench.sh --compare+$ cabal build --flag inspection --flag fusion-plugin --enable-benchmarks streamly-benchmarks ``` -To compare the head commit with some other base commit:+### Compiling with diagnostics +1. Comment out all other benchmarks in the given benchmark suite, and+   keep only the one you are examining.+2. Edit the file and add the following line on top:+ ```-$ ./bench.sh --compare --base d918833+{-# OPTIONS_GHC+  -ddump-simpl+  -ddump-to-file+  -dsuppress-all+  -Wmissed-specialisations+  -Wall-missed-specialisations+  -fplugin-opt=Fusion.Plugin:verbose=2+  -fplugin-opt=Fusion.Plugin:dump-core+#-} ```+3. Build the benchmark suite with fusion-plugin enabled: -To compare two arbitrary commits:+```+$ cabal build bench:Prelude.Serial --flag fusion-plugin+``` +See the `.dump-simpl` file in the cabal build directory. You can find it+like this:+ ```-$ ./bench.sh --compare --base d918833 --candidate 38aa5f2+$ find dist-newstyle/ -name "*.dump-simpl" ``` -Note that the above may not always work because the script and the benchmarks-themselves might have changed across the commits. The `--append` method is more-reliable to compare.+Make sure you are looking into the right build dir (`--build-dir` may change+`dist-newstyle` to something else), and check in the appropriate GHC+version dir. -## Available Benchmarks+### Compiling standalone example -The benchmark names that you can use when running `bench.sh`:+Sometimes you may want to create a separate program from the benchmark code+removing the benchmarking harness to simplify and isolate the code for better+reasoning and simpler core. -* `base`: a benchmark that measures the raw operations of the basic streams-  `StreamD` and `StreamK`.+Add the following GHC options at the top of your file, say, example.hs: -* `linear`: measures the non-monadic operations of serial streams-* `linear-async`: measures the non-monadic operations of concurrent streams-* `linear-rate`: measures the rate limiting operations-* `nested`: measures the monadic operations of all streams-* `all`: runs all of the above benchmarks+```+{-# OPTIONS_GHC+  -ddump-simpl+  -ddump-to-file+  -dsuppress-all+  -Wmissed-specialisations+  -Wall-missed-specialisations+  -fplugin Fusion.Plugin+  -fplugin-opt=Fusion.Plugin:verbose=2+  -fplugin-opt=Fusion.Plugin:dump-core+#-}+``` -## Reporting without measuring+Do not include the optimization options in OPTIONS_GHC pragma, instead, specify+them on the command line. This is to avoid optimization failing if you import+another module which is not compiled with the same optimization options. -You can use the `--no-measure` option to report the already measured results in-the benchmarks results file. A results file may collect an arbitrary number of-results by running with `--append` multiple times. Each benchmark has its own-results file, for example the `linear` benchmark has the results file at-`charts/linear/results.csv`.+```+$ cabal build # build and write ghc environment file+$ ghc -O2 -fspec-constr-recursive=16 -fmax-worker-args=16 example.hs+``` -You can also manually edit the file to remove a set of results if you like or-to append results from previously saved results or from some other results-file. After editing you can run `bench.sh` with the `--no-measure` option to-see the reports corresponding to the results.+To pinpoint where the optimization is going wrong you can examine the+plugin generated core files for each optimization pass. The files are+numbered for each optimization pass. You can compare successive files+using side-by-side diff and see what the compiler is doing between each+pass.++### Diagnosing the Problem++#### Specialization Issues++Look for missed specialization messages. When you are comparing against a+baseline, check if something that was specialized before is no longer+specialized.++In the core you have to look for type class dictionaries e.g.++```+exc_r6DD = \ @s_a6ai -> try $fMonadCatchIO $fExceptionSomeException+```++Search for `$f` in the core.++#### Fusion Issues++Look for unfused function warnings emitted by fusion-plugin. You may+want to take a look at the unfused constructors or functions that+fusion-plugin is warning about.  Beware that:++* fusion-plugin emits warnings for unfused stuff in intermediate functions as+  well, those should be ignored.+* the constructors may remain genuinely unfused unless the loop is+  closed. So you should look at the warnings in the file where the loop is+  closed and everything is supposed to be fused.++Also, look at the core for unfused constructors. At times you may need+to look for the boxed primitive type constructors e.g. W8# or I#, these+may not be eliminated, usually, due to strictness issues.++Often it is useful to diff and compare the core without the problem and+the core with the problem especially in cases when the problem is due to+GHC version changes, or smaller changes in the code.++Note, some operations are inherently fusion breaking, those cannot fuse,+they are usually annotated so in their documentation.++### Resolving the problem++Review the problematic code, see [the optimization+guide](dev/optimization-guidelines.md) for common problems and how to+solve those. If no obvious issues are found on review, then generate and+examine the core.++You may want to add the `Fuse` annotation on some of those constructors+to make the code fuse. Please note that unnecessary `Fuse` annotations+may cause unnecessary inlining. Also, make sure that the constructor you+are adding fuse annotation is not shared by any other code where you may+not want inlining/fusion.
benchmark/Streamly/Benchmark/Data/Array.hs view
@@ -1,29 +1,46 @@ -- | -- Module      : Main--- Copyright   : (c) 2019 Composewell Technologies+-- Copyright   : (c) 2020 Composewell Technologies -- -- License     : BSD-3-Clause -- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC  {-# LANGUAGE CPP #-}--module Main (main) where+{-# LANGUAGE FlexibleContexts #-} -import Control.DeepSeq (NFData(..), deepseq)+import Control.DeepSeq (NFData(..)) import System.Random (randomRIO)  import qualified Streamly.Benchmark.Data.ArrayOps as Ops-import qualified Streamly.Internal.Data.Array as A-import qualified Streamly.Prelude as S+import qualified Streamly.Data.Array.Foreign as A+import qualified Streamly.Internal.Data.Array.Foreign as IA+import qualified Streamly.Prelude  as S  import Gauge+import Streamly.Benchmark.Common hiding (benchPureSrc)+import qualified Streamly.Benchmark.Prelude as P +#ifdef MEMORY_ARRAY+import qualified GHC.Exts as GHC+import Foreign.Storable (Storable(..))+#endif++#if !defined(DATA_ARRAY_PRIM) && !defined(DATA_ARRAY_PRIM_PINNED)+import Control.DeepSeq (deepseq)+#endif+ ------------------------------------------------------------------------------- -- ------------------------------------------------------------------------------- +#ifdef MEMORY_ARRAY+-- Drain a source that generates a pure array+{-# INLINE benchPureSrc #-}+benchPureSrc ::+       (NFData a, Storable a) => String -> (Int -> Ops.Stream a) -> Benchmark+benchPureSrc name src = benchPure name src id+#endif+ {-# INLINE benchIO #-} benchIO :: NFData b => String -> (Int -> IO a) -> (a -> b) -> Benchmark benchIO name src f = bench name $ nfIO $@@ -31,13 +48,19 @@  -- Drain a source that generates an array in the IO monad {-# INLINE benchIOSrc #-}-benchIOSrc :: (NFData a)-    => String -> (Int -> IO (Ops.Stream a)) -> Benchmark+benchIOSrc ::+#if !defined(DATA_ARRAY_PRIM) && !defined(DATA_ARRAY_PRIM_PINNED)+       NFData a =>+#endif+#ifdef MEMORY_ARRAY+       Storable a =>+#endif+       String -> (Int -> IO (Ops.Stream a)) -> Benchmark benchIOSrc name src = benchIO name src id  {-# INLINE benchPureSink #-}-benchPureSink :: NFData b => String -> (Ops.Stream Int -> b) -> Benchmark-benchPureSink name f = benchIO name Ops.sourceIntFromTo f+benchPureSink :: NFData b => Int -> String -> (Ops.Stream Int -> b) -> Benchmark+benchPureSink value name f = benchIO name (Ops.sourceIntFromTo value) f  {-# INLINE benchIO' #-} benchIO' :: NFData b => String -> (Int -> IO a) -> (a -> IO b) -> Benchmark@@ -45,52 +68,132 @@     randomRIO (1,1) >>= src >>= f  {-# INLINE benchIOSink #-}-benchIOSink :: NFData b => String -> (Ops.Stream Int -> IO b) -> Benchmark-benchIOSink name f = benchIO' name Ops.sourceIntFromTo f--mkString :: String-mkString = "[1" ++ concat (replicate Ops.value ",1") ++ "]"+benchIOSink :: NFData b => Int -> String -> (Ops.Stream Int -> IO b) -> Benchmark+benchIOSink value name f = benchIO' name (Ops.sourceIntFromTo value) f -main :: IO ()-main =-  defaultMain-    [ bgroup "Data.Array"-     [  bgroup "generation"-        [ benchIOSrc "writeN . intFromTo" Ops.sourceIntFromTo-        , benchIOSrc "write . intFromTo" Ops.sourceIntFromToFromStream-       , benchIOSrc "fromList . intFromTo" Ops.sourceIntFromToFromList-        , benchIOSrc "writeN . unfoldr" Ops.sourceUnfoldr-        , benchIOSrc "writeN . fromList" Ops.sourceFromList-        -- , benchPureSrc "writeN . IsList.fromList" Ops.sourceIsList-        -- , benchPureSrc "writeN . IsString.fromString" Ops.sourceIsString-        , mkString `deepseq` (bench "read" $ nf Ops.readInstance mkString)-        , benchPureSink "show" Ops.showInstance+o_1_space_generation :: Int -> [Benchmark]+o_1_space_generation value =+    [ bgroup+        "generation"+        [ benchIOSrc "writeN . intFromTo" (Ops.sourceIntFromTo value)+#ifndef DATA_SMALLARRAY+        , benchIOSrc "write . intFromTo" (Ops.sourceIntFromToFromStream value)+#endif+        , benchIOSrc+              "fromList . intFromTo"+              (Ops.sourceIntFromToFromList value)+        , benchIOSrc "writeN . unfoldr" (Ops.sourceUnfoldr value)+        , benchIOSrc "writeN . fromList" (Ops.sourceFromList value)+#ifdef MEMORY_ARRAY+        , benchPureSrc "writeN . IsList.fromList" (Ops.sourceIsList value)+        , benchPureSrc+              "writeN . IsString.fromString"+              (Ops.sourceIsString value)+#endif+#if !defined(DATA_ARRAY_PRIM) && !defined(DATA_ARRAY_PRIM_PINNED)+#ifdef DATA_SMALLARRAY+        , let testStr =+                  "fromListN " +++                  show (value + 1) +++                  "[1" ++ concat (replicate value ",1") ++ "]"+#else+        , let testStr = mkListString value+#endif+           in testStr `deepseq` (bench "read" $ nf Ops.readInstance testStr)+#endif+        , benchPureSink value "show" Ops.showInstance         ]-      , bgroup "elimination"-        [ benchPureSink "id" id-        , benchPureSink "==" Ops.eqInstance-        , benchPureSink "/=" Ops.eqInstanceNotEq-        , benchPureSink "<" Ops.ordInstance-        , benchPureSink "min" Ops.ordInstanceMin+    ]++o_1_space_elimination :: Int -> [Benchmark]+o_1_space_elimination value =+    [ bgroup "elimination"+        [ benchPureSink value "id" id+        , benchPureSink value "==" Ops.eqInstance+        , benchPureSink value "/=" Ops.eqInstanceNotEq+        , benchPureSink value "<" Ops.ordInstance+        , benchPureSink value "min" Ops.ordInstanceMin+#ifdef MEMORY_ARRAY         -- length is used to check for foldr/build fusion-        -- , benchPureSink "length . IsList.toList" (length . GHC.toList)-        , benchIOSink "foldl'" Ops.pureFoldl'-        , benchIOSink "read" (S.drain . S.unfold A.read)-        , benchIOSink "toStreamRev" (S.drain . A.toStreamRev)+        , benchPureSink value "length . IsList.toList" (length . GHC.toList)+#endif+        , benchIOSink value "foldl'" Ops.pureFoldl'+        , benchIOSink value "read" Ops.unfoldReadDrain+        , benchIOSink value "toStreamRev" Ops.toStreamRevDrain+        , benchFold "writeLastN.1" (S.fold (IA.writeLastN 1)) (P.sourceUnfoldrM value)+        , benchFold "writeLastN.10" (S.fold (IA.writeLastN 10)) (P.sourceUnfoldrM value)+#if !defined(DATA_ARRAY_PRIM) && !defined(DATA_ARRAY_PRIM_PINNED) #ifdef DEVBUILD-        , benchPureSink "foldable/foldl'" Ops.foldableFoldl'-        , benchPureSink "foldable/sum" Ops.foldableSum+        , benchPureSink value "foldable/foldl'" Ops.foldableFoldl'+        , benchPureSink value "foldable/sum" Ops.foldableSum #endif+#endif         ]-      , bgroup "transformation"-        [ benchIOSink "scanl'" (Ops.scanl' 1)-        , benchIOSink "scanl1'" (Ops.scanl1' 1)-        , benchIOSink "map" (Ops.map 1)+      ]++o_n_heap_serial :: Int -> [Benchmark]+o_n_heap_serial value =+    [ bgroup "elimination"+        [+        -- Converting the stream to an array+            benchFold "writeLastN.Max" (S.fold (IA.writeLastN (value + 1)))+                (P.sourceUnfoldrM value)+            , benchFold "writeN" (S.fold (A.writeN value))+                (P.sourceUnfoldrM value)+         ]+    ]++o_1_space_transformation :: Int -> [Benchmark]+o_1_space_transformation value =+   [ bgroup "transformation"+        [ benchIOSink value "scanl'" (Ops.scanl' value 1)+        , benchIOSink value "scanl1'" (Ops.scanl1' value 1)+        , benchIOSink value "map" (Ops.map value 1)         ]-      , bgroup "transformationX4"-        [ benchIOSink "scanl'" (Ops.scanl' 4)-        , benchIOSink "scanl1'" (Ops.scanl1' 4)-        , benchIOSink "map" (Ops.map 4)+   ]++o_1_space_transformationX4 :: Int -> [Benchmark]+o_1_space_transformationX4 value =+    [ bgroup "transformationX4"+        [ benchIOSink value "scanl'" (Ops.scanl' value 4)+        , benchIOSink value "scanl1'" (Ops.scanl1' value 4)+        , benchIOSink value "map" (Ops.map value 4)         ]-    ]-    ]+      ]++moduleName :: String+#ifdef DATA_SMALLARRAY+moduleName = "Data.SmallArray"+#elif defined(MEMORY_ARRAY)+moduleName = "Data.Array.Foreign"+#elif defined(DATA_ARRAY_PRIM)+moduleName = "Data.Array.Prim"+#elif defined(DATA_ARRAY_PRIM_PINNED)+moduleName = "Data.Array.Prim.Pinned"+#else+moduleName = "Data.Array"+#endif++#ifdef DATA_SMALLARRAY+defStreamSize :: Int+defStreamSize = 128+#else+defStreamSize :: Int+defStreamSize = defaultStreamSize+#endif++main :: IO ()+main = runWithCLIOpts defStreamSize allBenchmarks++    where++    allBenchmarks size =+        [ bgroup (o_1_space_prefix moduleName) $ concat+            [ o_1_space_generation size+            , o_1_space_elimination size+            , o_1_space_transformation size+            , o_1_space_transformationX4 size+            ]+        , bgroup (o_n_space_prefix moduleName) $+             o_n_heap_serial size+        ]
+ benchmark/Streamly/Benchmark/Data/Array/Stream/Foreign.hs view
@@ -0,0 +1,205 @@+-- |+-- Module      : Streamly.Benchmark.Data.ParserD+-- Copyright   : (c) 2020 Composewell Technologies+--+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++#ifdef __HADDOCK_VERSION__+#undef INSPECTION+#endif++#ifdef INSPECTION+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}+#endif++module Main+  (+    main+  ) where++import Data.Functor.Identity (runIdentity)+import Data.Word (Word8)+import System.IO (Handle)+import Prelude hiding ()++import qualified Streamly.Prelude  as Stream+import qualified Streamly.Internal.Data.Array.Foreign as Array+import qualified Streamly.Internal.Data.Array.Stream.Foreign as ArrayStream+import qualified Streamly.Internal.FileSystem.Handle as Handle+import qualified Streamly.Internal.Unicode.Stream as Unicode++import Gauge hiding (env)+import Streamly.Benchmark.Common+import Streamly.Benchmark.Common.Handle++#ifdef INSPECTION+import Foreign.Storable (Storable)+import Streamly.Internal.Data.Stream.StreamD.Type (Step(..))+import Test.Inspection+#endif++-------------------------------------------------------------------------------+-- read chunked using toChunks+-------------------------------------------------------------------------------++-- | Get the last byte from a file bytestream.+toChunksLast :: Handle -> IO (Maybe Word8)+toChunksLast inh = do+    let s = Handle.toChunks inh+    larr <- Stream.last s+    return $ case larr of+        Nothing -> Nothing+        Just arr -> Array.getIndex arr (Array.length arr - 1)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'toChunksLast+inspect $ 'toChunksLast `hasNoType` ''Step+#endif++-- | Count the number of bytes in a file.+toChunksSumLengths :: Handle -> IO Int+toChunksSumLengths inh =+    let s = Handle.toChunks inh+    in Stream.sum (Stream.map Array.length s)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'toChunksSumLengths+inspect $ 'toChunksSumLengths `hasNoType` ''Step+#endif++-- | Sum the bytes in a file.+toChunksCountBytes :: Handle -> IO Word8+toChunksCountBytes inh = do+    let foldlArr' f z = runIdentity . Stream.foldl' f z . Array.toStream+    let s = Handle.toChunks inh+    Stream.foldl' (\acc arr -> acc + foldlArr' (+) 0 arr) 0 s++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'toChunksCountBytes+inspect $ 'toChunksCountBytes `hasNoType` ''Step+#endif++toChunksDecodeUtf8Arrays :: Handle -> IO ()+toChunksDecodeUtf8Arrays =+   Stream.drain . Unicode.decodeUtf8Arrays . Handle.toChunks++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'toChunksDecodeUtf8Arrays+-- inspect $ 'toChunksDecodeUtf8ArraysLenient `hasNoType` ''Step+#endif++-------------------------------------------------------------------------------+-- Splitting+-------------------------------------------------------------------------------++-- | Count the number of lines in a file.+toChunksSplitOnSuffix :: Handle -> IO Int+toChunksSplitOnSuffix =+    Stream.length . ArrayStream.splitOnSuffix 10 . Handle.toChunks++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'toChunksSplitOnSuffix+inspect $ 'toChunksSplitOnSuffix `hasNoType` ''Step+#endif++-- XXX use a word splitting combinator instead of splitOn and test it.+-- | Count the number of words in a file.+toChunksSplitOn :: Handle -> IO Int+toChunksSplitOn = Stream.length . ArrayStream.splitOn 32 . Handle.toChunks++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'toChunksSplitOn+inspect $ 'toChunksSplitOn `hasNoType` ''Step+#endif++o_1_space_read_chunked :: BenchEnv -> [Benchmark]+o_1_space_read_chunked env =+    -- read using toChunks instead of read+    [ bgroup "reduce/toChunks"+        [ mkBench "Stream.last" env $ \inH _ ->+            toChunksLast inH+        -- Note: this cannot be fairly compared with GNU wc -c or wc -m as+        -- wc uses lseek to just determine the file size rather than reading+        -- and counting characters.+        , mkBench "Stream.sum . Stream.map Array.length" env $ \inH _ ->+            toChunksSumLengths inH+        , mkBench "splitOnSuffix" env $ \inH _ ->+            toChunksSplitOnSuffix inH+        , mkBench "splitOn" env $ \inH _ ->+            toChunksSplitOn inH+        , mkBench "countBytes" env $ \inH _ ->+            toChunksCountBytes inH+        , mkBenchSmall "decodeUtf8Arrays" env $ \inH _ ->+            toChunksDecodeUtf8Arrays inH+        ]+    ]++-------------------------------------------------------------------------------+-- copy with group/ungroup transformations+-------------------------------------------------------------------------------++-- | Lines and unlines+{-# NOINLINE copyChunksSplitInterposeSuffix #-}+copyChunksSplitInterposeSuffix :: Handle -> Handle -> IO ()+copyChunksSplitInterposeSuffix inh outh =+    Stream.fold (Handle.write outh)+        $ ArrayStream.interposeSuffix 10+        $ ArrayStream.splitOnSuffix 10+        $ Handle.toChunks inh++#ifdef INSPECTION+inspect $ hasNoTypeClassesExcept 'copyChunksSplitInterposeSuffix [''Storable]+inspect $ 'copyChunksSplitInterposeSuffix `hasNoType` ''Step+#endif++-- | Words and unwords+{-# NOINLINE copyChunksSplitInterpose #-}+copyChunksSplitInterpose :: Handle -> Handle -> IO ()+copyChunksSplitInterpose inh outh =+    Stream.fold (Handle.write outh)+        $ ArrayStream.interpose 32+        -- XXX this is not correct word splitting combinator+        $ ArrayStream.splitOn 32+        $ Handle.toChunks inh++#ifdef INSPECTION+inspect $ hasNoTypeClassesExcept 'copyChunksSplitInterpose [''Storable]+inspect $ 'copyChunksSplitInterpose `hasNoType` ''Step+#endif++o_1_space_copy_toChunks_group_ungroup :: BenchEnv -> [Benchmark]+o_1_space_copy_toChunks_group_ungroup env =+    [ bgroup "copy/toChunks/group-ungroup"+        [ mkBench "interposeSuffix . splitOnSuffix" env $ \inh outh ->+            copyChunksSplitInterposeSuffix inh outh+        , mkBenchSmall "interpose . splitOn" env $ \inh outh ->+            copyChunksSplitInterpose inh outh+        ]+    ]++-------------------------------------------------------------------------------+-- Driver+-------------------------------------------------------------------------------++moduleName :: String+moduleName = "Data.Array.Stream.Foreign"++main :: IO ()+main = do+    env <- mkHandleBenchEnv+    defaultMain (allBenchmarks env)++    where++    allBenchmarks env =+        [ bgroup (o_1_space_prefix moduleName)+          ( o_1_space_read_chunked env+          ++ o_1_space_copy_toChunks_group_ungroup env+          )+        ]
benchmark/Streamly/Benchmark/Data/ArrayOps.hs view
@@ -1,33 +1,53 @@ -- | -- Module      : Streamly.Benchmark.Data.ArrayOps--- Copyright   : (c) 2019 Composewell Technologies+-- Copyright   : (c) 2020 Composewell Technologies -- -- License     : BSD-3-Clause -- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC -{-# LANGUAGE CPP                 #-}-{-# LANGUAGE DeriveAnyClass      #-}-{-# LANGUAGE DeriveGeneric       #-}-{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} +-- CPP:+-- MEMORY_ARRAY+-- DATA_ARRAY+-- DATA_ARRAY_PRIM+-- DATA_ARRAY_PRIM_PINNED+-- DATA_SMALLARRAY+ module Streamly.Benchmark.Data.ArrayOps where  import Control.Monad.IO.Class (MonadIO)-import Prelude (Int, Bool, (+), ($), (==), (>), (.), Maybe(..), undefined)+import Prelude (Bool, Int, Maybe(..), ($), (+), (.), (==), (>), undefined)+ import qualified Prelude as P+import qualified Streamly.Prelude as S++#if !defined(DATA_ARRAY_PRIM) && !defined(DATA_ARRAY_PRIM_PINNED) #ifdef DEVBUILD import qualified Data.Foldable as F #endif+#endif -import qualified Streamly           as S hiding (foldMapWith, runStream)+#ifdef DATA_SMALLARRAY+import qualified Streamly.Internal.Data.SmallArray as A+type Stream = A.SmallArray+#elif defined(MEMORY_ARRAY)+import qualified GHC.Exts as GHC+import qualified Streamly.Data.Array.Foreign as A+import qualified Streamly.Internal.Data.Array.Foreign as A+type Stream = A.Array+#elif defined(DATA_ARRAY_PRIM)+import qualified Streamly.Internal.Data.Array.Prim as A+type Stream = A.Array+#elif defined(DATA_ARRAY_PRIM_PINNED)+import qualified Streamly.Internal.Data.Array.Prim.Pinned as A+type Stream = A.Array+#elif defined(DATA_ARRAY) import qualified Streamly.Internal.Data.Array as A-import qualified Streamly.Prelude   as S--value :: Int-value = 100000+type Stream = A.Array+#endif  ------------------------------------------------------------------------------- -- Benchmark ops@@ -37,11 +57,18 @@ -- Stream generation and elimination ------------------------------------------------------------------------------- -type Stream = A.Array+-------------------------------------------------------------------------------+-- CPP Common to:+-- MEMORY_ARRAY+-- DATA_ARRAY+-- DATA_ARRAY_PRIM+-- DATA_ARRAY_PRIM_PINNED+-- DATA_SMALLARRAY+-------------------------------------------------------------------------------  {-# INLINE sourceUnfoldr #-}-sourceUnfoldr :: MonadIO m => Int -> m (Stream Int)-sourceUnfoldr n = S.fold (A.writeN value) $ S.unfoldr step n+sourceUnfoldr :: MonadIO m => Int -> Int -> m (Stream Int)+sourceUnfoldr value n = S.fold (A.writeN value) $ S.unfoldr step n     where     step cnt =         if cnt > n + value@@ -49,33 +76,67 @@         else (Just (cnt, cnt + 1))  {-# INLINE sourceIntFromTo #-}-sourceIntFromTo :: MonadIO m => Int -> m (Stream Int)-sourceIntFromTo n = S.fold (A.writeN value) $ S.enumerateFromTo n (n + value)+sourceIntFromTo :: MonadIO m => Int -> Int -> m (Stream Int)+sourceIntFromTo value n = S.fold (A.writeN value) $ S.enumerateFromTo n (n + value) -{-# INLINE sourceIntFromToFromStream #-}-sourceIntFromToFromStream :: MonadIO m => Int -> m (Stream Int)-sourceIntFromToFromStream n = S.fold A.write $ S.enumerateFromTo n (n + value)+{-# INLINE sourceFromList #-}+sourceFromList :: MonadIO m => Int -> Int -> m (Stream Int)+sourceFromList value n = S.fold (A.writeN value) $ S.fromList [n..n+value] +-- Different defination of sourceIntFromToFromList for DATA_SMALLARRAY+-- CPP: {-# INLINE sourceIntFromToFromList #-}-sourceIntFromToFromList :: MonadIO m => Int -> m (Stream Int)-sourceIntFromToFromList n = P.return $ A.fromList $ [n..n + value]+sourceIntFromToFromList :: MonadIO m => Int -> Int -> m (Stream Int)+#ifndef DATA_SMALLARRAY+sourceIntFromToFromList value n = P.return $ A.fromList $ [n..n + value]+#else+sourceIntFromToFromList value n = P.return $ A.fromListN value $ [n..n + value]+#endif -{-# INLINE sourceFromList #-}-sourceFromList :: MonadIO m => Int -> m (Stream Int)-sourceFromList n = S.fold (A.writeN value) $ S.fromList [n..n+value]-{-+-------------------------------------------------------------------------------+-- CPP Common to:+-- MEMORY_ARRAY+-- DATA_ARRAY+-- DATA_ARRAY_PRIM+-- DATA_ARRAY_PRIM_PINNED+-------------------------------------------------------------------------------++-- CPP:+#ifndef DATA_SMALLARRAY+{-# INLINE sourceIntFromToFromStream #-}+sourceIntFromToFromStream :: MonadIO m => Int -> Int -> m (Stream Int)+sourceIntFromToFromStream value n = S.fold A.write $ S.enumerateFromTo n (n + value)+#endif++-------------------------------------------------------------------------------+-- CPP Common to:+-- MEMORY_ARRAY+-------------------------------------------------------------------------------++-- CPP:+#ifdef MEMORY_ARRAY {-# INLINE sourceIsList #-}-sourceIsList :: Int -> Stream Int-sourceIsList n = GHC.fromList [n..n+value]+sourceIsList :: Int -> Int -> Stream Int+sourceIsList value n = GHC.fromList [n..n+value]  {-# INLINE sourceIsString #-}-sourceIsString :: Int -> Stream P.Char-sourceIsString n = GHC.fromString (P.replicate (n + value) 'a')--}+sourceIsString :: Int -> Int -> Stream P.Char+sourceIsString value n = GHC.fromString (P.replicate (n + value) 'a')+#endif+ ------------------------------------------------------------------------------- -- Transformation ------------------------------------------------------------------------------- +-------------------------------------------------------------------------------+-- CPP Common to:+-- MEMORY_ARRAY+-- DATA_ARRAY+-- DATA_ARRAY_PRIM+-- DATA_ARRAY_PRIM_PINNED+-- DATA_SMALLARRAY+-------------------------------------------------------------------------------+ {-# INLINE composeN #-} composeN :: P.Monad m     => Int -> (Stream Int -> m (Stream Int)) -> Stream Int -> m (Stream Int)@@ -91,19 +152,21 @@ {-# INLINE scanl1' #-} {-# INLINE map #-} -scanl', scanl1', map-    :: MonadIO m => Int -> Stream Int -> m (Stream Int)+scanl' , scanl1', map+    :: MonadIO m => Int -> Int -> Stream Int -> m (Stream Int) + {-# INLINE onArray #-} onArray-    :: MonadIO m => (S.SerialT m Int -> S.SerialT m Int)+    :: MonadIO m => Int -> (S.SerialT m Int -> S.SerialT m Int)     -> Stream Int     -> m (Stream Int)-onArray f arr = S.fold (A.writeN value) $ f $ (S.unfold A.read arr)+onArray value f arr = S.fold (A.writeN value) $ f $ (S.unfold A.read arr) -scanl'        n = composeN n $ onArray $ S.scanl' (+) 0-scanl1'       n = composeN n $ onArray $ S.scanl1' (+)-map           n = composeN n $ onArray $ S.map (+1)+scanl'  value n = composeN n $ onArray value $ S.scanl' (+) 0+scanl1' value n = composeN n $ onArray value $ S.scanl1' (+)+map     value n = composeN n $ onArray value $ S.map (+1)+-- map           n = composeN n $ A.map (+1)  {-# INLINE eqInstance #-} eqInstance :: Stream Int -> Bool@@ -125,6 +188,19 @@ showInstance :: Stream Int -> P.String showInstance src = P.show src +{-# INLINE pureFoldl' #-}+pureFoldl' :: MonadIO m => Stream Int -> m Int+pureFoldl' = S.foldl' (+) 0 . S.unfold A.read++-------------------------------------------------------------------------------+-- CPP Common to:+-- MEMORY_ARRAY+-- DATA_ARRAY+-- DATA_SMALLARRAY+-------------------------------------------------------------------------------++-- CPP:+#if !defined(DATA_ARRAY_PRIM) && !defined(DATA_ARRAY_PRIM_PINNED) {-# INLINE readInstance #-} readInstance :: P.String -> Stream Int readInstance str =@@ -133,10 +209,6 @@         [(x,"")] -> x         _ -> P.error "readInstance: no parse" -{-# INLINE pureFoldl' #-}-pureFoldl' :: MonadIO m => Stream Int -> m Int-pureFoldl' = S.foldl' (+) 0 . S.unfold A.read- #ifdef DEVBUILD {-# INLINE foldableFoldl' #-} foldableFoldl' :: Stream Int -> Int@@ -146,3 +218,25 @@ foldableSum :: Stream Int -> Int foldableSum = P.sum #endif+#endif++-------------------------------------------------------------------------------+-- Elimination+-------------------------------------------------------------------------------++-------------------------------------------------------------------------------+-- CPP Common to:+-- MEMORY_ARRAY+-- DATA_ARRAY+-- DATA_ARRAY_PRIM+-- DATA_ARRAY_PRIM_PINNED+-- DATA_SMALLARRAY+-------------------------------------------------------------------------------++{-# INLINE unfoldReadDrain #-}+unfoldReadDrain :: MonadIO m => Stream Int -> m ()+unfoldReadDrain = S.drain . S.unfold A.read++{-# INLINE toStreamRevDrain #-}+toStreamRevDrain :: MonadIO m => Stream Int -> m ()+toStreamRevDrain = S.drain . A.toStreamRev
benchmark/Streamly/Benchmark/Data/Fold.hs view
@@ -10,28 +10,23 @@ module Main (main) where  import Control.DeepSeq (NFData(..))-import Data.Monoid (Last(..))-+import Data.Map.Strict (Map)+import Data.Monoid (Last(..), Sum(..)) import System.Random (randomRIO)-import Prelude (IO, Int, Double, String, (>), (<*>), (<$>), (+), ($),-                (<=), Monad(..), (==), Maybe(..), (.), fromIntegral,-                compare, (>=), concat, seq) -import qualified Streamly as S hiding (runStream)-import qualified Streamly.Prelude  as S+import Streamly.Prelude (SerialT)+import Streamly.Internal.Data.Fold (Fold(..))++import qualified Data.Map.Strict as Map import qualified Streamly.Internal.Data.Fold as FL import qualified Streamly.Internal.Data.Pipe as Pipe- import qualified Streamly.Internal.Data.Sink as Sink--import qualified Streamly.Memory.Array as A-import qualified Streamly.Internal.Memory.Array as IA-import qualified Streamly.Internal.Data.Fold as IFL-import qualified Streamly.Internal.Prelude as IP+import qualified Streamly.Internal.Data.Stream.IsStream as IP+import qualified Streamly.Prelude as S  import Gauge-import Streamly hiding (runStream) import Streamly.Benchmark.Common+import Prelude hiding (all, any, take, unzip, sequence_)  -- We need a monadic bind here to make sure that the function f does not get -- completely optimized out by the compiler in some cases.@@ -52,179 +47,288 @@ -- | Takes a fold method, and uses it with a default source. {-# INLINE benchIOSink #-} benchIOSink-    :: (IsStream t, NFData b)+    :: (S.IsStream t, NFData b)     => Int -> String -> (t IO Int -> IO b) -> Benchmark benchIOSink value name f = bench name $ nfIO $ randomRIO (1,1) >>= f . source value  ---------------------------------------------------------------------------------- Stream folds+-- Folds ------------------------------------------------------------------------------- -o_1_space_serial_folds :: Int -> [Benchmark]-o_1_space_serial_folds value =-    [ bgroup-          "serially"-          [ bgroup-                "folds"-                [ benchIOSink value "drain" (S.fold FL.drain)-                , benchIOSink value "drainN" (S.fold (IFL.drainN value))-                , benchIOSink-                      value-                      "drainWhileTrue"-                      (S.fold (IFL.drainWhile $ (<=) (value + 1)))-                , benchIOSink-                      value-                      "drainWhileFalse"-                      (S.fold (IFL.drainWhile $ (>=) (value + 1)))-                , benchIOSink value "sink" (S.fold $ Sink.toFold Sink.drain)-                , benchIOSink value "last" (S.fold FL.last)-                , benchIOSink value "lastN.1" (S.fold (IA.lastN 1))-                , benchIOSink value "lastN.10" (S.fold (IA.lastN 10))-                , benchIOSink value "length" (S.fold FL.length)-                , benchIOSink value "sum" (S.fold FL.sum)-                , benchIOSink value "product" (S.fold FL.product)-                , benchIOSink value "maximumBy" (S.fold (FL.maximumBy compare))-                , benchIOSink value "maximum" (S.fold FL.maximum)-                , benchIOSink value "minimumBy" (S.fold (FL.minimumBy compare))-                , benchIOSink value "minimum" (S.fold FL.minimum)-                , benchIOSink-                      value-                      "mean"-                      (\s ->-                           S.fold-                               FL.mean-                               (S.map (fromIntegral :: Int -> Double) s))-                , benchIOSink-                      value-                      "variance"-                      (\s ->-                           S.fold-                               FL.variance-                               (S.map (fromIntegral :: Int -> Double) s))-                , benchIOSink-                      value-                      "stdDev"-                      (\s ->-                           S.fold-                               FL.stdDev-                               (S.map (fromIntegral :: Int -> Double) s))-                , benchIOSink-                      value-                      "mconcat"-                      (S.fold FL.mconcat . (S.map (Last . Just)))-                , benchIOSink-                      value-                      "foldMap"-                      (S.fold (FL.foldMap (Last . Just)))-                , benchIOSink value "index" (S.fold (FL.index (value + 1)))-                , benchIOSink value "head" (S.fold FL.head)-                , benchIOSink value "find" (S.fold (FL.find (== (value + 1))))-                , benchIOSink-                      value-                      "findIndex"-                      (S.fold (FL.findIndex (== (value + 1))))-                , benchIOSink-                      value-                      "elemIndex"-                      (S.fold (FL.elemIndex (value + 1)))-                , benchIOSink value "null" (S.fold FL.null)-                , benchIOSink value "elem" (S.fold (FL.elem (value + 1)))-                , benchIOSink value "notElem" (S.fold (FL.notElem (value + 1)))-                , benchIOSink value "all" (S.fold (FL.all (<= (value + 1))))-                , benchIOSink value "any" (S.fold (FL.any (> (value + 1))))-                , benchIOSink-                      value-                      "and"-                      (\s -> S.fold FL.and (S.map (<= (value + 1)) s))-                , benchIOSink-                      value-                      "or"-                      (\s -> S.fold FL.or (S.map (> (value + 1)) s))-                ]-          ]-    ]+{-# INLINE any #-}+any :: (Monad m, Ord a) => a -> SerialT m a -> m Bool+any value = IP.fold (FL.any (> value)) +{-# INLINE all #-}+all :: (Monad m, Ord a) => a -> SerialT m a -> m Bool+all value = IP.fold (FL.all (<= value)) -o_1_space_serial_foldsTransforms :: Int -> [Benchmark]-o_1_space_serial_foldsTransforms value =-    [ bgroup-          "serially"-          [ bgroup-                "folds-transforms"-                [ benchIOSink value "drain" (S.fold FL.drain)-                , benchIOSink value "lmap" (S.fold (IFL.lmap (+ 1) FL.drain))-                , benchIOSink-                      value-                      "pipe-mapM"-                      (S.fold-                           (IFL.transform-                                (Pipe.mapM (\x -> return $ x + 1))-                                FL.drain))-                ]-          ]-    ]+{-# INLINE take #-}+take :: Monad m => Int -> SerialT m a -> m ()+take value = IP.fold (FL.take value FL.drain) +{-# INLINE sequence_ #-}+sequence_ :: Monad m => Int -> Fold m a ()+sequence_ value =+    foldr f (FL.fromPure ()) (Prelude.replicate value (FL.take 1 FL.drain)) -o_1_space_serial_foldsCompositions :: Int -> [Benchmark]-o_1_space_serial_foldsCompositions value =-    [ bgroup-          "serially"-          [ bgroup-                "folds-compositions" -- Applicative-                [ benchIOSink-                      value-                      "all,any"-                      (S.fold-                           ((,) <$> FL.all (<= (value + 1)) <*>-                            FL.any (> (value + 1))))-                , benchIOSink-                      value-                      "sum,length"-                      (S.fold ((,) <$> FL.sum <*> FL.length))-                ]-          ]+    where++    {-# INLINE f #-}+    f m k = FL.concatMap (const k) m++-------------------------------------------------------------------------------+-- Splitting by serial application+-------------------------------------------------------------------------------++{-# INLINE takeEndBy_ #-}+takeEndBy_ :: Monad m => Int -> SerialT m Int -> m ()+takeEndBy_ value = IP.fold (FL.takeEndBy_ (>= value) FL.drain)++{-# INLINE many #-}+many :: Monad m => SerialT m Int -> m ()+many = IP.fold (FL.many (FL.take 1 FL.drain) FL.drain)++{-# INLINE splitAllAny #-}+splitAllAny :: Monad m => Int -> SerialT m Int -> m (Bool, Bool)+splitAllAny value =+    IP.fold+        (FL.serialWith (,)+            (FL.all (<= (value `div` 2)))+            (FL.any (> value))+        )++{-+{-# INLINE split_ #-}+split_ :: Monad m+    => Int -> SerialT m Int -> m ()+split_ value =+    IP.fold+        (FL.split_+            (FL.all (<= (value `div` 2)))+            (FL.any (> value))+        )+-}++-------------------------------------------------------------------------------+-- Distributing by parallel application+-------------------------------------------------------------------------------++{-# INLINE teeSumLength #-}+teeSumLength :: Monad m => SerialT m Int -> m (Int, Int)+teeSumLength = IP.fold (FL.teeWith (,) FL.sum FL.length)++{-# INLINE teeAllAny #-}+teeAllAny :: (Monad m, Ord a) => a -> SerialT m a -> m (Bool, Bool)+teeAllAny value = IP.fold (FL.teeWith (,) all_ any_)++    where++    all_ = FL.all (<= value)+    any_ = FL.any (> value)++{-# INLINE distribute #-}+distribute :: Monad m => SerialT m Int -> m [Int]+distribute = IP.fold (FL.distribute [FL.sum, FL.length])++-------------------------------------------------------------------------------+-- Partitioning+-------------------------------------------------------------------------------++{-# INLINE partition #-}+partition :: Monad m => SerialT m Int -> m (Int, Int)+partition =+    let f a =+            if odd a+            then Left a+            else Right a+     in IP.fold $ FL.map f (FL.partition FL.sum FL.length)++{-# INLINE demuxWith  #-}+demuxWith ::+       (Monad m, Ord k)+    => (a -> (k, a'))+    -> Map k (Fold m a' b)+    -> SerialT m a+    -> m (Map k b)+demuxWith f mp = S.fold (FL.demuxWith f mp)++{-# INLINE demuxDefaultWith #-}+demuxDefaultWith ::+       (Monad m, Ord k, Num b)+    => (a -> (k, b))+    -> Map k (Fold m b b)+    -> SerialT m a+    -> m (Map k b, b)+demuxDefaultWith f mp = S.fold (FL.demuxDefaultWith f mp (FL.map snd FL.sum))++{-# INLINE classifyWith #-}+classifyWith ::+       (Monad m, Ord k, Num a) => (a -> k) -> SerialT m a -> m (Map k a)+classifyWith f = S.fold (FL.classifyWith f FL.sum)++-------------------------------------------------------------------------------+-- unzip+-------------------------------------------------------------------------------++{-# INLINE unzip #-}+unzip :: Monad m => SerialT m Int -> m (Int, Int)+unzip = IP.fold $ FL.map (\a -> (a, a)) (FL.unzip FL.sum FL.length)++-------------------------------------------------------------------------------+-- Benchmarks+-------------------------------------------------------------------------------++moduleName :: String+moduleName = "Data.Fold"++o_1_space_serial_elimination :: Int -> [Benchmark]+o_1_space_serial_elimination value =+    [ bgroup "elimination"+        [ benchIOSink value "drain" (S.fold FL.drain)+        , benchIOSink value "drainBy" (S.fold (FL.drainBy return))+        , benchIOSink value "drainN" (S.fold (FL.drainN value))+        , benchIOSink value "sink" (S.fold $ Sink.toFold Sink.drain)+        , benchIOSink value "last" (S.fold FL.last)+        , benchIOSink value "length" (S.fold FL.length)+        , benchIOSink value "sum" (S.fold FL.sum)+        , benchIOSink value "sum (foldMap)" (S.fold (FL.foldMap Sum))+        , benchIOSink value "product" (S.fold FL.product)+        , benchIOSink value "maximumBy" (S.fold (FL.maximumBy compare))+        , benchIOSink value "maximum" (S.fold FL.maximum)+        , benchIOSink value "minimumBy" (S.fold (FL.minimumBy compare))+        , benchIOSink value "minimum" (S.fold FL.minimum)+        , benchIOSink+              value+              "mean"+              (S.fold FL.mean . S.map (fromIntegral :: Int -> Double))+        , benchIOSink+              value+              "variance"+              (S.fold FL.variance . S.map (fromIntegral :: Int -> Double))+        , benchIOSink+              value+              "stdDev"+              (S.fold FL.stdDev . S.map (fromIntegral :: Int -> Double))+        , benchIOSink+              value+              "mconcat"+              (S.fold FL.mconcat . S.map (Last . Just))+        , benchIOSink+              value+              "foldMap"+              (S.fold (FL.foldMap (Last . Just)))+        , benchIOSink+              value+              "foldMapM"+              (S.fold (FL.foldMapM (return . Last . Just)))+        , benchIOSink value "index" (S.fold (FL.index (value + 1)))+        , benchIOSink value "head" (S.fold FL.head)+        , benchIOSink value "find" (S.fold (FL.find (== (value + 1))))+        , benchIOSink+              value+              "lookup"+              (S.fold (FL.map (\a -> (a, a)) (FL.lookup (value + 1))))+        , benchIOSink+              value+              "findIndex"+              (S.fold (FL.findIndex (== (value + 1))))+        , benchIOSink+              value+              "elemIndex"+              (S.fold (FL.elemIndex (value + 1)))+        , benchIOSink value "null" (S.fold FL.null)+        , benchIOSink value "elem" (S.fold (FL.elem (value + 1)))+        , benchIOSink value "notElem" (S.fold (FL.notElem (value + 1)))+        , benchIOSink value "all" $ all value+        , benchIOSink value "any" $ any value+        , benchIOSink value "take" $ take value+        , benchIOSink value "takeEndBy_" $ takeEndBy_ value+        , benchIOSink value "and" (S.fold FL.and . S.map (<= (value + 1)))+        , benchIOSink value "or" (S.fold FL.or . S.map (> (value + 1)))+        ]     ] +o_1_space_serial_transformation :: Int -> [Benchmark]+o_1_space_serial_transformation value =+    [ bgroup "transformation"+        [ benchIOSink value "map" (S.fold (FL.map (+ 1) FL.drain))+        , let f x = if even x then Just x else Nothing+              fld = FL.mapMaybe f FL.drain+           in benchIOSink value "mapMaybe" (S.fold fld)+        , benchIOSink+              value+              "rsequence"+              (S.fold (FL.rmapM id (return <$> FL.drain)))+        , benchIOSink value "rmapM" (S.fold (FL.rmapM return FL.drain))+        , benchIOSink+              value+              "pipe-mapM"+              (S.fold+                   (FL.transform+                        (Pipe.mapM (\x -> return $ x + 1))+                        FL.drain))+        ]+    ] -o_n_heap_serial_folds :: Int -> [Benchmark]-o_n_heap_serial_folds value =-    [ bgroup-          "serially"-          [ bgroup-                "foldl"-          -- Left folds for building a structure are inherently non-streaming-          -- as the structure cannot be lazily consumed until fully built.-                [ benchIOSink value "toStream" (S.fold IP.toStream)-                , benchIOSink value "toStreamRev" (S.fold IP.toStreamRev)-                , benchIOSink value "toList" (S.fold FL.toList)-                , benchIOSink value "toListRevF" (S.fold IFL.toListRevF)-          -- Converting the stream to an array-                , benchIOSink value "lastN.Max" (S.fold (IA.lastN (value + 1)))-                , benchIOSink value "writeN" (S.fold (A.writeN value))-                ]-          ]+o_1_space_serial_composition :: Int -> [Benchmark]+o_1_space_serial_composition value =+      [ bgroup+            "composition"+            [ benchIOSink value "serialWith (all, any)" $ splitAllAny value+            , benchIOSink value "tee (all, any)" $ teeAllAny value+            , benchIOSink value "many drain (take 1)" many+            , benchIOSink value "tee (sum, length)" teeSumLength+            , benchIOSink value "distribute [sum, length]" distribute+            , benchIOSink value "partition (sum, length)" partition+            , benchIOSink value "unzip (sum, length)" unzip+            , benchIOSink value "demuxDefaultWith [sum, length] sum"+                  $ demuxDefaultWith fn mp+            , benchIOSink value "demuxWith [sum, length]" $ demuxWith fn mp+            , benchIOSink value "classifyWith sum" $ classifyWith (fst . fn)+            ]+      ]++    where++    -- We use three keys 0, 1, and 2. 0 and 1 are mapped and 3 is unmapped.+    fn x = (x `mod` 3, x)++    mp = Map.fromList [(0, FL.sum), (1, FL.length)]++o_n_space_serial :: Int -> [Benchmark]+o_n_space_serial value =+    [ benchIOSink value "sequence_/100" $ S.fold (sequence_ (value `div` 100))     ] +o_n_heap_serial :: Int -> [Benchmark]+o_n_heap_serial value =+    [ bgroup "elimination"+      -- Left folds for building a structure are inherently non-streaming+      -- as the structure cannot be lazily consumed until fully built.+            [+              benchIOSink value "toList" (S.fold FL.toList)+            , benchIOSink value "toListRev" (S.fold FL.toListRev)+            , benchIOSink value "toStream" (S.fold FL.toStream)+            , benchIOSink value "toStreamRev" (S.fold FL.toStreamRev)+            ]+    ]+ ------------------------------------------------------------------------------- -- Driver -------------------------------------------------------------------------------  main :: IO ()-main = do-  (value, cfg, benches) <- parseCLIOpts defaultStreamSize-  value `seq` runMode (mode cfg) cfg benches (allBenchmarks value)-  where+main = runWithCLIOpts defaultStreamSize allBenchmarks++    where+     allBenchmarks value =-      [ bgroup-          "o-1-space"-          [ bgroup "fold" $-            concat-              [ o_1_space_serial_folds value-              , o_1_space_serial_foldsTransforms value-              , o_1_space_serial_foldsCompositions value-              ]-          ]-      , bgroup-          "o-n-heap"-          [bgroup "fold" $ concat [o_n_heap_serial_folds value]]-      ]+        [ bgroup (o_1_space_prefix moduleName) $ concat+            [ o_1_space_serial_elimination value+            , o_1_space_serial_transformation value+            , o_1_space_serial_composition value+            ]+        , bgroup (o_n_space_prefix moduleName) (o_n_space_serial value)+        , bgroup (o_n_heap_prefix moduleName) (o_n_heap_serial value)+        ]
− benchmark/Streamly/Benchmark/Data/NestedUnfoldOps.hs 
@@ -1,126 +0,0 @@--- |--- Module      : NestedUnfoldOps--- Copyright   : (c) 2019 Composewell Technologies------ License     : BSD3--- Maintainer  : streamly@composewell.com--module Streamly.Benchmark.Data.NestedUnfoldOps where--import Control.Monad.IO.Class (MonadIO (..))-import Streamly.Internal.Data.Unfold (Unfold)--import qualified Streamly.Internal.Data.Unfold as UF-import qualified Streamly.Internal.Data.Fold as FL---- n * (n + 1) / 2 == linearCount-concatCount :: Int -> Int-concatCount linearCount =-    round (((1 + 8 * fromIntegral linearCount)**(1/2::Double) - 1) / 2)---- double nested loop-nestedCount2 :: Int -> Int-nestedCount2 linearCount = round (fromIntegral linearCount**(1/2::Double))---- triple nested loop-nestedCount3 :: Int -> Int-nestedCount3 linearCount = round (fromIntegral linearCount**(1/3::Double))------------------------------------------------------------------------------------ Stream generation and elimination------------------------------------------------------------------------------------ generate numbers up to the argument value-{-# INLINE source #-}-source :: Monad m => Int -> Unfold m Int Int-source n = UF.enumerateFromToIntegral n------------------------------------------------------------------------------------ Benchmark ops----------------------------------------------------------------------------------{-# INLINE toNull #-}-toNull :: MonadIO m => Int -> Int -> m ()-toNull linearCount start = do-    let end = start + nestedCount2 linearCount-    UF.fold-        (UF.map (\(x, y) -> x + y)-        $ UF.outerProduct (source end) (source end))-        FL.drain (start, start)--{-# INLINE toNull3 #-}-toNull3 :: MonadIO m => Int -> Int -> m ()-toNull3 linearCount start = do-    let end = start + nestedCount3 linearCount-    UF.fold-            (UF.map (\(x, y) -> x + y)-            $ UF.outerProduct (source end)-                ((UF.map (\(x, y) -> x + y)-                $ UF.outerProduct (source end) (source end))))-            FL.drain (start, (start, start))--{-# INLINE concat #-}-concat :: MonadIO m => Int -> Int -> m ()-concat linearCount start = do-    let end = start + concatCount linearCount-    UF.fold-        (UF.concat (source end) (source end))-        FL.drain start--{-# INLINE toList #-}-toList :: MonadIO m => Int -> Int -> m [Int]-toList linearCount start = do-    let end = start + nestedCount2 linearCount-    UF.fold-        (UF.map (\(x, y) -> x + y)-        $ UF.outerProduct (source end) (source end))-        FL.toList (start, start)--{-# INLINE toListSome #-}-toListSome :: MonadIO m => Int -> Int -> m [Int]-toListSome linearCount start = do-    let end = start + nestedCount2 linearCount-    UF.fold-        (UF.take 1000 $ (UF.map (\(x, y) -> x + y)-            $ UF.outerProduct (source end) (source end)))-        FL.toList (start, start)--{-# INLINE filterAllOut #-}-filterAllOut :: MonadIO m => Int -> Int -> m ()-filterAllOut linearCount start = do-    let end = start + nestedCount2 linearCount-    UF.fold-        (UF.filter (< 0)-        $ UF.map (\(x, y) -> x + y)-        $ UF.outerProduct (source end) (source end))-        FL.drain (start, start)--{-# INLINE filterAllIn #-}-filterAllIn :: MonadIO m => Int -> Int -> m ()-filterAllIn linearCount start = do-    let end = start + nestedCount2 linearCount-    UF.fold-        (UF.filter (> 0)-        $ UF.map (\(x, y) -> x + y)-        $ UF.outerProduct (source end) (source end))-        FL.drain (start, start)--{-# INLINE filterSome #-}-filterSome :: MonadIO m => Int -> Int -> m ()-filterSome linearCount start = do-    let end = start + nestedCount2 linearCount-    UF.fold-        (UF.filter (> 1100000)-        $ UF.map (\(x, y) -> x + y)-        $ UF.outerProduct (source end) (source end))-        FL.drain (start, start)--{-# INLINE breakAfterSome #-}-breakAfterSome :: MonadIO m => Int -> Int -> m ()-breakAfterSome linearCount start = do-    let end = start + nestedCount2 linearCount-    UF.fold-        (UF.takeWhile (<= 1100000)-        $ UF.map (\(x, y) -> x + y)-        $ UF.outerProduct (source end) (source end))-        FL.drain (start, start)
benchmark/Streamly/Benchmark/Data/Parser.hs view
@@ -2,11 +2,11 @@ -- Module      : Streamly.Benchmark.Data.Parser -- Copyright   : (c) 2020 Composewell Technologies ----- License     : MIT+-- License     : BSD-3-Clause -- Maintainer  : streamly@composewell.com +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}-{-# OPTIONS_GHC -fspec-constr-recursive=4 #-}  module Main   (@@ -14,22 +14,38 @@   ) where  import Control.DeepSeq (NFData(..))-import Control.Monad.Catch (MonadCatch, MonadThrow)+import Control.Monad.Catch (MonadCatch) import Data.Foldable (asum)+import Data.Functor (($>))+import Data.Maybe (fromMaybe)+import Data.Monoid (Sum(..))+import GHC.Magic (inline)+#if __GLASGOW_HASKELL__ >= 802+import GHC.Magic (noinline)+#else+#define noinline+#endif+import System.IO (Handle) import System.Random (randomRIO)-import Prelude hiding (any, all, take, sequence, sequenceA, takeWhile)+import Prelude+       hiding (any, all, take, sequence, sequence_, sequenceA, takeWhile)  import qualified Data.Traversable as TR+import qualified Data.Foldable as F import qualified Control.Applicative as AP-import qualified Streamly as S hiding (runStream)+import qualified Streamly.FileSystem.Handle as Handle import qualified Streamly.Prelude  as S+import qualified Streamly.Internal.Data.Array.Foreign as Array import qualified Streamly.Internal.Data.Fold as FL import qualified Streamly.Internal.Data.Parser as PR-import qualified Streamly.Internal.Prelude as IP+import qualified Streamly.Internal.Data.Stream.IsStream as IP+import qualified Streamly.Internal.Data.Producer as Producer+import qualified Streamly.Internal.Data.Producer.Source as Source -import Gauge-import Streamly hiding (runStream)+import Gauge hiding (env)+import Streamly.Prelude (SerialT) import Streamly.Benchmark.Common+import Streamly.Benchmark.Common.Handle  ------------------------------------------------------------------------------- -- Utilities@@ -37,9 +53,6 @@  -- XXX these can be moved to the common module --- We need a monadic bind here to make sure that the function f does not get--- completely optimized out by the compiler in some cases.- {-# INLINE sourceUnfoldrM #-} sourceUnfoldrM :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int sourceUnfoldrM value n = S.unfoldrM step n@@ -52,7 +65,7 @@ -- | Takes a fold method, and uses it with a default source. {-# INLINE benchIOSink #-} benchIOSink-    :: (IsStream t, NFData b)+    :: (S.IsStream t, NFData b)     => Int -> String -> (t IO Int -> IO b) -> Benchmark benchIOSink value name f =     bench name $ nfIO $ randomRIO (1,1) >>= f . sourceUnfoldrM value@@ -61,25 +74,48 @@ -- Parsers ------------------------------------------------------------------------------- -{-# INLINE any #-}-any :: (MonadThrow m, Ord a) => a -> SerialT m a -> m Bool-any value = IP.parse (PR.any (> value))+{-# INLINE takeBetween #-}+takeBetween :: MonadCatch m => Int -> SerialT m a -> m ()+takeBetween value =  IP.parse (PR.takeBetween 0 value FL.drain) -{-# INLINE all #-}-all :: (MonadThrow m, Ord a) => a -> SerialT m a -> m Bool-all value = IP.parse (PR.all (<= value))+{-# INLINE takeEQ #-}+takeEQ :: MonadCatch m => Int -> SerialT m a -> m ()+takeEQ value = IP.parse (PR.takeEQ value FL.drain) -{-# INLINE take #-}-take :: MonadThrow m => Int -> SerialT m a -> m ()-take value = IP.parse (PR.take value FL.drain)+{-# INLINE drainWhile #-}+drainWhile :: MonadCatch m => Int -> SerialT m Int -> m ()+drainWhile value = IP.parse (PR.drainWhile (<= value)) +{-# INLINE sliceBeginWith #-}+sliceBeginWith :: MonadCatch m => Int -> SerialT m Int -> m ()+sliceBeginWith value stream = do+    stream1 <- return . fromMaybe (S.fromPure (value + 1)) =<< S.tail stream+    let stream2 = value `S.cons` stream1+    IP.parse (PR.sliceBeginWith (== value) FL.drain) stream2+ {-# INLINE takeWhile #-}-takeWhile :: MonadThrow m => Int -> SerialT m Int -> m ()+takeWhile :: MonadCatch m => Int -> SerialT m Int -> m () takeWhile value = IP.parse (PR.takeWhile (<= value) FL.drain) +{-# INLINE groupBy #-}+groupBy :: MonadCatch m => SerialT m Int -> m ()+groupBy = IP.parse (PR.groupBy (<=) FL.drain)++{-# INLINE groupByRolling #-}+groupByRolling :: MonadCatch m => SerialT m Int -> m ()+groupByRolling = IP.parse (PR.groupByRolling (<=) FL.drain)++{-# INLINE wordBy #-}+wordBy :: MonadCatch m => Int -> SerialT m Int -> m ()+wordBy value = IP.parse (PR.wordBy (>= value) FL.drain)++{-# INLINE manyWordByEven #-}+manyWordByEven :: MonadCatch m => SerialT m Int -> m ()+manyWordByEven = IP.parse (PR.many (PR.wordBy (Prelude.even) FL.drain) FL.drain)+ {-# INLINE many #-} many :: MonadCatch m => SerialT m Int -> m Int-many = IP.parse (PR.many FL.length (PR.satisfy (> 0)))+many = IP.parse (PR.many (PR.satisfy (> 0)) FL.length)  {-# INLINE manyAlt #-} manyAlt :: MonadCatch m => SerialT m Int -> m Int@@ -89,7 +125,7 @@  {-# INLINE some #-} some :: MonadCatch m => SerialT m Int -> m Int-some = IP.parse (PR.some FL.length (PR.satisfy (> 0)))+some = IP.parse (PR.some (PR.satisfy (> 0)) FL.length)  {-# INLINE someAlt #-} someAlt :: MonadCatch m => SerialT m Int -> m Int@@ -100,39 +136,125 @@ {-# INLINE manyTill #-} manyTill :: MonadCatch m => Int -> SerialT m Int -> m Int manyTill value =-    IP.parse (PR.manyTill FL.length (PR.satisfy (> 0)) (PR.satisfy (== value)))+    IP.parse (PR.manyTill (PR.satisfy (> 0)) (PR.satisfy (== value)) FL.length) -{-# INLINE splitAllAny #-}-splitAllAny :: MonadThrow m-    => Int -> SerialT m Int -> m (Bool, Bool)-splitAllAny value =-    IP.parse ((,) <$> PR.all (<= (value `div` 2)) <*> PR.any (> value))+{-# INLINE splitAp #-}+splitAp :: MonadCatch m+    => Int -> SerialT m Int -> m ((), ())+splitAp value =+    IP.parse+        ((,)+            <$> PR.drainWhile (<= (value `div` 2))+            <*> PR.drainWhile (<= value)+        ) +{-# INLINE splitApBefore #-}+splitApBefore :: MonadCatch m+    => Int -> SerialT m Int -> m ()+splitApBefore value =+    IP.parse+        (  PR.drainWhile (<= (value `div` 2))+        *> PR.drainWhile (<= value)+        )++{-# INLINE splitApAfter #-}+splitApAfter :: MonadCatch m+    => Int -> SerialT m Int -> m ()+splitApAfter value =+    IP.parse+        (  PR.drainWhile (<= (value `div` 2))+        <* PR.drainWhile (<= value)+        )++{-# INLINE serialWith #-}+serialWith :: MonadCatch m+    => Int -> SerialT m Int -> m ((), ())+serialWith value =+    IP.parse+        (PR.serialWith (,)+            (PR.drainWhile (<= (value `div` 2)))+            (PR.drainWhile (<= value))+        )++{-# INLINE split_ #-}+split_ :: MonadCatch m+    => Int -> SerialT m Int -> m ()+split_ value =+    IP.parse+        (PR.split_+            (PR.drainWhile (<= (value `div` 2)))+            (PR.drainWhile (<= value))+        )++{-# INLINE sliceSepByP #-}+sliceSepByP :: MonadCatch m+    => Int -> SerialT m Int -> m()+sliceSepByP value = IP.parse (PR.sliceSepByP (>= value) (PR.fromFold FL.drain))+ {-# INLINE teeAllAny #-}-teeAllAny :: (MonadThrow m, Ord a)-    => a -> SerialT m a -> m (Bool, Bool)+teeAllAny :: MonadCatch m+    => Int -> SerialT m Int -> m ((), ()) teeAllAny value =-    IP.parse (PR.teeWith (,) (PR.all (<= value)) (PR.any (> value)))+    IP.parse+        (PR.teeWith (,)+            (PR.drainWhile (<= value))+            (PR.drainWhile (<= value))+        )  {-# INLINE teeFstAllAny #-}-teeFstAllAny :: (MonadThrow m, Ord a)-    => a -> SerialT m a -> m (Bool, Bool)+teeFstAllAny :: MonadCatch m+    => Int -> SerialT m Int -> m ((), ()) teeFstAllAny value =-    IP.parse (PR.teeWithFst (,) (PR.all (<= value)) (PR.any (> value)))+    IP.parse+        (PR.teeWithFst (,)+            (PR.drainWhile (<= value))+            (PR.drainWhile (<= value))+        )  {-# INLINE shortestAllAny #-}-shortestAllAny :: (MonadThrow m, Ord a)-    => a -> SerialT m a -> m Bool+shortestAllAny :: MonadCatch m+    => Int -> SerialT m Int -> m () shortestAllAny value =-    IP.parse (PR.shortest (PR.all (<= value)) (PR.any (> value)))+    IP.parse+        (PR.shortest+            (PR.drainWhile (<= value))+            (PR.drainWhile (<= value))+        )  {-# INLINE longestAllAny #-}-longestAllAny :: (MonadCatch m, Ord a)-    => a -> SerialT m a -> m Bool+longestAllAny :: MonadCatch m+    => Int -> SerialT m Int -> m () longestAllAny value =-    IP.parse (PR.longest (PR.all (<= value)) (PR.any (> value)))+    IP.parse+        (PR.longest+            (PR.drainWhile (<= value))+            (PR.drainWhile (<= value))+        ) +parseManyChunksOfSum :: Int -> Handle -> IO Int+parseManyChunksOfSum n inh =+    S.length+        $ IP.parseMany+              (PR.fromFold $ FL.take n FL.sum)+              (S.unfold Handle.read inh)+ -------------------------------------------------------------------------------+-- Parsing with unfolds+-------------------------------------------------------------------------------++{-# INLINE parseManyUnfoldArrays #-}+parseManyUnfoldArrays :: Int -> [Array.Array Int] -> IO ()+parseManyUnfoldArrays count arrays = do+    let src = Source.source (Just (Producer.OuterLoop arrays))+    let parser = PR.fromFold (FL.take count FL.drain)+    let readSrc =+            Source.producer+                $ Producer.concat Producer.fromList Array.producer+    let streamParser =+            Producer.simplify (Source.parseMany parser readSrc)+    S.drain $ S.unfold streamParser src++------------------------------------------------------------------------------- -- Parsers in which -fspec-constr-recursive=16 is problematic ------------------------------------------------------------------------------- @@ -141,57 +263,132 @@ -- not have to rely on it. -- {-# INLINE lookAhead #-}-lookAhead :: MonadThrow m => Int -> SerialT m Int -> m ()+lookAhead :: MonadCatch m => Int -> SerialT m Int -> m () lookAhead value =-    IP.parse (PR.lookAhead (PR.takeWhile (<= value) FL.drain) *> pure ())+    IP.parse (PR.lookAhead (PR.takeWhile (<= value) FL.drain) $> ()) --- quadratic complexity {-# INLINE sequenceA #-}-sequenceA :: MonadThrow m => Int -> SerialT m Int -> m Int+sequenceA :: MonadCatch m => Int -> SerialT m Int -> m Int sequenceA value xs = do     x <- IP.parse (TR.sequenceA (replicate value (PR.satisfy (> 0)))) xs     return $ length x --- quadratic complexity+{-# INLINE sequenceA_ #-}+sequenceA_ :: MonadCatch m => Int -> SerialT m Int -> m ()+sequenceA_ value =+    IP.parse (F.sequenceA_ $ replicate value (PR.satisfy (> 0)))+ {-# INLINE sequence #-}-sequence :: MonadThrow m => Int -> SerialT m Int -> m Int+sequence :: MonadCatch m => Int -> SerialT m Int -> m Int sequence value xs = do     x <- IP.parse (TR.sequence (replicate value (PR.satisfy (> 0)))) xs     return $ length x --- choice using the "Alternative" instance with direct style parser type has--- quadratic performance complexity.---+{-# INLINE sequence_ #-}+sequence_ :: MonadCatch m => Int -> SerialT m Int -> m ()+sequence_ value =+    IP.parse (F.sequence_ $ replicate value (PR.satisfy (> 0)))+ {-# INLINE choice #-} choice :: MonadCatch m => Int -> SerialT m Int -> m Int-choice value = do+choice value =     IP.parse (asum (replicate value (PR.satisfy (< 0)))         AP.<|> PR.satisfy (> 0))  -------------------------------------------------------------------------------+-- Stream transformation+-------------------------------------------------------------------------------++{-# INLINE parseMany #-}+parseMany :: MonadCatch m => Int -> SerialT m Int -> m ()+parseMany n =+      S.drain+    . S.map getSum+    . IP.parseMany (PR.fromFold $ FL.take n FL.mconcat)+    . S.map Sum++{-# INLINE parseIterate #-}+parseIterate :: MonadCatch m => Int -> SerialT m Int -> m ()+parseIterate n =+      S.drain+    . S.map getSum+    . IP.parseIterate (PR.fromFold . FL.take n . FL.sconcat) (Sum 0)+    . S.map Sum++------------------------------------------------------------------------------- -- Benchmarks ------------------------------------------------------------------------------- -o_1_space_serial_parse :: Int -> [Benchmark]-o_1_space_serial_parse value =-    [ benchIOSink value "any" $ any value-    , benchIOSink value "all" $ all value-    , benchIOSink value "take" $ take value+moduleName :: String+moduleName = "Data.Parser"++o_1_space_serial :: Int -> [Benchmark]+o_1_space_serial value =+    [ benchIOSink value "takeBetween" $ takeBetween value+    , benchIOSink value "takeEQ" $ takeEQ value     , benchIOSink value "takeWhile" $ takeWhile value-    , benchIOSink value "lookAhead" $ lookAhead value-    , benchIOSink value "split (all,any)" $ splitAllAny value+    , benchIOSink value "drainWhile" $ drainWhile value+    , benchIOSink value "sliceBeginWith" $ sliceBeginWith value+    , benchIOSink value "groupBy" $ groupBy+    , benchIOSink value "groupByRolling" $ groupByRolling+    , benchIOSink value "wordBy" $ wordBy value+    , benchIOSink value "splitAp" $ splitAp value+    , benchIOSink value "splitApBefore" $ splitApBefore value+    , benchIOSink value "splitApAfter" $ splitApAfter value+    , benchIOSink value "serialWith" $ serialWith value+    , benchIOSink value "sliceSepByP" $ sliceSepByP value     , benchIOSink value "many" many+    , benchIOSink value "many (wordBy even)" $ manyWordByEven     , benchIOSink value "some" some+    , benchIOSink value "manyTill" $ manyTill value+    , benchIOSink value "tee" $ teeAllAny value+    , benchIOSink value "teeFst" $ teeFstAllAny value+    , benchIOSink value "shortest" $ shortestAllAny value+    , benchIOSink value "longest" $ longestAllAny value+    , benchIOSink value "parseMany (take 1)" (parseMany 1)+    , benchIOSink value "parseMany (take all)" (parseMany value)+    , benchIOSink value "parseIterate (take 1)" (parseIterate 1)+    , benchIOSink value "parseIterate (take all)" (parseIterate value)+    ]++o_1_space_filesystem :: BenchEnv -> [Benchmark]+o_1_space_filesystem env =+    [ mkBench ("S.parseMany (FL.take " ++ show (bigSize env) ++ " FL.sum)") env+          $ \inh _ -> noinline parseManyChunksOfSum (bigSize env) inh+    , mkBench "S.parseMany (FL.take 1 FL.sum)" env+          $ \inh _ -> inline parseManyChunksOfSum 1 inh+    ]++o_1_space_serial_unfold :: Int -> [Array.Array Int] -> [Benchmark]+o_1_space_serial_unfold bound arrays =+    [ bench "parseMany/Unfold/1000 arrays/take all"+        $ nfIO $ parseManyUnfoldArrays bound arrays+    , bench "parseMany/Unfold/1000 arrays/take 1"+        $ nfIO $ parseManyUnfoldArrays 1 arrays+    ]++o_n_heap_serial :: Int -> [Benchmark]+o_n_heap_serial value =+    [+    -- lookahead benchmark holds the entire input till end+      benchIOSink value "lookAhead" $ lookAhead value++    -- accumulates the results in a list+    , benchIOSink value "sequence" $ sequence value+    , benchIOSink value "sequenceA" $ sequenceA value++    -- XXX why should this take O(n) heap, it discards the results?+    , benchIOSink value "sequence_" $ sequence_ value+    , benchIOSink value "sequenceA_" $ sequenceA_ value+    -- non-linear time complexity (parserD)+    , benchIOSink value "split_" $ split_ value+    -- XXX why O(n) heap?+    , benchIOSink value "choice" $ choice value++    -- These show non-linear time complexity.+    -- They accumulate the results in a list.     , benchIOSink value "manyAlt" manyAlt     , benchIOSink value "someAlt" someAlt-    , benchIOSink value "manyTill" $ manyTill value-    , benchIOSink value "choice/100" $ choice (value `div` 100)-    , benchIOSink value "tee (all,any)" $ teeAllAny value-    , benchIOSink value "teeFst (all,any)" $ teeFstAllAny value-    , benchIOSink value "shortest (all,any)" $ shortestAllAny value-    , benchIOSink value "longest (all,any)" $ longestAllAny value-    , benchIOSink value "sequenceA/100" $ sequenceA (value `div` 100)-    , benchIOSink value "sequence/100" $ sequence (value `div` 100)     ]  -------------------------------------------------------------------------------@@ -200,16 +397,19 @@  main :: IO () main = do-    (value, cfg, benches) <- parseCLIOpts defaultStreamSize-    value `seq` runMode (mode cfg) cfg benches (allBenchmarks value)+    env <- mkHandleBenchEnv+    runWithCLIOptsEnv defaultStreamSize alloc (allBenchmarks env)      where -    allBenchmarks value =-        [ bgroup "o1"-            [ bgroup "parser" $ concat-                [-                  o_1_space_serial_parse value-                ]-            ]+    alloc value = IP.toList $ IP.arraysOf 100 $ sourceUnfoldrM value 0++    allBenchmarks env arrays value =+        [ bgroup (o_1_space_prefix moduleName) (o_1_space_serial value)+        , bgroup+              (o_1_space_prefix moduleName ++ "/filesystem")+              (o_1_space_filesystem env)+        , bgroup (o_1_space_prefix moduleName)+            (o_1_space_serial_unfold value arrays)+        , bgroup (o_n_heap_prefix moduleName) (o_n_heap_serial value)         ]
+ benchmark/Streamly/Benchmark/Data/Parser/ParserD.hs view
@@ -0,0 +1,376 @@+-- |+-- Module      : Streamly.Benchmark.Data.ParserD+-- Copyright   : (c) 2020 Composewell Technologies+--+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fspec-constr-recursive=4 #-}++module Main+  (+    main+  ) where++import Control.DeepSeq (NFData(..))+import Control.Monad.Catch (MonadCatch, MonadThrow)+import Data.Foldable (asum)+import Data.Functor (($>))+import Data.Maybe (fromMaybe)+import System.Random (randomRIO)+import Prelude hiding (any, all, take, sequence, sequenceA, sequence_, takeWhile, span)++import qualified Data.Traversable as TR+import qualified Data.Foldable as F+import qualified Control.Applicative as AP+import qualified Streamly.Prelude  as S+import qualified Streamly.Internal.Data.Array.Foreign as Array+import qualified Streamly.Internal.Data.Fold as FL+import qualified Streamly.Internal.Data.Parser.ParserD as PR+import qualified Streamly.Internal.Data.Producer as Producer+import qualified Streamly.Internal.Data.Producer.Source as Source+import qualified Streamly.Internal.Data.Stream.IsStream as IP++import Gauge+import Streamly.Prelude (SerialT, MonadAsync, IsStream)+import Streamly.Benchmark.Common++-------------------------------------------------------------------------------+-- Utilities+-------------------------------------------------------------------------------++-- XXX these can be moved to the common module++{-# INLINE sourceUnfoldrM #-}+sourceUnfoldrM :: (IsStream t, MonadAsync m) => Int -> Int -> t m Int+sourceUnfoldrM value n = S.unfoldrM step n+    where+    step cnt =+        if cnt > n + value+        then return Nothing+        else return (Just (cnt, cnt + 1))++-- | Takes a fold method, and uses it with a default source.+{-# INLINE benchIOSink #-}+benchIOSink+    :: (IsStream t, NFData b)+    => Int -> String -> (t IO Int -> IO b) -> Benchmark+benchIOSink value name f =+    bench name $ nfIO $ randomRIO (1,1) >>= f . sourceUnfoldrM value++-------------------------------------------------------------------------------+-- Parsers+-------------------------------------------------------------------------------++{-# INLINE drainWhile #-}+drainWhile :: MonadThrow m => (a -> Bool) -> PR.Parser m a ()+drainWhile p = PR.takeWhile p FL.drain++{-# INLINE sliceBeginWith #-}+sliceBeginWith :: MonadCatch m => Int -> SerialT m Int -> m ()+sliceBeginWith value stream = do+    stream1 <- return . fromMaybe (S.fromPure (value + 1)) =<< S.tail stream+    let stream2 = value `S.cons` stream1+    IP.parseD (PR.sliceBeginWith (== value) FL.drain) stream2++{-# INLINE takeWhile #-}+takeWhile :: MonadThrow m => Int -> SerialT m Int -> m ()+takeWhile value = IP.parseD (drainWhile (<= value))++{-# INLINE groupBy #-}+groupBy :: MonadThrow m => SerialT m Int -> m ()+groupBy = IP.parseD (PR.groupBy (<=) FL.drain)++{-# INLINE groupByRolling #-}+groupByRolling :: MonadThrow m => SerialT m Int -> m ()+groupByRolling = IP.parseD (PR.groupByRolling (<=) FL.drain)++{-# INLINE wordBy #-}+wordBy :: MonadThrow m => Int -> SerialT m Int -> m ()+wordBy value = IP.parseD (PR.wordBy (>= value) FL.drain)++{-# INLINE manyWordByEven #-}+manyWordByEven :: MonadCatch m => SerialT m Int -> m ()+manyWordByEven =+    IP.parseD (PR.many (PR.wordBy (Prelude.even) FL.drain) FL.drain)++{-# INLINE many #-}+many :: MonadCatch m => SerialT m Int -> m Int+many = IP.parseD (PR.many (PR.satisfy (> 0)) FL.length)++{-# INLINE manyAlt #-}+manyAlt :: MonadCatch m => SerialT m Int -> m Int+manyAlt xs = do+    x <- IP.parseD (AP.many (PR.satisfy (> 0))) xs+    return $ Prelude.length x++{-# INLINE some #-}+some :: MonadCatch m => SerialT m Int -> m Int+some = IP.parseD (PR.some (PR.satisfy (> 0)) FL.length)++{-# INLINE someAlt #-}+someAlt :: MonadCatch m => SerialT m Int -> m Int+someAlt xs = do+    x <- IP.parseD (AP.some (PR.satisfy (> 0))) xs+    return $ Prelude.length x++{-#INLINE sliceSepByP #-}+sliceSepByP :: MonadCatch m => Int -> SerialT m Int -> m ()+sliceSepByP value = IP.parseD (PR.sliceSepByP (>= value) (PR.fromFold FL.drain))++{-# INLINE manyTill #-}+manyTill :: MonadCatch m => Int -> SerialT m Int -> m Int+manyTill value =+    let p = PR.satisfy (> 0)+        pcond = PR.satisfy (== value)+    in IP.parseD (PR.manyTill FL.length p pcond)++{-# INLINE serialWith #-}+serialWith :: MonadThrow m+    => Int -> SerialT m Int -> m ((), ())+serialWith value =+    IP.parseD+        ((,)+            <$> drainWhile (<= (value `div` 2))+            <*> drainWhile (<= value)+        )++{-# INLINE teeAllAny #-}+teeAllAny :: MonadThrow m+    => Int -> SerialT m Int -> m ((), ())+teeAllAny value =+    IP.parseD+        (PR.teeWith (,)+            (drainWhile (<= value))+            (drainWhile (<= value))+        )++{-# INLINE teeFstAllAny #-}+teeFstAllAny :: MonadThrow m+    => Int -> SerialT m Int -> m ((), ())+teeFstAllAny value =+    IP.parseD+        (PR.teeWithFst (,)+            (drainWhile (<= value))+            (drainWhile (<= value))+        )++{-# INLINE shortestAllAny #-}+shortestAllAny :: MonadThrow m+    => Int -> SerialT m Int -> m ()+shortestAllAny value =+    IP.parseD+        (PR.shortest+            (drainWhile (<= value))+            (drainWhile (<= value))+        )++{-# INLINE longestAllAny #-}+longestAllAny :: MonadCatch m+    => Int -> SerialT m Int -> m ()+longestAllAny value =+    IP.parseD+        (PR.longest+            (drainWhile (<= value))+            (drainWhile (<= value))+        )++-------------------------------------------------------------------------------+-- Spanning+-------------------------------------------------------------------------------++{-# INLINE span #-}+span :: MonadThrow m => Int -> SerialT m Int -> m ((), ())+span value = IP.parseD (PR.span (<= (value `div` 2)) FL.drain FL.drain)++{-# INLINE spanBy #-}+spanBy :: MonadThrow m => Int -> SerialT m Int -> m ((), ())+spanBy value =+    IP.parseD (PR.spanBy (\_ i -> i <= (value `div` 2)) FL.drain FL.drain)++{-# INLINE spanByRolling #-}+spanByRolling :: MonadThrow m => Int -> SerialT m Int -> m ((), ())+spanByRolling value =+    IP.parseD (PR.spanByRolling (\_ i -> i <= value `div` 2) FL.drain FL.drain)++-------------------------------------------------------------------------------+-- Nested+-------------------------------------------------------------------------------++{-# INLINE parseMany #-}+parseMany :: MonadThrow m => Int -> SerialT m Int -> m ()+parseMany value = IP.drain . IP.parseManyD (drainWhile (<= value + 1))++{-# INLINE parseManyGroups #-}+parseManyGroups :: MonadThrow m => Bool -> SerialT m Int -> m ()+parseManyGroups b = IP.drain . IP.parseManyD (PR.groupBy (\_ _ -> b) FL.drain)++{-# INLINE parseManyGroupsRolling #-}+parseManyGroupsRolling :: MonadThrow m => Bool -> SerialT m Int -> m ()+parseManyGroupsRolling b =+    IP.drain . IP.parseManyD (PR.groupByRolling (\_ _ -> b) FL.drain)++-------------------------------------------------------------------------------+-- Parsing with unfolds+-------------------------------------------------------------------------------++{-# INLINE parseManyUnfoldArrays #-}+parseManyUnfoldArrays :: Int -> [Array.Array Int] -> IO ()+parseManyUnfoldArrays count arrays = do+    let src = Source.source (Just (Producer.OuterLoop arrays))+    let parser = PR.fromFold (FL.take count FL.drain)+    let readSrc =+            Source.producer+                $ Producer.concat Producer.fromList Array.producer+    let streamParser =+            Producer.simplify (Source.parseManyD parser readSrc)+    S.drain $ S.unfold streamParser src++-------------------------------------------------------------------------------+-- Parsers in which -fspec-constr-recursive=16 is problematic+-------------------------------------------------------------------------------++-- XXX -fspec-constr-recursive=16 makes GHC go beserk when compiling these.+-- We need to fix GHC so that we can have better control over that option or do+-- not have to rely on it.+--+{-# INLINE lookAhead #-}+lookAhead :: MonadThrow m => Int -> SerialT m Int -> m ()+lookAhead value =+    IP.parseD (PR.lookAhead (PR.takeWhile (<= value) FL.drain) $> ())++{-# INLINE sequenceA_ #-}+sequenceA_ :: MonadThrow m => Int -> SerialT m Int -> m ()+sequenceA_ value =+    IP.parseD (F.sequenceA_ $ replicate value (PR.satisfy (> 0)))++-- quadratic complexity+{-# INLINE sequenceA #-}+sequenceA :: MonadThrow m => Int -> SerialT m Int -> m Int+sequenceA value xs = do+    x <- IP.parseD (TR.sequenceA (replicate value (PR.satisfy (> 0)))) xs+    return $ length x++-- quadratic complexity+{-# INLINE sequence #-}+sequence :: MonadThrow m => Int -> SerialT m Int -> m Int+sequence value xs = do+    x <- IP.parseD (TR.sequence (replicate value (PR.satisfy (> 0)))) xs+    return $ length x++{-# INLINE sequence_ #-}+sequence_ :: MonadCatch m => Int -> SerialT m Int -> m ()+sequence_ value xs =+    IP.parseD (foldr f (return ()) (replicate value (PR.takeBetween 0 1 FL.drain))) xs++    where++    {-# INLINE f #-}+    f m k = m >>= (\_ -> k)++-- choice using the "Alternative" instance with direct style parser type has+-- quadratic performance complexity.+--+{-# INLINE choice #-}+choice :: MonadCatch m => Int -> SerialT m Int -> m Int+choice value =+    IP.parseD (asum (replicate value (PR.satisfy (< 0)))+        AP.<|> PR.satisfy (> 0))++-------------------------------------------------------------------------------+-- Benchmarks+-------------------------------------------------------------------------------++moduleName :: String+moduleName = "Data.Parser.ParserD"++o_1_space_serial :: Int -> [Benchmark]+o_1_space_serial value =+    [ benchIOSink value "takeWhile" $ takeWhile value+    , benchIOSink value "sliceBeginWith" $ sliceBeginWith value+    , benchIOSink value "groupBy" $ groupBy+    , benchIOSink value "groupByRolling" $ groupByRolling+    , benchIOSink value "wordBy" $ wordBy value+    , benchIOSink value "serialWith" $ serialWith value+    , benchIOSink value "many" many+    , benchIOSink value "many (wordBy even)" $ manyWordByEven+    , benchIOSink value "some" some+    , benchIOSink value "sliceSepByP" $ sliceSepByP value+    , benchIOSink value "manyTill" $ manyTill value+    , benchIOSink value "tee (all,any)" $ teeAllAny value+    , benchIOSink value "teeFst (all,any)" $ teeFstAllAny value+    , benchIOSink value "shortest (all,any)" $ shortestAllAny value+    , benchIOSink value "longest (all,any)" $ longestAllAny value+    ]++o_1_space_serial_spanning :: Int -> [Benchmark]+o_1_space_serial_spanning value =+    [ benchIOSink value "span" $ span value+    , benchIOSink value "spanBy" $ spanBy value+    , benchIOSink value "spanByRolling" $ spanByRolling value+    ]++o_1_space_serial_nested :: Int -> [Benchmark]+o_1_space_serial_nested value =+    [ benchIOSink value "parseMany" $ parseMany value+    , benchIOSink value "parseMany groupBy (bound groups)"+          $ (parseManyGroups False)+    , benchIOSink value "parseMany groupRollingBy (bound groups)"+          $ (parseManyGroupsRolling False)+    , benchIOSink value "parseMany groupBy (1 group)" $ (parseManyGroups True)+    , benchIOSink value "parseMany groupRollingBy (1 group)"+          $ (parseManyGroupsRolling True)+    ]++o_1_space_serial_unfold :: Int -> [Array.Array Int] -> [Benchmark]+o_1_space_serial_unfold bound arrays =+    [ bench "parseMany/Unfold/1000 arrays/1 parse"+        $ nfIO $ parseManyUnfoldArrays bound arrays+    , bench "parseMany/Unfold/1000 arrays/100000 parses"+        $ nfIO $ parseManyUnfoldArrays 1 arrays+    ]++o_n_heap_serial :: Int -> [Benchmark]+o_n_heap_serial value =+    [+    -- lookahead benchmark holds the entire input till end+      benchIOSink value "lookAhead" $ lookAhead value++    -- These show non-linear time complexity+    -- They accumulate the results in a list.+    , benchIOSink value "manyAlt" manyAlt+    , benchIOSink value "someAlt" someAlt+    ]++-- accumulate results in a list in IO+o_n_space_serial :: Int -> [Benchmark]+o_n_space_serial value =+    [ benchIOSink value "sequenceA/100" $ sequenceA (value `div` 100)+    , benchIOSink value "sequenceA_/100" $ sequenceA_ (value `div` 100)+    , benchIOSink value "sequence/100" $ sequence (value `div` 100)+    , benchIOSink value "sequence_/100" $ sequence_ (value `div` 100)+    , benchIOSink value "choice/100" $ choice (value `div` 100)+    ]++-------------------------------------------------------------------------------+-- Driver+-------------------------------------------------------------------------------++main :: IO ()+main = runWithCLIOptsEnv defaultStreamSize alloc allBenchmarks++    where++    alloc value = IP.toList $ IP.arraysOf 100 $ sourceUnfoldrM value 0++    allBenchmarks arraysSmall value =+        [ bgroup (o_1_space_prefix moduleName) (o_1_space_serial value)+        , bgroup (o_1_space_prefix moduleName) (o_1_space_serial_spanning value)+        , bgroup (o_1_space_prefix moduleName) (o_1_space_serial_nested value)+        , bgroup (o_1_space_prefix moduleName)+            (o_1_space_serial_unfold value arraysSmall)+        , bgroup (o_n_heap_prefix moduleName) (o_n_heap_serial value)+        , bgroup (o_n_space_prefix moduleName) (o_n_space_serial value)+        ]
+ benchmark/Streamly/Benchmark/Data/Parser/ParserK.hs view
@@ -0,0 +1,163 @@+-- |+-- Module      : Streamly.Benchmark.Data.ParserK+-- Copyright   : (c) 2020 Composewell Technologies+--+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}++module Main+  (+    main+  ) where++import Control.DeepSeq (NFData(..))+import Control.Monad.Catch (MonadCatch)+import Data.Foldable (asum)+import System.Random (randomRIO)+import Prelude hiding (any, all, take, sequence, sequenceA, takeWhile)++import qualified Control.Applicative as AP+import qualified Data.Foldable as F+import qualified Data.Traversable as TR+import qualified Streamly.Prelude  as S+import qualified Streamly.Internal.Data.Fold as FL+import qualified Streamly.Internal.Data.Parser.ParserK.Type as PR+import qualified Streamly.Internal.Data.Parser.ParserD as PRD+import qualified Streamly.Internal.Data.Stream.IsStream as IP++import Gauge+import Streamly.Prelude (SerialT, MonadAsync, IsStream)+import Streamly.Benchmark.Common++-------------------------------------------------------------------------------+-- Utilities+-------------------------------------------------------------------------------++-- XXX these can be moved to the common module++{-# INLINE sourceUnfoldrM #-}+sourceUnfoldrM :: (IsStream t, MonadAsync m) => Int -> Int -> t m Int+sourceUnfoldrM value n = S.unfoldrM step n+    where+    step cnt =+        if cnt > n + value+        then return Nothing+        else return (Just (cnt, cnt + 1))++-- | Takes a fold method, and uses it with a default source.+{-# INLINE benchIOSink #-}+benchIOSink+    :: (IsStream t, NFData b)+    => Int -> String -> (t IO Int -> IO b) -> Benchmark+benchIOSink value name f =+    bench name $ nfIO $ randomRIO (1,1) >>= f . sourceUnfoldrM value++-------------------------------------------------------------------------------+-- Parsers+-------------------------------------------------------------------------------++#ifdef FROM_PARSERK+#define PARSE_OP (IP.parseD . PR.fromParserK)+#else+#define PARSE_OP IP.parseK+#endif++{-# INLINE satisfy #-}+satisfy :: MonadCatch m => (a -> Bool) -> PR.Parser m a a+satisfy = PR.toParserK . PRD.satisfy++{-# INLINE takeWhile #-}+takeWhile :: MonadCatch m => (a -> Bool) -> PR.Parser m a ()+takeWhile p = PR.toParserK $ PRD.takeWhile p FL.drain++{-# INLINE takeWhileK #-}+takeWhileK :: MonadCatch m => Int -> SerialT m Int -> m ()+takeWhileK value = PARSE_OP (takeWhile (<= value))++{-# INLINE splitApp #-}+splitApp :: MonadCatch m+    => Int -> SerialT m Int -> m ((), ())+splitApp value =+    PARSE_OP ((,) <$> takeWhile (<= (value `div` 2)) <*> takeWhile (<= value))++{-# INLINE sequenceA #-}+sequenceA :: MonadCatch m => Int -> SerialT m Int -> m Int+sequenceA value xs = do+    let parser = satisfy (> 0)+        list = Prelude.replicate value parser+    x <- PARSE_OP (TR.sequenceA list) xs+    return $ Prelude.length x++{-# INLINE sequenceA_ #-}+sequenceA_ :: MonadCatch m => Int -> SerialT m Int -> m ()+sequenceA_ value xs = do+    let parser = satisfy (> 0)+        list = Prelude.replicate value parser+    PARSE_OP (F.sequenceA_ list) xs++{-# INLINE sequence #-}+sequence :: MonadCatch m => Int -> SerialT m Int -> m Int+sequence value xs = do+    let parser = satisfy (> 0)+        list = Prelude.replicate value parser+    x <- PARSE_OP (TR.sequence list) xs+    return $ Prelude.length x++{-# INLINE manyAlt #-}+manyAlt :: MonadCatch m => SerialT m Int -> m Int+manyAlt xs = do+    x <- PARSE_OP (AP.many (satisfy (> 0))) xs+    return $ Prelude.length x++{-# INLINE someAlt #-}+someAlt :: MonadCatch m => SerialT m Int -> m Int+someAlt xs = do+    x <- PARSE_OP (AP.some (satisfy (> 0))) xs+    return $ Prelude.length x++{-# INLINE choice #-}+choice :: MonadCatch m => Int -> SerialT m Int -> m Int+choice value =+    PARSE_OP (asum (replicate value (satisfy (< 0)))+        AP.<|> satisfy (> 0))++-------------------------------------------------------------------------------+-- Benchmarks+-------------------------------------------------------------------------------++moduleName :: String+moduleName = "Data.Parser.ParserK"++o_1_space_serial :: Int -> [Benchmark]+o_1_space_serial value =+    [ benchIOSink value "takeWhile" $ takeWhileK value+    , benchIOSink value "splitApp" $ splitApp value+    ]++-- O(n) heap beacuse of accumulation of the list in strict IO monad?+o_n_heap_serial :: Int -> [Benchmark]+o_n_heap_serial value =+    [ benchIOSink value "sequenceA" $ sequenceA value+    , benchIOSink value "sequenceA_" $ sequenceA_ value+    , benchIOSink value "sequence" $ sequence value+    , benchIOSink value "manyAlt" manyAlt+    , benchIOSink value "someAlt" someAlt+    , benchIOSink value "choice" $ choice value+    ]++-------------------------------------------------------------------------------+-- Driver+-------------------------------------------------------------------------------++main :: IO ()+main = runWithCLIOpts defaultStreamSize allBenchmarks++    where++    allBenchmarks value =+        [ bgroup (o_1_space_prefix moduleName) (o_1_space_serial value)+        , bgroup (o_n_heap_prefix moduleName) (o_n_heap_serial value)+        ]
− benchmark/Streamly/Benchmark/Data/Prim/Array.hs 
@@ -1,100 +0,0 @@--- |--- Module      : Main--- Copyright   : (c) 2019 Composewell Technologies------ License     : BSD-3-Clause--- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC--{-# LANGUAGE CPP #-}--module Main (main) where--import Control.DeepSeq (NFData(..))-import System.Random (randomRIO)--import qualified Streamly.Benchmark.Data.Prim.ArrayOps as Ops-import qualified Streamly.Internal.Data.Prim.Array as A-import qualified Streamly.Prelude as S--import Gauge----------------------------------------------------------------------------------------------------------------------------------------------------------------------{-# INLINE benchIO #-}-benchIO :: NFData b => String -> (Int -> IO a) -> (a -> b) -> Benchmark-benchIO name src f = bench name $ nfIO $-    randomRIO (1,1) >>= src >>= return . f---- Drain a source that generates an array in the IO monad-{-# INLINE benchIOSrc #-}-benchIOSrc :: A.Prim a => String -> (Int -> IO (Ops.Stream a)) -> Benchmark-benchIOSrc name src = benchIO name src id--{-# INLINE benchPureSink #-}-benchPureSink :: NFData b => String -> (Ops.Stream Int -> b) -> Benchmark-benchPureSink name f = benchIO name Ops.sourceIntFromTo f--{-# INLINE benchIO' #-}-benchIO' :: NFData b => String -> (Int -> IO a) -> (a -> IO b) -> Benchmark-benchIO' name src f = bench name $ nfIO $-    randomRIO (1,1) >>= src >>= f--{-# INLINE benchIOSink #-}-benchIOSink :: NFData b => String -> (Ops.Stream Int -> IO b) -> Benchmark-benchIOSink name f = benchIO' name Ops.sourceIntFromTo f--{--mkString :: String-mkString = "[1" ++ concat (replicate Ops.value ",1") ++ "]"--}--main :: IO ()-main =-  defaultMain-    [ bgroup "Data.Prim.Array"-     [  bgroup "generation"-        [ benchIOSrc "writeN . intFromTo" Ops.sourceIntFromTo-        , benchIOSrc "write . intFromTo" Ops.sourceIntFromToFromStream-        , benchIOSrc "fromList . intFromTo" Ops.sourceIntFromToFromList-        , benchIOSrc "writeN . unfoldr" Ops.sourceUnfoldr-        , benchIOSrc "writeN . fromList" Ops.sourceFromList-        -- , benchPureSrc "writeN . IsList.fromList" Ops.sourceIsList-        -- , benchPureSrc "writeN . IsString.fromString" Ops.sourceIsString-        -- , mkString `deepseq` (bench "read" $ nf Ops.readInstance mkString)-        , benchPureSink "show" Ops.showInstance-        ]-      , bgroup "elimination"-        [ benchPureSink "id" id-        , benchPureSink "==" Ops.eqInstance-        , benchPureSink "/=" Ops.eqInstanceNotEq-        , benchPureSink "<" Ops.ordInstance-        , benchPureSink "min" Ops.ordInstanceMin-        -- length is used to check for foldr/build fusion-        -- , benchPureSink "length . IsList.toList" (length . GHC.toList)-        , benchIOSink "foldl'" Ops.pureFoldl'-        , benchIOSink "read" (S.drain . S.unfold A.read)-        , benchIOSink "toStreamRev" (S.drain . A.toStreamRev)-#if 0-        -- PrimArray does not have a Foldable instance because it requires a-        -- Prim constraint. Though it should be possible to make an instance in-        -- the same way as we do in Memory.Array.-        , benchPureSink "foldable/foldl'" Ops.foldableFoldl'-        , benchPureSink "foldable/sum" Ops.foldableSum-#endif-        ]-      , bgroup "transformation"-        [ benchIOSink "scanl'" (Ops.scanl' 1)-        , benchIOSink "scanl1'" (Ops.scanl1' 1)-        , benchIOSink "map" (Ops.map 1)-        ]-      , bgroup "transformationX4"-        [ benchIOSink "scanl'" (Ops.scanl' 4)-        , benchIOSink "scanl1'" (Ops.scanl1' 4)-        , benchIOSink "map" (Ops.map 4)-        ]-    ]-    ]
− benchmark/Streamly/Benchmark/Data/Prim/ArrayOps.hs 
@@ -1,153 +0,0 @@--- |--- Module      : Streamly.Benchmark.Data.Prim.ArrayOps--- Copyright   : (c) 2019 Composewell Technologies------ License     : BSD-3-Clause--- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC--{-# LANGUAGE CPP                 #-}-{-# LANGUAGE DeriveAnyClass      #-}-{-# LANGUAGE DeriveGeneric       #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Streamly.Benchmark.Data.Prim.ArrayOps where--import Control.Monad.IO.Class (MonadIO)-import Prelude (Int, Bool, (+), ($), (==), (>), (.), Maybe(..), undefined)-import qualified Prelude as P-#ifdef DEVBUILD--- import qualified Data.Foldable as F-#endif--import qualified Streamly           as S hiding (foldMapWith, runStream)-import qualified Streamly.Internal.Data.Prim.Array as A-import qualified Streamly.Prelude   as S--value :: Int-value = 100000------------------------------------------------------------------------------------ Benchmark ops-------------------------------------------------------------------------------------------------------------------------------------------------------------------- Stream generation and elimination----------------------------------------------------------------------------------type Stream = A.PrimArray--{-# INLINE sourceUnfoldr #-}-sourceUnfoldr :: MonadIO m => Int -> m (Stream Int)-sourceUnfoldr n = S.fold (A.writeN value) $ S.unfoldr step n-    where-    step cnt =-        if cnt > n + value-        then Nothing-        else (Just (cnt, cnt + 1))--{-# INLINE sourceIntFromTo #-}-sourceIntFromTo :: MonadIO m => Int -> m (Stream Int)-sourceIntFromTo n = S.fold (A.writeN value) $ S.enumerateFromTo n (n + value)--{-# INLINE sourceIntFromToFromStream #-}-sourceIntFromToFromStream :: MonadIO m => Int -> m (Stream Int)-sourceIntFromToFromStream n = S.fold A.write $ S.enumerateFromTo n (n + value)--{-# INLINE sourceIntFromToFromList #-}-sourceIntFromToFromList :: MonadIO m => Int -> m (Stream Int)-sourceIntFromToFromList n = P.return $ A.fromList $ [n..n + value]--{-# INLINE sourceFromList #-}-sourceFromList :: MonadIO m => Int -> m (Stream Int)-sourceFromList n = S.fold (A.writeN value) $ S.fromList [n..n+value]-{--{-# INLINE sourceIsList #-}-sourceIsList :: Int -> Stream Int-sourceIsList n = GHC.fromList [n..n+value]--{-# INLINE sourceIsString #-}-sourceIsString :: Int -> Stream P.Char-sourceIsString n = GHC.fromString (P.replicate (n + value) 'a')--}----------------------------------------------------------------------------------- Transformation----------------------------------------------------------------------------------{-# INLINE composeN #-}-composeN :: P.Monad m-    => Int -> (Stream Int -> m (Stream Int)) -> Stream Int -> m (Stream Int)-composeN n f x =-    case n of-        1 -> f x-        2 -> f x P.>>= f-        3 -> f x P.>>= f P.>>= f-        4 -> f x P.>>= f P.>>= f P.>>= f-        _ -> undefined--{-# INLINE scanl' #-}-{-# INLINE scanl1' #-}-{-# INLINE map #-}--scanl', scanl1', map-    :: MonadIO m => Int -> Stream Int -> m (Stream Int)--{-# INLINE onArray #-}-onArray-    :: MonadIO m => (S.SerialT m Int -> S.SerialT m Int)-    -> Stream Int-    -> m (Stream Int)-onArray f arr = S.fold (A.writeN value) $ f $ (S.unfold A.read arr)--scanl'        n = composeN n $ onArray $ S.scanl' (+) 0-scanl1'       n = composeN n $ onArray $ S.scanl1' (+)-map           n = composeN n $ onArray $ S.map (+1)--{-# INLINE eqInstance #-}-eqInstance :: Stream Int -> Bool-eqInstance src = src == src--{-# INLINE eqInstanceNotEq #-}-eqInstanceNotEq :: Stream Int -> Bool-eqInstanceNotEq src = src P./= src--{-# INLINE ordInstance #-}-ordInstance :: Stream Int -> Bool-ordInstance src = src P.< src--{-# INLINE ordInstanceMin #-}-ordInstanceMin :: Stream Int -> Stream Int-ordInstanceMin src = P.min src src--{-# INLINE showInstance #-}-showInstance :: Stream Int -> P.String-showInstance src = P.show src--{--{-# INLINE readInstance #-}-readInstance :: P.String -> Stream Int-readInstance str =-    let r = P.reads str-    in case r of-        [(x,"")] -> x-        _ -> P.error "readInstance: no parse"--}--{-# INLINE pureFoldl' #-}-pureFoldl' :: MonadIO m => Stream Int -> m Int-pureFoldl' = S.foldl' (+) 0 . S.unfold A.read--#if 0--- PrimArray does not have a Foldable instance because it reuqires a Prim--- constraint. Though it should be possible to make an instance in the same way--- as we do in Memory.Array.-{-# INLINE foldableFoldl' #-}-foldableFoldl' :: Stream Int -> Int-foldableFoldl' = F.foldl' (+) 0--{-# INLINE foldableSum #-}-foldableSum :: Stream Int -> Int-foldableSum = P.sum-#endif
− benchmark/Streamly/Benchmark/Data/SmallArray.hs 
@@ -1,95 +0,0 @@--- |--- Module      : Main--- Copyright   : (c) 2019 Composewell Technologies------ License     : BSD-3-Clause--- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC--{-# LANGUAGE CPP #-}--module Main (main) where--import Control.DeepSeq (NFData(..), deepseq)-import System.Random (randomRIO)--import qualified Streamly.Benchmark.Data.SmallArrayOps as Ops-import qualified Streamly.Internal.Data.SmallArray as A-import qualified Streamly.Prelude as S--import Gauge----------------------------------------------------------------------------------------------------------------------------------------------------------------------{-# INLINE benchIO #-}-benchIO :: NFData b => String -> (Int -> IO a) -> (a -> b) -> Benchmark-benchIO name src f = bench name $ nfIO $-    randomRIO (1,1) >>= src >>= return . f---- Drain a source that generates an array in the IO monad-{-# INLINE benchIOSrc #-}-benchIOSrc :: (NFData a)-    => String -> (Int -> IO (Ops.Stream a)) -> Benchmark-benchIOSrc name src = benchIO name src id--{-# INLINE benchPureSink #-}-benchPureSink :: NFData b => String -> (Ops.Stream Int -> b) -> Benchmark-benchPureSink name f = benchIO name Ops.sourceIntFromTo f--{-# INLINE benchIO' #-}-benchIO' :: NFData b => String -> (Int -> IO a) -> (a -> IO b) -> Benchmark-benchIO' name src f = bench name $ nfIO $-    randomRIO (1,1) >>= src >>= f--{-# INLINE benchIOSink #-}-benchIOSink :: NFData b => String -> (Ops.Stream Int -> IO b) -> Benchmark-benchIOSink name f = benchIO' name Ops.sourceIntFromTo f--mkString :: String-mkString =-    "fromListN " ++-    show (Ops.value + 1) ++ " [1" ++ concat (replicate Ops.value ",1") ++ "]"--main :: IO ()-main =-  defaultMain-    [ bgroup "SmallArray"-     [  bgroup "generation"-        [ benchIOSrc "writeN . intFromTo" Ops.sourceIntFromTo-        , benchIOSrc "fromList . intFromTo" Ops.sourceIntFromToFromList-        , benchIOSrc "writeN . unfoldr" Ops.sourceUnfoldr-        , benchIOSrc "writeN . fromList" Ops.sourceFromList-        , mkString `deepseq` (bench "read" $ nf Ops.readInstance mkString)-        , benchPureSink "show" Ops.showInstance-        ]-      , bgroup "elimination"-        [ benchPureSink "id" id-        , benchPureSink "==" Ops.eqInstance-        , benchPureSink "/=" Ops.eqInstanceNotEq-        , benchPureSink "<" Ops.ordInstance-        , benchPureSink "min" Ops.ordInstanceMin-        -- length is used to check for foldr/build fusion-        -- , benchPureSink "length . IsList.toList" (length . GHC.toList)-        , benchIOSink "foldl'" Ops.pureFoldl'-        , benchIOSink "read" (S.drain . S.unfold A.read)-        , benchIOSink "toStreamRev" (S.drain . A.toStreamRev)-#ifdef DEVBUILD-        , benchPureSink "foldable/foldl'" Ops.foldableFoldl'-        , benchPureSink "foldable/sum" Ops.foldableSum-#endif-        ]-      , bgroup "transformation"-        [ benchIOSink "scanl'" (Ops.scanl' 1)-        , benchIOSink "scanl1'" (Ops.scanl1' 1)-        , benchIOSink "map" (Ops.map 1)-        ]-      , bgroup "transformationX4"-        [ benchIOSink "scanl'" (Ops.scanl' 4)-        , benchIOSink "scanl1'" (Ops.scanl1' 4)-        , benchIOSink "map" (Ops.map 4)-        ]-    ]-    ]
− benchmark/Streamly/Benchmark/Data/SmallArrayOps.hs 
@@ -1,136 +0,0 @@--- |--- Module      : Streamly.Benchmark.Data.SmallArrayOps--- Copyright   : (c) 2019 Composewell Technologies------ License     : BSD-3-Clause--- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC--{-# LANGUAGE CPP                 #-}-{-# LANGUAGE DeriveAnyClass      #-}-{-# LANGUAGE DeriveGeneric       #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Streamly.Benchmark.Data.SmallArrayOps where--import Control.Monad.IO.Class (MonadIO)-import Prelude (Int, Bool, (+), ($), (==), (>), (.), Maybe(..), undefined)-import qualified Prelude as P-#ifdef DEVBUILD-import qualified Data.Foldable as F-#endif--import qualified Streamly           as S hiding (foldMapWith, runStream)-import qualified Streamly.Internal.Data.SmallArray as A-import qualified Streamly.Prelude   as S--value :: Int-value = 128------------------------------------------------------------------------------------ Benchmark ops-------------------------------------------------------------------------------------------------------------------------------------------------------------------- Stream generation and elimination----------------------------------------------------------------------------------type Stream = A.SmallArray--{-# INLINE sourceUnfoldr #-}-sourceUnfoldr :: MonadIO m => Int -> m (Stream Int)-sourceUnfoldr n = S.fold (A.writeN value) $ S.unfoldr step n-    where-    step cnt =-        if cnt > n + value-        then Nothing-        else (Just (cnt, cnt + 1))--{-# INLINE sourceIntFromTo #-}-sourceIntFromTo :: MonadIO m => Int -> m (Stream Int)-sourceIntFromTo n = S.fold (A.writeN value) $ S.enumerateFromTo n (n + value)--{-# INLINE sourceIntFromToFromList #-}-sourceIntFromToFromList :: MonadIO m => Int -> m (Stream Int)-sourceIntFromToFromList n = P.return $ (A.fromListN value) $ [n..n + value]--{-# INLINE sourceFromList #-}-sourceFromList :: MonadIO m => Int -> m (Stream Int)-sourceFromList n = S.fold (A.writeN value) $ S.fromList [n..n+value]------------------------------------------------------------------------------------ Transformation----------------------------------------------------------------------------------{-# INLINE composeN #-}-composeN :: P.Monad m-    => Int -> (Stream Int -> m (Stream Int)) -> Stream Int -> m (Stream Int)-composeN n f x =-    case n of-        1 -> f x-        2 -> f x P.>>= f-        3 -> f x P.>>= f P.>>= f-        4 -> f x P.>>= f P.>>= f P.>>= f-        _ -> undefined--{-# INLINE scanl' #-}-{-# INLINE scanl1' #-}-{-# INLINE map #-}--scanl', scanl1', map-    :: MonadIO m => Int -> Stream Int -> m (Stream Int)--{-# INLINE onArray #-}-onArray-    :: MonadIO m => (S.SerialT m Int -> S.SerialT m Int)-    -> Stream Int-    -> m (Stream Int)-onArray f arr = S.fold (A.writeN value) $ f $ (S.unfold A.read arr)--scanl'        n = composeN n $ onArray $ S.scanl' (+) 0-scanl1'       n = composeN n $ onArray $ S.scanl1' (+)-map           n = composeN n $ onArray $ S.map (+1)--{-# INLINE eqInstance #-}-eqInstance :: Stream Int -> Bool-eqInstance src = src == src--{-# INLINE eqInstanceNotEq #-}-eqInstanceNotEq :: Stream Int -> Bool-eqInstanceNotEq src = src P./= src--{-# INLINE ordInstance #-}-ordInstance :: Stream Int -> Bool-ordInstance src = src P.< src--{-# INLINE ordInstanceMin #-}-ordInstanceMin :: Stream Int -> Stream Int-ordInstanceMin src = P.min src src--{-# INLINE showInstance #-}-showInstance :: Stream Int -> P.String-showInstance src = P.show src--{-# INLINE readInstance #-}-readInstance :: P.String -> Stream Int-readInstance str =-    let r = P.reads str-    in case r of-        [(x,"")] -> x-        _ -> P.error "readInstance: no parse"--{-# INLINE pureFoldl' #-}-pureFoldl' :: MonadIO m => Stream Int -> m Int-pureFoldl' = S.foldl' (+) 0 . S.unfold A.read--#ifdef DEVBUILD-{-# INLINE foldableFoldl' #-}-foldableFoldl' :: Stream Int -> Int-foldableFoldl' = F.foldl' (+) 0--{-# INLINE foldableSum #-}-foldableSum :: Stream Int -> Int-foldableSum = P.sum-#endif
− benchmark/Streamly/Benchmark/Data/Stream/BaseStreams.hs 
@@ -1,40 +0,0 @@--- |--- Module      : Main--- Copyright   : (c) 2018 Harendra Kumar------ License     : BSD3--- Maintainer  : streamly@composewell.com--{-# LANGUAGE CPP #-}--import qualified Streamly.Benchmark.Data.Stream.StreamK as K--#if !defined(O_N_HEAP)-import qualified Streamly.Benchmark.Data.Stream.StreamD as D-#endif--#ifdef O_1_SPACE-import qualified Streamly.Benchmark.Data.Stream.StreamDK as DK-#endif--import Gauge--main :: IO ()-main =-  defaultMain $-#ifdef O_1_SPACE-       D.o_1_space-    ++ K.o_1_space_list-    ++ K.o_1_space-    ++ DK.o_1_space-#elif defined(O_N_HEAP)-       K.o_n_heap-#elif defined(O_N_STACK)-       D.o_n_stack-    ++ K.o_n_stack-#elif defined(O_N_SPACE)-       D.o_n_space-    ++ K.o_n_space-#else-#error "One of O_1_SPACE/O_N_HEAP/O_N_STACK/O_N_SPACE must be defined"-#endif
benchmark/Streamly/Benchmark/Data/Stream/StreamD.hs view
@@ -1,37 +1,41 @@ -- | -- Module      : Streamly.Benchmark.Data.Stream.StreamD--- Copyright   : (c) 2018 Harendra Kumar+-- Copyright   : (c) 2018 Composewell Technologies -- -- License     : BSD3 -- Maintainer  : streamly@composewell.com +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -module Streamly.Benchmark.Data.Stream.StreamD-    (-      o_1_space-    , o_n_stack-    , o_n_space-    )-where+#ifdef __HADDOCK_VERSION__+#undef INSPECTION+#endif +#ifdef INSPECTION+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}+#endif++module Main (main) where+ import Control.Monad (when) import Data.Maybe (isJust)-import Prelude-        (Monad, Int, (+), ($), (.), return, (>), even, (<=), div,-         subtract, undefined, Maybe(..), not, (>>=),-         maxBound, fmap, odd, (==), flip, (<$>), (<*>), round, (/), (**), (<))+import Gauge (bench, nfIO, bgroup, Benchmark, defaultMain) import System.Random (randomRIO)+import Prelude hiding (tail, mapM_, foldl, last, map, mapM, concatMap, zip)  import qualified Prelude as P- import qualified Streamly.Internal.Data.Stream.StreamD as S import qualified Streamly.Internal.Data.Unfold as UF -import Streamly.Benchmark.Common (benchFold)-import Gauge (bench, nfIO, bgroup, Benchmark)+import Streamly.Benchmark.Common +#ifdef INSPECTION+import GHC.Types (SPEC(..))+import Test.Inspection+#endif  -- We try to keep the total number of iterations same irrespective of nesting -- of the loops so that the overhead is easy to compare.@@ -185,12 +189,11 @@ {-# INLINE dropWhileFalse #-} {-# INLINE _foldrS #-} {-# INLINE _foldlS #-}-{-# INLINE concatMap #-} {-# INLINE intersperse #-} scan, map, fmapD, mapM, mapMaybe, mapMaybeM, filterEven, filterAllOut,     filterAllIn, _takeOne, takeAll, takeWhileTrue, _takeWhileMTrue, dropOne,     dropAll, dropWhileTrue, _dropWhileMTrue, dropWhileFalse, _foldrS, _foldlS,-    concatMap, intersperse+    intersperse     :: Monad m     => Int -> Stream m Int -> m () @@ -216,7 +219,6 @@ dropWhileFalse n = composeN n $ S.dropWhile (> maxValue) _foldrS        n = composeN n $ S.foldrS S.cons S.nil _foldlS         n = composeN n $ S.foldlS (flip S.cons) S.nil-concatMap      n = composeN n $ (\s -> S.concatMap (\_ -> s) s) intersperse    n = composeN n $ S.intersperse maxValue  -------------------------------------------------------------------------------@@ -264,7 +266,7 @@ iterateM i = S.take maxIters (S.iterateM (\x -> return (x + 1)) (return i))  ---------------------------------------------------------------------------------- Zipping and concat+-- Zipping -------------------------------------------------------------------------------  {-# INLINE eqBy #-}@@ -279,14 +281,6 @@ zip :: Monad m => Stream m Int -> m () zip src = transform $ S.zipWith (,) src src -{-# INLINE concatMapRepl4xN #-}-concatMapRepl4xN :: Monad m => Stream m Int -> m ()-concatMapRepl4xN src = transform $ (S.concatMap (S.replicate 4) src)--{-# INLINE concatMapURepl4xN #-}-concatMapURepl4xN :: Monad m => Stream m Int -> m ()-concatMapURepl4xN src = transform $ S.concatMapU (UF.replicateM 4) src- ------------------------------------------------------------------------------- -- Mixed Composition -------------------------------------------------------------------------------@@ -365,12 +359,75 @@     else S.nil  -------------------------------------------------------------------------------+-- ConcatMap+-------------------------------------------------------------------------------++-- concatMap unfoldrM/unfoldrM++{-# INLINE concatMap #-}+concatMap :: Int -> Int -> Int -> IO ()+concatMap outer inner n =+    S.drain $ S.concatMap+        (\_ -> sourceUnfoldrMN inner n)+        (sourceUnfoldrMN outer n)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'concatMap+inspect $ 'concatMap `hasNoType` ''SPEC+#endif++-- concatMap unfoldr/unfoldr++{-# INLINE concatMapPure #-}+concatMapPure :: Int -> Int -> Int -> IO ()+concatMapPure outer inner n =+    S.drain $ S.concatMap+        (\_ -> sourceUnfoldrN inner n)+        (sourceUnfoldrN outer n)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'concatMapPure+inspect $ 'concatMapPure `hasNoType` ''SPEC+#endif++-- concatMap replicate/unfoldrM++{-# INLINE concatMapRepl #-}+concatMapRepl :: Int -> Int -> Int -> IO ()+concatMapRepl outer inner n =+    S.drain $ S.concatMap (S.replicate inner) (sourceUnfoldrMN outer n)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'concatMapRepl+inspect $ 'concatMapRepl `hasNoType` ''SPEC+#endif++-- unfoldMany replicate/unfoldrM++{-# INLINE unfoldManyRepl #-}+unfoldManyRepl :: Int -> Int -> Int -> IO ()+unfoldManyRepl outer inner n =+    S.drain+         $ S.unfoldMany+               (UF.lmap return (UF.replicateM inner))+               (sourceUnfoldrMN outer n)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'unfoldManyRepl+inspect $ 'unfoldManyRepl `hasNoType` ''S.ConcatMapUState+inspect $ 'unfoldManyRepl `hasNoType` ''SPEC+#endif++------------------------------------------------------------------------------- -- Benchmarks ------------------------------------------------------------------------------- +moduleName :: String+moduleName = "Data.Stream.StreamD"+ o_1_space :: [Benchmark] o_1_space =-    [ bgroup "streamD"+    [ bgroup (o_1_space_prefix moduleName)       [ bgroup "generation"         [ benchFold "unfoldr"      toNull sourceUnfoldr         , benchFold "unfoldrM"     toNull sourceUnfoldrM@@ -404,12 +461,6 @@         , benchFold "mapM"      (mapM      1) sourceUnfoldrM         , benchFold "mapMaybe"  (mapMaybe  1) sourceUnfoldrM         , benchFold "mapMaybeM" (mapMaybeM 1) sourceUnfoldrM-        , benchFold "concatMapNxN" (concatMap 1) (sourceUnfoldrMN value2)-        , benchFold "concatMapRepl4xN" concatMapRepl4xN-            (sourceUnfoldrMN (value `div` 4))-        , benchFold "concatMapPureNxN" (concatMap 1) (sourceUnfoldrN value2)-        , benchFold "concatMapURepl4xN" concatMapURepl4xN-            (sourceUnfoldrMN (value `div` 4))         ]       , bgroup "transformationX4"         [ benchFold "scan"      (scan      4) sourceUnfoldrM@@ -421,6 +472,28 @@         -- XXX this is horribly slow         -- , benchFold "concatMap" (concatMap 4) (sourceUnfoldrMN value16)         ]++      , bgroup "concat"+        [ benchIOSrc1 "concatMapPure (n of 1)"+            (concatMapPure value 1)+        , benchIOSrc1 "concatMapPure (sqrt n of sqrt n)"+            (concatMapPure value2 value2)+        , benchIOSrc1 "concatMapPure (1 of n)"+            (concatMapPure 1 value)++        , benchIOSrc1 "concatMap (n of 1)"+            (concatMap value 1)+        , benchIOSrc1 "concatMap (sqrt n of sqrt n)"+            (concatMap value2 value2)+        , benchIOSrc1 "concatMap (1 of n)"+            (concatMap 1 value)++        -- concatMap vs unfoldMany+        , benchIOSrc1 "concatMapRepl (sqrt n of sqrt n)"+            (concatMapRepl value2 value2)+        , benchIOSrc1 "unfoldManyRepl (sqrt n of sqrt n)"+            (unfoldManyRepl value2 value2)+        ]       , bgroup "filtering"         [ benchFold "filter-even"     (filterEven     1) sourceUnfoldrM         , benchFold "filter-all-out"  (filterAllOut   1) sourceUnfoldrM@@ -494,7 +567,7 @@  o_n_stack :: [Benchmark] o_n_stack =-    [ bgroup "streamD"+    [ bgroup (o_n_stack_prefix moduleName)       [ bgroup "elimination"         [ benchFold "tail"   tail     sourceUnfoldrM         , benchFold "nullTail" nullTail sourceUnfoldrM@@ -527,7 +600,7 @@  o_n_space :: [Benchmark] o_n_space =-    [ bgroup "streamD"+    [ bgroup (o_n_space_prefix moduleName)       [ bgroup "elimination"         [ benchFold "toList" toList   sourceUnfoldrM         ]@@ -539,3 +612,6 @@         ]       ]     ]++main :: IO ()+main = defaultMain $ concat [o_1_space, o_n_stack, o_n_space]
benchmark/Streamly/Benchmark/Data/Stream/StreamDK.hs view
@@ -1,6 +1,6 @@ -- | -- Module      : Streamly.Benchmark.Data.Stream.StreamDK--- Copyright   : (c) 2018 Harendra Kumar+-- Copyright   : (c) 2018 Composewell Technologies -- -- License     : BSD3 -- Maintainer  : streamly@composewell.com@@ -8,16 +8,11 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -module Streamly.Benchmark.Data.Stream.StreamDK-    (-      o_1_space-    )-where+module Main (main) where  -- import Control.Monad (when) -- import Data.Maybe (isJust)-import Prelude-       (Monad, Int, (+), return, Maybe(..), (>))+import Prelude hiding () -- import qualified Prelude as P -- import qualified Data.List as List @@ -25,8 +20,8 @@ -- import qualified Streamly.Internal.Data.Stream.Prelude as SP -- import qualified Streamly.Internal.Data.SVar as S -import Streamly.Benchmark.Common (benchFold)-import Gauge (bgroup, Benchmark)+import Streamly.Benchmark.Common+import Gauge (bgroup, Benchmark, defaultMain)  value :: Int value = 100000@@ -109,11 +104,11 @@ {- {-# INLINE sourceFoldMapWith #-} sourceFoldMapWith :: Int -> Stream m Int-sourceFoldMapWith n = SP.foldMapWith S.serial S.yield [n..n+value]+sourceFoldMapWith n = SP.foldMapWith S.serial S.fromPure [n..n+value]  {-# INLINE sourceFoldMapWithM #-} sourceFoldMapWithM :: Monad m => Int -> Stream m Int-sourceFoldMapWithM n = SP.foldMapWith S.serial (S.yieldM . return) [n..n+value]+sourceFoldMapWithM n = SP.foldMapWith S.serial (S.fromEffect . return) [n..n+value] -}  -------------------------------------------------------------------------------@@ -437,9 +432,12 @@ -- Benchmarks ------------------------------------------------------------------------------- +moduleName :: String+moduleName = "Data.Stream.StreamDK"+ o_1_space :: [Benchmark] o_1_space =-    [ bgroup "streamDK"+    [ bgroup (o_1_space_prefix moduleName)       [ bgroup "generation"         [ benchFold "unfoldr"       toNull sourceUnfoldr         , benchFold "unfoldrM"      toNull sourceUnfoldrM@@ -450,3 +448,6 @@         ]       ]     ]++main :: IO ()+main = defaultMain $ concat [o_1_space]
benchmark/Streamly/Benchmark/Data/Stream/StreamK.hs view
@@ -1,140 +1,200 @@ -- | -- Module      : Streamly.Benchmark.Data.Stream.StreamK--- Copyright   : (c) 2018 Harendra Kumar+-- Copyright   : (c) 2018 Composewell Technologies -- -- License     : BSD3 -- Maintainer  : streamly@composewell.com +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -module Streamly.Benchmark.Data.Stream.StreamK-    (-      o_1_space-    , o_n_stack-    , o_n_heap-    , o_n_space-    , o_1_space_list-    )-where+#ifdef __HADDOCK_VERSION__+#undef INSPECTION+#endif +#ifdef INSPECTION+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}+#endif++module Main (main) where+ import Control.Monad (when) import Data.Maybe (isJust)-import Prelude-       (Monad, Int, (+), ($), (.), return, even, (>), (<=), div,-        subtract, undefined, Maybe(..), not, (>>=),-        maxBound, flip, (<$>), (<*>), round, (/), (**), (<), foldr, fmap) import System.Random (randomRIO)+import Prelude hiding+    ( tail, mapM_, foldl, last, map, mapM, concatMap, zipWith, init, iterate+    , repeat, replicate+    )+ import qualified Prelude as P import qualified Data.List as List  import qualified Streamly.Internal.Data.Stream.StreamK as S-import qualified Streamly.Internal.Data.Stream.Prelude as SP import qualified Streamly.Internal.Data.SVar as S -import Streamly.Benchmark.Common (benchFold)-import Gauge (bench, nfIO, bgroup, Benchmark)+import Gauge (bench, nfIO, bgroup, Benchmark, defaultMain) -value, value2, value3, value16, maxValue :: Int-value = 100000-value2 = round (P.fromIntegral value**(1/2::P.Double)) -- double nested loop-value3 = round (P.fromIntegral value**(1/3::P.Double)) -- triple nested loop-value16 = round (P.fromIntegral value**(1/16::P.Double)) -- triple nested loop-maxValue = value+import Streamly.Benchmark.Common ----------------------------------------------------------------------------------- Benchmark ops--------------------------------------------------------------------------------+#ifdef INSPECTION+import Test.Inspection+#endif -{-# INLINE toNull #-}-{-# INLINE uncons #-}-{-# INLINE nullTail #-}-{-# INLINE headTail #-}-{-# INLINE zip #-}-toNull, uncons, nullTail, headTail, zip-    :: Monad m-    => Stream m Int -> m ()+{- -{-# INLINE toList #-}-toList :: Monad m => Stream m Int -> m [Int]-{-# INLINE foldl #-}-foldl :: Monad m => Stream m Int -> m Int-{-# INLINE last #-}-last :: Monad m => Stream m Int -> m (Maybe Int)+Benchmarks that need to be added +-- fromList++-- bindWith+-- concatPairsWith+-- apWith+-- apSerial+-- apSerialDiscardFst+-- apSerialDiscardSnd++-- the+-- serial+-- consMStream+-- withLocal+-- mfix++-- elem+-- notElem+-- all+-- any+-- minimum+-- minimumBy+-- maximum+-- maximumBy+-- findIndices+-- lookup+-- findM+-- find+-- (!!)++-- foldlM'+-- foldlT+-- foldlx'+-- foldlMx'+-- fold++-- sequence++-- foldrSM+-- buildS+-- buildM+-- augmentS+-- augmentSM+-- foldr+-- foldr1+-- foldrM+-- foldrT++-- intersperseM+-- insertBy+-- deleteBy+-- reverse+-- mapMaybe++-- zipWithM+-- mergeBy+-- mergeByM++-- toStreamK (Probably can be skipped)+-- hoist++-- scanlx'++-}+ ------------------------------------------------------------------------------- -- Stream generation and elimination -------------------------------------------------------------------------------  type Stream m a = S.Stream m a -{-# INLINE sourceUnfoldr #-}-sourceUnfoldr :: Int -> Stream m Int-sourceUnfoldr n = S.unfoldr step n-    where-    step cnt =-        if cnt > n + value-        then Nothing-        else Just (cnt, cnt + 1)--{-# INLINE sourceUnfoldrN #-}-sourceUnfoldrN :: Int -> Int -> Stream m Int-sourceUnfoldrN m n = S.unfoldr step n+{-# INLINE unfoldr #-}+unfoldr :: Int -> Int -> Stream m Int+unfoldr streamLen n = S.unfoldr step n     where     step cnt =-        if cnt > n + m+        if cnt > n + streamLen         then Nothing         else Just (cnt, cnt + 1) -{-# INLINE sourceUnfoldrM #-}-sourceUnfoldrM :: S.MonadAsync m => Int -> Stream m Int-sourceUnfoldrM n = S.unfoldrM step n+{-# INLINE unfoldrM #-}+unfoldrM :: S.MonadAsync m => Int -> Int -> Stream m Int+unfoldrM streamLen n = S.unfoldrM step n     where     step cnt =-        if cnt > n + value+        if cnt > n + streamLen         then return Nothing         else return (Just (cnt, cnt + 1)) -{-# INLINE sourceUnfoldrMN #-}-sourceUnfoldrMN :: S.MonadAsync m => Int -> Int -> Stream m Int-sourceUnfoldrMN m n = S.unfoldrM step n-    where-    step cnt =-        if cnt > n + m-        then return Nothing-        else return (Just (cnt, cnt + 1))+{-# INLINE repeat #-}+repeat :: Int -> Int -> Stream m Int+repeat streamLen = S.take streamLen . S.repeat -{-# INLINE sourceFromFoldable #-}-sourceFromFoldable :: Int -> Stream m Int-sourceFromFoldable n = S.fromFoldable [n..n+value]+{-# INLINE repeatM #-}+repeatM :: S.MonadAsync m => Int -> Int -> Stream m Int+repeatM streamLen = S.take streamLen . S.repeatM . return -{-# INLINE sourceFromFoldableM #-}-sourceFromFoldableM :: S.MonadAsync m => Int -> Stream m Int-sourceFromFoldableM n =-    Prelude.foldr S.consM S.nil (Prelude.fmap return [n..n+value])+{-# INLINE replicate #-}+replicate :: Int -> Int -> Stream m Int+replicate = S.replicate -{-# INLINE sourceFoldMapWith #-}-sourceFoldMapWith :: Int -> Stream m Int-sourceFoldMapWith n = SP.foldMapWith S.serial S.yield [n..n+value]+{-# INLINE replicateM #-}+replicateM :: S.MonadAsync m => Int -> Int -> Stream m Int+replicateM streamLen = S.replicateM streamLen . return -{-# INLINE sourceFoldMapWithM #-}-sourceFoldMapWithM :: Monad m => Int -> Stream m Int-sourceFoldMapWithM n = SP.foldMapWith S.serial (S.yieldM . return) [n..n+value]+{-# INLINE iterate #-}+iterate :: Int -> Int -> Stream m Int+iterate streamLen = S.take streamLen . S.iterate (+1) +{-# INLINE iterateM #-}+iterateM :: S.MonadAsync m => Int -> Int -> Stream m Int+iterateM streamLen = S.take streamLen . S.iterateM (return . (+1)) . return++{-# INLINE fromFoldable #-}+fromFoldable :: Int -> Int -> Stream m Int+fromFoldable streamLen n = S.fromFoldable [n..n+streamLen]++{-# INLINE fromFoldableM #-}+fromFoldableM :: S.MonadAsync m => Int -> Int -> Stream m Int+fromFoldableM streamLen n =+    Prelude.foldr S.consM S.nil (Prelude.fmap return [n..n+streamLen])++{-# INLINABLE concatMapFoldableWith #-}+concatMapFoldableWith :: (S.IsStream t, Foldable f)+    => (t m b -> t m b -> t m b) -> (a -> t m b) -> f a -> t m b+concatMapFoldableWith f g = Prelude.foldr (f . g) S.nil++{-# INLINE concatMapFoldableSerial #-}+concatMapFoldableSerial :: Int -> Int -> Stream m Int+concatMapFoldableSerial streamLen n = concatMapFoldableWith S.serial S.fromPure [n..n+streamLen]++{-# INLINE concatMapFoldableSerialM #-}+concatMapFoldableSerialM :: Monad m => Int -> Int -> Stream m Int+concatMapFoldableSerialM streamLen n =+    concatMapFoldableWith S.serial (S.fromEffect . return) [n..n+streamLen]+ ------------------------------------------------------------------------------- -- Elimination ------------------------------------------------------------------------------- -{-# INLINE runStream #-}-runStream :: Monad m => Stream m a -> m ()-runStream = S.drain--- runStream = S.mapM_ (\_ -> return ())+{-# INLINE drain #-}+drain :: Monad m => Stream m a -> m ()+drain = S.drain  {-# INLINE mapM_ #-} mapM_ :: Monad m => Stream m a -> m () mapM_ = S.mapM_ (\_ -> return ()) -toNull = runStream+{-# INLINE uncons #-}+uncons :: Monad m => Stream m Int -> m () uncons s = do     r <- S.uncons s     case r of@@ -151,196 +211,299 @@ tail :: (Monad m, S.IsStream t) => t m a -> m () tail s = S.tail s >>= P.mapM_ tail +{-# INLINE nullTail #-}+nullTail :: Monad m => Stream m Int -> m () nullTail s = do     r <- S.null s     when (not r) $ S.tail s >>= P.mapM_ nullTail +{-# INLINE headTail #-}+headTail :: Monad m => Stream m Int -> m () headTail s = do     h <- S.head s     when (isJust h) $ S.tail s >>= P.mapM_ headTail +{-# INLINE toList #-}+toList :: Monad m => Stream m Int -> m [Int] toList = S.toList-foldl  = S.foldl' (+) 0-last   = S.last +{-# INLINE foldl' #-}+foldl' :: Monad m => Stream m Int -> m Int+foldl' = S.foldl' (+) 0++{-# INLINE last #-}+last :: Monad m => Stream m Int -> m (Maybe Int)+last = S.last+ ------------------------------------------------------------------------------- -- Transformation ------------------------------------------------------------------------------- -{-# INLINE transform #-}-transform :: Monad m => Stream m a -> m ()-transform = runStream- {-# INLINE composeN #-} composeN     :: Monad m     => Int -> (Stream m Int -> Stream m Int) -> Stream m Int -> m () composeN n f =     case n of-        1 -> transform . f-        2 -> transform . f . f-        3 -> transform . f . f . f-        4 -> transform . f . f . f . f+        1 -> drain . f+        2 -> drain . f . f+        3 -> drain . f . f . f+        4 -> drain . f . f . f . f         _ -> undefined -{-# INLINE scan #-}+{-# INLINE scanl' #-}+scanl' :: Monad m => Int -> Stream m Int -> m ()+scanl' n = composeN n $ S.scanl' (+) 0+ {-# INLINE map #-}+map :: Monad m => Int -> Stream m Int -> m ()+map n = composeN n $ S.map (+ 1)+ {-# INLINE fmapK #-}+fmapK :: Monad m => Int -> Stream m Int -> m ()+fmapK n = composeN n $ P.fmap (+ 1)++{-# INLINE mapM #-}+mapM :: S.MonadAsync m => Int -> Stream m Int -> m ()+mapM n = composeN n $ S.mapM return++{-# INLINE mapMSerial #-}+mapMSerial :: S.MonadAsync m => Int -> Stream m Int -> m ()+mapMSerial n = composeN n $ S.mapMSerial return+ {-# INLINE filterEven #-}+filterEven :: Monad m => Int -> Stream m Int -> m ()+filterEven n = composeN n $ S.filter even+ {-# INLINE filterAllOut #-}+filterAllOut :: Monad m => Int -> Int -> Stream m Int -> m ()+filterAllOut streamLen n = composeN n $ S.filter (> streamLen)+ {-# INLINE filterAllIn #-}+filterAllIn :: Monad m => Int -> Int -> Stream m Int -> m ()+filterAllIn streamLen n = composeN n $ S.filter (<= streamLen)+ {-# INLINE _takeOne #-}+_takeOne :: Monad m => Int -> Stream m Int -> m ()+_takeOne n = composeN n $ S.take 1+ {-# INLINE takeAll #-}+takeAll :: Monad m => Int -> Int -> Stream m Int -> m ()+takeAll streamLen n = composeN n $ S.take streamLen+ {-# INLINE takeWhileTrue #-}+takeWhileTrue :: Monad m => Int -> Int -> Stream m Int -> m ()+takeWhileTrue streamLen n = composeN n $ S.takeWhile (<= streamLen)+ {-# INLINE dropOne #-}+dropOne :: Monad m => Int -> Stream m Int -> m ()+dropOne n = composeN n $ S.drop 1+ {-# INLINE dropAll #-}+dropAll :: Monad m => Int -> Int -> Stream m Int -> m ()+dropAll streamLen n = composeN n $ S.drop streamLen+ {-# INLINE dropWhileTrue #-}+dropWhileTrue :: Monad m => Int -> Int -> Stream m Int -> m ()+dropWhileTrue streamLen n = composeN n $ S.dropWhile (<= streamLen)+ {-# INLINE dropWhileFalse #-}+dropWhileFalse :: Monad m => Int -> Stream m Int -> m ()+dropWhileFalse n = composeN n $ S.dropWhile (<= 1)+ {-# INLINE foldrS #-}+foldrS :: Monad m => Int -> Stream m Int -> m ()+foldrS n = composeN n $ S.foldrS S.cons S.nil+ {-# INLINE foldlS #-}-{-# INLINE concatMap #-}-scan, map, fmapK, filterEven, filterAllOut,-    filterAllIn, _takeOne, takeAll, takeWhileTrue, dropAll, dropOne,-    dropWhileTrue, dropWhileFalse, foldrS, foldlS, concatMap-    :: Monad m-    => Int -> Stream m Int -> m ()+foldlS :: Monad m => Int -> Stream m Int -> m ()+foldlS n = composeN n $ S.foldlS (flip S.cons) S.nil -{-# INLINE mapM #-}-{-# INLINE mapMSerial #-} {-# INLINE intersperse #-}-mapM, mapMSerial, intersperse-    :: S.MonadAsync m => Int -> Stream m Int -> m ()--scan           n = composeN n $ S.scanl' (+) 0-map            n = composeN n $ P.fmap (+1)-fmapK          n = composeN n $ P.fmap (+1)-mapM           n = composeN n $ S.mapM return-mapMSerial     n = composeN n $ S.mapMSerial return-filterEven     n = composeN n $ S.filter even-filterAllOut   n = composeN n $ S.filter (> maxValue)-filterAllIn    n = composeN n $ S.filter (<= maxValue)-_takeOne       n = composeN n $ S.take 1-takeAll        n = composeN n $ S.take maxValue-takeWhileTrue  n = composeN n $ S.takeWhile (<= maxValue)-dropOne        n = composeN n $ S.drop 1-dropAll        n = composeN n $ S.drop maxValue-dropWhileTrue  n = composeN n $ S.dropWhile (<= maxValue)-dropWhileFalse n = composeN n $ S.dropWhile (<= 1)-foldrS         n = composeN n $ S.foldrS S.cons S.nil-foldlS         n = composeN n $ S.foldlS (flip S.cons) S.nil--- We use a (sqrt n) element stream as source and then concat the same stream--- for each element to produce an n element stream.-concatMap      n = composeN n $ (\s -> S.concatMap (\_ -> s) s)-intersperse    n = composeN n $ S.intersperse maxValue+intersperse :: S.MonadAsync m => Int -> Int -> Stream m Int -> m ()+intersperse streamLen n = composeN n $ S.intersperse streamLen  ------------------------------------------------------------------------------- -- Iteration ------------------------------------------------------------------------------- -iterStreamLen, maxIters :: Int-iterStreamLen = 10-maxIters = 10000- {-# INLINE iterateSource #-} iterateSource     :: S.MonadAsync m-    => (Stream m Int -> Stream m Int) -> Int -> Int -> Stream m Int-iterateSource g i n = f i (sourceUnfoldrMN iterStreamLen n)+    => Int -> (Stream m Int -> Stream m Int) -> Int -> Int -> Stream m Int+iterateSource iterStreamLen g i n = f i (unfoldrM iterStreamLen n)     where         f (0 :: Int) m = g m         f x m = g (f (x P.- 1) m) -{-# INLINE iterateMapM #-}+-- this is quadratic {-# INLINE iterateScan #-}+iterateScan :: S.MonadAsync m => Int -> Int -> Int -> Stream m Int+iterateScan iterStreamLen maxIters = iterateSource iterStreamLen (S.scanl' (+) 0) (maxIters `div` 10)++-- this is quadratic+{-# INLINE iterateDropWhileFalse #-}+iterateDropWhileFalse :: S.MonadAsync m => Int -> Int -> Int -> Int -> Stream m Int+iterateDropWhileFalse streamLen iterStreamLen maxIters =+    iterateSource iterStreamLen (S.dropWhile (> streamLen)) (maxIters `div` 10)++{-# INLINE iterateMapM #-}+iterateMapM :: S.MonadAsync m => Int -> Int -> Int -> Stream m Int+iterateMapM iterStreamLen maxIters = iterateSource iterStreamLen (S.mapM return) maxIters+ {-# INLINE iterateFilterEven #-}+iterateFilterEven :: S.MonadAsync m => Int -> Int -> Int -> Stream m Int+iterateFilterEven iterStreamLen maxIters = iterateSource iterStreamLen (S.filter even) maxIters+ {-# INLINE iterateTakeAll #-}-{-# INLINE iterateDropOne #-}-{-# INLINE iterateDropWhileFalse #-}-{-# INLINE iterateDropWhileTrue #-}-iterateMapM, iterateScan, iterateFilterEven, iterateTakeAll, iterateDropOne,-    iterateDropWhileFalse, iterateDropWhileTrue-    :: S.MonadAsync m-    => Int -> Stream m Int+iterateTakeAll :: S.MonadAsync m => Int -> Int -> Int -> Int -> Stream m Int+iterateTakeAll streamLen iterStreamLen maxIters = iterateSource iterStreamLen (S.take streamLen) maxIters --- this is quadratic-iterateScan            = iterateSource (S.scanl' (+) 0) (maxIters `div` 10)-iterateDropWhileFalse  = iterateSource (S.dropWhile (> maxValue))-                                       (maxIters `div` 10)+{-# INLINE iterateDropOne #-}+iterateDropOne :: S.MonadAsync m => Int -> Int -> Int -> Stream m Int+iterateDropOne iterStreamLen maxIters = iterateSource iterStreamLen (S.drop 1) maxIters -iterateMapM            = iterateSource (S.mapM return) maxIters-iterateFilterEven      = iterateSource (S.filter even) maxIters-iterateTakeAll         = iterateSource (S.take maxValue) maxIters-iterateDropOne         = iterateSource (S.drop 1) maxIters-iterateDropWhileTrue   = iterateSource (S.dropWhile (<= maxValue)) maxIters+{-# INLINE iterateDropWhileTrue #-}+iterateDropWhileTrue :: S.MonadAsync m => Int -> Int -> Int -> Int -> Stream m Int+iterateDropWhileTrue streamLen iterStreamLen maxIters = iterateSource iterStreamLen (S.dropWhile (<= streamLen)) maxIters  ---------------------------------------------------------------------------------- Zipping and concat+-- Zipping ------------------------------------------------------------------------------- -zip src       = transform $ S.zipWith (,) src src--{-# INLINE concatMapRepl4xN #-}-concatMapRepl4xN :: Monad m => Stream m Int -> m ()-concatMapRepl4xN src = transform $ (S.concatMap (S.replicate 4) src)+{-# INLINE zipWith #-}+zipWith :: Monad m => Stream m Int -> m ()+zipWith src = drain $ S.zipWith (,) src src  ------------------------------------------------------------------------------- -- Mixed Composition -------------------------------------------------------------------------------  {-# INLINE scanMap #-}+scanMap :: Monad m => Int -> Stream m Int -> m ()+scanMap n = composeN n $ S.map (subtract 1) . S.scanl' (+) 0+ {-# INLINE dropMap #-}+dropMap :: Monad m => Int -> Stream m Int -> m ()+dropMap n = composeN n $ S.map (subtract 1) . S.drop 1+ {-# INLINE dropScan #-}+dropScan :: Monad m => Int -> Stream m Int -> m ()+dropScan n = composeN n $ S.scanl' (+) 0 . S.drop 1+ {-# INLINE takeDrop #-}+takeDrop :: Monad m => Int -> Int -> Stream m Int -> m ()+takeDrop streamLen n = composeN n $ S.drop 1 . S.take streamLen+ {-# INLINE takeScan #-}+takeScan :: Monad m => Int -> Int -> Stream m Int -> m ()+takeScan streamLen n = composeN n $ S.scanl' (+) 0 . S.take streamLen+ {-# INLINE takeMap #-}+takeMap :: Monad m => Int -> Int -> Stream m Int -> m ()+takeMap streamLen n = composeN n $ S.map (subtract 1) . S.take streamLen+ {-# INLINE filterDrop #-}+filterDrop :: Monad m => Int -> Int -> Stream m Int -> m ()+filterDrop streamLen n = composeN n $ S.drop 1 . S.filter (<= streamLen)+ {-# INLINE filterTake #-}+filterTake :: Monad m => Int -> Int -> Stream m Int -> m ()+filterTake streamLen n = composeN n $ S.take streamLen . S.filter (<= streamLen)+ {-# INLINE filterScan #-}+filterScan :: Monad m => Int -> Stream m Int -> m ()+filterScan n = composeN n $ S.scanl' (+) 0 . S.filter (<= maxBound)+ {-# INLINE filterMap #-}-scanMap, dropMap, dropScan, takeDrop, takeScan, takeMap, filterDrop,-    filterTake, filterScan, filterMap-    :: Monad m => Int -> Stream m Int -> m ()+filterMap :: Monad m => Int -> Int -> Stream m Int -> m ()+filterMap streamLen n = composeN n $ S.map (subtract 1) . S.filter (<= streamLen) -scanMap    n = composeN n $ S.map (subtract 1) . S.scanl' (+) 0-dropMap    n = composeN n $ S.map (subtract 1) . S.drop 1-dropScan   n = composeN n $ S.scanl' (+) 0 . S.drop 1-takeDrop   n = composeN n $ S.drop 1 . S.take maxValue-takeScan   n = composeN n $ S.scanl' (+) 0 . S.take maxValue-takeMap    n = composeN n $ S.map (subtract 1) . S.take maxValue-filterDrop n = composeN n $ S.drop 1 . S.filter (<= maxValue)-filterTake n = composeN n $ S.take maxValue . S.filter (<= maxValue)-filterScan n = composeN n $ S.scanl' (+) 0 . S.filter (<= maxBound)-filterMap  n = composeN n $ S.map (subtract 1) . S.filter (<= maxValue)+-------------------------------------------------------------------------------+-- ConcatMap+------------------------------------------------------------------------------- +-- concatMap unfoldrM/unfoldrM++{-# INLINE concatMap #-}+concatMap :: Int -> Int -> Int -> IO ()+concatMap outer inner n =+    S.drain $ S.concatMap+        (\_ -> unfoldrM inner n)+        (unfoldrM outer n)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'concatMap+#endif++-- concatMap unfoldr/unfoldr++{-# INLINE concatMapPure #-}+concatMapPure :: Int -> Int -> Int -> IO ()+concatMapPure outer inner n =+    S.drain $ S.concatMap+        (\_ -> unfoldr inner n)+        (unfoldr outer n)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'concatMapPure+#endif++-- concatMap replicate/unfoldrM++{-# INLINE concatMapRepl #-}+concatMapRepl :: Int -> Int -> Int -> IO ()+concatMapRepl outer inner n =+    S.drain $ S.concatMap (S.replicate inner) (unfoldrM outer n)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'concatMapRepl+#endif++-- concatMapWith++{-# INLINE sourceConcatMapId #-}+sourceConcatMapId :: Monad m+    => Int -> Int -> Stream m (Stream m Int)+sourceConcatMapId val n =+    S.fromFoldable $ fmap (S.fromEffect . return) [n..n+val]++{-# INLINE concatMapBySerial #-}+concatMapBySerial :: Int -> Int -> Int -> IO ()+concatMapBySerial outer inner n =+    S.drain $ S.concatMapBy S.serial+        (unfoldrM inner)+        (unfoldrM outer n)+ ------------------------------------------------------------------------------- -- Nested Composition ------------------------------------------------------------------------------- -{-# INLINE toNullApNested #-}-toNullApNested :: Monad m => Stream m Int -> m ()-toNullApNested s = runStream $ do+{-# INLINE drainApplicative #-}+drainApplicative :: Monad m => Stream m Int -> m ()+drainApplicative s = drain $ do     (+) <$> s <*> s -{-# INLINE toNullNested #-}-toNullNested :: Monad m => Stream m Int -> m ()-toNullNested s = runStream $ do+{-# INLINE drainMonad #-}+drainMonad :: Monad m => Stream m Int -> m ()+drainMonad s = drain $ do     x <- s     y <- s     return $ x + y -{-# INLINE toNullNested3 #-}-toNullNested3 :: Monad m => Stream m Int -> m ()-toNullNested3 s = runStream $ do+{-# INLINE drainMonad3 #-}+drainMonad3 :: Monad m => Stream m Int -> m ()+drainMonad3 s = drain $ do     x <- s     y <- s     z <- s     return $ x + y + z -{-# INLINE filterAllOutNested #-}-filterAllOutNested+{-# INLINE filterAllOutMonad #-}+filterAllOutMonad     :: Monad m     => Stream m Int -> m ()-filterAllOutNested str = runStream $ do+filterAllOutMonad str = drain $ do     x <- str     y <- str     let s = x + y@@ -348,11 +511,11 @@     then return s     else S.nil -{-# INLINE filterAllInNested #-}-filterAllInNested+{-# INLINE filterAllInMonad #-}+filterAllInMonad     :: Monad m     => Stream m Int -> m ()-filterAllInNested str = runStream $ do+filterAllInMonad str = drain $ do     x <- str     y <- str     let s = x + y@@ -364,9 +527,14 @@ -- Nested Composition Pure lists ------------------------------------------------------------------------------- -{-# INLINE sourceUnfoldrList #-}-sourceUnfoldrList :: Int -> Int -> [Int]-sourceUnfoldrList maxval n = List.unfoldr step n+-- There are several list benchmarks here for comparison with lists. It is easy+-- and convenient to see the comparisons when they are here, otherwise we'll+-- have to add a separate module for list benchmarks with the same names and+-- then add a comparison in bench.sh.++{-# INLINE unfoldrList #-}+unfoldrList :: Int -> Int -> [Int]+unfoldrList maxval n = List.unfoldr step n     where     step cnt =         if cnt > n + maxval@@ -416,194 +584,298 @@ -- Benchmarks ------------------------------------------------------------------------------- -o_1_space :: [Benchmark]-o_1_space =-    [ bgroup "streamK"-      [ bgroup "generation"-        [ benchFold "unfoldr"       toNull sourceUnfoldr-        , benchFold "unfoldrM"      toNull sourceUnfoldrM+moduleName :: String+moduleName = "Data.Stream.StreamK" -        , benchFold "fromFoldable"  toNull sourceFromFoldable-        , benchFold "fromFoldableM" toNull sourceFromFoldableM+o_1_space_generation :: Int -> Benchmark+o_1_space_generation streamLen =+    bgroup "generation"+        [ benchFold "unfoldr" drain (unfoldr streamLen)+        , benchFold "unfoldrM" drain (unfoldrM streamLen)+        , benchFold "repeat" drain (repeat streamLen)+        , benchFold "repeatM" drain (repeatM streamLen)+        , benchFold "replicate" drain (replicate streamLen)+        , benchFold "replicateM" drain (replicateM streamLen)+        , benchFold "iterate" drain (iterate streamLen)+        , benchFold "iterateM" drain (iterateM streamLen) +        , benchFold "fromFoldable"  drain (fromFoldable streamLen)+        , benchFold "fromFoldableM" drain (fromFoldableM streamLen)+         -- appends-        , benchFold "foldMapWith"  toNull sourceFoldMapWith-        , benchFold "foldMapWithM" toNull sourceFoldMapWithM+        , benchFold "concatMapFoldableWith"  drain (concatMapFoldableSerial streamLen)+        , benchFold "concatMapFoldableWithM" drain (concatMapFoldableSerialM streamLen)         ]-      , bgroup "elimination"-        [ benchFold "toNull"   toNull   sourceUnfoldrM-        , benchFold "mapM_"    mapM_    sourceUnfoldrM-        , benchFold "uncons"   uncons   sourceUnfoldrM-        , benchFold "init"   init     sourceUnfoldrM-        , benchFold "foldl'" foldl    sourceUnfoldrM-        , benchFold "last"   last     sourceUnfoldrM++o_1_space_elimination :: Int -> Benchmark+o_1_space_elimination streamLen =+    bgroup "elimination"+        [ benchFold "toNull"   drain   (unfoldrM streamLen)+        , benchFold "mapM_"    mapM_    (unfoldrM streamLen)+        , benchFold "uncons"   uncons   (unfoldrM streamLen)+        , benchFold "init"   init     (unfoldrM streamLen)+        , benchFold "foldl'" foldl'    (unfoldrM streamLen)+        , benchFold "last"   last     (unfoldrM streamLen)         ]-      , bgroup "nested"-        [ benchFold "toNullAp" toNullApNested (sourceUnfoldrMN value2)-        , benchFold "toNull"   toNullNested   (sourceUnfoldrMN value2)-        , benchFold "toNull3"  toNullNested3  (sourceUnfoldrMN value3)-        , benchFold "filterAllIn"  filterAllInNested  (sourceUnfoldrMN value2)-        , benchFold "filterAllOut" filterAllOutNested (sourceUnfoldrMN value2)-        , benchFold "toNullApPure" toNullApNested (sourceUnfoldrN value2)-        , benchFold "toNullPure"   toNullNested   (sourceUnfoldrN value2)-        , benchFold "toNull3Pure"  toNullNested3  (sourceUnfoldrN value3)-        , benchFold "filterAllInPure"  filterAllInNested  (sourceUnfoldrN value2)-        , benchFold "filterAllOutPure" filterAllOutNested (sourceUnfoldrN value2)++o_1_space_nested :: Int -> Benchmark+o_1_space_nested streamLen =+    bgroup "nested"+        [ benchFold "drainApplicative" drainApplicative (unfoldrM streamLen2)+        , benchFold "drainMonad"   drainMonad   (unfoldrM streamLen2)+        , benchFold "drainMonad3"  drainMonad3  (unfoldrM streamLen3)+        , benchFold "filterAllInMonad"  filterAllInMonad  (unfoldrM streamLen2)+        , benchFold "filterAllOutMonad" filterAllOutMonad (unfoldrM streamLen2)+        , benchFold "drainApplicative (pure)" drainApplicative (unfoldr streamLen2)+        , benchFold "drainMonad (pure)"   drainMonad   (unfoldr streamLen2)+        , benchFold "drainMonad3 (pure)"  drainMonad3  (unfoldr streamLen3)+        , benchFold "filterAllInMonad (pure)"  filterAllInMonad  (unfoldr streamLen2)+        , benchFold "filterAllOutMonad (pure)" filterAllOutMonad (unfoldr streamLen2)         ]-      , bgroup "transformation"-        [ benchFold "foldrS" (foldrS 1) sourceUnfoldrM-        , benchFold "scan"   (scan 1) sourceUnfoldrM-        , benchFold "map"    (map  1) sourceUnfoldrM-        , benchFold "fmap"   (fmapK 1) sourceUnfoldrM-        , benchFold "mapM"   (mapM 1) sourceUnfoldrM-        , benchFold "mapMSerial"  (mapMSerial 1) sourceUnfoldrM-        -- , benchFoldSrcK "concatMap" concatMap-        , benchFold "concatMapNxN" (concatMap 1) (sourceUnfoldrMN value2)-        , benchFold "concatMapPureNxN" (concatMap 1) (sourceUnfoldrN value2)-        , benchFold "concatMapRepl4xN" concatMapRepl4xN-            (sourceUnfoldrMN (value `div` 4))+    where+    streamLen2 = round (P.fromIntegral streamLen**(1/2::P.Double)) -- double nested loop+    streamLen3 = round (P.fromIntegral streamLen**(1/3::P.Double)) -- triple nested loop++o_1_space_transformation :: Int -> Benchmark+o_1_space_transformation streamLen =+    bgroup "transformation"+        [ benchFold "foldrS" (foldrS 1) (unfoldrM streamLen)+        , benchFold "scanl'"   (scanl' 1) (unfoldrM streamLen)+        , benchFold "map"    (map  1) (unfoldrM streamLen)+        , benchFold "fmap"   (fmapK 1) (unfoldrM streamLen)+        , benchFold "mapM"   (mapM 1) (unfoldrM streamLen)+        , benchFold "mapMSerial"  (mapMSerial 1) (unfoldrM streamLen)         ]-      , bgroup "transformationX4"-        [ benchFold "scan"   (scan 4) sourceUnfoldrM-        , benchFold "map"    (map  4) sourceUnfoldrM-        , benchFold "fmap"   (fmapK 4) sourceUnfoldrM-        , benchFold "mapM"   (mapM 4) sourceUnfoldrM-        , benchFold "mapMSerial" (mapMSerial 4) sourceUnfoldrM++o_1_space_transformationX4 :: Int -> Benchmark+o_1_space_transformationX4 streamLen =+    bgroup "transformationX4"+        [ benchFold "scanl'"   (scanl' 4) (unfoldrM streamLen)+        , benchFold "map"    (map  4) (unfoldrM streamLen)+        , benchFold "fmap"   (fmapK 4) (unfoldrM streamLen)+        , benchFold "mapM"   (mapM 4) (unfoldrM streamLen)+        , benchFold "mapMSerial" (mapMSerial 4) (unfoldrM streamLen)         -- XXX this is horribly slow-        -- , benchFold "concatMap" (concatMap 4) (sourceUnfoldrMN value16)+        -- , benchFold "concatMap" (concatMap 4) (unfoldrM streamLen16)         ]-      , bgroup "filtering"-        [ benchFold "filter-even"     (filterEven     1) sourceUnfoldrM-        , benchFold "filter-all-out"  (filterAllOut   1) sourceUnfoldrM-        , benchFold "filter-all-in"   (filterAllIn    1) sourceUnfoldrM-        , benchFold "take-all"        (takeAll        1) sourceUnfoldrM-        , benchFold "takeWhile-true"  (takeWhileTrue  1) sourceUnfoldrM-        , benchFold "drop-one"        (dropOne        1) sourceUnfoldrM-        , benchFold "drop-all"        (dropAll        1) sourceUnfoldrM-        , benchFold "dropWhile-true"  (dropWhileTrue  1) sourceUnfoldrM-        , benchFold "dropWhile-false" (dropWhileFalse 1) sourceUnfoldrM++o_1_space_concat :: Int -> Benchmark+o_1_space_concat streamLen =+    bgroup "concat"+        [ benchIOSrc1 "concatMapPure (n of 1)"+            (concatMapPure streamLen 1)+        , benchIOSrc1 "concatMapPure (sqrt n of sqrt n)"+            (concatMapPure streamLen2 streamLen2)+        , benchIOSrc1 "concatMapPure (1 of n)"+            (concatMapPure 1 streamLen)++        , benchIOSrc1 "concatMap (n of 1)"+            (concatMap streamLen 1)+        , benchIOSrc1 "concatMap (sqrt n of sqrt n)"+            (concatMap streamLen2 streamLen2)+        , benchIOSrc1 "concatMap (1 of n)"+            (concatMap 1 streamLen)++        , benchIOSrc1 "concatMapRepl (sqrt n of sqrt n)"+            (concatMapRepl streamLen2 streamLen2)++        -- This is for comparison with concatMapFoldableWith+        , benchIOSrc1 "concatMapWithId (n of 1) (fromFoldable)"+            (S.drain . S.concatMapBy S.serial id . sourceConcatMapId streamLen)++        , benchIOSrc1 "concatMapBy serial (n of 1)"+            (concatMapBySerial streamLen 1)+        , benchIOSrc1 "concatMapBy serial (sqrt n of sqrt n)"+            (concatMapBySerial streamLen2 streamLen2)+        , benchIOSrc1 "concatMapBy serial (1 of n)"+            (concatMapBySerial 1 streamLen)         ]-      , bgroup "filteringX4"-        [ benchFold "filter-even"     (filterEven     4) sourceUnfoldrM-        , benchFold "filter-all-out"  (filterAllOut   4) sourceUnfoldrM-        , benchFold "filter-all-in"   (filterAllIn    4) sourceUnfoldrM-        , benchFold "take-all"        (takeAll        4) sourceUnfoldrM-        , benchFold "takeWhile-true"  (takeWhileTrue  4) sourceUnfoldrM-        , benchFold "drop-one"        (dropOne        4) sourceUnfoldrM-        , benchFold "drop-all"        (dropAll        4) sourceUnfoldrM-        , benchFold "dropWhile-true"  (dropWhileTrue  4) sourceUnfoldrM-        , benchFold "dropWhile-false" (dropWhileFalse 4) sourceUnfoldrM+    where+    streamLen2 = round (P.fromIntegral streamLen**(1/2::P.Double)) -- double nested loop++o_1_space_filtering :: Int -> Benchmark+o_1_space_filtering streamLen =+    bgroup "filtering"+        [ benchFold "filter-even"     (filterEven     1) (unfoldrM streamLen)+        , benchFold "filter-all-out"  (filterAllOut streamLen   1) (unfoldrM streamLen)+        , benchFold "filter-all-in"   (filterAllIn streamLen    1) (unfoldrM streamLen)+        , benchFold "take-all"        (takeAll streamLen        1) (unfoldrM streamLen)+        , benchFold "takeWhile-true"  (takeWhileTrue streamLen  1) (unfoldrM streamLen)+        , benchFold "drop-one"        (dropOne        1) (unfoldrM streamLen)+        , benchFold "drop-all"        (dropAll streamLen        1) (unfoldrM streamLen)+        , benchFold "dropWhile-true"  (dropWhileTrue streamLen  1) (unfoldrM streamLen)+        , benchFold "dropWhile-false" (dropWhileFalse 1) (unfoldrM streamLen)         ]-      , bgroup "zipping"-        [ benchFold "zip" zip sourceUnfoldrM++o_1_space_filteringX4 :: Int -> Benchmark+o_1_space_filteringX4 streamLen =+    bgroup "filteringX4"+        [ benchFold "filter-even"     (filterEven     4) (unfoldrM streamLen)+        , benchFold "filter-all-out"  (filterAllOut streamLen   4) (unfoldrM streamLen)+        , benchFold "filter-all-in"   (filterAllIn streamLen    4) (unfoldrM streamLen)+        , benchFold "take-all"        (takeAll streamLen        4) (unfoldrM streamLen)+        , benchFold "takeWhile-true"  (takeWhileTrue streamLen  4) (unfoldrM streamLen)+        , benchFold "drop-one"        (dropOne        4) (unfoldrM streamLen)+        , benchFold "drop-all"        (dropAll streamLen        4) (unfoldrM streamLen)+        , benchFold "dropWhile-true"  (dropWhileTrue streamLen  4) (unfoldrM streamLen)+        , benchFold "dropWhile-false" (dropWhileFalse 4) (unfoldrM streamLen)         ]-      , bgroup "mixed"-        [ benchFold "scan-map"    (scanMap    1) sourceUnfoldrM-        , benchFold "drop-map"    (dropMap    1) sourceUnfoldrM-        , benchFold "drop-scan"   (dropScan   1) sourceUnfoldrM-        , benchFold "take-drop"   (takeDrop   1) sourceUnfoldrM-        , benchFold "take-scan"   (takeScan   1) sourceUnfoldrM-        , benchFold "take-map"    (takeMap    1) sourceUnfoldrM-        , benchFold "filter-drop" (filterDrop 1) sourceUnfoldrM-        , benchFold "filter-take" (filterTake 1) sourceUnfoldrM-        , benchFold "filter-scan" (filterScan 1) sourceUnfoldrM-        , benchFold "filter-map"  (filterMap  1) sourceUnfoldrM++o_1_space_zipping :: Int -> Benchmark+o_1_space_zipping streamLen =+    bgroup "zipping"+        [ benchFold "zipWith" zipWith (unfoldrM streamLen)         ]-      , bgroup "mixedX2"-        [ benchFold "scan-map"    (scanMap    2) sourceUnfoldrM-        , benchFold "drop-map"    (dropMap    2) sourceUnfoldrM-        , benchFold "drop-scan"   (dropScan   2) sourceUnfoldrM-        , benchFold "take-drop"   (takeDrop   2) sourceUnfoldrM-        , benchFold "take-scan"   (takeScan   2) sourceUnfoldrM-        , benchFold "take-map"    (takeMap    2) sourceUnfoldrM-        , benchFold "filter-drop" (filterDrop 2) sourceUnfoldrM-        , benchFold "filter-take" (filterTake 2) sourceUnfoldrM-        , benchFold "filter-scan" (filterScan 2) sourceUnfoldrM-        , benchFold "filter-map"  (filterMap  2) sourceUnfoldrM++o_1_space_mixed :: Int -> Benchmark+o_1_space_mixed streamLen =+    bgroup "mixed"+        [ benchFold "scan-map"    (scanMap    1) (unfoldrM streamLen)+        , benchFold "drop-map"    (dropMap    1) (unfoldrM streamLen)+        , benchFold "drop-scan"   (dropScan   1) (unfoldrM streamLen)+        , benchFold "take-drop"   (takeDrop streamLen   1) (unfoldrM streamLen)+        , benchFold "take-scan"   (takeScan streamLen   1) (unfoldrM streamLen)+        , benchFold "take-map"    (takeMap streamLen   1) (unfoldrM streamLen)+        , benchFold "filter-drop" (filterDrop streamLen 1) (unfoldrM streamLen)+        , benchFold "filter-take" (filterTake streamLen 1) (unfoldrM streamLen)+        , benchFold "filter-scan" (filterScan 1) (unfoldrM streamLen)+        , benchFold "filter-map"  (filterMap streamLen 1) (unfoldrM streamLen)         ]-      , bgroup "mixedX4"-        [ benchFold "scan-map"    (scanMap    4) sourceUnfoldrM-        , benchFold "drop-map"    (dropMap    4) sourceUnfoldrM-        , benchFold "drop-scan"   (dropScan   4) sourceUnfoldrM-        , benchFold "take-drop"   (takeDrop   4) sourceUnfoldrM-        , benchFold "take-scan"   (takeScan   4) sourceUnfoldrM-        , benchFold "take-map"    (takeMap    4) sourceUnfoldrM-        , benchFold "filter-drop" (filterDrop 4) sourceUnfoldrM-        , benchFold "filter-take" (filterTake 4) sourceUnfoldrM-        , benchFold "filter-scan" (filterScan 4) sourceUnfoldrM-        , benchFold "filter-map"  (filterMap  4) sourceUnfoldrM++o_1_space_mixedX2 :: Int -> Benchmark+o_1_space_mixedX2 streamLen =+    bgroup "mixedX2"+        [ benchFold "scan-map"    (scanMap    2) (unfoldrM streamLen)+        , benchFold "drop-map"    (dropMap    2) (unfoldrM streamLen)+        , benchFold "drop-scan"   (dropScan   2) (unfoldrM streamLen)+        , benchFold "take-drop"   (takeDrop streamLen   2) (unfoldrM streamLen)+        , benchFold "take-scan"   (takeScan streamLen   2) (unfoldrM streamLen)+        , benchFold "take-map"    (takeMap streamLen   2) (unfoldrM streamLen)+        , benchFold "filter-drop" (filterDrop streamLen 2) (unfoldrM streamLen)+        , benchFold "filter-take" (filterTake streamLen 2) (unfoldrM streamLen)+        , benchFold "filter-scan" (filterScan 2) (unfoldrM streamLen)+        , benchFold "filter-map"  (filterMap streamLen 2) (unfoldrM streamLen)         ]++o_1_space_mixedX4 :: Int -> Benchmark+o_1_space_mixedX4 streamLen =+    bgroup "mixedX4"+        [ benchFold "scan-map"    (scanMap    4) (unfoldrM streamLen)+        , benchFold "drop-map"    (dropMap    4) (unfoldrM streamLen)+        , benchFold "drop-scan"   (dropScan   4) (unfoldrM streamLen)+        , benchFold "take-drop"   (takeDrop streamLen   4) (unfoldrM streamLen)+        , benchFold "take-scan"   (takeScan streamLen   4) (unfoldrM streamLen)+        , benchFold "take-map"    (takeMap streamLen   4) (unfoldrM streamLen)+        , benchFold "filter-drop" (filterDrop streamLen 4) (unfoldrM streamLen)+        , benchFold "filter-take" (filterTake streamLen 4) (unfoldrM streamLen)+        , benchFold "filter-scan" (filterScan 4) (unfoldrM streamLen)+        , benchFold "filter-map"  (filterMap streamLen 4) (unfoldrM streamLen)+        ]++o_1_space_list :: Int -> Benchmark+o_1_space_list streamLen =+    bgroup "list"+      [ bgroup "elimination"+        [ benchList "last" (\xs -> [List.last xs]) (unfoldrList streamLen)+        ]+      , bgroup "nested"+        [ benchList "toNullAp" toNullApNestedList (unfoldrList streamLen2)+        , benchList "toNull"   toNullNestedList (unfoldrList streamLen2)+        , benchList "toNull3"  toNullNestedList3 (unfoldrList streamLen3)+        , benchList "filterAllIn"  filterAllInNestedList (unfoldrList streamLen2)+        , benchList "filterAllOut"  filterAllOutNestedList (unfoldrList streamLen2)+        ]       ]-    ]+    where -o_n_heap :: [Benchmark]-o_n_heap =-    [ bgroup "streamK"+    streamLen2 = round (P.fromIntegral streamLen**(1/2::P.Double)) -- double nested loop+    streamLen3 = round (P.fromIntegral streamLen**(1/3::P.Double)) -- triple nested loop++o_1_space :: Int -> Benchmark+o_1_space streamLen =+    bgroup (o_1_space_prefix moduleName)+      [ o_1_space_generation streamLen+      , o_1_space_elimination streamLen+      , o_1_space_nested streamLen+      , o_1_space_transformation streamLen+      , o_1_space_transformationX4 streamLen+      , o_1_space_concat streamLen+      , o_1_space_filtering streamLen+      , o_1_space_filteringX4 streamLen+      , o_1_space_zipping streamLen+      , o_1_space_mixed streamLen+      , o_1_space_mixedX2 streamLen+      , o_1_space_mixedX4 streamLen+      , o_1_space_list streamLen+      ]++o_n_heap :: Int -> Benchmark+o_n_heap streamLen =+    bgroup (o_n_heap_prefix moduleName)       [ bgroup "transformation"-        [ benchFold "foldlS" (foldlS 1) sourceUnfoldrM+        [ benchFold "foldlS" (foldlS 1) (unfoldrM streamLen)         ]       ]-    ]  {-# INLINE benchK #-} benchK :: P.String -> (Int -> Stream P.IO Int) -> Benchmark-benchK name f = bench name $ nfIO $ randomRIO (1,1) >>= toNull . f+benchK name f = bench name $ nfIO $ randomRIO (1,1) >>= drain . f -o_n_stack :: [Benchmark]-o_n_stack =-    [ bgroup "streamK"+o_n_stack :: Int -> Int -> Int -> Benchmark+o_n_stack streamLen iterStreamLen maxIters =+    bgroup (o_n_stack_prefix moduleName)       [ bgroup "elimination"-        [ benchFold "tail"   tail     sourceUnfoldrM-        , benchFold "nullTail" nullTail sourceUnfoldrM-        , benchFold "headTail" headTail sourceUnfoldrM+        [ benchFold "tail"   tail     (unfoldrM streamLen)+        , benchFold "nullTail" nullTail (unfoldrM streamLen)+        , benchFold "headTail" headTail (unfoldrM streamLen)         ]       , bgroup "transformation"         [           -- XXX why do these need so much stack-          benchFold "intersperse" (intersperse 1) (sourceUnfoldrMN value2)-        , benchFold "interspersePure" (intersperse 1) (sourceUnfoldrN value2)+          benchFold "intersperse" (intersperse streamLen 1) (unfoldrM streamLen2)+        , benchFold "interspersePure" (intersperse streamLen 1) (unfoldr streamLen2)         ]       , bgroup "transformationX4"         [-          benchFold "intersperse" (intersperse 4) (sourceUnfoldrMN value16)+          benchFold "intersperse" (intersperse streamLen 4) (unfoldrM streamLen16)         ]       , bgroup "iterated"-        [ benchK "mapM"                 iterateMapM-        , benchK "scan(1/10)"           iterateScan-        , benchK "filterEven"           iterateFilterEven-        , benchK "takeAll"              iterateTakeAll-        , benchK "dropOne"              iterateDropOne-        , benchK "dropWhileFalse(1/10)" iterateDropWhileFalse-        , benchK "dropWhileTrue"        iterateDropWhileTrue+        [ benchK "mapM"                 (iterateMapM iterStreamLen maxIters)+        , benchK "scan(1/10)"           (iterateScan iterStreamLen maxIters)+        , benchK "filterEven"           (iterateFilterEven iterStreamLen maxIters)+        , benchK "takeAll"              (iterateTakeAll streamLen iterStreamLen maxIters)+        , benchK "dropOne"              (iterateDropOne iterStreamLen maxIters)+        , benchK "dropWhileFalse(1/10)" (iterateDropWhileFalse streamLen iterStreamLen maxIters)+        , benchK "dropWhileTrue"        (iterateDropWhileTrue streamLen iterStreamLen maxIters)         ]       ]-   ]+    where+    streamLen2 = round (P.fromIntegral streamLen**(1/2::P.Double)) -- double nested loop+    streamLen16 = round (P.fromIntegral streamLen**(1/16::P.Double)) -- triple nested loop -o_n_space :: [Benchmark]-o_n_space =-    [ bgroup "streamK"+o_n_space :: Int -> Benchmark+o_n_space streamLen =+    bgroup (o_n_space_prefix moduleName)       [ bgroup "elimination"-        [ benchFold "toList" toList   sourceUnfoldrM+        [ benchFold "toList" toList   (unfoldrM streamLen)         ]       ]-   ]  {-# INLINE benchList #-} benchList :: P.String -> ([Int] -> [Int]) -> (Int -> [Int]) -> Benchmark benchList name run f = bench name $ nfIO $ randomRIO (1,1) >>= return . run . f -o_1_space_list :: [Benchmark]-o_1_space_list =-    [ bgroup "list"-      [ bgroup "elimination"-        [ benchList "last" (\xs -> [List.last xs]) (sourceUnfoldrList value)-        ]-      , bgroup "nested"-        [ benchList "toNullAp" toNullApNestedList (sourceUnfoldrList value2)-        , benchList "toNull"   toNullNestedList (sourceUnfoldrList value2)-        , benchList "toNull3"  toNullNestedList3 (sourceUnfoldrList value3)-        , benchList "filterAllIn"  filterAllInNestedList (sourceUnfoldrList value2)-        , benchList "filterAllOut"  filterAllOutNestedList (sourceUnfoldrList value2)+main :: IO ()+main =+    defaultMain+        [ o_1_space streamLen+        , o_n_stack streamLen iterStreamLen maxIters+        , o_n_heap streamLen+        , o_n_space streamLen         ]-      ]-    ]++    where++    streamLen = 100000+    maxIters = 10000+    iterStreamLen = 10
benchmark/Streamly/Benchmark/Data/Unfold.hs view
@@ -1,77 +1,820 @@ -- | -- Module      : Streamly.Benchmark.Data.Fold -- Copyright   : (c) 2018 Composewell--- -- License     : MIT -- Maintainer  : streamly@composewell.com  {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-} +#ifdef __HADDOCK_VERSION__+#undef INSPECTION+#endif++#ifdef INSPECTION+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}+#endif+ module Main (main) where  import Control.DeepSeq (NFData(..))-+import Control.Exception (SomeException, ErrorCall, try)+import Streamly.Internal.Data.Unfold (Unfold)+import System.IO (Handle, hClose) import System.Random (randomRIO) -import Gauge--import Prelude hiding (concat)+import qualified Prelude+import qualified Streamly.FileSystem.Handle as FH+import qualified Streamly.Internal.Data.Fold as FL+import qualified Streamly.Internal.Data.Unfold as UF+import qualified Streamly.Internal.Data.Stream.IsStream as S+import qualified Streamly.Internal.Data.Stream.StreamD as D+import qualified Streamly.Internal.Data.Stream.StreamK as K+import qualified Streamly.Prelude as SP +import Gauge hiding (env)+import Prelude hiding (concat, take, filter, zipWith, map, mapM, takeWhile) import Streamly.Benchmark.Common-import Streamly.Benchmark.Data.NestedUnfoldOps+import Streamly.Benchmark.Common.Handle +#ifdef INSPECTION+import Test.Inspection+#endif+ {-# INLINE benchIO #-} benchIO :: (NFData b) => String -> (Int -> IO b) -> Benchmark benchIO name f = bench name $ nfIO $ randomRIO (1,1) >>= f  ---------------------------------------------------------------------------------- Stream folds+-- Stream generation and elimination ------------------------------------------------------------------------------- -o_1_space_serial_outerProductUnfolds :: Int -> [Benchmark]-o_1_space_serial_outerProductUnfolds value =+-- generate numbers up to the argument value+{-# INLINE source #-}+source :: Monad m => Int -> Unfold m Int Int+source n = UF.enumerateFromToIntegral n++-------------------------------------------------------------------------------+-- Benchmark helpers+-------------------------------------------------------------------------------++{-# INLINE drainGeneration #-}+drainGeneration :: Monad m => Unfold m a b -> a -> m ()+drainGeneration unf seed = UF.fold FL.drain unf seed++{-# INLINE drainTransformation #-}+drainTransformation ::+       Monad m => Unfold m a b -> (Unfold m a b -> Unfold m c d) -> c -> m ()+drainTransformation unf f seed = drainGeneration (f unf) seed++{-# INLINE drainTransformationDefault #-}+drainTransformationDefault ::+       Monad m => Int -> (Unfold m Int Int -> Unfold m c d) -> c -> m ()+drainTransformationDefault to =+    drainTransformation (UF.enumerateFromToIntegral to)++{-# INLINE drainProduct #-}+drainProduct ::+       Monad m+    => Unfold m a b+    -> Unfold m c d+    -> (Unfold m a b -> Unfold m c d -> Unfold m e f)+    -> e+    -> m ()+drainProduct unf1 unf2 f seed = drainGeneration (f unf1 unf2) seed++{-# INLINE drainProductDefault #-}+drainProductDefault ::+       Monad m+    => Int+    -> (Unfold m Int Int -> Unfold m Int Int -> Unfold m e f)+    -> e+    -> m ()+drainProductDefault to = drainProduct src src++    where++    src = UF.enumerateFromToIntegral to++-------------------------------------------------------------------------------+-- Operations on input+-------------------------------------------------------------------------------++{-# INLINE lmap #-}+lmap :: Monad m => Int -> Int -> m ()+lmap size start =+    drainTransformationDefault (size + start) (UF.lmap (+ 1)) start++{-# INLINE lmapM #-}+lmapM :: Monad m => Int -> Int -> m ()+lmapM size start =+    drainTransformationDefault (size + start) (UF.lmapM (return . (+) 1)) start++{-# INLINE supply #-}+supply :: Monad m => Int -> Int -> m ()+supply size start =+    drainTransformationDefault (size + start) (UF.supply start) undefined+++{-# INLINE supplyFirst #-}+supplyFirst :: Monad m => Int -> Int -> m ()+supplyFirst size start =+    drainTransformation+        (UF.take size UF.enumerateFromStepIntegral)+        (UF.supplyFirst start)+        1++{-# INLINE supplySecond #-}+supplySecond :: Monad m => Int -> Int -> m ()+supplySecond size start =+    drainTransformation+        (UF.take size UF.enumerateFromStepIntegral)+        (UF.supplySecond 1)+        start++{-# INLINE discardFirst #-}+discardFirst :: Monad m => Int -> Int -> m ()+discardFirst size start =+    drainTransformationDefault (size + start) UF.discardFirst (start, start)++{-# INLINE discardSecond #-}+discardSecond :: Monad m => Int -> Int -> m ()+discardSecond size start =+    drainTransformationDefault (size + start) UF.discardSecond (start, start)++{-# INLINE swap #-}+swap :: Monad m => Int -> Int -> m ()+swap size start =+    drainTransformation+        (UF.take size UF.enumerateFromStepIntegral)+        UF.swap+        (1, start)++-------------------------------------------------------------------------------+-- Stream generation+-------------------------------------------------------------------------------++{-# INLINE fromStream #-}+fromStream :: Int -> Int -> IO ()+fromStream size start =+    drainGeneration UF.fromStream (S.replicate size start :: S.SerialT IO Int)++-- XXX INVESTIGATE: Although the performance of this should be equivalant to+-- fromStream, this is considerably worse. More than 4x worse.+{-# INLINE fromStreamK #-}+fromStreamK :: Monad m => Int -> Int -> m ()+fromStreamK size start = drainGeneration UF.fromStreamK (K.replicate size start)++{-# INLINE fromStreamD #-}+fromStreamD :: Monad m => Int -> Int -> m ()+fromStreamD size start =+    drainGeneration UF.fromStreamD (D.replicate size start)++{-# INLINE _nilM #-}+_nilM :: Monad m => Int -> Int -> m ()+_nilM _ start = drainGeneration (UF.nilM return) start++{-# INLINE consM #-}+consM :: Monad m => Int -> Int -> m ()+consM size start =+    drainTransformationDefault (size + start) (UF.consM return) start++{-# INLINE _functionM #-}+_functionM :: Monad m => Int -> Int -> m ()+_functionM _ start = drainGeneration (UF.functionM return) start++{-# INLINE _function #-}+_function :: Monad m => Int -> Int -> m ()+_function _ start = drainGeneration (UF.function id) start++{-# INLINE _identity #-}+_identity :: Monad m => Int -> Int -> m ()+_identity _ start = drainGeneration UF.identity start++{-# INLINE _const #-}+_const :: Monad m => Int -> Int -> m ()+_const size start =+    drainGeneration (UF.take size (UF.fromEffect (return start))) undefined++{-# INLINE unfoldrM #-}+unfoldrM :: Monad m => Int -> Int -> m ()+unfoldrM size start = drainGeneration (UF.unfoldrM step) start++    where++    step i =+        return+            $ if i < start + size+              then Just (i, i + 1)+              else Nothing++{-# INLINE fromList #-}+fromList :: Monad m => Int -> Int -> m ()+fromList size start = drainGeneration UF.fromList [start .. start + size]++{-# INLINE fromListM #-}+fromListM :: Monad m => Int -> Int -> m ()+fromListM size start =+    drainGeneration UF.fromListM (Prelude.map return [start .. start + size])++{-# INLINE _fromSVar #-}+_fromSVar :: Int -> Int -> m ()+_fromSVar = undefined++{-# INLINE _fromProducer #-}+_fromProducer :: Int -> Int -> m ()+_fromProducer = undefined++{-# INLINE replicateM #-}+replicateM :: Monad m => Int -> Int -> m ()+replicateM size start = drainGeneration (UF.replicateM size) (return start)++{-# INLINE repeatM #-}+repeatM :: Monad m => Int -> Int -> m ()+repeatM size start = drainGeneration (UF.take size UF.repeatM) (return start)++{-# INLINE iterateM #-}+iterateM :: Monad m => Int -> Int -> m ()+iterateM size start =+    drainGeneration (UF.take size (UF.iterateM return)) (return start)++{-# INLINE fromIndicesM #-}+fromIndicesM :: Monad m => Int -> Int -> m ()+fromIndicesM size start =+    drainGeneration (UF.take size (UF.fromIndicesM return)) start++{-# INLINE enumerateFromStepIntegral #-}+enumerateFromStepIntegral :: Monad m => Int -> Int -> m ()+enumerateFromStepIntegral size start =+    drainGeneration (UF.take size UF.enumerateFromStepIntegral) (start, 1)++{-# INLINE enumerateFromToIntegral #-}+enumerateFromToIntegral :: Monad m => Int -> Int -> m ()+enumerateFromToIntegral size start =+    drainGeneration (UF.enumerateFromToIntegral (size + start)) start++{-# INLINE enumerateFromIntegral #-}+enumerateFromIntegral :: Monad m => Int -> Int -> m ()+enumerateFromIntegral size start =+    drainGeneration (UF.take size UF.enumerateFromIntegral) start++{-# INLINE enumerateFromStepNum #-}+enumerateFromStepNum :: Monad m => Int -> Int -> m ()+enumerateFromStepNum size start =+    drainGeneration (UF.take size (UF.enumerateFromStepNum 1)) start++{-# INLINE numFrom #-}+numFrom :: Monad m => Int -> Int -> m ()+numFrom size start = drainGeneration (UF.take size UF.numFrom) start++{-# INLINE enumerateFromToFractional #-}+enumerateFromToFractional :: Monad m => Int -> Int -> m ()+enumerateFromToFractional size start =+    let intToDouble x = (fromInteger (fromIntegral x)) :: Double+     in drainGeneration+            (UF.enumerateFromToFractional (intToDouble $ start + size))+            (intToDouble start)++-------------------------------------------------------------------------------+-- Stream transformation+-------------------------------------------------------------------------------++{-# INLINE map #-}+map :: Monad m => Int -> Int -> m ()+map size start = drainTransformationDefault (size + start) (UF.map (+1)) start++{-# INLINE mapM #-}+mapM :: Monad m => Int -> Int -> m ()+mapM size start =+    drainTransformationDefault (size + start) (UF.mapM (return . (+) 1)) start++{-# INLINE mapMWithInput #-}+mapMWithInput :: Monad m => Int -> Int -> m ()+mapMWithInput size start =+    drainTransformationDefault+        size+        (UF.mapMWithInput (\a b -> return $ a + b))+        start++-------------------------------------------------------------------------------+-- Stream filtering+-------------------------------------------------------------------------------++{-# INLINE takeWhileM #-}+takeWhileM :: Monad m => Int -> Int -> m ()+takeWhileM size start =+    drainTransformationDefault+        size+        (UF.takeWhileM (\b -> return (b <= size + start)))+        start++{-# INLINE takeWhile #-}+takeWhile :: Monad m => Int -> Int -> m ()+takeWhile size start =+    drainTransformationDefault+        size+        (UF.takeWhile (\b -> b <= size + start))+        start++{-# INLINE take #-}+take :: Monad m => Int -> Int -> m ()+take size start = drainTransformationDefault (size + start) (UF.take size) start++{-# INLINE filter #-}+filter :: Monad m => Int -> Int -> m ()+filter size start =+    drainTransformationDefault (size + start) (UF.filter (\_ -> True)) start++{-# INLINE filterM #-}+filterM :: Monad m => Int -> Int -> m ()+filterM size start =+    drainTransformationDefault+        (size + start)+        (UF.filterM (\_ -> (return True)))+        start++{-# INLINE _dropOne #-}+_dropOne :: Monad m => Int -> Int -> m ()+_dropOne size start =+    drainTransformationDefault (size + start) (UF.drop 1) start++{-# INLINE dropAll #-}+dropAll :: Monad m => Int -> Int -> m ()+dropAll size start =+    drainTransformationDefault (size + start) (UF.drop (size + 1)) start++{-# INLINE dropWhileTrue #-}+dropWhileTrue :: Monad m => Int -> Int -> m ()+dropWhileTrue size start =+    drainTransformationDefault+        (size + start)+        (UF.dropWhileM (\_ -> return True))+        start++{-# INLINE dropWhileFalse #-}+dropWhileFalse :: Monad m => Int -> Int -> m ()+dropWhileFalse size start =+    drainTransformationDefault+        (size + start)+        (UF.dropWhileM (\_ -> return False))+        start++{-# INLINE dropWhileMTrue #-}+dropWhileMTrue :: Monad m => Int -> Int -> m ()+dropWhileMTrue size start =+    drainTransformationDefault+        size+        (UF.dropWhileM (\_ -> return True))+        start++{-# INLINE dropWhileMFalse #-}+dropWhileMFalse :: Monad m => Int -> Int -> m ()+dropWhileMFalse size start =+    drainTransformationDefault+        size+        (UF.dropWhileM (\_ -> return False))+        start++-------------------------------------------------------------------------------+-- Stream combination+-------------------------------------------------------------------------------++{-# INLINE zipWith #-}+zipWith :: Monad m => Int -> Int -> m ()+zipWith size start =+    drainProductDefault (size + start) (UF.zipWith (+)) start++{-# INLINE zipWithM #-}+zipWithM :: Monad m => Int -> Int -> m ()+zipWithM size start =+    drainProductDefault+        (size + start)+        (UF.zipWithM (\a b -> return $ a + b))+        start++{-# INLINE teeZipWith #-}+teeZipWith :: Monad m => Int -> Int -> m ()+teeZipWith size start =+    drainProductDefault (size + start) (UF.zipWith (+)) start++-------------------------------------------------------------------------------+-- Applicative+-------------------------------------------------------------------------------++{-# INLINE toNullAp #-}+toNullAp :: Monad m => Int -> Int -> m ()+toNullAp value start =+    let end = start + nthRoot 2 value+        s = source end+    -- in UF.fold ((+) <$> s <*> s) FL.drain start+    in UF.fold FL.drain ((+) `fmap` s `UF.apply` s) start++{-# INLINE _apDiscardFst #-}+_apDiscardFst :: Int -> Int -> m ()+_apDiscardFst = undefined++{-# INLINE _apDiscardSnd #-}+_apDiscardSnd :: Int -> Int -> m ()+_apDiscardSnd = undefined++-------------------------------------------------------------------------------+-- Monad+-------------------------------------------------------------------------------++nthRoot :: Double -> Int -> Int+nthRoot n value = round (fromIntegral value**(1/n))++{-# INLINE concatMapM #-}+concatMapM :: Monad m => Int -> Int -> m ()+concatMapM value start =+    val `seq` drainGeneration (UF.concatMapM unfoldInGen unfoldOut) start++    where++    val = nthRoot 2 value+    unfoldInGen i = return (UF.enumerateFromToIntegral (i + val))+    unfoldOut = UF.enumerateFromToIntegral (start + val)++{-# INLINE toNull #-}+toNull :: Monad m => Int -> Int -> m ()+toNull value start =+    let end = start + nthRoot 2 value+        src = source end+        {-+        u = do+            x <- src+            y <- src+            return (x + y)+        -}+        u = src `UF.bind` \x ->+            src `UF.bind` \y ->+                UF.fromPure (x + y)+     in UF.fold FL.drain u start+++{-# INLINE toNull3 #-}+toNull3 :: Monad m => Int -> Int -> m ()+toNull3 value start =+    let end = start + nthRoot 3 value+        src = source end+        {-+        u = do+            x <- src+            y <- src+            z <- src+            return (x + y + z)+        -}+        u = src `UF.bind` \x ->+            src `UF.bind` \y ->+                UF.fromPure (x + y)+     in UF.fold FL.drain u start++{-# INLINE toList #-}+toList :: Monad m => Int -> Int -> m [Int]+toList value start = do+    let end = start + nthRoot 2 value+        src = source end+        {-+        u = do+            x <- src+            y <- src+            return (x + y)+        -}+        u = src `UF.bind` \x ->+            src `UF.bind` \y ->+                UF.fromPure (x + y)+     in UF.fold FL.toList u start++{-# INLINE toListSome #-}+toListSome :: Monad m => Int -> Int -> m [Int]+toListSome value start = do+    let end = start + nthRoot 2 value+        src = source end+        {-+        u = do+            x <- src+            y <- src+            return (x + y)+        -}+        u = src `UF.bind` \x ->+            src `UF.bind` \y ->+                UF.fromPure (x + y)+     in UF.fold FL.toList (UF.take 1000 u) start++{-# INLINE filterAllOut #-}+filterAllOut :: Monad m => Int -> Int -> m ()+filterAllOut value start = do+    let end = start + nthRoot 2 value+        src = source end+        {-+        u = do+            x <- src+            y <- src+        -}+        u = src `UF.bind` \x ->+            src `UF.bind` \y ->+            let s = x + y+             in if s < 0+                then UF.fromPure s+                else UF.nilM (return . const ())+     in UF.fold FL.drain u start++{-# INLINE filterAllIn #-}+filterAllIn :: Monad m => Int -> Int -> m ()+filterAllIn value start = do+    let end = start + nthRoot 2 value+        src = source end+        {-+        u = do+            x <- src+            y <- src+        -}+        u = src `UF.bind` \x ->+            src `UF.bind` \y ->+            let s = x + y+             in if s > 0+                then UF.fromPure s+                else UF.nilM (return . const ())+     in UF.fold FL.drain u start++{-# INLINE filterSome #-}+filterSome :: Monad m => Int -> Int -> m ()+filterSome value start = do+    let end = start + nthRoot 2 value+        src = source end+        {-+        u = do+            x <- src+            y <- src+        -}+        u = src `UF.bind` \x ->+            src `UF.bind` \y ->+            let s = x + y+             in if s > 1100000+                then UF.fromPure s+                else UF.nilM (return . const ())+     in UF.fold FL.drain u start++{-# INLINE breakAfterSome #-}+breakAfterSome :: Int -> Int -> IO ()+breakAfterSome value start =+    let end = start + nthRoot 2 value+        src = source end+        {-+        u = do+            x <- src+            y <- src+        -}+        u = src `UF.bind` \x ->+            src `UF.bind` \y ->+            let s = x + y+             in if s > 1100000+                then error "break"+                else UF.fromPure s+     in do+        (_ :: Either ErrorCall ()) <- try $ UF.fold FL.drain u start+        return ()++-------------------------------------------------------------------------------+-- Benchmark ops+-------------------------------------------------------------------------------++-- n * (n + 1) / 2 == linearCount+concatCount :: Int -> Int+concatCount linearCount =+    round (((1 + 8 * fromIntegral linearCount)**(1/2::Double) - 1) / 2)++{-# INLINE concat #-}+concat :: Monad m => Int -> Int -> m ()+concat linearCount start = do+    let end = start + concatCount linearCount+    UF.fold FL.drain (UF.many (source end) (source end)) start++-------------------------------------------------------------------------------+-- Benchmarks+-------------------------------------------------------------------------------++moduleName :: String+moduleName = "Data.Unfold"++o_1_space_transformation_input :: Int -> [Benchmark]+o_1_space_transformation_input size =     [ bgroup-          "serially"-          [ bgroup-                "outer-product-unfolds"-                [ benchIO "toNull" $ toNull value-                , benchIO "toNull3" $ toNull3 value-                , benchIO "concat" $ concat value-                , benchIO "filterAllOut" $ filterAllOut value-                , benchIO "filterAllIn" $ filterAllIn value-                , benchIO "filterSome" $ filterSome value-                , benchIO "breakAfterSome" $ breakAfterSome value-                ]+          "transformation/input"+          [ benchIO "lmap" $ lmap size+          , benchIO "lmapM" $ lmapM size+          , benchIO "supply" $ supply size+          , benchIO "supplyFirst" $ supplyFirst size+          , benchIO "supplySecond" $ supplySecond size+          , benchIO "discardFirst" $ discardFirst size+          , benchIO "discardSecond" $ discardSecond size+          , benchIO "swap" $ swap size           ]     ] +o_1_space_generation :: Int -> [Benchmark]+o_1_space_generation size =+    [ bgroup+          "generation"+          [ benchIO "fromStream" $ fromStream size+          , benchIO "fromStreamK" $ fromStreamK size+          , benchIO "fromStreamD" $ fromStreamD size+          -- Very small benchmarks, reporting in ns+          -- , benchIO "nilM" $ nilM size+          , benchIO "consM" $ consM size+          -- , benchIO "functionM" $ functionM size+          -- , benchIO "function" $ function size+          -- , benchIO "identity" $ identity size+          -- , benchIO "const" $ const size+          , benchIO "unfoldrM" $ unfoldrM size+          , benchIO "fromList" $ fromList size+          , benchIO "fromListM" $ fromListM size+          -- Unimplemented+          -- , benchIO "fromSVar" $ fromSVar size+          -- , benchIO "fromProducer" $ fromProducer size+          , benchIO "replicateM" $ replicateM size+          , benchIO "repeatM" $ repeatM size+          , benchIO "iterateM" $ iterateM size+          , benchIO "fromIndicesM" $ fromIndicesM size+          , benchIO "enumerateFromStepIntegral" $ enumerateFromStepIntegral size+          , benchIO "enumerateFromToIntegral" $ enumerateFromToIntegral size+          , benchIO "enumerateFromIntegral" $ enumerateFromIntegral size+          , benchIO "enumerateFromStepNum" $ enumerateFromStepNum size+          , benchIO "numFrom" $ numFrom size+          , benchIO "enumerateFromToFractional" $ enumerateFromToFractional size+          ]+    ] -o_n_space_serial_outerProductUnfolds :: Int -> [Benchmark]-o_n_space_serial_outerProductUnfolds value =+o_1_space_transformation :: Int -> [Benchmark]+o_1_space_transformation size =     [ bgroup-          "serially"-          [ bgroup-                "outer-product-unfolds"-                [ benchIO "toList" $ toList value-                , benchIO "toListSome" $ toListSome value-                ]+          "transformation"+          [ benchIO "map" $ map size+          , benchIO "mapM" $ mapM size+          , benchIO "mapMWithInput" $ mapMWithInput size           ]     ] +o_1_space_filtering :: Int -> [Benchmark]+o_1_space_filtering size =+    [ bgroup+          "filtering"+          [ benchIO "takeWhileM" $ takeWhileM size+          , benchIO "takeWhile" $ takeWhile size+          , benchIO "take" $ take size+          , benchIO "filter" $ filter size+          , benchIO "filterM" $ filterM size+          -- Very small benchmark, reporting in ns+          -- , benchIO "dropOne" $ dropOne size+          , benchIO "dropAll" $ dropAll size+          , benchIO "dropWhileTrue" $ dropWhileTrue size+          , benchIO "dropWhileFalse" $ dropWhileFalse size+          , benchIO "dropWhileMTrue" $ dropWhileMTrue size+          , benchIO "dropWhileMFalse" $ dropWhileMFalse size+          ]+    ]++o_1_space_zip :: Int -> [Benchmark]+o_1_space_zip size =+    [ bgroup+          "zip"+          [ benchIO "zipWithM" $ zipWithM size+          , benchIO "zipWith" $ zipWith size+          , benchIO "teeZipWith" $ teeZipWith size+          ]+    ]++o_1_space_nested :: Int -> [Benchmark]+o_1_space_nested size =+    [ bgroup+          "nested"+          [ benchIO "(<*>) (sqrt n x sqrt n)" $ toNullAp size+          -- Unimplemented+          -- , benchIO "apDiscardFst" $ apDiscardFst size+          -- , benchIO "apDiscardSnd" $ apDiscardSnd size++          , benchIO "concatMapM (sqrt n x sqrt n)" $ concatMapM size+          , benchIO "(>>=) (sqrt n x sqrt n)" $ toNull size+          , benchIO "(>>=) (cubert n x cubert n x cubert n)" $ toNull3 size+          , benchIO "breakAfterSome" $ breakAfterSome size+          , benchIO "filterAllOut" $ filterAllOut size+          , benchIO "filterAllIn" $ filterAllIn size+          , benchIO "filterSome" $ filterSome size++          , benchIO "concat" $ concat size+          ]+    ]++o_n_space_nested :: Int -> [Benchmark]+o_n_space_nested size =+    [ bgroup+          "nested"+          [ benchIO "toList" $ toList size+          , benchIO "toListSome" $ toListSome size+          ]+    ]+ -------------------------------------------------------------------------------+-- Unfold Exception Benchmarks+-------------------------------------------------------------------------------+-- | Send the file contents to /dev/null with exception handling+readWriteOnExceptionUnfold :: Handle -> Handle -> IO ()+readWriteOnExceptionUnfold inh devNull =+    let readEx = UF.onException (\_ -> hClose inh) FH.read+    in SP.fold (FH.write devNull) $ SP.unfold readEx inh++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'readWriteOnExceptionUnfold+-- inspect $ 'readWriteOnExceptionUnfold `hasNoType` ''Step+#endif++-- | Send the file contents to /dev/null with exception handling+readWriteHandleExceptionUnfold :: Handle -> Handle -> IO ()+readWriteHandleExceptionUnfold inh devNull =+    let handler (_e :: SomeException) = hClose inh >> return 10+        readEx = UF.handle (UF.functionM handler) FH.read+    in SP.fold (FH.write devNull) $ SP.unfold readEx inh++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'readWriteHandleExceptionUnfold+-- inspect $ 'readWriteHandleExceptionUnfold `hasNoType` ''Step+#endif++-- | Send the file contents to /dev/null with exception handling+readWriteFinally_Unfold :: Handle -> Handle -> IO ()+readWriteFinally_Unfold inh devNull =+    let readEx = UF.finally_ (\_ -> hClose inh) FH.read+    in SP.fold (FH.write devNull) $ SP.unfold readEx inh++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'readWriteFinally_Unfold+-- inspect $ 'readWriteFinallyUnfold `hasNoType` ''Step+#endif++readWriteFinallyUnfold :: Handle -> Handle -> IO ()+readWriteFinallyUnfold inh devNull =+    let readEx = UF.finally (\_ -> hClose inh) FH.read+    in SP.fold (FH.write devNull) $ SP.unfold readEx inh++-- | Send the file contents to /dev/null with exception handling+readWriteBracket_Unfold :: Handle -> Handle -> IO ()+readWriteBracket_Unfold inh devNull =+    let readEx = UF.bracket_ return (\_ -> hClose inh) FH.read+    in SP.fold (FH.write devNull) $ SP.unfold readEx inh++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'readWriteBracket_Unfold+-- inspect $ 'readWriteBracketUnfold `hasNoType` ''Step+#endif++readWriteBracketUnfold :: Handle -> Handle -> IO ()+readWriteBracketUnfold inh devNull =+    let readEx = UF.bracket return (\_ -> hClose inh) FH.read+    in SP.fold (FH.write devNull) $ S.unfold readEx inh++o_1_space_copy_read_exceptions :: BenchEnv -> [Benchmark]+o_1_space_copy_read_exceptions env =+    [ bgroup "exceptions"+       [ mkBenchSmall "UF.onException" env $ \inh _ ->+           readWriteOnExceptionUnfold inh (nullH env)+       , mkBenchSmall "UF.handle" env $ \inh _ ->+           readWriteHandleExceptionUnfold inh (nullH env)+       , mkBenchSmall "UF.finally_" env $ \inh _ ->+           readWriteFinally_Unfold inh (nullH env)+       , mkBenchSmall "UF.finally" env $ \inh _ ->+           readWriteFinallyUnfold inh (nullH env)+       , mkBenchSmall "UF.bracket_" env $ \inh _ ->+           readWriteBracket_Unfold inh (nullH env)+       , mkBenchSmall "UF.bracket" env $ \inh _ ->+           readWriteBracketUnfold inh (nullH env)+        ]+    ]+++------------------------------------------------------------------------------- -- Driver -------------------------------------------------------------------------------  main :: IO () main = do-  (value, cfg, benches) <- parseCLIOpts defaultStreamSize-  value `seq` runMode (mode cfg) cfg benches (allBenchmarks value)-  where-    allBenchmarks value =-      [ bgroup-          "o-1-space"-          [bgroup "unfold" (o_1_space_serial_outerProductUnfolds value)]-      , bgroup-          "o-n-space"-          [bgroup "unfold" (o_n_space_serial_outerProductUnfolds value)]-      ]+    env <- mkHandleBenchEnv+    runWithCLIOpts defaultStreamSize (allBenchmarks env)++    where++    allBenchmarks env size =+        [ bgroup (o_1_space_prefix moduleName)+            $ Prelude.concat+                  [ o_1_space_transformation_input size+                  , o_1_space_generation size+                  , o_1_space_transformation size+                  , o_1_space_filtering size+                  , o_1_space_zip size+                  , o_1_space_nested size+                  , o_1_space_copy_read_exceptions env+                  ]+        , bgroup (o_n_space_prefix moduleName)+            $ Prelude.concat [o_n_space_nested size]+        ]
− benchmark/Streamly/Benchmark/FileIO/Array.hs 
@@ -1,259 +0,0 @@--- |--- Module      : Streamly.Benchmark.FileIO.Array--- Copyright   : (c) 2019 Composewell Technologies------ License     : BSD3--- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC--{-# LANGUAGE CPP #-}--#ifdef __HADDOCK_VERSION__-#undef INSPECTION-#endif--#ifdef INSPECTION-{-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}-#endif--module Streamly.Benchmark.FileIO.Array-    (-      last-    , countBytes-    , countLines-    , countWords-    , sumBytes-    , cat-    , catOnException-    , catBracket-    , catBracketIO-    , catBracketStream-    , catBracketStreamIO-    , copy-    , linesUnlinesCopy-    , wordsUnwordsCopy-    , decodeUtf8Lenient-    , copyCodecUtf8Lenient-    )-where--import Data.Functor.Identity (runIdentity)-import Data.Word (Word8)-import System.IO (Handle, hClose)-import Prelude hiding (last)--import qualified Streamly.FileSystem.Handle as FH-import qualified Streamly.Memory.Array as A-import qualified Streamly.Prelude as S-import qualified Streamly.Data.Unicode.Stream as SS-import qualified Streamly.Internal.Data.Unicode.Stream as IUS--import qualified Streamly.Internal.FileSystem.Handle as IFH-import qualified Streamly.Internal.Memory.Array as IA-import qualified Streamly.Internal.Memory.ArrayStream as AS-import qualified Streamly.Internal.Data.Unfold as IUF-import qualified Streamly.Internal.Prelude as IP--#ifdef INSPECTION-import Foreign.Storable (Storable)-import Streamly.Internal.Data.Stream.StreamD.Type (Step(..))-import Test.Inspection-#endif---- | Get the last byte from a file bytestream.-{-# INLINE last #-}-last :: Handle -> IO (Maybe Word8)-last inh = do-    let s = IFH.toChunks inh-    larr <- S.last s-    return $ case larr of-        Nothing -> Nothing-        Just arr -> IA.readIndex arr (A.length arr - 1)--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'last-inspect $ 'last `hasNoType` ''Step-#endif---- | Count the number of bytes in a file.-{-# INLINE countBytes #-}-countBytes :: Handle -> IO Int-countBytes inh =-    let s = IFH.toChunks inh-    in S.sum (S.map A.length s)--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'countBytes-inspect $ 'countBytes `hasNoType` ''Step-#endif---- | Count the number of lines in a file.-{-# INLINE countLines #-}-countLines :: Handle -> IO Int-countLines = S.length . AS.splitOnSuffix 10 . IFH.toChunks--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'countLines-inspect $ 'countLines `hasNoType` ''Step-#endif---- XXX use a word splitting combinator instead of splitOn and test it.--- | Count the number of lines in a file.-{-# INLINE countWords #-}-countWords :: Handle -> IO Int-countWords = S.length . AS.splitOn 32 . IFH.toChunks--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'countWords-inspect $ 'countWords `hasNoType` ''Step-#endif---- | Sum the bytes in a file.-{-# INLINE sumBytes #-}-sumBytes :: Handle -> IO Word8-sumBytes inh = do-    let foldlArr' f z = runIdentity . S.foldl' f z . IA.toStream-    let s = IFH.toChunks inh-    S.foldl' (\acc arr -> acc + foldlArr' (+) 0 arr) 0 s--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'sumBytes-inspect $ 'sumBytes `hasNoType` ''Step-#endif---- | Send the file contents to /dev/null-{-# INLINE cat #-}-cat :: Handle -> Handle -> IO ()-cat devNull inh =-    S.fold (IFH.writeChunks devNull) $ IFH.toChunksWithBufferOf (256*1024) inh--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'cat-inspect $ 'cat `hasNoType` ''Step-#endif---- | Send the file contents to /dev/null with exception handling-{-# INLINE catBracket #-}-catBracket :: Handle -> Handle -> IO ()-catBracket devNull inh =-    let readEx = IUF.bracket return (\_ -> hClose inh)-                    (IUF.supplyFirst FH.readChunksWithBufferOf (256*1024))-    in IUF.fold readEx (IFH.writeChunks devNull) inh--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'catBracket--- inspect $ 'catBracket `hasNoType` ''Step-#endif--{-# INLINE catBracketIO #-}-catBracketIO :: Handle -> Handle -> IO ()-catBracketIO devNull inh =-    let readEx = IUF.bracketIO return (\_ -> hClose inh)-                    (IUF.supplyFirst FH.readChunksWithBufferOf (256*1024))-    in IUF.fold readEx (IFH.writeChunks devNull) inh---- | Send the file contents to /dev/null with exception handling-{-# INLINE catBracketStream #-}-catBracketStream :: Handle -> Handle -> IO ()-catBracketStream devNull inh =-    let readEx = S.bracket (return ()) (\_ -> hClose inh)-                    (\_ -> IFH.toChunksWithBufferOf (256*1024) inh)-    in S.fold (IFH.writeChunks devNull) $ readEx--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'catBracketStream--- inspect $ 'catBracketStream `hasNoType` ''Step-#endif--{-# INLINE catBracketStreamIO #-}-catBracketStreamIO :: Handle -> Handle -> IO ()-catBracketStreamIO devNull inh =-    let readEx = IP.bracketIO (return ()) (\_ -> hClose inh)-                    (\_ -> IFH.toChunksWithBufferOf (256*1024) inh)-    in S.fold (IFH.writeChunks devNull) $ readEx---- | Send the file contents to /dev/null with exception handling-{-# INLINE catOnException #-}-catOnException :: Handle -> Handle -> IO ()-catOnException devNull inh =-    let readEx = IUF.onException (\_ -> hClose inh)-                    (IUF.supplyFirst FH.readChunksWithBufferOf (256*1024))-    in IUF.fold readEx (IFH.writeChunks devNull) inh--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'catOnException--- inspect $ 'catOnException `hasNoType` ''Step-#endif---- | Copy file-{-# INLINE copy #-}-copy :: Handle -> Handle -> IO ()-copy inh outh =-    let s = IFH.toChunks inh-    in S.fold (IFH.writeChunks outh) s--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'copy-inspect $ 'copy `hasNoType` ''Step-#endif---- | Lines and unlines-{-# INLINE linesUnlinesCopy #-}-linesUnlinesCopy :: Handle -> Handle -> IO ()-linesUnlinesCopy inh outh =-    S.fold (IFH.writeWithBufferOf (1024*1024) outh)-        $ AS.interposeSuffix 10-        $ AS.splitOnSuffix 10-        $ IFH.toChunksWithBufferOf (1024*1024) inh--#ifdef INSPECTION-inspect $ hasNoTypeClassesExcept 'linesUnlinesCopy [''Storable]--- inspect $ 'linesUnlinesCopy `hasNoType` ''Step-#endif---- | Words and unwords-{-# INLINE wordsUnwordsCopy #-}-wordsUnwordsCopy :: Handle -> Handle -> IO ()-wordsUnwordsCopy inh outh =-    S.fold (IFH.writeWithBufferOf (1024*1024) outh)-        $ AS.interpose 32-        -- XXX this is not correct word splitting combinator-        $ AS.splitOn 32-        $ IFH.toChunksWithBufferOf (1024*1024) inh--#ifdef INSPECTION-inspect $ hasNoTypeClassesExcept 'wordsUnwordsCopy [''Storable]--- inspect $ 'wordsUnwordsCopy `hasNoType` ''Step-#endif--{-# INLINE decodeUtf8Lenient #-}-decodeUtf8Lenient :: Handle -> IO ()-decodeUtf8Lenient inh =-   S.drain-     $ IUS.decodeUtf8ArraysLenient-     $ IFH.toChunksWithBufferOf (1024*1024) inh--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'decodeUtf8Lenient--- inspect $ 'decodeUtf8Lenient `hasNoType` ''Step--- inspect $ 'decodeUtf8Lenient `hasNoType` ''AT.FlattenState--- inspect $ 'decodeUtf8Lenient `hasNoType` ''D.ConcatMapUState-#endif---- | Copy file-{-# INLINE copyCodecUtf8Lenient #-}-copyCodecUtf8Lenient :: Handle -> Handle -> IO ()-copyCodecUtf8Lenient inh outh =-   S.fold (FH.write outh)-     $ SS.encodeUtf8-     $ IUS.decodeUtf8ArraysLenient-     $ IFH.toChunksWithBufferOf (1024*1024) inh--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'copyCodecUtf8Lenient--- inspect $ 'copyCodecUtf8Lenient `hasNoType` ''Step--- inspect $ 'copyCodecUtf8Lenient `hasNoType` ''AT.FlattenState--- inspect $ 'copyCodecUtf8Lenient `hasNoType` ''D.ConcatMapUState-#endif
− benchmark/Streamly/Benchmark/FileIO/Stream.hs 
@@ -1,666 +0,0 @@--- |--- Module      : Streamly.Benchmark.FileIO.Stream--- Copyright   : (c) 2019 Composewell Technologies------ License     : BSD3--- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC--{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}--#ifdef __HADDOCK_VERSION__-#undef INSPECTION-#endif--#ifdef INSPECTION-{-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}-#endif--module Streamly.Benchmark.FileIO.Stream-    (-    -- * FileIO-      last-    , countBytes-    , countLines-    , countLinesU-    , countWords-    , sumBytes-    , cat-    , catStreamWrite-    , catBracket-    , catBracketIO-    , catBracketStream-    , catBracketStreamIO-    , catOnException-    , catOnExceptionStream-    , catHandle-    , catHandleStream-    , catFinally-    , catFinallyIO-    , catFinallyStream-    , catFinallyStreamIO-    , copy-    , linesUnlinesCopy-    , linesUnlinesArrayWord8Copy-    , linesUnlinesArrayCharCopy-    -- , linesUnlinesArrayUtf8Copy-    , wordsUnwordsCopyWord8-    , wordsUnwordsCopy-    , wordsUnwordsCharArrayCopy-    , readWord8-    , decodeLatin1-    , copyCodecChar8-    , copyCodecUtf8-    , decodeUtf8Lax-    , copyCodecUtf8Lenient-    , chunksOfSum-    , splitParseChunksOfSum-    , chunksOf-    , chunksOfD-    , splitOn-    , splitOnSuffix-    , splitParseSepBy-    , wordsBy-    , splitOnSeq-    , splitOnSeqUtf8-    , splitOnSuffixSeq-    )-where--import Control.Exception (SomeException)-import Data.Char (ord, chr)-import Data.Word (Word8)-import System.IO (Handle, hClose)-import Prelude hiding (last, length)--import qualified Streamly.FileSystem.Handle as FH-import qualified Streamly.Internal.FileSystem.Handle as IFH-import qualified Streamly.Memory.Array as A--- import qualified Streamly.Internal.Memory.Array as IA-import qualified Streamly.Internal.Memory.Array.Types as AT-import qualified Streamly.Prelude as S-import qualified Streamly.Data.Fold as FL--- import qualified Streamly.Internal.Data.Fold as IFL-import qualified Streamly.Data.Unicode.Stream as SS-import qualified Streamly.Internal.Data.Unicode.Stream as IUS-import qualified Streamly.Internal.Memory.Unicode.Array as IUA-import qualified Streamly.Internal.Data.Unfold as IUF-import qualified Streamly.Internal.Data.Parser as PR-import qualified Streamly.Internal.Prelude as IP-import qualified Streamly.Internal.Data.Stream.StreamD as D--#ifdef INSPECTION-import Foreign.Storable (Storable)-import Streamly.Internal.Data.Stream.StreamD.Type (Step(..), GroupState)-import Test.Inspection-#endif---- | Get the last byte from a file bytestream.-{-# INLINE last #-}-last :: Handle -> IO (Maybe Word8)-last = S.last . S.unfold FH.read--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'last-inspect $ 'last `hasNoType` ''Step-inspect $ 'last `hasNoType` ''AT.FlattenState-inspect $ 'last `hasNoType` ''D.ConcatMapUState-#endif---- assert that flattenArrays constructors are not present--- | Count the number of bytes in a file.-{-# INLINE countBytes #-}-countBytes :: Handle -> IO Int-countBytes = S.length . S.unfold FH.read--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'countBytes-inspect $ 'countBytes `hasNoType` ''Step-inspect $ 'countBytes `hasNoType` ''AT.FlattenState-inspect $ 'countBytes `hasNoType` ''D.ConcatMapUState-#endif---- | Count the number of lines in a file.-{-# INLINE countLines #-}-countLines :: Handle -> IO Int-countLines =-    S.length-        . IUS.lines FL.drain-        . SS.decodeLatin1-        . S.unfold FH.read--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'countLines-inspect $ 'countLines `hasNoType` ''Step-inspect $ 'countLines `hasNoType` ''AT.FlattenState-inspect $ 'countLines `hasNoType` ''D.ConcatMapUState-#endif---- | Count the number of words in a file.-{-# INLINE countWords #-}-countWords :: Handle -> IO Int-countWords =-    S.length-        . IUS.words FL.drain-        . SS.decodeLatin1-        . S.unfold FH.read--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'countWords--- inspect $ 'countWords `hasNoType` ''Step--- inspect $ 'countWords `hasNoType` ''D.ConcatMapUState-#endif---- | Count the number of lines in a file.-{-# INLINE countLinesU #-}-countLinesU :: Handle -> IO Int-countLinesU inh =-    S.length-        $ IUS.lines FL.drain-        $ SS.decodeLatin1-        $ S.concatUnfold A.read (IFH.toChunks inh)--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'countLinesU-inspect $ 'countLinesU `hasNoType` ''Step-inspect $ 'countLinesU `hasNoType` ''D.ConcatMapUState-#endif---- | Sum the bytes in a file.-{-# INLINE sumBytes #-}-sumBytes :: Handle -> IO Word8-sumBytes = S.sum . S.unfold FH.read--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'sumBytes-inspect $ 'sumBytes `hasNoType` ''Step-inspect $ 'sumBytes `hasNoType` ''AT.FlattenState-inspect $ 'sumBytes `hasNoType` ''D.ConcatMapUState-#endif---- | Send the file contents to /dev/null-{-# INLINE cat #-}-cat :: Handle -> Handle -> IO ()-cat devNull inh = S.fold (FH.write devNull) $ S.unfold FH.read inh--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'cat-inspect $ 'cat `hasNoType` ''Step-inspect $ 'cat `hasNoType` ''AT.FlattenState-inspect $ 'cat `hasNoType` ''D.ConcatMapUState-#endif---- | Send the file contents to /dev/null-{-# INLINE catStreamWrite #-}-catStreamWrite :: Handle -> Handle -> IO ()-catStreamWrite devNull inh = IFH.fromBytes devNull $ S.unfold FH.read inh--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'catStreamWrite-inspect $ 'catStreamWrite `hasNoType` ''Step-inspect $ 'catStreamWrite `hasNoType` ''AT.FlattenState-inspect $ 'catStreamWrite `hasNoType` ''D.ConcatMapUState-#endif---- | Send the file contents to /dev/null with exception handling-{-# INLINE catBracket #-}-catBracket :: Handle -> Handle -> IO ()-catBracket devNull inh =-    let readEx = IUF.bracket return (\_ -> hClose inh) FH.read-    in S.fold (FH.write devNull) $ S.unfold readEx inh--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'catBracket--- inspect $ 'catBracket `hasNoType` ''Step--- inspect $ 'catBracket `hasNoType` ''AT.FlattenState--- inspect $ 'catBracket `hasNoType` ''D.ConcatMapUState-#endif--{-# INLINE catBracketIO #-}-catBracketIO :: Handle -> Handle -> IO ()-catBracketIO devNull inh =-    let readEx = IUF.bracketIO return (\_ -> hClose inh) FH.read-    in S.fold (FH.write devNull) $ S.unfold readEx inh---- | Send the file contents to /dev/null with exception handling-{-# INLINE catBracketStream #-}-catBracketStream :: Handle -> Handle -> IO ()-catBracketStream devNull inh =-    let readEx = S.bracket (return ()) (\_ -> hClose inh)-                    (\_ -> IFH.toBytes inh)-    in IFH.fromBytes devNull $ readEx--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'catBracketStream--- inspect $ 'catBracketStream `hasNoType` ''Step-#endif--{-# INLINE catBracketStreamIO #-}-catBracketStreamIO :: Handle -> Handle -> IO ()-catBracketStreamIO devNull inh =-    let readEx = IP.bracketIO (return ()) (\_ -> hClose inh)-                    (\_ -> IFH.toBytes inh)-    in IFH.fromBytes devNull $ readEx---- | Send the file contents to /dev/null with exception handling-{-# INLINE catOnException #-}-catOnException :: Handle -> Handle -> IO ()-catOnException devNull inh =-    let readEx = IUF.onException (\_ -> hClose inh) FH.read-    in S.fold (FH.write devNull) $ S.unfold readEx inh--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'catOnException--- inspect $ 'catOnException `hasNoType` ''Step--- inspect $ 'catOnException `hasNoType` ''AT.FlattenState--- inspect $ 'catOnException `hasNoType` ''D.ConcatMapUState-#endif---- | Send the file contents to /dev/null with exception handling-{-# INLINE catOnExceptionStream #-}-catOnExceptionStream :: Handle -> Handle -> IO ()-catOnExceptionStream devNull inh =-    let readEx = S.onException (hClose inh) (S.unfold FH.read inh)-    in S.fold (FH.write devNull) $ readEx---- | Send the file contents to /dev/null with exception handling-{-# INLINE catFinally #-}-catFinally :: Handle -> Handle -> IO ()-catFinally devNull inh =-    let readEx = IUF.finally (\_ -> hClose inh) FH.read-    in S.fold (FH.write devNull) $ S.unfold readEx inh--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'catFinally--- inspect $ 'catFinally `hasNoType` ''Step--- inspect $ 'catFinally `hasNoType` ''AT.FlattenState--- inspect $ 'catFinally `hasNoType` ''D.ConcatMapUState-#endif--{-# INLINE catFinallyIO #-}-catFinallyIO :: Handle -> Handle -> IO ()-catFinallyIO devNull inh =-    let readEx = IUF.finallyIO (\_ -> hClose inh) FH.read-    in S.fold (FH.write devNull) $ S.unfold readEx inh---- | Send the file contents to /dev/null with exception handling-{-# INLINE catFinallyStream #-}-catFinallyStream :: Handle -> Handle -> IO ()-catFinallyStream devNull inh =-    let readEx = S.finally (hClose inh) (S.unfold FH.read inh)-    in S.fold (FH.write devNull) readEx--{-# INLINE catFinallyStreamIO #-}-catFinallyStreamIO :: Handle -> Handle -> IO ()-catFinallyStreamIO devNull inh =-    let readEx = IP.finallyIO (hClose inh) (S.unfold FH.read inh)-    in S.fold (FH.write devNull) readEx---- | Send the file contents to /dev/null with exception handling-{-# INLINE catHandle #-}-catHandle :: Handle -> Handle -> IO ()-catHandle devNull inh =-    let handler (_e :: SomeException) = hClose inh >> return 10-        readEx = IUF.handle (IUF.singletonM handler) FH.read-    in S.fold (FH.write devNull) $ S.unfold readEx inh--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'catHandle--- inspect $ 'catHandle `hasNoType` ''Step--- inspect $ 'catHandle `hasNoType` ''AT.FlattenState--- inspect $ 'catHandle `hasNoType` ''D.ConcatMapUState-#endif---- | Send the file contents to /dev/null with exception handling-{-# INLINE catHandleStream #-}-catHandleStream :: Handle -> Handle -> IO ()-catHandleStream devNull inh =-    let handler (_e :: SomeException) = S.yieldM (hClose inh >> return 10)-        readEx = S.handle handler (S.unfold FH.read inh)-    in S.fold (FH.write devNull) $ readEx---- | Copy file-{-# INLINE copy #-}-copy :: Handle -> Handle -> IO ()-copy inh outh = S.fold (FH.write outh) (S.unfold FH.read inh)--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'copy-inspect $ 'copy `hasNoType` ''Step-inspect $ 'copy `hasNoType` ''AT.FlattenState-inspect $ 'copy `hasNoType` ''D.ConcatMapUState-#endif--{-# INLINE readWord8 #-}-readWord8 :: Handle -> IO ()-readWord8 inh = S.drain $ S.unfold FH.read inh--{-# INLINE decodeLatin1 #-}-decodeLatin1 :: Handle -> IO ()-decodeLatin1 inh =-   S.drain-     $ SS.decodeLatin1-     $ S.unfold FH.read inh---- | Copy file-{-# INLINE copyCodecChar8 #-}-copyCodecChar8 :: Handle -> Handle -> IO ()-copyCodecChar8 inh outh =-   S.fold (FH.write outh)-     $ SS.encodeLatin1-     $ SS.decodeLatin1-     $ S.unfold FH.read inh--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'copyCodecChar8-inspect $ 'copyCodecChar8 `hasNoType` ''Step-inspect $ 'copyCodecChar8 `hasNoType` ''AT.FlattenState-inspect $ 'copyCodecChar8 `hasNoType` ''D.ConcatMapUState-#endif--{-# INLINE decodeUtf8Lax #-}-decodeUtf8Lax :: Handle -> IO ()-decodeUtf8Lax inh =-   S.drain-     $ SS.decodeUtf8Lax-     $ S.unfold FH.read inh--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'decodeUtf8Lax--- inspect $ 'decodeUtf8Lax `hasNoType` ''Step--- inspect $ 'decodeUtf8Lax `hasNoType` ''AT.FlattenState--- inspect $ 'decodeUtf8Lax `hasNoType` ''D.ConcatMapUState-#endif---- | Copy file-{-# INLINE copyCodecUtf8 #-}-copyCodecUtf8 :: Handle -> Handle -> IO ()-copyCodecUtf8 inh outh =-   S.fold (FH.write outh)-     $ SS.encodeUtf8-     $ SS.decodeUtf8-     $ S.unfold FH.read inh--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'copyCodecUtf8--- inspect $ 'copyCodecUtf8 `hasNoType` ''Step--- inspect $ 'copyCodecUtf8 `hasNoType` ''AT.FlattenState--- inspect $ 'copyCodecUtf8 `hasNoType` ''D.ConcatMapUState-#endif---- | Copy file-{-# INLINE copyCodecUtf8Lenient #-}-copyCodecUtf8Lenient :: Handle -> Handle -> IO ()-copyCodecUtf8Lenient inh outh =-   S.fold (FH.write outh)-     $ SS.encodeUtf8-     $ SS.decodeUtf8Lax-     $ S.unfold FH.read inh--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'copyCodecUtf8Lenient--- inspect $ 'copyCodecUtf8Lenient `hasNoType` ''Step--- inspect $ 'copyCodecUtf8Lenient `hasNoType` ''AT.FlattenState--- inspect $ 'copyCodecUtf8Lenient `hasNoType` ''D.ConcatMapUState-#endif--{-# INLINE chunksOfSum #-}-chunksOfSum :: Int -> Handle -> IO Int-chunksOfSum n inh = S.length $ S.chunksOf n FL.sum (S.unfold FH.read inh)---- | Slice in chunks of size n and get the count of chunks.-{-# INLINE chunksOf #-}-chunksOf :: Int -> Handle -> IO Int-chunksOf n inh =-    -- writeNUnsafe gives 2.5x boost here over writeN.-    S.length $ S.chunksOf n (AT.writeNUnsafe n) (S.unfold FH.read inh)--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'chunksOf-inspect $ 'chunksOf `hasNoType` ''Step-inspect $ 'chunksOf `hasNoType` ''AT.FlattenState-inspect $ 'chunksOf `hasNoType` ''D.ConcatMapUState-inspect $ 'chunksOf `hasNoType` ''GroupState-#endif---- This is to make sure that the concatMap in FH.read, groupsOf and foldlM'--- together can fuse.------ | Slice in chunks of size n and get the count of chunks.-{-# INLINE chunksOfD #-}-chunksOfD :: Int -> Handle -> IO Int-chunksOfD n inh =-    D.foldlM' (\i _ -> return $ i + 1) 0-        $ D.groupsOf n (AT.writeNUnsafe n)-        $ D.fromStreamK (S.unfold FH.read inh)--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'chunksOf-inspect $ 'chunksOf `hasNoType` ''Step-inspect $ 'chunksOfD `hasNoType` ''GroupState-inspect $ 'chunksOfD `hasNoType` ''AT.FlattenState-inspect $ 'chunksOfD `hasNoType` ''D.ConcatMapUState-#endif--{-# INLINE splitParseChunksOfSum #-}-splitParseChunksOfSum :: Int -> Handle -> IO Int-splitParseChunksOfSum n inh =-    S.length $ IP.splitParse (PR.take n FL.sum) (S.unfold FH.read inh)--{-# INLINE linesUnlinesCopy #-}-linesUnlinesCopy :: Handle -> Handle -> IO ()-linesUnlinesCopy inh outh =-    S.fold (FH.write outh)-      $ SS.encodeLatin1-      $ IUS.unlines IUF.fromList-      $ S.splitOnSuffix (== '\n') FL.toList-      $ SS.decodeLatin1-      $ S.unfold FH.read inh--{-# INLINE linesUnlinesArrayWord8Copy #-}-linesUnlinesArrayWord8Copy :: Handle -> Handle -> IO ()-linesUnlinesArrayWord8Copy inh outh =-    S.fold (FH.write outh)-      $ IP.interposeSuffix 10 A.read-      $ S.splitOnSuffix (== 10) A.write-      $ S.unfold FH.read inh---- XXX splitSuffixOn requires -funfolding-use-threshold=150 for better fusion--- | Lines and unlines-{-# INLINE linesUnlinesArrayCharCopy #-}-linesUnlinesArrayCharCopy :: Handle -> Handle -> IO ()-linesUnlinesArrayCharCopy inh outh =-    S.fold (FH.write outh)-      $ SS.encodeLatin1-      $ IUA.unlines-      $ IUA.lines-      $ SS.decodeLatin1-      $ S.unfold FH.read inh--#ifdef INSPECTION-inspect $ hasNoTypeClassesExcept 'linesUnlinesArrayCharCopy [''Storable]--- inspect $ 'linesUnlinesArrayCharCopy `hasNoType` ''Step--- inspect $ 'linesUnlinesArrayCharCopy `hasNoType` ''AT.FlattenState--- inspect $ 'linesUnlinesArrayCharCopy `hasNoType` ''D.ConcatMapUState-#endif---- XXX to write this we need to be able to map decodeUtf8 on the A.read fold.--- For that we have to write decodeUtf8 as a Pipe.-{--{-# INLINE linesUnlinesArrayUtf8Copy #-}-linesUnlinesArrayUtf8Copy :: Handle -> Handle -> IO ()-linesUnlinesArrayUtf8Copy inh outh =-    S.fold (FH.write outh)-      $ SS.encodeLatin1-      $ IP.intercalate (A.fromList [10]) (pipe SS.decodeUtf8P A.read)-      $ S.splitOnSuffix (== '\n') (IFL.lmap SS.encodeUtf8 A.write)-      $ SS.decodeLatin1-      $ S.unfold FH.read inh--}--foreign import ccall unsafe "u_iswspace"-  iswspace :: Int -> Int---- Code copied from base/Data.Char to INLINE it-{-# INLINE isSpace #-}-isSpace                 :: Char -> Bool--- isSpace includes non-breaking space--- The magic 0x377 isn't really that magical. As of 2014, all the codepoints--- at or below 0x377 have been assigned, so we shouldn't have to worry about--- any new spaces appearing below there. It would probably be best to--- use branchless ||, but currently the eqLit transformation will undo that,--- so we'll do it like this until there's a way around that.-isSpace c-  | uc <= 0x377 = uc == 32 || uc - 0x9 <= 4 || uc == 0xa0-  | otherwise = iswspace (ord c) /= 0-  where-    uc = fromIntegral (ord c) :: Word--{-# INLINE isSp #-}-isSp :: Word8 -> Bool-isSp = isSpace . chr . fromIntegral---- | Word, unwords and copy-{-# INLINE wordsUnwordsCopyWord8 #-}-wordsUnwordsCopyWord8 :: Handle -> Handle -> IO ()-wordsUnwordsCopyWord8 inh outh =-    S.fold (FH.write outh)-        $ IP.interposeSuffix 32 IUF.fromList-        $ S.wordsBy isSp FL.toList-        $ S.unfold FH.read inh--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'wordsUnwordsCopyWord8--- inspect $ 'wordsUnwordsCopyWord8 `hasNoType` ''Step--- inspect $ 'wordsUnwordsCopyWord8 `hasNoType` ''D.ConcatMapUState-#endif---- | Word, unwords and copy-{-# INLINE wordsUnwordsCopy #-}-wordsUnwordsCopy :: Handle -> Handle -> IO ()-wordsUnwordsCopy inh outh =-    S.fold (FH.write outh)-      $ SS.encodeLatin1-      $ IUS.unwords IUF.fromList-      -- XXX This pipeline does not fuse with wordsBy but fuses with splitOn-      -- with -funfolding-use-threshold=300.  With wordsBy it does not fuse-      -- even with high limits for inlining and spec-constr ghc options. With-      -- -funfolding-use-threshold=400 it performs pretty well and there-      -- is no evidence in the core that a join point involving Step-      -- constructors is not getting inlined. Not being able to fuse at all in-      -- this case could be an unknown issue, need more investigation.-      $ S.wordsBy isSpace FL.toList-      -- -- $ S.splitOn isSpace FL.toList-      $ SS.decodeLatin1-      $ S.unfold FH.read inh--#ifdef INSPECTION--- inspect $ hasNoTypeClasses 'wordsUnwordsCopy--- inspect $ 'wordsUnwordsCopy `hasNoType` ''Step--- inspect $ 'wordsUnwordsCopy `hasNoType` ''AT.FlattenState--- inspect $ 'wordsUnwordsCopy `hasNoType` ''D.ConcatMapUState-#endif--{-# INLINE wordsUnwordsCharArrayCopy #-}-wordsUnwordsCharArrayCopy :: Handle -> Handle -> IO ()-wordsUnwordsCharArrayCopy inh outh =-    S.fold (FH.write outh)-      $ SS.encodeLatin1-      $ IUA.unwords-      $ IUA.words-      $ SS.decodeLatin1-      $ S.unfold FH.read inh--lf :: Word8-lf = fromIntegral (ord '\n')--toarr :: String -> A.Array Word8-toarr = A.fromList . map (fromIntegral . ord)---- | Split on line feed.-{-# INLINE splitOn #-}-splitOn :: Handle -> IO Int-splitOn inh =-    (S.length $ S.splitOn (== lf) FL.drain-        $ S.unfold FH.read inh) -- >>= print--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'splitOn-inspect $ 'splitOn `hasNoType` ''Step-inspect $ 'splitOn `hasNoType` ''AT.FlattenState-inspect $ 'splitOn `hasNoType` ''D.ConcatMapUState-#endif---- | Split suffix on line feed.-{-# INLINE splitOnSuffix #-}-splitOnSuffix :: Handle -> IO Int-splitOnSuffix inh =-    (S.length $ S.splitOnSuffix (== lf) FL.drain-        $ S.unfold FH.read inh) -- >>= print--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'splitOnSuffix-inspect $ 'splitOnSuffix `hasNoType` ''Step-inspect $ 'splitOnSuffix `hasNoType` ''AT.FlattenState-inspect $ 'splitOnSuffix `hasNoType` ''D.ConcatMapUState-#endif---- | Split on line feed.-{-# INLINE splitParseSepBy #-}-splitParseSepBy :: Handle -> IO Int-splitParseSepBy inh =-    (S.length $ IP.splitParse (PR.sliceSepBy (== lf) FL.drain)-                              (S.unfold FH.read inh)) -- >>= print---- | Words by space-{-# INLINE wordsBy #-}-wordsBy :: Handle -> IO Int-wordsBy inh =-    (S.length $ S.wordsBy isSp FL.drain-        $ S.unfold FH.read inh) -- >>= print--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'wordsBy-inspect $ 'wordsBy `hasNoType` ''Step-inspect $ 'wordsBy `hasNoType` ''AT.FlattenState-inspect $ 'wordsBy `hasNoType` ''D.ConcatMapUState-#endif---- | Split on a word8 sequence.-{-# INLINE splitOnSeq #-}-splitOnSeq :: String -> Handle -> IO Int-splitOnSeq str inh =-    (S.length $ IP.splitOnSeq (toarr str) FL.drain-        $ S.unfold FH.read inh) -- >>= print--#ifdef INSPECTION--- inspect $ hasNoTypeClasses 'splitOnSeq--- inspect $ 'splitOnSeq `hasNoType` ''Step--- inspect $ 'splitOnSeq `hasNoType` ''AT.FlattenState--- inspect $ 'splitOnSeq `hasNoType` ''D.ConcatMapUState-#endif---- | Split on a character sequence.-{-# INLINE splitOnSeqUtf8 #-}-splitOnSeqUtf8 :: String -> Handle -> IO Int-splitOnSeqUtf8 str inh =-    (S.length $ IP.splitOnSeq (A.fromList str) FL.drain-        $ IUS.decodeUtf8ArraysLenient-        $ IFH.toChunks inh) -- >>= print---- | Split on suffix sequence.-{-# INLINE splitOnSuffixSeq #-}-splitOnSuffixSeq :: String -> Handle -> IO Int-splitOnSuffixSeq str inh =-    (S.length $ IP.splitOnSuffixSeq (toarr str) FL.drain-        $ S.unfold FH.read inh) -- >>= print--#ifdef INSPECTION--- inspect $ hasNoTypeClasses 'splitOnSuffixSeq--- inspect $ 'splitOnSuffixSeq `hasNoType` ''Step--- inspect $ 'splitOnSuffixSeq `hasNoType` ''AT.FlattenState--- inspect $ 'splitOnSuffixSeq `hasNoType` ''D.ConcatMapUState-#endif
+ benchmark/Streamly/Benchmark/FileSystem/Handle.hs view
@@ -0,0 +1,56 @@+-- |+-- Module      : Streamly.Benchmark.FileSystem.Handle+-- Copyright   : (c) 2019 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}++#ifdef __HADDOCK_VERSION__+#undef INSPECTION+#endif++#ifdef INSPECTION+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}+#endif++#if __GLASGOW_HASKELL__ >= 800+#endif++import Streamly.Benchmark.Common.Handle (mkHandleBenchEnv)++import qualified Handle.ReadWrite as RW+import qualified Handle.Read as RO++import Gauge hiding (env)+import Prelude hiding (last, length)+import Streamly.Benchmark.Common++-------------------------------------------------------------------------------+--+-------------------------------------------------------------------------------++moduleName :: String+moduleName = "FileSystem.Handle"++-------------------------------------------------------------------------------+--+-------------------------------------------------------------------------------++main :: IO ()+main = do+    env <- mkHandleBenchEnv+    defaultMain (allBenchmarks env)++    where++    allBenchmarks env =+        [ bgroup (o_1_space_prefix moduleName) $ Prelude.concat+            [ RO.allBenchmarks env+            , RW.allBenchmarks env+            ]+        ]
+ benchmark/Streamly/Benchmark/FileSystem/Handle/Read.hs view
@@ -0,0 +1,301 @@+-- |+-- Module      : Streamly.Benchmark.FileSystem.Handle+-- Copyright   : (c) 2019 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}++#ifdef __HADDOCK_VERSION__+#undef INSPECTION+#endif++#ifdef INSPECTION+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}+#endif++module Handle.Read+    (allBenchmarks)+where++import Data.Word (Word8)+import GHC.Magic (inline)+#if __GLASGOW_HASKELL__ >= 802+import GHC.Magic (noinline)+#else+#define noinline+#endif+import System.IO (Handle)++import qualified Streamly.FileSystem.Handle as FH+import qualified Streamly.Internal.Data.Array.Foreign as A+import qualified Streamly.Internal.Data.Array.Foreign.Type as AT+import qualified Streamly.Internal.Data.Fold as FL+import qualified Streamly.Internal.Data.Stream.IsStream as IP+import qualified Streamly.Internal.FileSystem.Handle as IFH+import qualified Streamly.Internal.Unicode.Stream as IUS+import qualified Streamly.Prelude as S+import qualified Streamly.Unicode.Stream as SS++import Gauge hiding (env)+import Prelude hiding (last, length)+import Streamly.Benchmark.Common.Handle++#ifdef INSPECTION+import Streamly.Internal.Data.Stream.StreamD.Type (Step(..), FoldMany)++import qualified Streamly.Internal.Data.Array.Foreign.Mut.Type as MA+import qualified Streamly.Internal.Data.Stream.StreamD as D+import qualified Streamly.Internal.Data.Unfold as IUF++import Test.Inspection+#endif++-- TBD reading with unfold++-------------------------------------------------------------------------------+-- unfold read+-------------------------------------------------------------------------------++-- | Get the last byte from a file bytestream.+readLast :: Handle -> IO (Maybe Word8)+readLast = S.last . S.unfold FH.read++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'readLast+inspect $ 'readLast `hasNoType` ''Step -- S.unfold+inspect $ 'readLast `hasNoType` ''IUF.ConcatState -- FH.read/UF.many+inspect $ 'readLast `hasNoType` ''MA.ReadUState  -- FH.read/A.read+#endif++-- assert that flattenArrays constructors are not present+-- | Count the number of bytes in a file.+readCountBytes :: Handle -> IO Int+readCountBytes = S.length . S.unfold FH.read++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'readCountBytes+inspect $ 'readCountBytes `hasNoType` ''Step -- S.unfold+inspect $ 'readCountBytes `hasNoType` ''IUF.ConcatState -- FH.read/UF.many+inspect $ 'readCountBytes `hasNoType` ''MA.ReadUState  -- FH.read/A.read+#endif++-- | Count the number of lines in a file.+readCountLines :: Handle -> IO Int+readCountLines =+    S.length+        . IUS.lines FL.drain+        . SS.decodeLatin1+        . S.unfold FH.read++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'readCountLines+inspect $ 'readCountLines `hasNoType` ''Step+inspect $ 'readCountLines `hasNoType` ''IUF.ConcatState -- FH.read/UF.many+inspect $ 'readCountLines `hasNoType` ''MA.ReadUState  -- FH.read/A.read+#endif++-- | Count the number of words in a file.+readCountWords :: Handle -> IO Int+readCountWords =+    S.length+        . IUS.words FL.drain+        . SS.decodeLatin1+        . S.unfold FH.read++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'readCountWords+-- inspect $ 'readCountWords `hasNoType` ''Step+#endif++-- | Sum the bytes in a file.+readSumBytes :: Handle -> IO Word8+readSumBytes = S.sum . S.unfold FH.read++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'readSumBytes+inspect $ 'readSumBytes `hasNoType` ''Step+inspect $ 'readSumBytes `hasNoType` ''IUF.ConcatState -- FH.read/UF.many+inspect $ 'readSumBytes `hasNoType` ''MA.ReadUState  -- FH.read/A.read+#endif++-- XXX When we mark this with INLINE and we have two benchmarks using S.drain+-- in one benchmark group then somehow GHC ends up delaying the inlining of+-- readDrain. Since S.drain has an INLINE[2] for proper rule firing, that does+-- not work well because of delyaed inlining and the code does not fuse. We+-- need some way of propagating the inline phase information up so that we can+-- expedite inlining of the callers too automatically. The minimal example for+-- the problem can be created by using just two benchmarks in a bench group+-- both using "readDrain". Either GHC should be fixed or we can use+-- fusion-plugin to propagate INLINE phase information such that this problem+-- does not occur.+readDrain :: Handle -> IO ()+readDrain inh = S.drain $ S.unfold FH.read inh++-- XXX investigate why we need an INLINE in this case (GHC)+{-# INLINE readDecodeLatin1 #-}+readDecodeLatin1 :: Handle -> IO ()+readDecodeLatin1 inh =+   S.drain+     $ SS.decodeLatin1+     $ S.unfold FH.read inh++readDecodeUtf8 :: Handle -> IO ()+readDecodeUtf8 inh =+   S.drain+     $ SS.decodeUtf8+     $ S.unfold FH.read inh++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'readDecodeUtf8+-- inspect $ 'readDecodeUtf8Lax `hasNoType` ''Step+#endif++o_1_space_reduce_read :: BenchEnv -> [Benchmark]+o_1_space_reduce_read env =+    [ bgroup "reduce/read"+        [ -- read raw bytes without any decoding+          mkBench "S.drain" env $ \inh _ ->+            readDrain inh+        , mkBench "S.last" env $ \inh _ ->+            readLast inh+        , mkBench "S.sum" env $ \inh _ ->+            readSumBytes inh++        -- read with Latin1 decoding+        , mkBench "SS.decodeLatin1" env $ \inh _ ->+            readDecodeLatin1 inh+        , mkBench "S.length" env $ \inh _ ->+            readCountBytes inh+        , mkBench "US.lines . SS.decodeLatin1" env $ \inh _ ->+            readCountLines inh+        , mkBench "US.words . SS.decodeLatin1" env $ \inh _ ->+            readCountWords inh++        -- read with utf8 decoding+        , mkBenchSmall "SS.decodeUtf8" env $ \inh _ ->+            readDecodeUtf8 inh+        ]+    ]++-------------------------------------------------------------------------------+-- stream toBytes+-------------------------------------------------------------------------------++-- | Count the number of lines in a file.+toChunksConcatUnfoldCountLines :: Handle -> IO Int+toChunksConcatUnfoldCountLines inh =+    S.length+        $ IUS.lines FL.drain+        $ SS.decodeLatin1+        -- XXX replace with toBytes+        $ S.unfoldMany A.read (IFH.toChunks inh)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'toChunksConcatUnfoldCountLines+inspect $ 'toChunksConcatUnfoldCountLines `hasNoType` ''Step+inspect $ 'toChunksConcatUnfoldCountLines `hasNoType` ''D.ConcatMapUState+#endif++o_1_space_reduce_toBytes :: BenchEnv -> [Benchmark]+o_1_space_reduce_toBytes env =+    [ bgroup "reduce/toBytes"+        [ mkBench "US.lines . SS.decodeLatin1" env $ \inh _ ->+            toChunksConcatUnfoldCountLines inh+        ]+    ]++-------------------------------------------------------------------------------+-- reduce after grouping in chunks+-------------------------------------------------------------------------------++chunksOfSum :: Int -> Handle -> IO Int+chunksOfSum n inh = S.length $ S.chunksOf n FL.sum (S.unfold FH.read inh)++foldManyPostChunksOfSum :: Int -> Handle -> IO Int+foldManyPostChunksOfSum n inh =+    S.length $ IP.foldManyPost (FL.take n FL.sum) (S.unfold FH.read inh)++foldManyChunksOfSum :: Int -> Handle -> IO Int+foldManyChunksOfSum n inh =+    S.length $ IP.foldMany (FL.take n FL.sum) (S.unfold FH.read inh)++-- XXX investigate why we need an INLINE in this case (GHC)+-- Even though allocations remain the same in both cases inlining improves time+-- by 4x.+-- | Slice in chunks of size n and get the count of chunks.+{-# INLINE chunksOf #-}+chunksOf :: Int -> Handle -> IO Int+chunksOf n inh =+    -- writeNUnsafe gives 2.5x boost here over writeN.+    S.length $ S.chunksOf n (AT.writeNUnsafe n) (S.unfold FH.read inh)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'chunksOf+inspect $ 'chunksOf `hasNoType` ''Step+inspect $ 'chunksOf `hasNoType` ''FoldMany+inspect $ 'chunksOf `hasNoType` ''AT.ArrayUnsafe -- AT.writeNUnsafe+inspect $ 'chunksOf `hasNoType` ''IUF.ConcatState -- FH.read/UF.many+inspect $ 'chunksOf `hasNoType` ''MA.ReadUState  -- FH.read/A.read+#endif++{-# INLINE arraysOf #-}+arraysOf :: Int -> Handle -> IO Int+arraysOf n inh = S.length $ IP.arraysOf n (S.unfold FH.read inh)++o_1_space_reduce_read_grouped :: BenchEnv -> [Benchmark]+o_1_space_reduce_read_grouped env =+    [ bgroup "reduce/read/chunks"+        [ mkBench ("S.chunksOf " ++ show (bigSize env) ++  " FL.sum") env $+            \inh _ ->+                chunksOfSum (bigSize env) inh+        , mkBench "S.chunksOf 1 FL.sum" env $ \inh _ ->+            chunksOfSum 1 inh++        -- XXX investigate why we need inline/noinline in these cases (GHC)+        -- Chunk using parsers+        , mkBench+            ("S.foldManyPost (FL.take " ++ show (bigSize env) ++ " FL.sum)")+            env+            $ \inh _ -> noinline foldManyPostChunksOfSum (bigSize env) inh+        , mkBench+            "S.foldManyPost (FL.take 1 FL.sum)"+            env+            $ \inh _ -> inline foldManyPostChunksOfSum 1 inh+        , mkBench+            ("S.foldMany (FL.take " ++ show (bigSize env) ++ " FL.sum)")+            env+            $ \inh _ -> noinline foldManyChunksOfSum (bigSize env) inh+        , mkBench+            "S.foldMany (FL.take 1 FL.sum)"+            env+            $ \inh _ -> inline foldManyChunksOfSum 1 inh++        -- folding chunks to arrays+        , mkBenchSmall "S.chunksOf 1" env $ \inh _ ->+            chunksOf 1 inh+        , mkBench "S.chunksOf 10" env $ \inh _ ->+            chunksOf 10 inh+        , mkBench "S.chunksOf 1000" env $ \inh _ ->+            chunksOf 1000 inh++        -- arraysOf may use a different impl than chunksOf+        , mkBenchSmall "S.arraysOf 1" env $ \inh _ ->+            arraysOf 1 inh+        , mkBench "S.arraysOf 10" env $ \inh _ ->+            arraysOf 10 inh+        , mkBench "S.arraysOf 1000" env $ \inh _ ->+            arraysOf 1000 inh+        ]+    ]++allBenchmarks :: BenchEnv -> [Benchmark]+allBenchmarks env = Prelude.concat+    [ o_1_space_reduce_read env+    , o_1_space_reduce_toBytes env+    , o_1_space_reduce_read_grouped env+    ]
+ benchmark/Streamly/Benchmark/FileSystem/Handle/ReadWrite.hs view
@@ -0,0 +1,217 @@+-- |+-- Module      : Streamly.Benchmark.FileSystem.Handle+-- Copyright   : (c) 2019 Composewell Technologies+-- License     : BSD3-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}++#ifdef __HADDOCK_VERSION__+#undef INSPECTION+#endif++#ifdef INSPECTION+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}+#endif++module Handle.ReadWrite+    (allBenchmarks)+where++import System.IO (Handle)+import Prelude hiding (last, length)+import Streamly.Internal.Data.Array.Foreign.Type (defaultChunkSize)++import qualified Streamly.FileSystem.Handle as FH+import qualified Streamly.Internal.Data.Unfold as IUF+import qualified Streamly.Internal.FileSystem.Handle as IFH+import qualified Streamly.Data.Array.Foreign as A+import qualified Streamly.Prelude as S++import Gauge hiding (env)+import Streamly.Benchmark.Common.Handle++#ifdef INSPECTION+import Streamly.Internal.Data.Stream.StreamD.Type (Step(..))++import qualified Streamly.Internal.Data.Stream.StreamD.Type as D+import qualified Streamly.Internal.Data.Tuple.Strict as Strict+import qualified Streamly.Internal.Data.Array.Stream.Mut.Foreign as MAS+import qualified Streamly.Internal.Data.Array.Foreign.Type as AT+import qualified Streamly.Internal.Data.Array.Foreign.Mut.Type as MA++import Test.Inspection+#endif++-------------------------------------------------------------------------------+-- copy chunked+-------------------------------------------------------------------------------++-- | Copy file+copyChunks :: Handle -> Handle -> IO ()+copyChunks inh outh = S.fold (IFH.writeChunks outh) $ IFH.toChunks inh++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'copyChunks+inspect $ 'copyChunks `hasNoType` ''Step+#endif++o_1_space_copy_chunked :: BenchEnv -> [Benchmark]+o_1_space_copy_chunked env =+    [ bgroup "copy/toChunks"+        [ mkBench "toNull" env $ \inH _ ->+            copyChunks inH (nullH env)+        , mkBench "raw" env $ \inH outH ->+            copyChunks inH outH+        ]+    ]++-------------------------------------------------------------------------------+-- copy unfold+-------------------------------------------------------------------------------++-- | Copy file+copyStream :: Handle -> Handle -> IO ()+copyStream inh outh = S.fold (FH.write outh) (S.unfold FH.read inh)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'copyStream+inspect $ 'copyStream `hasNoType` ''Step -- S.unfold+inspect $ 'copyStream `hasNoType` ''IUF.ConcatState -- FH.read/UF.many+inspect $ 'copyStream `hasNoType` ''MA.ReadUState  -- FH.read/A.read+inspect $ 'copyStream `hasNoType` ''AT.ArrayUnsafe -- FH.write/writeNUnsafe+inspect $ 'copyStream `hasNoType` ''Strict.Tuple3' -- FH.write/chunksOf+#endif++o_1_space_copy_read :: BenchEnv -> [Benchmark]+o_1_space_copy_read env =+    [ bgroup "copy/read"+        [ mkBench "rawToNull" env $ \inh _ ->+            copyStream inh (nullH env)+        , mkBench "rawToFile" env $ \inh outh ->+            copyStream inh outh+        ]+    ]++-------------------------------------------------------------------------------+-- copy stream+-------------------------------------------------------------------------------++-- | Send the file contents to /dev/null+readFromBytesNull :: Handle -> Handle -> IO ()+readFromBytesNull inh devNull = IFH.putBytes devNull $ S.unfold FH.read inh++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'readFromBytesNull+inspect $ 'readFromBytesNull `hasNoType` ''Step+inspect $ 'readFromBytesNull `hasNoType` ''MAS.SpliceState+inspect $ 'readFromBytesNull `hasNoType` ''AT.ArrayUnsafe -- FH.fromBytes/S.arraysOf+inspect $ 'readFromBytesNull `hasNoType` ''D.FoldMany+#endif++-- | Send the file contents ('defaultChunkSize') to /dev/null+readWithBufferOfFromBytesNull :: Handle -> Handle -> IO ()+readWithBufferOfFromBytesNull inh devNull =+    IFH.putBytes devNull+        $ S.unfold FH.readWithBufferOf (defaultChunkSize, inh)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'readWithBufferOfFromBytesNull+inspect $ 'readWithBufferOfFromBytesNull `hasNoType` ''Step+inspect $ 'readWithBufferOfFromBytesNull `hasNoType` ''MAS.SpliceState+inspect $ 'readWithBufferOfFromBytesNull `hasNoType` ''AT.ArrayUnsafe -- FH.fromBytes/S.arraysOf+inspect $ 'readWithBufferOfFromBytesNull `hasNoType` ''D.FoldMany+#endif++-- | Send the chunk content ('defaultChunkSize') to /dev/null+-- Implicitly benchmarked via 'readFromBytesNull'+_readChunks :: Handle -> Handle -> IO ()+_readChunks inh devNull = IUF.fold fld unf inh++    where++    fld = FH.write devNull+    unf = IUF.many FH.readChunks A.read++-- | Send the chunk content to /dev/null+-- Implicitly benchmarked via 'readWithBufferOfFromBytesNull'+_readChunksWithBufferOf :: Handle -> Handle -> IO ()+_readChunksWithBufferOf inh devNull = IUF.fold fld unf (defaultChunkSize, inh)++    where++    fld = FH.write devNull+    unf = IUF.many FH.readChunksWithBufferOf A.read+++o_1_space_copy_fromBytes :: BenchEnv -> [Benchmark]+o_1_space_copy_fromBytes env =+    [ bgroup "copy/putBytes"+        [ mkBench "rawToNull" env $ \inh _ ->+            readFromBytesNull inh (nullH env)+        , mkBench "FH.readWithBufferOf" env $ \inh _ ->+            readWithBufferOfFromBytesNull inh (nullH env)+        ]+    ]++-- | Send the file contents ('defaultChunkSize') to /dev/null+{-# NOINLINE writeReadWithBufferOf #-}+writeReadWithBufferOf :: Handle -> Handle -> IO ()+writeReadWithBufferOf inh devNull = IUF.fold fld unf (defaultChunkSize, inh)++    where++    fld = FH.writeWithBufferOf defaultChunkSize devNull+    unf = FH.readWithBufferOf++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'writeReadWithBufferOf+inspect $ 'writeReadWithBufferOf `hasNoType` ''Step+inspect $ 'writeReadWithBufferOf `hasNoType` ''IUF.ConcatState -- FH.read/UF.many+inspect $ 'writeReadWithBufferOf `hasNoType` ''MA.ReadUState  -- FH.read/A.read+inspect $ 'writeReadWithBufferOf `hasNoType` ''AT.ArrayUnsafe -- FH.write/writeNUnsafe+#endif++-- | Send the file contents ('AT.defaultChunkSize') to /dev/null+{-# NOINLINE writeRead #-}+writeRead :: Handle -> Handle -> IO ()+writeRead inh devNull = IUF.fold fld unf inh++    where++    fld = FH.write devNull+    unf = FH.read++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'writeRead+inspect $ 'writeRead `hasNoType` ''Step+inspect $ 'writeRead `hasNoType` ''IUF.ConcatState -- FH.read/UF.many+inspect $ 'writeRead `hasNoType` ''MA.ReadUState  -- FH.read/A.read+inspect $ 'writeRead `hasNoType` ''AT.ArrayUnsafe -- FH.write/writeNUnsafe+#endif++o_1_space_copy :: BenchEnv -> [Benchmark]+o_1_space_copy env =+    [ bgroup "copy"+        [ mkBench "FH.write . FH.read" env $ \inh _ ->+            writeRead inh (nullH env)+        , mkBench "FH.writeWithBufferOf . FH.readWithBufferOf" env $ \inh _ ->+            writeReadWithBufferOf inh (nullH env)+        ]+    ]++-------------------------------------------------------------------------------+--+-------------------------------------------------------------------------------++allBenchmarks :: BenchEnv -> [Benchmark]+allBenchmarks env = Prelude.concat+    [ o_1_space_copy_chunked env+    , o_1_space_copy_read env+    , o_1_space_copy_fromBytes env+    , o_1_space_copy env+    ]
− benchmark/Streamly/Benchmark/Memory/Array.hs 
@@ -1,251 +0,0 @@-{-# LANGUAGE CPP #-}--- |--- Module      : Main--- Copyright   : (c) 2018 Harendra Kumar------ License     : BSD3--- Maintainer  : streamly@composewell.com--import Control.DeepSeq (NFData(..), deepseq)-import Foreign.Storable (Storable(..))-import System.Random (randomRIO)--import qualified GHC.Exts as GHC--import qualified Streamly.Benchmark.Memory.ArrayOps as Ops-import qualified Streamly.Internal.Memory.Array as IA-import qualified Streamly.Memory.Array as A-import qualified Streamly.Prelude as S--import Gauge----------------------------------------------------------------------------------------------------------------------------------------------------------------------{-# INLINE benchPure #-}-benchPure :: NFData b => String -> (Int -> a) -> (a -> b) -> Benchmark-benchPure name src f = bench name $ nfIO $-    randomRIO (1,1) >>= return . f . src---- Drain a source that generates a pure array-{-# INLINE benchPureSrc #-}-benchPureSrc :: (NFData a, Storable a)-    => String -> (Int -> Ops.Stream a) -> Benchmark-benchPureSrc name src = benchPure name src id--{-# INLINE benchIO #-}-benchIO :: NFData b => String -> (Int -> IO a) -> (a -> b) -> Benchmark-benchIO name src f = bench name $ nfIO $-    randomRIO (1,1) >>= src >>= return . f---- Drain a source that generates an array in the IO monad-{-# INLINE benchIOSrc #-}-benchIOSrc :: (NFData a, Storable a)-    => String -> (Int -> IO (Ops.Stream a)) -> Benchmark-benchIOSrc name src = benchIO name src id--{-# INLINE benchPureSink #-}-benchPureSink :: NFData b => String -> (Ops.Stream Int -> b) -> Benchmark-benchPureSink name f = benchIO name Ops.sourceIntFromTo f--{-# INLINE benchIO' #-}-benchIO' :: NFData b => String -> (Int -> IO a) -> (a -> IO b) -> Benchmark-benchIO' name src f = bench name $ nfIO $-    randomRIO (1,1) >>= src >>= f--{-# INLINE benchIOSink #-}-benchIOSink :: NFData b => String -> (Ops.Stream Int -> IO b) -> Benchmark-benchIOSink name f = benchIO' name Ops.sourceIntFromTo f--mkString :: String-mkString = "[1" ++ concat (replicate Ops.value ",1") ++ "]"--main :: IO ()-main =-  defaultMain-    [ bgroup "array"-     [  bgroup "generation"-        [ benchIOSrc "writeN . intFromTo" Ops.sourceIntFromTo-        , benchIOSrc "write . intFromTo" Ops.sourceIntFromToFromStream-        , benchIOSrc "fromList . intFromTo" Ops.sourceIntFromToFromList-        , benchIOSrc "writeN . unfoldr" Ops.sourceUnfoldr-        , benchIOSrc "writeN . fromList" Ops.sourceFromList-        , benchPureSrc "writeN . IsList.fromList" Ops.sourceIsList-        , benchPureSrc "writeN . IsString.fromString" Ops.sourceIsString-        , mkString `deepseq` (bench "read" $ nf Ops.readInstance mkString)-        , benchPureSink "show" Ops.showInstance-        ]-      , bgroup "elimination"-        [ benchPureSink "id" id-        -- , benchPureSink "eqBy" Ops.eqBy-        , benchPureSink "==" Ops.eqInstance-        , benchPureSink "/=" Ops.eqInstanceNotEq-        {--        , benchPureSink "cmpBy" Ops.cmpBy-        -}-        , benchPureSink "<" Ops.ordInstance-        , benchPureSink "min" Ops.ordInstanceMin-        -- length is used to check for foldr/build fusion-        , benchPureSink "length . IsList.toList" (length . GHC.toList)-        , benchIOSink "foldl'" Ops.pureFoldl'-        , benchIOSink "read" (S.drain . S.unfold A.read)-        , benchIOSink "toStreamRev" (S.drain . IA.toStreamRev)-#ifdef DEVBUILD-        , benchPureSink "foldable/foldl'" Ops.foldableFoldl'-        , benchPureSink "foldable/sum" Ops.foldableSum-        -- , benchPureSinkIO "traversable/mapM" Ops.traversableMapM-#endif-        ]--        {--        [ benchPureSink "uncons" Ops.uncons-        , benchPureSink "toNull" $ Ops.toNull serially-        , benchPureSink "mapM_" Ops.mapM_--        , benchPureSink "init" Ops.init-        , benchPureSink "tail" Ops.tail-        , benchPureSink "nullHeadTail" Ops.nullHeadTail--        -- this is too low and causes all benchmarks reported in ns-        -- , benchPureSink "head" Ops.head-        , benchPureSink "last" Ops.last-        -- , benchPureSink "lookup" Ops.lookup-        , benchPureSink "find" Ops.find-        , benchPureSink "findIndex" Ops.findIndex-        , benchPureSink "elemIndex" Ops.elemIndex--        -- this is too low and causes all benchmarks reported in ns-        -- , benchPureSink "null" Ops.null-        , benchPureSink "elem" Ops.elem-        , benchPureSink "notElem" Ops.notElem-        , benchPureSink "all" Ops.all-        , benchPureSink "any" Ops.any-        , benchPureSink "and" Ops.and-        , benchPureSink "or" Ops.or--        , benchPureSink "length" Ops.length-        , benchPureSink "sum" Ops.sum-        , benchPureSink "product" Ops.product--        , benchPureSink "maximumBy" Ops.maximumBy-        , benchPureSink "maximum" Ops.maximum-        , benchPureSink "minimumBy" Ops.minimumBy-        , benchPureSink "minimum" Ops.minimum--        , benchPureSink "toList" Ops.toList-        , benchPureSink "toRevList" Ops.toRevList-        ]-        -}-      , bgroup "transformation"-        [ benchIOSink "scanl'" (Ops.scanl' 1)-        , benchIOSink "scanl1'" (Ops.scanl1' 1)-        , benchIOSink "map" (Ops.map 1)-        {--        , benchPureSink "fmap" (Ops.fmap 1)-        , benchPureSink "mapM" (Ops.mapM serially 1)-        , benchPureSink "mapMaybe" (Ops.mapMaybe 1)-        , benchPureSink "mapMaybeM" (Ops.mapMaybeM 1)-        , bench "sequence" $ nfIO $ randomRIO (1,1000) >>= \n ->-            Ops.sequence serially (Ops.sourceUnfoldrMAction n)-        , benchPureSink "findIndices" (Ops.findIndices 1)-        , benchPureSink "elemIndices" (Ops.elemIndices 1)-        , benchPureSink "reverse" (Ops.reverse 1)-        , benchPureSink "foldrS" (Ops.foldrS 1)-        , benchPureSink "foldrSMap" (Ops.foldrSMap 1)-        , benchPureSink "foldrT" (Ops.foldrT 1)-        , benchPureSink "foldrTMap" (Ops.foldrTMap 1)-        -}-        ]-      , bgroup "transformationX4"-        [ benchIOSink "scanl'" (Ops.scanl' 4)-        , benchIOSink "scanl1'" (Ops.scanl1' 4)-        , benchIOSink "map" (Ops.map 4)-        {--        , benchPureSink "fmap" (Ops.fmap 4)-        , benchPureSink "mapM" (Ops.mapM serially 4)-        , benchPureSink "mapMaybe" (Ops.mapMaybe 4)-        , benchPureSink "mapMaybeM" (Ops.mapMaybeM 4)-        -- , bench "sequence" $ nfIO $ randomRIO (1,1000) >>= \n ->-            -- Ops.sequence serially (Ops.sourceUnfoldrMAction n)-        , benchPureSink "findIndices" (Ops.findIndices 4)-        , benchPureSink "elemIndices" (Ops.elemIndices 4)-        -}-        ]-        {--      , bgroup "filtering"-        [ benchPureSink "filter-even"     (Ops.filterEven 1)-        , benchPureSink "filter-all-out"  (Ops.filterAllOut 1)-        , benchPureSink "filter-all-in"   (Ops.filterAllIn 1)-        , benchPureSink "take-all"        (Ops.takeAll 1)-        , benchPureSink "takeWhile-true"  (Ops.takeWhileTrue 1)-        --, benchPureSink "takeWhileM-true" (Ops.takeWhileMTrue 1)-        , benchPureSink "drop-one"        (Ops.dropOne 1)-        , benchPureSink "drop-all"        (Ops.dropAll 1)-        , benchPureSink "dropWhile-true"  (Ops.dropWhileTrue 1)-        --, benchPureSink "dropWhileM-true" (Ops.dropWhileMTrue 1)-        , benchPureSink "dropWhile-false" (Ops.dropWhileFalse 1)-        , benchPureSink "deleteBy" (Ops.deleteBy 1)-        , benchPureSink "insertBy" (Ops.insertBy 1)-        ]-      , bgroup "filteringX4"-        [ benchPureSink "filter-even"     (Ops.filterEven 4)-        , benchPureSink "filter-all-out"  (Ops.filterAllOut 4)-        , benchPureSink "filter-all-in"   (Ops.filterAllIn 4)-        , benchPureSink "take-all"        (Ops.takeAll 4)-        , benchPureSink "takeWhile-true"  (Ops.takeWhileTrue 4)-        --, benchPureSink "takeWhileM-true" (Ops.takeWhileMTrue 4)-        , benchPureSink "drop-one"        (Ops.dropOne 4)-        , benchPureSink "drop-all"        (Ops.dropAll 4)-        , benchPureSink "dropWhile-true"  (Ops.dropWhileTrue 4)-        --, benchPureSink "dropWhileM-true" (Ops.dropWhileMTrue 4)-        , benchPureSink "dropWhile-false" (Ops.dropWhileFalse 4)-        , benchPureSink "deleteBy" (Ops.deleteBy 4)-        , benchPureSink "insertBy" (Ops.insertBy 4)-        ]-      , bgroup "multi-stream"-        [ benchPureSink "eqBy" Ops.eqBy-        , benchPureSink "cmpBy" Ops.cmpBy-        , benchPureSink "zip" Ops.zip-        , benchPureSink "zipM" Ops.zipM-        , benchPureSink "mergeBy" Ops.mergeBy-        , benchPureSink "isPrefixOf" Ops.isPrefixOf-        , benchPureSink "isSubsequenceOf" Ops.isSubsequenceOf-        , benchPureSink "stripPrefix" Ops.stripPrefix-        , benchPureSrc  serially "concatMap" Ops.concatMap-        ]-    -- scanl-map and foldl-map are equivalent to the scan and fold in the foldl-    -- library. If scan/fold followed by a map is efficient enough we may not-    -- need monolithic implementations of these.-    , bgroup "mixed"-      [ benchPureSink "scanl-map" (Ops.scanMap 1)-      , benchPureSink "foldl-map" Ops.foldl'ReduceMap-      , benchPureSink "sum-product-fold"  Ops.sumProductFold-      , benchPureSink "sum-product-scan"  Ops.sumProductScan-      ]-    , bgroup "mixedX4"-      [ benchPureSink "scan-map"    (Ops.scanMap 4)-      , benchPureSink "drop-map"    (Ops.dropMap 4)-      , benchPureSink "drop-scan"   (Ops.dropScan 4)-      , benchPureSink "take-drop"   (Ops.takeDrop 4)-      , benchPureSink "take-scan"   (Ops.takeScan 4)-      , benchPureSink "take-map"    (Ops.takeMap 4)-      , benchPureSink "filter-drop" (Ops.filterDrop 4)-      , benchPureSink "filter-take" (Ops.filterTake 4)-      , benchPureSink "filter-scan" (Ops.filterScan 4)-      , benchPureSink "filter-scanl1" (Ops.filterScanl1 4)-      , benchPureSink "filter-map"  (Ops.filterMap 4)-      ]-    , bgroup "iterated"-      [ benchPureSrc serially "mapM"           Ops.iterateMapM-      , benchPureSrc serially "scan(1/100)"    Ops.iterateScan-      , benchPureSrc serially "scanl1(1/100)"  Ops.iterateScanl1-      , benchPureSrc serially "filterEven"     Ops.iterateFilterEven-      , benchPureSrc serially "takeAll"        Ops.iterateTakeAll-      , benchPureSrc serially "dropOne"        Ops.iterateDropOne-      , benchPureSrc serially "dropWhileFalse" Ops.iterateDropWhileFalse-      , benchPureSrc serially "dropWhileTrue"  Ops.iterateDropWhileTrue-      ]-      -}-    ]-    ]
− benchmark/Streamly/Benchmark/Memory/ArrayOps.hs 
@@ -1,531 +0,0 @@--- |--- Module      : ArrayOps--- Copyright   : (c) 2018 Harendra Kumar------ License     : MIT--- Maintainer  : streamly@composewell.com--{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}--module Streamly.Benchmark.Memory.ArrayOps where---- import Control.Monad (when)-import Control.Monad.IO.Class (MonadIO)--- import Data.Maybe (fromJust)-import Prelude (Int, Bool, (+), ($), (==), (>), (.), Maybe(..), undefined)-import qualified Prelude as P-#ifdef DEVBUILD-import qualified Data.Foldable as F-#endif-import qualified GHC.Exts as GHC--- import Control.DeepSeq (NFData)--- import GHC.Generics (Generic)--import qualified Streamly           as S hiding (foldMapWith, runStream)-import qualified Streamly.Memory.Array as A-import qualified Streamly.Prelude   as S--value, maxValue :: Int-#ifdef LINEAR_ASYNC-value = 10000-#else-value = 100000-#endif-maxValue = value + 1------------------------------------------------------------------------------------ Benchmark ops-------------------------------------------------------------------------------------------------------------------------------------------------------------------- Stream generation and elimination----------------------------------------------------------------------------------type Stream = A.Array--{-# INLINE sourceUnfoldr #-}-sourceUnfoldr :: MonadIO m => Int -> m (Stream Int)-sourceUnfoldr n = S.fold (A.writeN value) $ S.unfoldr step n-    where-    step cnt =-        if cnt > n + value-        then Nothing-        else (Just (cnt, cnt + 1))--{-# INLINE sourceIntFromTo #-}-sourceIntFromTo :: MonadIO m => Int -> m (Stream Int)-sourceIntFromTo n = S.fold (A.writeN value) $ S.enumerateFromTo n (n + value)--{-# INLINE sourceIntFromToFromStream #-}-sourceIntFromToFromStream :: MonadIO m => Int -> m (Stream Int)-sourceIntFromToFromStream n = S.fold A.write $ S.enumerateFromTo n (n + value)--sourceIntFromToFromList :: MonadIO m => Int -> m (Stream Int)-sourceIntFromToFromList n = P.return $ A.fromList $ [n..n + value]--{-# INLINE sourceFromList #-}-sourceFromList :: MonadIO m => Int -> m (Stream Int)-sourceFromList n = S.fold (A.writeN value) $ S.fromList [n..n+value]--{-# INLINE sourceIsList #-}-sourceIsList :: Int -> Stream Int-sourceIsList n = GHC.fromList [n..n+value]--{-# INLINE sourceIsString #-}-sourceIsString :: Int -> Stream P.Char-sourceIsString n = GHC.fromString (P.replicate (n + value) 'a')--{------------------------------------------------------------------------------------ Elimination----------------------------------------------------------------------------------{-# INLINE runStream #-}-runStream :: Monad m => Stream m a -> m ()-runStream = S.runStream--{-# INLINE toList #-}-toList :: Monad m => Stream m Int -> m [Int]--{-# INLINE head #-}-{-# INLINE last #-}-{-# INLINE maximum #-}-{-# INLINE minimum #-}-{-# INLINE find #-}-{-# INLINE findIndex #-}-{-# INLINE elemIndex #-}-{-# INLINE foldl1'Reduce #-}-head, last, minimum, maximum, find, findIndex, elemIndex, foldl1'Reduce-    :: Monad m => Stream m Int -> m (Maybe Int)--{-# INLINE minimumBy #-}-{-# INLINE maximumBy #-}-minimumBy, maximumBy :: Monad m => Stream m Int -> m (Maybe Int)--{-# INLINE foldl'Reduce #-}-{-# INLINE foldl'ReduceMap #-}-{-# INLINE foldlM'Reduce #-}-{-# INLINE foldrMReduce #-}-{-# INLINE length #-}-{-# INLINE sum #-}-{-# INLINE product #-}-foldl'Reduce, foldl'ReduceMap, foldlM'Reduce, foldrMReduce, length, sum, product-    :: Monad m-    => Stream m Int -> m Int--{-# INLINE foldl'Build #-}-{-# INLINE foldlM'Build #-}-{-# INLINE foldrMBuild #-}-foldrMBuild, foldl'Build, foldlM'Build-    :: Monad m-    => Stream m Int -> m [Int]--{-# INLINE all #-}-{-# INLINE any #-}-{-# INLINE and #-}-{-# INLINE or #-}-{-# INLINE null #-}-{-# INLINE elem #-}-{-# INLINE notElem #-}-null, elem, notElem, all, any, and, or :: Monad m => Stream m Int -> m Bool--{-# INLINE toNull #-}-toNull :: Monad m => (t m a -> S.SerialT m a) -> t m a -> m ()-toNull t = runStream . t--{-# INLINE uncons #-}-uncons :: Monad m => Stream m Int -> m ()-uncons s = do-    r <- S.uncons s-    case r of-        Nothing -> return ()-        Just (_, t) -> uncons t--{-# INLINE init #-}-init :: Monad m => Stream m a -> m ()-init s = S.init s >>= Prelude.mapM_ S.runStream--{-# INLINE tail #-}-tail :: Monad m => Stream m a -> m ()-tail s = S.tail s >>= Prelude.mapM_ tail--{-# INLINE nullHeadTail #-}-nullHeadTail :: Monad m => Stream m Int -> m ()-nullHeadTail s = do-    r <- S.null s-    when (not r) $ do-        _ <- S.head s-        S.tail s >>= Prelude.mapM_ nullHeadTail--{-# INLINE mapM_ #-}-mapM_ :: Monad m => Stream m Int -> m ()-mapM_  = S.mapM_ (\_ -> return ())--toList = S.toList--{-# INLINE toRevList #-}-toRevList :: Monad m => Stream m Int -> m [Int]-toRevList = S.toRevList--foldrMBuild  = S.foldrM  (\x xs -> xs >>= return . (x :)) (return [])-foldl'Build = S.foldl' (flip (:)) []-foldlM'Build = S.foldlM' (\xs x -> return $ x : xs) []--foldrMReduce = S.foldrM (\x xs -> xs >>= return . (x +)) (return 0)-foldl'Reduce = S.foldl' (+) 0-foldl'ReduceMap = P.fmap (+1) . S.foldl' (+) 0-foldl1'Reduce = S.foldl1' (+)-foldlM'Reduce = S.foldlM' (\xs a -> return $ a + xs) 0--last   = S.last-null   = S.null-head   = S.head-elem   = S.elem maxValue-notElem = S.notElem maxValue-length = S.length-all    = S.all (<= maxValue)-any    = S.any (> maxValue)-and    = S.and . S.map (<= maxValue)-or     = S.or . S.map (> maxValue)-find   = S.find (== maxValue)-findIndex = S.findIndex (== maxValue)-elemIndex = S.elemIndex maxValue-maximum = S.maximum-minimum = S.minimum-sum    = S.sum-product = S.product-minimumBy = S.minimumBy compare-maximumBy = S.maximumBy compare--}------------------------------------------------------------------------------------ Transformation----------------------------------------------------------------------------------{--{-# INLINE transform #-}-transform :: Stream a -> Stream a-transform = P.id--}--{-# INLINE composeN #-}-composeN :: P.Monad m-    => Int -> (Stream Int -> m (Stream Int)) -> Stream Int -> m (Stream Int)-composeN n f x =-    case n of-        1 -> f x-        2 -> f x P.>>= f-        3 -> f x P.>>= f P.>>= f-        4 -> f x P.>>= f P.>>= f P.>>= f-        _ -> undefined--{-# INLINE scanl' #-}-{-# INLINE scanl1' #-}-{-# INLINE map #-}-{--{-# INLINE fmap #-}-{-# INLINE mapMaybe #-}-{-# INLINE filterEven #-}-{-# INLINE filterAllOut #-}-{-# INLINE filterAllIn #-}-{-# INLINE takeOne #-}-{-# INLINE takeAll #-}-{-# INLINE takeWhileTrue #-}-{-# INLINE takeWhileMTrue #-}-{-# INLINE dropOne #-}-{-# INLINE dropAll #-}-{-# INLINE dropWhileTrue #-}-{-# INLINE dropWhileMTrue #-}-{-# INLINE dropWhileFalse #-}-{-# INLINE findIndices #-}-{-# INLINE elemIndices #-}-{-# INLINE insertBy #-}-{-# INLINE deleteBy #-}-{-# INLINE reverse #-}-{-# INLINE foldrS #-}-{-# INLINE foldrSMap #-}-{-# INLINE foldrT #-}-{-# INLINE foldrTMap #-}-    -}-scanl' , scanl1', map{-, fmap, mapMaybe, filterEven, filterAllOut,-    filterAllIn, takeOne, takeAll, takeWhileTrue, takeWhileMTrue, dropOne,-    dropAll, dropWhileTrue, dropWhileMTrue, dropWhileFalse,-    findIndices, elemIndices, insertBy, deleteBy, reverse,-    foldrS, foldrSMap, foldrT, foldrTMap -}-    :: MonadIO m => Int -> Stream Int -> m (Stream Int)--{--{-# INLINE mapMaybeM #-}-mapMaybeM :: S.MonadAsync m => Int -> Stream m Int -> m ()--{-# INLINE mapM #-}-{-# INLINE map' #-}-{-# INLINE fmap' #-}-mapM, map' :: (S.IsStream t, S.MonadAsync m)-    => (t m Int -> S.SerialT m Int) -> Int -> t m Int -> m ()--fmap' :: (S.IsStream t, S.MonadAsync m, P.Functor (t m))-    => (t m Int -> S.SerialT m Int) -> Int -> t m Int -> m ()--{-# INLINE sequence #-}-sequence :: (S.IsStream t, S.MonadAsync m)-    => (t m Int -> S.SerialT m Int) -> t m (m Int) -> m ()-    -}--{-# INLINE onArray #-}-onArray-    :: MonadIO m => (S.SerialT m Int -> S.SerialT m Int)-    -> Stream Int-    -> m (Stream Int)-onArray f arr = S.fold (A.writeN value) $ f $ (S.unfold A.read arr)--scanl'        n = composeN n $ onArray $ S.scanl' (+) 0-scanl1'       n = composeN n $ onArray $ S.scanl1' (+)-map           n = composeN n $ onArray $ S.map (+1)--- map           n = composeN n $ A.map (+1)-{--fmap          n = composeN n $ Prelude.fmap (+1)-fmap' t       n = composeN' n $ t . Prelude.fmap (+1)-map' t        n = composeN' n $ t . S.map (+1)-mapM t        n = composeN' n $ t . S.mapM return-mapMaybe      n = composeN n $ S.mapMaybe-    (\x -> if Prelude.odd x then Nothing else Just x)-mapMaybeM     n = composeN n $ S.mapMaybeM-    (\x -> if Prelude.odd x then return Nothing else return $ Just x)-sequence t    = transform . t . S.sequence-filterEven    n = composeN n $ S.filter even-filterAllOut  n = composeN n $ S.filter (> maxValue)-filterAllIn   n = composeN n $ S.filter (<= maxValue)-takeOne       n = composeN n $ S.take 1-takeAll       n = composeN n $ S.take maxValue-takeWhileTrue n = composeN n $ S.takeWhile (<= maxValue)-takeWhileMTrue n = composeN n $ S.takeWhileM (return . (<= maxValue))-dropOne        n = composeN n $ S.drop 1-dropAll        n = composeN n $ S.drop maxValue-dropWhileTrue  n = composeN n $ S.dropWhile (<= maxValue)-dropWhileMTrue n = composeN n $ S.dropWhileM (return . (<= maxValue))-dropWhileFalse n = composeN n $ S.dropWhile (> maxValue)-findIndices    n = composeN n $ S.findIndices (== maxValue)-elemIndices    n = composeN n $ S.elemIndices maxValue-insertBy       n = composeN n $ S.insertBy compare maxValue-deleteBy       n = composeN n $ S.deleteBy (>=) maxValue-reverse        n = composeN n $ S.reverse-foldrS         n = composeN n $ S.foldrS S.cons S.nil-foldrSMap      n = composeN n $ S.foldrS (\x xs -> x + 1 `S.cons` xs) S.nil-foldrT         n = composeN n $ S.foldrT S.cons S.nil-foldrTMap      n = composeN n $ S.foldrT (\x xs -> x + 1 `S.cons` xs) S.nil------------------------------------------------------------------------------------ Iteration----------------------------------------------------------------------------------iterStreamLen, maxIters :: Int-iterStreamLen = 10-maxIters = 10000--{-# INLINE iterateSource #-}-iterateSource-    :: S.MonadAsync m-    => (Stream m Int -> Stream m Int) -> Int -> Int -> Stream m Int-iterateSource g i n = f i (sourceUnfoldrMN iterStreamLen n)-    where-        f (0 :: Int) m = g m-        f x m = g (f (x P.- 1) m)--{-# INLINE iterateMapM #-}-{-# INLINE iterateScan #-}-{-# INLINE iterateScanl1 #-}-{-# INLINE iterateFilterEven #-}-{-# INLINE iterateTakeAll #-}-{-# INLINE iterateDropOne #-}-{-# INLINE iterateDropWhileFalse #-}-{-# INLINE iterateDropWhileTrue #-}-iterateMapM, iterateScan, iterateScanl1, iterateFilterEven, iterateTakeAll,-    iterateDropOne, iterateDropWhileFalse, iterateDropWhileTrue-    :: S.MonadAsync m-    => Int -> Stream m Int---- this is quadratic-iterateScan            = iterateSource (S.scanl' (+) 0) (maxIters `div` 10)--- so is this-iterateScanl1          = iterateSource (S.scanl1' (+)) (maxIters `div` 10)--iterateMapM            = iterateSource (S.mapM return) maxIters-iterateFilterEven      = iterateSource (S.filter even) maxIters-iterateTakeAll         = iterateSource (S.take maxValue) maxIters-iterateDropOne         = iterateSource (S.drop 1) maxIters-iterateDropWhileFalse  = iterateSource (S.dropWhile (> maxValue)) maxIters-iterateDropWhileTrue   = iterateSource (S.dropWhile (<= maxValue)) maxIters------------------------------------------------------------------------------------ Zipping and concat----------------------------------------------------------------------------------{-# INLINE zip #-}-{-# INLINE zipM #-}-{-# INLINE mergeBy #-}-zip, zipM, mergeBy :: Monad m => Stream m Int -> m ()--zip src       = do-    r <- S.tail src-    let src1 = fromJust r-    transform (S.zipWith (,) src src1)-zipM src      =  do-    r <- S.tail src-    let src1 = fromJust r-    transform (S.zipWithM (curry return) src src1)--mergeBy src     =  do-    r <- S.tail src-    let src1 = fromJust r-    transform (S.mergeBy P.compare src src1)--{-# INLINE isPrefixOf #-}-{-# INLINE isSubsequenceOf #-}-isPrefixOf, isSubsequenceOf :: Monad m => Stream m Int -> m Bool--isPrefixOf src = S.isPrefixOf src src-isSubsequenceOf src = S.isSubsequenceOf src src--{-# INLINE stripPrefix #-}-stripPrefix :: Monad m => Stream m Int -> m ()-stripPrefix src = do-    _ <- S.stripPrefix src src-    return ()--{-# INLINE zipAsync #-}-{-# INLINE zipAsyncM #-}-{-# INLINE zipAsyncAp #-}-zipAsync, zipAsyncAp, zipAsyncM :: S.MonadAsync m => Stream m Int -> m ()--zipAsync src  = do-    r <- S.tail src-    let src1 = fromJust r-    transform (S.zipAsyncWith (,) src src1)--zipAsyncM src = do-    r <- S.tail src-    let src1 = fromJust r-    transform (S.zipAsyncWithM (curry return) src src1)--zipAsyncAp src  = do-    r <- S.tail src-    let src1 = fromJust r-    transform (S.zipAsyncly $ (,) <$> S.serially src-                                  <*> S.serially src1)--{-# INLINE eqBy #-}-eqBy :: (Monad m, P.Eq a) => Stream m a -> m P.Bool-eqBy src = S.eqBy (==) src src--{-# INLINE cmpBy #-}-cmpBy :: (Monad m, P.Ord a) => Stream m a -> m P.Ordering-cmpBy src = S.cmpBy P.compare src src--concatStreamLen, maxNested :: Int-concatStreamLen = 1-maxNested = 100000--{-# INLINE concatMap #-}-concatMap :: S.MonadAsync m => Int -> Stream m Int-concatMap n = S.concatMap (\_ -> sourceUnfoldrMN maxNested n)-                          (sourceUnfoldrMN concatStreamLen n)------------------------------------------------------------------------------------ Mixed Composition----------------------------------------------------------------------------------{-# INLINE scanMap #-}-{-# INLINE dropMap #-}-{-# INLINE dropScan #-}-{-# INLINE takeDrop #-}-{-# INLINE takeScan #-}-{-# INLINE takeMap #-}-{-# INLINE filterDrop #-}-{-# INLINE filterTake #-}-{-# INLINE filterScan #-}-{-# INLINE filterScanl1 #-}-{-# INLINE filterMap #-}-scanMap, dropMap, dropScan, takeDrop, takeScan, takeMap, filterDrop,-    filterTake, filterScan, filterScanl1, filterMap-    :: Monad m => Int -> Stream m Int -> m ()--scanMap    n = composeN n $ S.map (subtract 1) . S.scanl' (+) 0-dropMap    n = composeN n $ S.map (subtract 1) . S.drop 1-dropScan   n = composeN n $ S.scanl' (+) 0 . S.drop 1-takeDrop   n = composeN n $ S.drop 1 . S.take maxValue-takeScan   n = composeN n $ S.scanl' (+) 0 . S.take maxValue-takeMap    n = composeN n $ S.map (subtract 1) . S.take maxValue-filterDrop n = composeN n $ S.drop 1 . S.filter (<= maxValue)-filterTake n = composeN n $ S.take maxValue . S.filter (<= maxValue)-filterScan n = composeN n $ S.scanl' (+) 0 . S.filter (<= maxBound)-filterScanl1 n = composeN n $ S.scanl1' (+) . S.filter (<= maxBound)-filterMap  n = composeN n $ S.map (subtract 1) . S.filter (<= maxValue)--data Pair a b = Pair !a !b deriving (Generic, NFData)--{-# INLINE sumProductFold #-}-sumProductFold :: Monad m => Stream m Int -> m (Int, Int)-sumProductFold = S.foldl' (\(s,p) x -> (s + x, p P.* x)) (0,1)--{-# INLINE sumProductScan #-}-sumProductScan :: Monad m => Stream m Int -> m (Pair Int Int)-sumProductScan = S.foldl' (\(Pair _  p) (s0,x) -> Pair s0 (p P.* x)) (Pair 0 1)-    . S.scanl' (\(s,_) x -> (s + x,x)) (0,0)------------------------------------------------------------------------------------ Pure stream operations-----------------------------------------------------------------------------------}-{-# INLINE eqInstance #-}-eqInstance :: Stream Int -> Bool-eqInstance src = src == src--{-# INLINE eqInstanceNotEq #-}-eqInstanceNotEq :: Stream Int -> Bool-eqInstanceNotEq src = src P./= src--{-# INLINE ordInstance #-}-ordInstance :: Stream Int -> Bool-ordInstance src = src P.< src--{-# INLINE ordInstanceMin #-}-ordInstanceMin :: Stream Int -> Stream Int-ordInstanceMin src = P.min src src--{-# INLINE showInstance #-}-showInstance :: Stream Int -> P.String-showInstance src = P.show src--{-# INLINE readInstance #-}-readInstance :: P.String -> Stream Int-readInstance str =-    let r = P.reads str-    in case r of-        [(x,"")] -> x-        _ -> P.error "readInstance: no parse"--{-# INLINE pureFoldl' #-}-pureFoldl' :: MonadIO m => Stream Int -> m Int-pureFoldl' = S.foldl' (+) 0 . S.unfold A.read--#ifdef DEVBUILD-{-# INLINE foldableFoldl' #-}-foldableFoldl' :: Stream Int -> Int-foldableFoldl' = F.foldl' (+) 0--{-# INLINE foldableSum #-}-foldableSum :: Stream Int -> Int-foldableSum = P.sum-#endif--{--{-# INLINE traversableMapM #-}-traversableMapM :: Stream Identity Int -> IO (Stream Identity Int)-traversableMapM = P.mapM return--}
benchmark/Streamly/Benchmark/Prelude/Adaptive.hs view
@@ -1,6 +1,6 @@ -- | -- Module      : Main--- Copyright   : (c) 2018 Harendra Kumar+-- Copyright   : (c) 2018 Composewell Technologies -- -- License     : BSD3 -- Maintainer  : streamly@composewell.com@@ -9,7 +9,6 @@ import Control.Monad (when) import Control.Monad.IO.Class (liftIO) import Gauge-import Streamly import Streamly.Prelude as S import System.Random (randomRIO) @@ -20,6 +19,9 @@ -- Also, the worker dispatch depends on the worker dispatch latency which is -- set to fixed 200 us. We need to keep that in mind when designing tests. +moduleName :: String+moduleName = "Prelude.Adaptive"+ value :: Int value = 1000 @@ -79,54 +81,58 @@  main :: IO () main =-  defaultMain+  defaultMain [bgroup moduleName allBenchmarks]++  where++  allBenchmarks =     [       bgroup "serialConstantSlowConsumer"-      [ bench "serially"    $ nfIO $ alwaysConstSlowSerial serially-      , bench "wSerially"   $ nfIO $ alwaysConstSlowSerial wSerially+      [ bench "serially"    $ nfIO $ alwaysConstSlowSerial fromSerial+      , bench "wSerially"   $ nfIO $ alwaysConstSlowSerial fromWSerial       ]     , bgroup "default"-      [ bench "serially"   $ nfIO $ noDelay serially-      , bench "wSerially"  $ nfIO $ noDelay wSerially-      , bench "aheadly"    $ nfIO $ noDelay aheadly-      , bench "asyncly"    $ nfIO $ noDelay asyncly-      , bench "wAsyncly"   $ nfIO $ noDelay wAsyncly-      , bench "parallely"  $ nfIO $ noDelay parallely+      [ bench "serially"   $ nfIO $ noDelay fromSerial+      , bench "wSerially"  $ nfIO $ noDelay fromWSerial+      , bench "aheadly"    $ nfIO $ noDelay fromAhead+      , bench "asyncly"    $ nfIO $ noDelay fromAsync+      , bench "wAsyncly"   $ nfIO $ noDelay fromWAsync+      , bench "parallely"  $ nfIO $ noDelay fromParallel       ]     , bgroup "constantSlowConsumer"-      [ bench "aheadly"    $ nfIO $ alwaysConstSlow aheadly-      , bench "asyncly"    $ nfIO $ alwaysConstSlow asyncly-      , bench "wAsyncly"   $ nfIO $ alwaysConstSlow wAsyncly-      , bench "parallely"  $ nfIO $ alwaysConstSlow parallely+      [ bench "aheadly"    $ nfIO $ alwaysConstSlow fromAhead+      , bench "asyncly"    $ nfIO $ alwaysConstSlow fromAsync+      , bench "wAsyncly"   $ nfIO $ alwaysConstSlow fromWAsync+      , bench "parallely"  $ nfIO $ alwaysConstSlow fromParallel       ]    ,  bgroup "constantFastConsumer"-      [ bench "aheadly"    $ nfIO $ alwaysConstFast aheadly-      , bench "asyncly"    $ nfIO $ alwaysConstFast asyncly-      , bench "wAsyncly"   $ nfIO $ alwaysConstFast wAsyncly-      , bench "parallely"  $ nfIO $ alwaysConstFast parallely+      [ bench "aheadly"    $ nfIO $ alwaysConstFast fromAhead+      , bench "asyncly"    $ nfIO $ alwaysConstFast fromAsync+      , bench "wAsyncly"   $ nfIO $ alwaysConstFast fromWAsync+      , bench "parallely"  $ nfIO $ alwaysConstFast fromParallel       ]    ,  bgroup "variableSlowConsumer"-      [ bench "aheadly"    $ nfIO $ alwaysVarSlow aheadly-      , bench "asyncly"    $ nfIO $ alwaysVarSlow asyncly-      , bench "wAsyncly"   $ nfIO $ alwaysVarSlow wAsyncly-      , bench "parallely"  $ nfIO $ alwaysVarSlow parallely+      [ bench "aheadly"    $ nfIO $ alwaysVarSlow fromAhead+      , bench "asyncly"    $ nfIO $ alwaysVarSlow fromAsync+      , bench "wAsyncly"   $ nfIO $ alwaysVarSlow fromWAsync+      , bench "parallely"  $ nfIO $ alwaysVarSlow fromParallel       ]    ,  bgroup "variableFastConsumer"-      [ bench "aheadly"    $ nfIO $ alwaysVarFast aheadly-      , bench "asyncly"    $ nfIO $ alwaysVarFast asyncly-      , bench "wAsyncly"   $ nfIO $ alwaysVarFast wAsyncly-      , bench "parallely"  $ nfIO $ alwaysVarFast parallely+      [ bench "aheadly"    $ nfIO $ alwaysVarFast fromAhead+      , bench "asyncly"    $ nfIO $ alwaysVarFast fromAsync+      , bench "wAsyncly"   $ nfIO $ alwaysVarFast fromWAsync+      , bench "parallely"  $ nfIO $ alwaysVarFast fromParallel       ]    ,  bgroup "variableSometimesFastConsumer"-      [ bench "aheadly"    $ nfIO $ runVarSometimesFast aheadly-      , bench "asyncly"    $ nfIO $ runVarSometimesFast asyncly-      , bench "wAsyncly"   $ nfIO $ runVarSometimesFast wAsyncly-      , bench "parallely"  $ nfIO $ runVarSometimesFast parallely+      [ bench "aheadly"    $ nfIO $ runVarSometimesFast fromAhead+      , bench "asyncly"    $ nfIO $ runVarSometimesFast fromAsync+      , bench "wAsyncly"   $ nfIO $ runVarSometimesFast fromWAsync+      , bench "parallely"  $ nfIO $ runVarSometimesFast fromParallel       ]    ,  bgroup "variableFullOverlap"-      [ bench "aheadly"    $ nfIO $ randomVar aheadly-      , bench "asyncly"    $ nfIO $ randomVar asyncly-      , bench "wAsyncly"   $ nfIO $ randomVar wAsyncly-      , bench "parallely"  $ nfIO $ randomVar parallely+      [ bench "aheadly"    $ nfIO $ randomVar fromAhead+      , bench "asyncly"    $ nfIO $ randomVar fromAsync+      , bench "wAsyncly"   $ nfIO $ randomVar fromWAsync+      , bench "parallely"  $ nfIO $ randomVar fromParallel       ]    ]
+ benchmark/Streamly/Benchmark/Prelude/Ahead.hs view
@@ -0,0 +1,133 @@+-- |+-- Module      : Main+-- Copyright   : (c) 2018 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com++import Prelude hiding (mapM)++import Streamly.Prelude (fromAhead, fromSerial, ahead, maxBuffer, maxThreads)+import qualified Streamly.Prelude as S++import Streamly.Benchmark.Common+import Streamly.Benchmark.Prelude++import Gauge++moduleName :: String+moduleName = "Prelude.Ahead"++-------------------------------------------------------------------------------+-- Benchmark groups+-------------------------------------------------------------------------------++-- unfoldr and fromFoldable are always serial and therefore the same for+-- all stream types. They can be removed to reduce the number of benchmarks.+o_1_space_generation :: Int -> [Benchmark]+o_1_space_generation value =+    [ bgroup "generation"+        [ benchIOSrc fromAhead "unfoldr" (sourceUnfoldr value)+        , benchIOSrc fromAhead "unfoldrM" (sourceUnfoldrM value)+        , benchIOSrc fromAhead "fromFoldable" (sourceFromFoldable value)+        , benchIOSrc fromAhead "fromFoldableM" (sourceFromFoldableM value)+        , benchIOSrc fromAhead "unfoldrM maxThreads 1"+            (maxThreads 1 . sourceUnfoldrM value)+        , benchIOSrc fromAhead "unfoldrM maxBuffer 1 (x/10 ops)"+            (maxBuffer 1 . sourceUnfoldrM (value `div` 10))+        ]+    ]++o_1_space_mapping :: Int -> [Benchmark]+o_1_space_mapping value =+    [ bgroup "mapping"+        [ benchIOSink value "map" $ mapN fromAhead 1+        , benchIOSink value "fmap" $ fmapN fromAhead 1+        , benchIOSink value "mapM" $ mapM fromAhead 1 . fromSerial+        ]+    ]++o_1_space_concatFoldable :: Int -> [Benchmark]+o_1_space_concatFoldable value =+    [ bgroup+        "concat-foldable"+        [ benchIOSrc fromAhead "foldMapWith (<>) (List)"+            (sourceFoldMapWith value)+        , benchIOSrc fromAhead "foldMapWith (<>) (Stream)"+            (sourceFoldMapWithStream value)+        , benchIOSrc fromAhead "foldMapWithM (<>) (List)"+            (sourceFoldMapWithM value)+        , benchIOSrc fromSerial "S.concatFoldableWith (<>) (List)"+            (concatFoldableWith value)+        , benchIOSrc fromSerial "S.concatForFoldableWith (<>) (List)"+            (concatForFoldableWith value)+        , benchIOSrc fromAhead "foldMapM (List)" (sourceFoldMapM value)+        ]+    ]++o_1_space_concatMap :: Int -> [Benchmark]+o_1_space_concatMap value =+    value2 `seq`+        [ bgroup "concat"+            -- This is for comparison with foldMapWith+            [ benchIOSrc fromSerial "concatMapWithId (n of 1) (fromFoldable)"+                (S.concatMapWith ahead id . sourceConcatMapId value)++            , benchIO "concatMapWith (n of 1)"+                  (concatStreamsWith ahead value 1)+            , benchIO "concatMapWith (sqrt x of sqrt x)"+                  (concatStreamsWith ahead value2 value2)+            , benchIO "concatMapWith (1 of n)"+                  (concatStreamsWith ahead 1 value)+            ]+        ]++    where++    value2 = round $ sqrt (fromIntegral value :: Double)++-------------------------------------------------------------------------------+-- Monadic outer product+-------------------------------------------------------------------------------++o_1_space_outerProduct :: Int -> [Benchmark]+o_1_space_outerProduct value =+    [ bgroup "monad-outer-product"+        [ benchIO "toNullAp"       $ toNullAp value fromAhead+        , benchIO "toNull"         $ toNullM value fromAhead+        , benchIO "toNull3"        $ toNullM3 value fromAhead+        , benchIO "filterAllOut"   $ filterAllOutM value fromAhead+        , benchIO "filterAllIn"    $ filterAllInM value fromAhead+        , benchIO "filterSome"     $ filterSome value fromAhead+        , benchIO "breakAfterSome" $ breakAfterSome value fromAhead++        ]+    ]++o_n_space_outerProduct :: Int -> [Benchmark]+o_n_space_outerProduct value =+    [ bgroup "monad-outer-product"+        [ benchIO "toList"         $ toListM value fromAhead+        , benchIO "toListSome"     $ toListSome value fromAhead+        ]+    ]++-------------------------------------------------------------------------------+-- Main+-------------------------------------------------------------------------------++main :: IO ()+main = runWithCLIOpts defaultStreamSize allBenchmarks++    where++    allBenchmarks value =+        [ bgroup (o_1_space_prefix moduleName) $ concat+            [ o_1_space_generation value+            , o_1_space_mapping value+            , o_1_space_concatFoldable value+            , o_1_space_concatMap value+            , o_1_space_outerProduct value+            ]+        , bgroup (o_n_space_prefix moduleName) (o_n_space_outerProduct value)+        ]
+ benchmark/Streamly/Benchmark/Prelude/Async.hs view
@@ -0,0 +1,202 @@+-- |+-- Module      : Main+-- Copyright   : (c) 2018 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com++import Prelude hiding (mapM)++import Streamly.Prelude (fromAsync, async, maxBuffer, maxThreads, fromSerial)+import qualified Streamly.Prelude as S+import qualified Streamly.Internal.Data.Stream.StreamK.Type as Internal++import Streamly.Benchmark.Common+import Streamly.Benchmark.Prelude++import Gauge++moduleName :: String+moduleName = "Prelude.Async"++-------------------------------------------------------------------------------+-- Generation+-------------------------------------------------------------------------------++o_1_space_generation :: Int -> [Benchmark]+o_1_space_generation value =+    -- These basically test the performance of consMAsync+    [ bgroup "generation"+        [ benchIOSrc fromAsync "unfoldr" (sourceUnfoldr value)+        , benchIOSrc fromAsync "unfoldrM" (sourceUnfoldrM value)+        , benchIOSrc fromAsync "fromListM" (sourceFromListM value)+        , benchIOSrc fromAsync "fromFoldable (List)" (sourceFromFoldable value)+        , benchIOSrc fromAsync "fromFoldableM (List)" (sourceFromFoldableM value)+        , benchIOSrc fromAsync "unfoldrM maxThreads 1"+            (maxThreads 1 . sourceUnfoldrM value)+        , benchIOSrc fromAsync "unfoldrM maxBuffer 1 (x/10 ops)"+            (maxBuffer 1 . sourceUnfoldrM (value `div` 10))+        ]+    ]++-------------------------------------------------------------------------------+-- Mapping+-------------------------------------------------------------------------------++{-# INLINE foldrSShared #-}+foldrSShared :: Int -> Int -> IO ()+foldrSShared count n =+      S.drain+    $ fromAsync+    $ Internal.foldrSShared (\x xs -> S.consM (return x) xs) S.nil+    $ fromSerial+    $ sourceUnfoldrM count n++o_1_space_mapping :: Int -> [Benchmark]+o_1_space_mapping value =+    [ bgroup "mapping"+        [ benchIOSink value "map" $ mapN fromAsync 1+        , benchIOSink value "fmap" $ fmapN fromAsync 1+        , benchIOSrc1 "foldrSShared" (foldrSShared value)+        -- This basically tests the performance of consMAsync+        , benchIOSink value "mapM" $ mapM fromAsync 1 . fromSerial+        ]+    ]++-------------------------------------------------------------------------------+-- Size conserving transformations (reordering, buffering, etc.)+-------------------------------------------------------------------------------++o_n_heap_buffering :: Int -> [Benchmark]+o_n_heap_buffering value =+    [bgroup "buffered" [benchIOSink value "mkAsync" (mkAsync fromAsync)]]++-------------------------------------------------------------------------------+-- Joining+-------------------------------------------------------------------------------++{-# INLINE async2 #-}+async2 :: Int -> Int -> IO ()+async2 count n =+    S.drain $+        (sourceUnfoldrM count n) `async` (sourceUnfoldrM count (n + 1))++{-# INLINE async4 #-}+async4 :: Int -> Int -> IO ()+async4 count n =+    S.drain $+                  (sourceUnfoldrM count (n + 0))+        `async` (sourceUnfoldrM count (n + 1))+        `async` (sourceUnfoldrM count (n + 2))+        `async` (sourceUnfoldrM count (n + 3))++{-# INLINE async2n2 #-}+async2n2 :: Int -> Int -> IO ()+async2n2 count n =+    S.drain $+        ((sourceUnfoldrM count (n + 0))+            `async` (sourceUnfoldrM count (n + 1)))+        `async` ((sourceUnfoldrM count (n + 2))+            `async` (sourceUnfoldrM count (n + 3)))++o_1_space_joining :: Int -> [Benchmark]+o_1_space_joining value =+    [ bgroup "joining"+        [ benchIOSrc1 "async (2 of n/2)" (async2 (value `div` 2))+        , benchIOSrc1 "async (4 of n/4)" (async4 (value `div` 4))+        , benchIOSrc1 "async (2 of (2 of n/4)" (async2n2 (value `div` 4))+        ]+    ]++-------------------------------------------------------------------------------+-- Concat+-------------------------------------------------------------------------------++-- These basically test the performance of folding streams with `async`+o_1_space_concatFoldable :: Int -> [Benchmark]+o_1_space_concatFoldable value =+    [ bgroup "concat-foldable"+        [ benchIOSrc fromAsync "foldMapWith (<>) (List)"+            (sourceFoldMapWith value)+        , benchIOSrc fromAsync "foldMapWith (<>) (Stream)"+            (sourceFoldMapWithStream value)+        , benchIOSrc fromAsync "foldMapWithM (<>) (List)"+            (sourceFoldMapWithM value)+        , benchIOSrc fromSerial "S.concatFoldableWith (<>) (List)"+            (concatFoldableWith value)+        , benchIOSrc fromSerial "S.concatForFoldableWith (<>) (List)"+            (concatForFoldableWith value)+        , benchIOSrc fromAsync "foldMapM (List)" (sourceFoldMapM value)+        ]+    ]++-- These basically test the performance of concating streams with `async`+o_1_space_concatMap :: Int -> [Benchmark]+o_1_space_concatMap value =+    value2 `seq`+        [ bgroup "concat"+            -- This is for comparison with foldMapWith+            [ benchIOSrc fromSerial "concatMapWithId (n of 1) (fromFoldable)"+                (S.concatMapWith async id . sourceConcatMapId value)++            , benchIO "concatMapWith (n of 1)"+                  (concatStreamsWith async value 1)+            , benchIO "concatMapWith (sqrt x of sqrt x)"+                  (concatStreamsWith async value2 value2)+            , benchIO "concatMapWith (1 of n)"+                  (concatStreamsWith async 1 value)+            ]+        ]++    where++    value2 = round $ sqrt (fromIntegral value :: Double)++-------------------------------------------------------------------------------+-- Monadic outer product+-------------------------------------------------------------------------------++o_1_space_outerProduct :: Int -> [Benchmark]+o_1_space_outerProduct value =+    [ bgroup "monad-outer-product"+        [ benchIO "toNullAp"       $ toNullAp value fromAsync+        , benchIO "toNull"         $ toNullM value fromAsync+        , benchIO "toNull3"        $ toNullM3 value fromAsync+        , benchIO "filterAllOut"   $ filterAllOutM value fromAsync+        , benchIO "filterAllIn"    $ filterAllInM value fromAsync+        , benchIO "filterSome"     $ filterSome value fromAsync+        , benchIO "breakAfterSome" $ breakAfterSome value fromAsync++        ]+    ]++o_n_space_outerProduct :: Int -> [Benchmark]+o_n_space_outerProduct value =+    [ bgroup "monad-outer-product"+        [ benchIO "toList"         $ toListM value fromAsync+        , benchIO "toListSome"     $ toListSome value fromAsync+        ]+    ]++-------------------------------------------------------------------------------+-- Main+-------------------------------------------------------------------------------++main :: IO ()+main = runWithCLIOpts defaultStreamSize allBenchmarks+++    where++    allBenchmarks value =+        [ bgroup (o_1_space_prefix moduleName) $ concat+            [ o_1_space_generation value+            , o_1_space_mapping value+            , o_1_space_concatFoldable value+            , o_1_space_concatMap value+            , o_1_space_outerProduct value+            , o_1_space_joining value+            ]+        , bgroup (o_n_heap_prefix moduleName) (o_n_heap_buffering value)+        , bgroup (o_n_space_prefix moduleName) (o_n_space_outerProduct value)+        ]
benchmark/Streamly/Benchmark/Prelude/Concurrent.hs view
@@ -1,16 +1,20 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} -- | -- Module      : Main--- Copyright   : (c) 2018 Harendra Kumar+-- Copyright   : (c) 2018 Composewell Technologies -- -- License     : BSD3 -- Maintainer  : streamly@composewell.com  import Control.Concurrent import Control.Monad (when, replicateM)+import Streamly.Prelude+    ( IsStream, SerialT, serial, async, fromAsync, ahead, fromAhead, wAsync+    , fromWAsync, parallel, fromParallel+    )  import Gauge-import Streamly import qualified Streamly.Prelude as S  -------------------------------------------------------------------------------@@ -28,9 +32,9 @@     let work = (\i -> when (d /= 0) (threadDelay d) >> return i)     in S.drain         $ t-        $ maxBuffer buflen-        $ maxThreads (-1)-        $ S.fromFoldableM $ map work [1..tcount]+        $ S.maxBuffer buflen+        $ S.maxThreads (-1)+        $ S.fromFoldableM $ fmap work [1..tcount]  -- | Run @threads@ concurrently, each producing streams of @elems@ elements -- with a delay of @d@ microseconds between successive elements, and merge@@ -46,35 +50,35 @@     -> (forall a. SerialT IO a -> SerialT IO a -> SerialT IO a)     -> IO () concated buflen threads d elems t =-    let work = \i -> S.replicateM i-                        ((when (d /= 0) (threadDelay d)) >> return i)+    let work = \i -> S.replicateM i (when (d /= 0) (threadDelay d) >> return i)     in S.drain-        $ adapt-        $ maxThreads (-1)-        $ maxBuffer buflen+        $ S.adapt+        $ S.maxThreads (-1)+        $ S.maxBuffer buflen         $ S.concatMapWith t work         $ S.replicate threads elems  appendGroup :: Int -> Int -> Int -> [Benchmark]-appendGroup buflen threads delay =-    [ -- bench "serial"   $ nfIO $ append buflen threads delay serially-      bench "ahead"    $ nfIO $ append buflen threads delay aheadly-    , bench "async"    $ nfIO $ append buflen threads delay asyncly-    , bench "wAsync"   $ nfIO $ append buflen threads delay wAsyncly-    , bench "parallel" $ nfIO $ append buflen threads delay parallely+appendGroup buflen threads usec =+    [ -- bench "serial"   $ nfIO $ append buflen threads delay fromSerial+      bench "ahead"    $ nfIO $ append buflen threads usec fromAhead+    , bench "async"    $ nfIO $ append buflen threads usec fromAsync+    , bench "wAsync"   $ nfIO $ append buflen threads usec fromWAsync+    , bench "parallel" $ nfIO $ append buflen threads usec fromParallel     ]  concatGroup :: Int -> Int -> Int -> Int -> [Benchmark]-concatGroup buflen threads delay n =-    [ bench "serial"   $ nfIO $ concated buflen threads delay n serial-    , bench "ahead"    $ nfIO $ concated buflen threads delay n ahead-    , bench "async"    $ nfIO $ concated buflen threads delay n async-    , bench "wAsync"   $ nfIO $ concated buflen threads delay n wAsync-    , bench "parallel" $ nfIO $ concated buflen threads delay n parallel+concatGroup buflen threads usec n =+    [ bench "serial"   $ nfIO $ concated buflen threads usec n serial+    , bench "ahead"    $ nfIO $ concated buflen threads usec n ahead+    , bench "async"    $ nfIO $ concated buflen threads usec n async+    , bench "wAsync"   $ nfIO $ concated buflen threads usec n wAsync+    , bench "parallel" $ nfIO $ concated buflen threads usec n parallel     ]  main :: IO ()-main = do+main =+#ifdef MIN_VERSION_gauge   defaultMainWith (defaultConfig     { timeLimit = Just 0     , minSamples = Just 1@@ -82,6 +86,9 @@     , includeFirstIter = True     , quickMode = True     })+#else+    defaultMain+#endif      [ -- bgroup "append/buf-1-threads-10k-0sec"  (appendGroup 1 10000 0)     -- , bgroup "append/buf-100-threads-100k-0sec"  (appendGroup 100 100000 0)
− benchmark/Streamly/Benchmark/Prelude/LinearAsync.hs 
@@ -1,46 +0,0 @@--- |--- Module      : Main--- Copyright   : (c) 2018 Harendra Kumar------ License     : BSD3--- Maintainer  : streamly@composewell.com--import Streamly.Benchmark.Common-import Streamly.Benchmark.Prelude--import Gauge--main :: IO ()-main = do-    (value, cfg, benches) <- parseCLIOpts defaultStreamSize-    value `seq` runMode (mode cfg) cfg benches (allBenchmarks value)-  where-    allBenchmarks value =-        concat-             [ async value-             , wAsync value-             , ahead value-             , zipAsync value-             ]-    async value =-        concat-            [ o_1_space_async_generation value-            , o_1_space_async_concatFoldable value-            , o_1_space_async_concatMap value-            , o_1_space_async_transformation value-            ]-    wAsync value =-        concat-            [ o_1_space_wAsync_generation value-            , o_1_space_wAsync_concatFoldable value-            , o_1_space_wAsync_concatMap value-            , o_1_space_wAsync_transformation value-            ]-    ahead value =-        concat-            [ o_1_space_ahead_generation value-            , o_1_space_ahead_concatFoldable value-            , o_1_space_ahead_concatMap value-            , o_1_space_ahead_transformation value-            ]-    zipAsync = o_1_space_async_zip
− benchmark/Streamly/Benchmark/Prelude/LinearRate.hs 
@@ -1,24 +0,0 @@--- |--- Module      : Main--- Copyright   : (c) 2018 Harendra Kumar------ License     : BSD3--- Maintainer  : streamly@composewell.com--import Streamly.Benchmark.Common-import Streamly.Benchmark.Prelude--import Gauge--main :: IO ()-main = do-    (value, cfg, benches) <- parseCLIOpts defaultStreamSize-    value `seq` runMode (mode cfg) cfg benches (allBenchmarks value)--    where--    allBenchmarks value =-        concat-            [ o_1_space_async_avgRate value-            , o_1_space_ahead_avgRate value-            ]
− benchmark/Streamly/Benchmark/Prelude/NestedConcurrent.hs 
@@ -1,84 +0,0 @@--- |--- Module      : Main--- Copyright   : (c) 2018 Harendra Kumar------ License     : BSD3--- Maintainer  : streamly@composewell.com--import Control.DeepSeq (NFData)-import Control.Monad (when)-import Data.Functor.Identity (Identity, runIdentity)-import System.Random (randomRIO)--import Streamly.Benchmark.Common (parseCLIOpts)--import Streamly-import Gauge--import qualified Streamly.Benchmark.Prelude.NestedOps as Ops--benchIO :: (NFData b) => String -> (Int -> IO b) -> Benchmark-benchIO name f = bench name $ nfIO $ randomRIO (1,1) >>= f--_benchId :: (NFData b) => String -> (Int -> Identity b) -> Benchmark-_benchId name f = bench name $ nf (\g -> runIdentity (g 1))  f--defaultStreamSize :: Int-defaultStreamSize = 100000--main :: IO ()-main = do-  -- XXX Fix indentation-  (linearCount, cfg, benches) <- parseCLIOpts defaultStreamSize-  let finiteCount = min linearCount defaultStreamSize-  when (finiteCount /= linearCount) $-    putStrLn $ "Limiting stream size to "-               ++ show defaultStreamSize-               ++ " for finite stream operations only"--  finiteCount `seq` linearCount `seq` runMode (mode cfg) cfg benches-    [-      bgroup "aheadly"-      [ benchIO "toNullAp"       $ Ops.toNullAp linearCount       aheadly-      , benchIO "toNull"         $ Ops.toNull linearCount         aheadly-      , benchIO "toNull3"        $ Ops.toNull3 linearCount        aheadly-      -- , benchIO "toList"         $ Ops.toList linearCount         aheadly-      -- XXX consumes too much stack space-      , benchIO "toListSome"     $ Ops.toListSome linearCount     aheadly-      , benchIO "filterAllOut"   $ Ops.filterAllOut linearCount   aheadly-      , benchIO "filterAllIn"    $ Ops.filterAllIn linearCount    aheadly-      , benchIO "filterSome"     $ Ops.filterSome linearCount     aheadly-      , benchIO "breakAfterSome" $ Ops.breakAfterSome linearCount aheadly-      ]--    , bgroup "asyncly"-      [ benchIO "toNullAp"       $ Ops.toNullAp linearCount       asyncly-      , benchIO "toNull"         $ Ops.toNull linearCount         asyncly-      , benchIO "toNull3"        $ Ops.toNull3 linearCount        asyncly-      -- , benchIO "toList"         $ Ops.toList linearCount         asyncly-      , benchIO "toListSome"     $ Ops.toListSome  linearCount    asyncly-      , benchIO "filterAllOut"   $ Ops.filterAllOut linearCount   asyncly-      , benchIO "filterAllIn"    $ Ops.filterAllIn linearCount    asyncly-      , benchIO "filterSome"     $ Ops.filterSome linearCount     asyncly-      , benchIO "breakAfterSome" $ Ops.breakAfterSome linearCount asyncly-      ]--    , bgroup "zipAsyncly"-      [ benchIO "toNullAp"       $ Ops.toNullAp linearCount       zipAsyncly-      ]--    -- Operations that are not scalable to infinite streams-    , bgroup "finite"-      [ bgroup "wAsyncly"-        [ benchIO "toNullAp"       $ Ops.toNullAp finiteCount       wAsyncly-        , benchIO "toNull"         $ Ops.toNull finiteCount         wAsyncly-        , benchIO "toNull3"        $ Ops.toNull3 finiteCount        wAsyncly-        -- , benchIO "toList"         $ Ops.toList finiteCount         wAsyncly-        , benchIO "toListSome"     $ Ops.toListSome finiteCount     wAsyncly-        , benchIO "filterAllOut"   $ Ops.filterAllOut finiteCount   wAsyncly-        -- , benchIO "filterAllIn"    $ Ops.filterAllIn finiteCount    wAsyncly-        , benchIO "filterSome"     $ Ops.filterSome finiteCount     wAsyncly-        , benchIO "breakAfterSome" $ Ops.breakAfterSome finiteCount wAsyncly-        ]-      ]-    ]
− benchmark/Streamly/Benchmark/Prelude/NestedOps.hs 
@@ -1,174 +0,0 @@--- |--- Module      : BenchmarkOps--- Copyright   : (c) 2018 Harendra Kumar------ License     : MIT--- Maintainer  : streamly@composewell.com--{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Streamly.Benchmark.Prelude.NestedOps where--import Control.Exception (try)-import GHC.Exception (ErrorCall)--import qualified Streamly          as S hiding (runStream)-import qualified Streamly.Prelude  as S------------------------------------------------------------------------------------ Stream generation and elimination----------------------------------------------------------------------------------type Stream m a = S.SerialT m a--{-# INLINE source #-}-source :: (S.MonadAsync m, S.IsStream t) => Int -> Int -> t m Int-source = sourceUnfoldrM---- Change this to "sourceUnfoldrM value n" for consistency-{-# INLINE sourceUnfoldrM #-}-sourceUnfoldrM :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int-sourceUnfoldrM n value = S.serially $ S.unfoldrM step n-    where-    step cnt =-        if cnt > n + value-        then return Nothing-        else return (Just (cnt, cnt + 1))--{-# INLINE sourceUnfoldr #-}-sourceUnfoldr :: (Monad m, S.IsStream t) => Int -> Int -> t m Int-sourceUnfoldr start n = S.unfoldr step start-    where-    step cnt =-        if cnt > start + n-        then Nothing-        else Just (cnt, cnt + 1)--{-# INLINE runStream #-}-runStream :: Monad m => Stream m a -> m ()-runStream = S.drain--{-# INLINE runToList #-}-runToList :: Monad m => Stream m a -> m [a]-runToList = S.toList------------------------------------------------------------------------------------ Benchmark ops----------------------------------------------------------------------------------{-# INLINE toNullAp #-}-toNullAp-    :: (S.IsStream t, S.MonadAsync m, Applicative (t m))-    => Int -> (t m Int -> S.SerialT m Int) -> Int -> m ()-toNullAp linearCount t start = runStream . t $-    (+) <$> source start nestedCount2 <*> source start nestedCount2-  where-    nestedCount2 = round (fromIntegral linearCount**(1/2::Double))--{-# INLINE toNull #-}-toNull-    :: (S.IsStream t, S.MonadAsync m, Monad (t m))-    => Int -> (t m Int -> S.SerialT m Int) -> Int -> m ()-toNull linearCount t start = runStream . t $ do-    x <- source start nestedCount2-    y <- source start nestedCount2-    return $ x + y-  where-    nestedCount2 = round (fromIntegral linearCount**(1/2::Double))--{-# INLINE toNull3 #-}-toNull3-    :: (S.IsStream t, S.MonadAsync m, Monad (t m))-    => Int -> (t m Int -> S.SerialT m Int) -> Int -> m ()-toNull3 linearCount t start = runStream . t $ do-    x <- source start nestedCount3-    y <- source start nestedCount3-    z <- source start nestedCount3-    return $ x + y + z-  where-    nestedCount3 = round (fromIntegral linearCount**(1/3::Double))--{-# INLINE toList #-}-toList-    :: (S.IsStream t, S.MonadAsync m, Monad (t m))-    => Int -> (t m Int -> S.SerialT m Int) -> Int -> m [Int]-toList linearCount t start = runToList . t $ do-    x <- source start nestedCount2-    y <- source start nestedCount2-    return $ x + y-  where-    nestedCount2 = round (fromIntegral linearCount**(1/2::Double))---- Taking a specified number of elements is very expensive in logict so we have--- a test to measure the same.-{-# INLINE toListSome #-}-toListSome-    :: (S.IsStream t, S.MonadAsync m, Monad (t m))-    => Int -> (t m Int -> S.SerialT m Int) -> Int -> m [Int]-toListSome linearCount t start =-    runToList . t $ S.take 10000 $ do-        x <- source start nestedCount2-        y <- source start nestedCount2-        return $ x + y-  where-    nestedCount2 = round (fromIntegral linearCount**(1/2::Double))--{-# INLINE filterAllOut #-}-filterAllOut-    :: (S.IsStream t, S.MonadAsync m, Monad (t m))-    => Int -> (t m Int -> S.SerialT m Int) -> Int -> m ()-filterAllOut linearCount t start = runStream . t $ do-    x <- source start nestedCount2-    y <- source start nestedCount2-    let s = x + y-    if s < 0-    then return s-    else S.nil-  where-    nestedCount2 = round (fromIntegral linearCount**(1/2::Double))--{-# INLINE filterAllIn #-}-filterAllIn-    :: (S.IsStream t, S.MonadAsync m, Monad (t m))-    => Int -> (t m Int -> S.SerialT m Int) -> Int -> m ()-filterAllIn linearCount t start = runStream . t $ do-    x <- source start nestedCount2-    y <- source start nestedCount2-    let s = x + y-    if s > 0-    then return s-    else S.nil-  where-    nestedCount2 = round (fromIntegral linearCount**(1/2::Double))--{-# INLINE filterSome #-}-filterSome-    :: (S.IsStream t, S.MonadAsync m, Monad (t m))-    => Int -> (t m Int -> S.SerialT m Int) -> Int -> m ()-filterSome linearCount t start = runStream . t $ do-    x <- source start nestedCount2-    y <- source start nestedCount2-    let s = x + y-    if s > 1100000-    then return s-    else S.nil-  where-    nestedCount2 = round (fromIntegral linearCount**(1/2::Double))--{-# INLINE breakAfterSome #-}-breakAfterSome-    :: (S.IsStream t, Monad (t IO))-    => Int -> (t IO Int -> S.SerialT IO Int) -> Int -> IO ()-breakAfterSome linearCount t start = do-    (_ :: Either ErrorCall ()) <- try $ runStream . t $ do-        x <- source start nestedCount2-        y <- source start nestedCount2-        let s = x + y-        if s > 1100000-        then error "break"-        else return s-    return ()-  where-    nestedCount2 = round (fromIntegral linearCount**(1/2::Double))
benchmark/Streamly/Benchmark/Prelude/Parallel.hs view
@@ -1,35 +1,239 @@ -- | -- Module      : Main--- Copyright   : (c) 2018 Harendra Kumar+-- Copyright   : (c) 2018 Composewell Technologies -- -- License     : BSD3 -- Maintainer  : streamly@composewell.com +{-# LANGUAGE FlexibleContexts #-}++import Prelude hiding (mapM)++import Data.Function ((&))+import Streamly.Prelude+       ( SerialT, fromParallel, parallel, fromSerial, maxBuffer, maxThreads)++import qualified Streamly.Prelude  as S+import qualified Streamly.Internal.Data.Fold as FL+import qualified Streamly.Internal.Data.Stream.Parallel as Par+import qualified Streamly.Internal.Data.Stream.IsStream as Internal+ import Streamly.Benchmark.Common import Streamly.Benchmark.Prelude  import Gauge +moduleName :: String+moduleName = "Prelude.Parallel"++-------------------------------------------------------------------------------+-- Merging+-------------------------------------------------------------------------------++{-# INLINE mergeAsyncByM #-}+mergeAsyncByM :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int+mergeAsyncByM count n =+    S.mergeAsyncByM+        (\a b -> return (a `compare` b))+        (sourceUnfoldrM count n)+        (sourceUnfoldrM count (n + 1))++{-# INLINE mergeAsyncBy #-}+mergeAsyncBy :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int+mergeAsyncBy count n =+    S.mergeAsyncBy+        compare+        (sourceUnfoldrM count n)+        (sourceUnfoldrM count (n + 1))++-------------------------------------------------------------------------------+-- Application/fold+-------------------------------------------------------------------------------++{-# INLINE parAppMap #-}+parAppMap :: S.MonadAsync m => SerialT m Int -> m ()+parAppMap src = S.drain $ S.map (+1) S.|$ src++{-# INLINE parAppSum #-}+parAppSum :: S.MonadAsync m => SerialT m Int -> m ()+parAppSum src = (S.sum S.|$. src) >>= \x -> seq x (return ())++{-# INLINE (|&) #-}+(|&) :: S.MonadAsync m => SerialT m Int -> m ()+(|&) src = src S.|& S.map (+ 1) & S.drain++{-# INLINE (|&.) #-}+(|&.) :: S.MonadAsync m => SerialT m Int -> m ()+(|&.) src = (src S.|&. S.sum) >>= \x -> seq x (return ())++-------------------------------------------------------------------------------+-- Tapping+-------------------------------------------------------------------------------++{-# INLINE tapAsyncS #-}+tapAsyncS :: S.MonadAsync m => Int -> SerialT m Int -> m ()+tapAsyncS n = composeN n $ Par.tapAsync S.sum++{-# INLINE tapAsync #-}+tapAsync :: S.MonadAsync m => Int -> SerialT m Int -> m ()+tapAsync n = composeN n $ Internal.tapAsync FL.sum++o_1_space_merge_app_tap :: Int -> [Benchmark]+o_1_space_merge_app_tap value =+    [ bgroup "merge-app-tap"+        [ benchIOSrc fromSerial "mergeAsyncBy (2,x/2)"+              (mergeAsyncBy (value `div` 2))+        , benchIOSrc fromSerial "mergeAsyncByM (2,x/2)"+              (mergeAsyncByM (value `div` 2))+        -- Parallel stages in a pipeline+        , benchIOSink value "parAppMap" parAppMap+        , benchIOSink value "parAppSum" parAppSum+        , benchIOSink value "(|&)" (|&)+        , benchIOSink value "(|&.)" (|&.)+        , benchIOSink value "tapAsync" (tapAsync 1)+        , benchIOSink value "tapAsyncS" (tapAsyncS 1)+        ]+    ]++-------------------------------------------------------------------------------+-- Generation+-------------------------------------------------------------------------------++o_n_heap_generation :: Int -> [Benchmark]+o_n_heap_generation value =+    [ bgroup+        "generation"+        [ benchIOSrc fromParallel "unfoldr" (sourceUnfoldr value)+        , benchIOSrc fromParallel "unfoldrM" (sourceUnfoldrM value)+        , benchIOSrc fromParallel "fromFoldable" (sourceFromFoldable value)+        , benchIOSrc fromParallel "fromFoldableM" (sourceFromFoldableM value)+        , benchIOSrc fromParallel "unfoldrM maxThreads 1"+              (maxThreads 1 . sourceUnfoldrM value)+        , benchIOSrc fromParallel "unfoldrM maxBuffer 1 (x/10 ops)"+              (maxBuffer 1 . sourceUnfoldrM (value `div` 10))+        ]+    ]++-------------------------------------------------------------------------------+-- Mapping+-------------------------------------------------------------------------------++o_n_heap_mapping :: Int -> [Benchmark]+o_n_heap_mapping value =+    [ bgroup "mapping"+        [ benchIOSink value "map" $ mapN fromParallel 1+        , benchIOSink value "fmap" $ fmapN fromParallel 1+        , benchIOSink value "mapM" $ mapM fromParallel 1 . fromSerial+        ]+    ]+++-------------------------------------------------------------------------------+-- Joining+-------------------------------------------------------------------------------++{-# INLINE parallel2 #-}+parallel2 :: Int -> Int -> IO ()+parallel2 count n =+    S.drain $+        (sourceUnfoldrM count n) `parallel` (sourceUnfoldrM count (n + 1))++o_1_space_joining :: Int -> [Benchmark]+o_1_space_joining value =+    [ bgroup "joining"+        [ benchIOSrc1 "parallel (2 of n/2)" (parallel2 (value `div` 2))+        ]+    ]++-------------------------------------------------------------------------------+-- Concat+-------------------------------------------------------------------------------++o_n_heap_concatFoldable :: Int -> [Benchmark]+o_n_heap_concatFoldable value =+    [ bgroup+        "concat-foldable"+        [ benchIOSrc fromParallel "foldMapWith (<>) (List)"+            (sourceFoldMapWith value)+        , benchIOSrc fromParallel "foldMapWith (<>) (Stream)"+            (sourceFoldMapWithStream value)+        , benchIOSrc fromParallel "foldMapWithM (<>) (List)"+            (sourceFoldMapWithM value)+        , benchIOSrc fromSerial "S.concatFoldableWith (<>) (List)"+            (concatFoldableWith value)+        , benchIOSrc fromSerial "S.concatForFoldableWith (<>) (List)"+            (concatForFoldableWith value)+        , benchIOSrc fromParallel "foldMapM (List)" (sourceFoldMapM value)+        ]+    ]++o_n_heap_concat :: Int -> [Benchmark]+o_n_heap_concat value =+    value2 `seq`+        [ bgroup "concat"+            -- This is for comparison with foldMapWith+            [ benchIOSrc fromSerial "concatMapWithId (n of 1) (fromFoldable)"+                (S.concatMapWith parallel id . sourceConcatMapId value)++            , benchIO "concatMapWith (n of 1)"+                  (concatStreamsWith parallel value 1)+            , benchIO "concatMapWith (sqrt x of sqrt x)"+                  (concatStreamsWith parallel value2 value2)+            , benchIO "concatMapWith (1 of n)"+                  (concatStreamsWith parallel 1 value)+            ]+        ]++    where++    value2 = round $ sqrt (fromIntegral value :: Double)++-------------------------------------------------------------------------------+-- Monadic outer product+-------------------------------------------------------------------------------++o_n_heap_outerProduct :: Int -> [Benchmark]+o_n_heap_outerProduct value =+    [ bgroup "monad-outer-product"+        [ benchIO "toNullAp" $ toNullAp value fromParallel+        , benchIO "toNull" $ toNullM value fromParallel+        , benchIO "toNull3" $ toNullM3 value fromParallel+        , benchIO "filterAllOut" $ filterAllOutM value fromParallel+        , benchIO "filterAllIn" $ filterAllInM value fromParallel+        , benchIO "filterSome" $ filterSome value fromParallel+        , benchIO "breakAfterSome" $ breakAfterSome value fromParallel+        ]+    ]++o_n_space_outerProduct :: Int -> [Benchmark]+o_n_space_outerProduct value =+    [ bgroup "monad-outer-product"+        [ benchIO "toList" $ toListM value fromParallel+        -- XXX disabled due to a bug for now+        -- , benchIO "toListSome" $ toListSome value fromParallel+        ]+    ]++-------------------------------------------------------------------------------+-- Main+-------------------------------------------------------------------------------+ main :: IO ()-main = do-    (value, cfg, benches) <- parseCLIOpts defaultStreamSize-    value `seq` runMode (mode cfg) cfg benches (allBenchmarks value)+main = runWithCLIOpts defaultStreamSize allBenchmarks      where      allBenchmarks value =-        concat-            [ linear value-            , nested value+        [ bgroup (o_1_space_prefix moduleName) $ concat+            [ o_1_space_merge_app_tap value+            , o_1_space_joining value             ]--    linear value =-        concat-            [ o_1_space_parallel_generation value-            , o_1_space_parallel_concatFoldable value-            -- , o_n_space_parallel_outerProductStreams-            , o_1_space_parallel_concatMap value-            , o_1_space_parallel_transformation value+        , bgroup (o_n_heap_prefix moduleName) $ concat+            [ o_n_heap_generation value+            , o_n_heap_mapping value+            , o_n_heap_concatFoldable value+            , o_n_heap_concat value+            , o_n_heap_outerProduct value             ]--    nested = o_1_space_parallel_outerProductStreams+        , bgroup (o_n_space_prefix moduleName) (o_n_space_outerProduct value)+        ]
+ benchmark/Streamly/Benchmark/Prelude/Rate.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module      : Main+-- Copyright   : (c) 2018 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com++import Streamly.Prelude (fromAsync, fromAhead, maxThreads, IsStream, MonadAsync)+import qualified Streamly.Prelude as S++import Streamly.Benchmark.Common+import Streamly.Benchmark.Prelude++import Gauge++moduleName :: String+moduleName = "Prelude.Rate"++-------------------------------------------------------------------------------+-- Average Rate+-------------------------------------------------------------------------------++{-# INLINE rateNothing #-}+rateNothing :: (MonadAsync m, IsStream t) => Int -> Int -> t m Int+rateNothing value = S.rate Nothing . sourceUnfoldrM value++{-# INLINE avgRate #-}+avgRate :: (MonadAsync m, IsStream t) => Int -> Double -> Int -> t m Int+avgRate value rate_ = S.avgRate rate_ . sourceUnfoldrM value++{-# INLINE avgRateThreads1 #-}+avgRateThreads1 :: (MonadAsync m, IsStream t) => Int -> Double -> Int -> t m Int+avgRateThreads1 value rate_ =+    maxThreads 1 . S.avgRate rate_ . sourceUnfoldrM value++{-# INLINE minRate #-}+minRate :: (MonadAsync m, IsStream t) => Int -> Double -> Int -> t m Int+minRate value rate_ = S.minRate rate_ . sourceUnfoldrM value++{-# INLINE maxRate #-}+maxRate :: (MonadAsync m, IsStream t) => Int -> Double -> Int -> t m Int+maxRate value rate_ = S.minRate rate_ . sourceUnfoldrM value++{-# INLINE constRate #-}+constRate :: (MonadAsync m, IsStream t) => Int -> Double -> Int -> t m Int+constRate value rate_ = S.constRate rate_ . sourceUnfoldrM value++-- XXX arbitrarily large rate should be the same as rate Nothing+o_1_space_async :: Int -> [Benchmark]+o_1_space_async value =+    [ bgroup+          "asyncly"+          [ bgroup+                "avgRate"+                -- benchIO "unfoldr" $ toNull fromAsync+                -- benchIOSrc fromAsync "unfoldrM" (sourceUnfoldrM value)+                [ benchIOSrc fromAsync "Nothing" $ rateNothing value+                , benchIOSrc fromAsync "1M" $ avgRate value 1000000+                , benchIOSrc fromAsync "3M" $ avgRate value 3000000+                , benchIOSrc fromAsync "10M/maxThreads1"+                      $ avgRateThreads1 value 10000000+                , benchIOSrc fromAsync "10M" $ avgRate value 10000000+                , benchIOSrc fromAsync "20M" $ avgRate value 20000000+                ]+          , bgroup+                "minRate"+                [ benchIOSrc fromAsync "1M" $ minRate value 1000000+                , benchIOSrc fromAsync "10M" $ minRate value 10000000+                , benchIOSrc fromAsync "20M" $ minRate value 20000000+                ]+          , bgroup+                "maxRate"+                [ -- benchIOSrc fromAsync "10K" $ maxRate value 10000+                  benchIOSrc fromAsync "10M" $ maxRate value 10000000+                ]+          , bgroup+                "constRate"+                [ -- benchIOSrc fromAsync "10K" $ constRate value 10000+                  benchIOSrc fromAsync "1M" $ constRate value 1000000+                , benchIOSrc fromAsync "10M" $ constRate value 10000000+                ]+          ]+    ]++o_1_space_ahead :: Int -> [Benchmark]+o_1_space_ahead value =+    [ bgroup+        "aheadly"+        [ benchIOSrc fromAhead "avgRate/1M" $ avgRate value 1000000+        , benchIOSrc fromAhead "minRate/1M" $ minRate value 1000000+        , benchIOSrc fromAhead "maxRate/1M" $ maxRate value 1000000+        , benchIOSrc fromAsync "constRate/1M" $ constRate value 1000000+        ]+    ]++-------------------------------------------------------------------------------+-- Main+-------------------------------------------------------------------------------++main :: IO ()+main = runWithCLIOpts defaultStreamSize allBenchmarks++    where++    allBenchmarks value =+        [ bgroup (o_1_space_prefix moduleName)+        $ concat [o_1_space_async value, o_1_space_ahead value]]
+ benchmark/Streamly/Benchmark/Prelude/Serial.hs view
@@ -0,0 +1,53 @@+-- |+-- Module      : Serial+-- Copyright   : (c) 2018 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}++module Main (main) where++import Streamly.Benchmark.Common.Handle (mkHandleBenchEnv)++import qualified Serial.Elimination as Elimination+import qualified Serial.Exceptions as Exceptions+import qualified Serial.Generation as Generation+import qualified Serial.Nested as Nested+import qualified Serial.Split as Split+import qualified Serial.Transformation1 as Transformation1+import qualified Serial.Transformation2 as Transformation2+import qualified Serial.Transformation3 as Transformation3++import Streamly.Benchmark.Common++moduleName :: String+moduleName = "Prelude.Serial"++-------------------------------------------------------------------------------+-- Main+-------------------------------------------------------------------------------++-- In addition to gauge options, the number of elements in the stream can be+-- passed using the --stream-size option.+--+main :: IO ()+main = do+    env <- mkHandleBenchEnv+    runWithCLIOpts defaultStreamSize (allBenchmarks env)++    where++    allBenchmarks env size = Prelude.concat+        [ Generation.benchmarks moduleName size+        , Elimination.benchmarks moduleName size+        , Exceptions.benchmarks moduleName env+        , Split.benchmarks moduleName env+        , Transformation1.benchmarks moduleName size+        , Transformation2.benchmarks moduleName size+        , Transformation3.benchmarks moduleName size+        , Nested.benchmarks moduleName size+        ]
+ benchmark/Streamly/Benchmark/Prelude/Serial/Elimination.hs view
@@ -0,0 +1,684 @@+-- |+-- Module      : Serial.Elimination+-- Copyright   : (c) 2018 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}++#ifdef __HADDOCK_VERSION__+#undef INSPECTION+#endif++#ifdef INSPECTION+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}+#endif++module Serial.Elimination (benchmarks) where++import Control.DeepSeq (NFData(..))+import Data.Functor.Identity (Identity, runIdentity)+import System.Random (randomRIO)++import qualified Data.Foldable as F+import qualified GHC.Exts as GHC++#ifdef INSPECTION+import GHC.Types (SPEC(..))+import Test.Inspection++import qualified Streamly.Internal.Data.Stream.StreamD as D+#endif++import qualified Streamly.Prelude  as S+import qualified Streamly.Internal.Data.Stream.IsStream as Internal++import Gauge+import Streamly.Prelude (SerialT, IsStream, fromSerial)+import Streamly.Benchmark.Common+import Streamly.Benchmark.Prelude+import Prelude hiding (length, sum, or, and, any, all, notElem, elem, (!!),+    lookup, repeat, minimum, maximum, product, last, mapM_, init)+import qualified Prelude++{-# INLINE repeat #-}+repeat :: (Monad m, S.IsStream t) => Int -> Int -> t m Int+repeat count = S.take count . S.repeat++-------------------------------------------------------------------------------+-- Elimination+-------------------------------------------------------------------------------++-------------------------------------------------------------------------------+-- Foldable Instance+-------------------------------------------------------------------------------++{-# INLINE foldableFoldl' #-}+foldableFoldl' :: Int -> Int -> Int+foldableFoldl' value n =+    F.foldl' (+) 0 (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableFoldrElem #-}+foldableFoldrElem :: Int -> Int -> Bool+foldableFoldrElem value n =+    F.foldr (\x xs -> x == value || xs)+            False+            (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableSum #-}+foldableSum :: Int -> Int -> Int+foldableSum value n =+    Prelude.sum (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableProduct #-}+foldableProduct :: Int -> Int -> Int+foldableProduct value n =+    Prelude.product (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE _foldableNull #-}+_foldableNull :: Int -> Int -> Bool+_foldableNull value n =+    Prelude.null (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableElem #-}+foldableElem :: Int -> Int -> Bool+foldableElem value n =+    value `Prelude.elem` (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableNotElem #-}+foldableNotElem :: Int -> Int -> Bool+foldableNotElem value n =+    value `Prelude.notElem` (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableFind #-}+foldableFind :: Int -> Int -> Maybe Int+foldableFind value n =+    F.find (== (value + 1)) (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableAll #-}+foldableAll :: Int -> Int -> Bool+foldableAll value n =+    Prelude.all (<= (value + 1)) (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableAny #-}+foldableAny :: Int -> Int -> Bool+foldableAny value n =+    Prelude.any (> (value + 1)) (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableAnd #-}+foldableAnd :: Int -> Int -> Bool+foldableAnd value n =+    Prelude.and $ S.map+        (<= (value + 1)) (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableOr #-}+foldableOr :: Int -> Int -> Bool+foldableOr value n =+    Prelude.or $ S.map+        (> (value + 1)) (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableLength #-}+foldableLength :: Int -> Int -> Int+foldableLength value n =+    Prelude.length (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableMin #-}+foldableMin :: Int -> Int -> Int+foldableMin value n =+    Prelude.minimum (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE ordInstanceMin #-}+ordInstanceMin :: SerialT Identity Int -> SerialT Identity Int+ordInstanceMin src = min src src++{-# INLINE foldableMax #-}+foldableMax :: Int -> Int -> Int+foldableMax value n =+    Prelude.maximum (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableMinBy #-}+foldableMinBy :: Int -> Int -> Int+foldableMinBy value n =+    F.minimumBy compare (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableListMinBy #-}+foldableListMinBy :: Int -> Int -> Int+foldableListMinBy value n = F.minimumBy compare [1..value+n]++{-# INLINE foldableMaxBy #-}+foldableMaxBy :: Int -> Int -> Int+foldableMaxBy value n =+    F.maximumBy compare (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableToList #-}+foldableToList :: Int -> Int -> [Int]+foldableToList value n =+    F.toList (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableMapM_ #-}+foldableMapM_ :: Monad m => Int -> Int -> m ()+foldableMapM_ value n =+    F.mapM_ (\_ -> return ()) (sourceUnfoldr value n :: S.SerialT Identity Int)++{-# INLINE foldableSequence_ #-}+foldableSequence_ :: Int -> Int -> IO ()+foldableSequence_ value n =+    F.sequence_ (sourceUnfoldrAction value n :: S.SerialT Identity (IO Int))++{-# INLINE _foldableMsum #-}+_foldableMsum :: Int -> Int -> IO Int+_foldableMsum value n =+    F.msum (sourceUnfoldrAction value n :: S.SerialT Identity (IO Int))++{-# INLINE showInstance #-}+showInstance :: SerialT Identity Int -> String+showInstance = show++o_1_space_elimination_foldable :: Int -> [Benchmark]+o_1_space_elimination_foldable value =+    [ bgroup "foldable"+          -- Foldable instance+        [ bench "foldl'" $ nf (foldableFoldl' value) 1+        , bench "foldrElem" $ nf (foldableFoldrElem value) 1+     -- , bench "null" $ nf (_foldableNull value) 1+        , bench "elem" $ nf (foldableElem value) 1+        , bench "length" $ nf (foldableLength value) 1+        , bench "sum" $ nf (foldableSum value) 1+        , bench "product" $ nf (foldableProduct value) 1+        , bench "minimum" $ nf (foldableMin value) 1+        , benchPureSink value "min (ord)" ordInstanceMin+        , bench "maximum" $ nf (foldableMax value) 1+        , bench "length . toList"+            $ nf (Prelude.length . foldableToList value) 1+        , bench "notElem" $ nf (foldableNotElem value) 1+        , bench "find" $ nf (foldableFind value) 1+        , bench "all" $ nf (foldableAll value) 1+        , bench "any" $ nf (foldableAny value) 1+        , bench "and" $ nf (foldableAnd value) 1+        , bench "or" $ nf (foldableOr value) 1++        -- Applicative and Traversable operations+        -- TBD: traverse_+        , benchIOSink1 "mapM_" (foldableMapM_ value)+        -- TBD: for_+        -- TBD: forM_+        , benchIOSink1 "sequence_" (foldableSequence_ value)+        -- TBD: sequenceA_+        -- TBD: asum+        -- XXX needs to be fixed, results are in ns+        -- , benchIOSink1 "msum" (foldableMsum value)+        ]+    ]++o_n_space_elimination_foldable :: Int -> [Benchmark]+o_n_space_elimination_foldable value =+    -- Head recursive strict right folds.+    [ bgroup "foldl"+        -- XXX the definitions of minimumBy and maximumBy in Data.Foldable use+        -- foldl1 which does not work in constant memory for our+        -- implementation.  It works in constant memory for lists but even for+        -- lists it takes 15x more time compared to our foldl' based+        -- implementation.+        [ bench "minimumBy" $ nf (`foldableMinBy` 1) value+        , bench "maximumBy" $ nf (`foldableMaxBy` 1) value+        , bench "minimumByList" $ nf (`foldableListMinBy` 1) value+        ]+    ]++-------------------------------------------------------------------------------+-- Stream folds+-------------------------------------------------------------------------------++{-# INLINE benchPureSink #-}+benchPureSink :: NFData b+    => Int -> String -> (SerialT Identity Int -> b) -> Benchmark+benchPureSink value name = benchPure name (sourceUnfoldr value)++{-# INLINE benchHoistSink #-}+benchHoistSink+    :: (IsStream t, NFData b)+    => Int -> String -> (t Identity Int -> IO b) -> Benchmark+benchHoistSink value name f =+    bench name $ nfIO $ randomRIO (1,1) >>= f .  sourceUnfoldr value++-- XXX We should be using sourceUnfoldrM for fair comparison with IO monad, but+-- we can't use it as it requires MonadAsync constraint.+{-# INLINE benchIdentitySink #-}+benchIdentitySink+    :: (IsStream t, NFData b)+    => Int -> String -> (t Identity Int -> Identity b) -> Benchmark+benchIdentitySink value name f = bench name $ nf (f . sourceUnfoldr value) 1++-------------------------------------------------------------------------------+-- Reductions+-------------------------------------------------------------------------------++{-# INLINE uncons #-}+uncons :: Monad m => SerialT m Int -> m ()+uncons s = do+    r <- S.uncons s+    case r of+        Nothing -> return ()+        Just (_, t) -> uncons t++{-# INLINE init #-}+init :: Monad m => SerialT m a -> m ()+init s = S.init s >>= Prelude.mapM_ S.drain++{-# INLINE mapM_ #-}+mapM_ :: Monad m => SerialT m Int -> m ()+mapM_ = S.mapM_ (\_ -> return ())++{-# INLINE foldrMElem #-}+foldrMElem :: Monad m => Int -> SerialT m Int -> m Bool+foldrMElem e =+    S.foldrM+        (\x xs ->+             if x == e+                 then return True+                 else xs)+        (return False)++{-# INLINE foldrToStream #-}+foldrToStream :: Monad m => SerialT m Int -> m (SerialT Identity Int)+foldrToStream = S.foldr S.cons S.nil++{-# INLINE foldrMBuild #-}+foldrMBuild :: Monad m => SerialT m Int -> m [Int]+foldrMBuild = S.foldrM (\x xs -> (x :) <$> xs) (return [])++{-# INLINE foldl'Reduce #-}+foldl'Reduce :: Monad m => SerialT m Int -> m Int+foldl'Reduce = S.foldl' (+) 0++{-# INLINE foldl1'Reduce #-}+foldl1'Reduce :: Monad m => SerialT m Int -> m (Maybe Int)+foldl1'Reduce = S.foldl1' (+)++{-# INLINE foldlM'Reduce #-}+foldlM'Reduce :: Monad m => SerialT m Int -> m Int+foldlM'Reduce = S.foldlM' (\xs a -> return $ a + xs) (return 0)++{-# INLINE last #-}+last :: Monad m => SerialT m Int -> m (Maybe Int)+last = S.last++{-# INLINE _head #-}+_head :: Monad m => SerialT m Int -> m (Maybe Int)+_head = S.head++{-# INLINE elem #-}+elem :: Monad m => Int -> SerialT m Int -> m Bool+elem value = S.elem (value + 1)++{-# INLINE notElem #-}+notElem :: Monad m => Int -> SerialT m Int -> m Bool+notElem value = S.notElem (value + 1)++{-# INLINE length #-}+length :: Monad m => SerialT m Int -> m Int+length = S.length++{-# INLINE all #-}+all :: Monad m => Int -> SerialT m Int -> m Bool+all value = S.all (<= (value + 1))++{-# INLINE any #-}+any :: Monad m => Int -> SerialT m Int -> m Bool+any value = S.any (> (value + 1))++{-# INLINE and #-}+and :: Monad m => Int -> SerialT m Int -> m Bool+and value = S.and . S.map (<= (value + 1))++{-# INLINE or #-}+or :: Monad m => Int -> SerialT m Int -> m Bool+or value = S.or . S.map (> (value + 1))++{-# INLINE find #-}+find :: Monad m => Int -> SerialT m Int -> m (Maybe Int)+find value = S.find (== (value + 1))++{-# INLINE findM #-}+findM :: Monad m => Int -> SerialT m Int -> m (Maybe Int)+findM value = S.findM (\z -> return $ z == (value + 1))++{-# INLINE findIndex #-}+findIndex :: Monad m => Int -> SerialT m Int -> m (Maybe Int)+findIndex value = S.findIndex (== (value + 1))++{-# INLINE elemIndex #-}+elemIndex :: Monad m => Int -> SerialT m Int -> m (Maybe Int)+elemIndex value = S.elemIndex (value + 1)++{-# INLINE maximum #-}+maximum :: Monad m => SerialT m Int -> m (Maybe Int)+maximum = S.maximum++{-# INLINE minimum #-}+minimum :: Monad m => SerialT m Int -> m (Maybe Int)+minimum = S.minimum++{-# INLINE sum #-}+sum :: Monad m => SerialT m Int -> m Int+sum = S.sum++{-# INLINE product #-}+product :: Monad m => SerialT m Int -> m Int+product = S.product++{-# INLINE minimumBy #-}+minimumBy :: Monad m => SerialT m Int -> m (Maybe Int)+minimumBy = S.minimumBy compare++{-# INLINE maximumBy #-}+maximumBy :: Monad m => SerialT m Int -> m (Maybe Int)+maximumBy = S.maximumBy compare++{-# INLINE the #-}+the :: Monad m => SerialT m Int -> m (Maybe Int)+the = S.the++{-# INLINE drainN #-}+drainN :: Monad m => Int -> SerialT m Int -> m ()+drainN = S.drainN++{-# INLINE drainWhile #-}+drainWhile :: Monad m => SerialT m Int -> m ()+drainWhile = S.drainWhile (const True)++{-# INLINE (!!) #-}+(!!) :: Monad m => Int -> SerialT m Int -> m (Maybe Int)+(!!) = flip (Internal.!!)++{-# INLINE lookup #-}+lookup :: Monad m => Int -> SerialT m Int -> m (Maybe Int)+lookup val = S.lookup val . S.map (\x -> (x, x))++o_1_space_elimination_folds :: Int -> [Benchmark]+o_1_space_elimination_folds value =+    [ bgroup "elimination"+        -- Basic folds+        [ bgroup "reduce"+            [ bgroup+                  "IO"+                  [ benchIOSink value "foldl'" foldl'Reduce+                  , benchIOSink value "foldl1'" foldl1'Reduce+                  , benchIOSink value "foldlM'" foldlM'Reduce+                  ]+            , bgroup+                  "Identity"+                  [ benchIdentitySink value "foldl'" foldl'Reduce+                  , benchIdentitySink value "foldl1'" foldl1'Reduce+                  , benchIdentitySink value "foldlM'" foldlM'Reduce+                  ]+            ]+        , bgroup "build"+            [ bgroup "IO"+                  [ benchIOSink value "foldrMElem" (foldrMElem value)+                  ]+            , bgroup "Identity"+                  [ benchIdentitySink value "foldrMElem" (foldrMElem value)+                  , benchIdentitySink value "foldrToStreamLength"+                        (S.length . runIdentity . foldrToStream)+                  , benchPureSink value "foldrMToListLength"+                        (Prelude.length . runIdentity . foldrMBuild)+                  ]+            ]++        -- deconstruction+        , benchIOSink value "uncons" uncons+        , benchIOSink value "init" init++        -- draining+        , benchIOSink value "drain" $ toNull fromSerial+        , benchIOSink value "drainN" $ drainN value+        , benchIOSink value "drainWhile" drainWhile+        , benchPureSink value "drain (pure)" id+        , benchIOSink value "mapM_" mapM_++        -- this is too fast, causes all benchmarks reported in ns+    -- , benchIOSink value "head" head+        , benchIOSink value "last" last+        , benchIOSink value "length" length+        , benchHoistSink value "length . generally"+              (length . Internal.generally)+        , benchIOSink value "sum" sum+        , benchIOSink value "product" product+        , benchIOSink value "maximumBy" maximumBy+        , benchIOSink value "maximum" maximum+        , benchIOSink value "minimumBy" minimumBy+        , benchIOSink value "minimum" minimum++        , bench "the" $ nfIO $ randomRIO (1,1) >>= the . repeat value+        , benchIOSink value "find" (find value)+        , benchIOSink value "findM" (findM value)+        -- , benchIOSink value "lookupFirst" (lookup 1)+        , benchIOSink value "lookupNever" (lookup (value + 1))+        , benchIOSink value "(!!)" (value !!)+        , benchIOSink value "findIndex" (findIndex value)+        , benchIOSink value "elemIndex" (elemIndex value)+        -- this is too fast, causes all benchmarks reported in ns+    -- , benchIOSink value "null" S.null+        , benchIOSink value "elem" (elem value)+        , benchIOSink value "notElem" (notElem value)+        , benchIOSink value "all" (all value)+        , benchIOSink value "any" (any value)+        , benchIOSink value "and" (and value)+        , benchIOSink value "or" (or value)++        -- length is used to check for foldr/build fusion+        , benchPureSink value "length . IsList.toList" (Prelude.length . GHC.toList)+        ]+    ]++-------------------------------------------------------------------------------+-- Buffered Transformations by fold+-------------------------------------------------------------------------------++{-# INLINE foldl'Build #-}+foldl'Build :: Monad m => SerialT m Int -> m [Int]+foldl'Build = S.foldl' (flip (:)) []++{-# INLINE foldlM'Build #-}+foldlM'Build :: Monad m => SerialT m Int -> m [Int]+foldlM'Build = S.foldlM' (\xs x -> return $ x : xs) (return [])++o_n_heap_elimination_foldl :: Int -> [Benchmark]+o_n_heap_elimination_foldl value =+    [ bgroup "foldl"+        -- Left folds for building a structure are inherently non-streaming+        -- as the structure cannot be lazily consumed until fully built.+        [ benchIOSink value "foldl'/build/IO" foldl'Build+        , benchIdentitySink value "foldl'/build/Identity" foldl'Build+        , benchIOSink value "foldlM'/build/IO" foldlM'Build+        , benchIdentitySink value "foldlM'/build/Identity" foldlM'Build+        ]+    ]++-- For comparisons+{-# INLINE showInstanceList #-}+showInstanceList :: [Int] -> String+showInstanceList = show++o_n_heap_elimination_buffered :: Int -> [Benchmark]+o_n_heap_elimination_buffered value =+    [ bgroup "buffered"+        -- Buffers the output of show/read.+        -- XXX can the outputs be streaming? Can we have special read/show+        -- style type classes, readM/showM supporting streaming effects?+        [ bench "showPrec Haskell lists" $ nf showInstanceList (mkList value)+        -- XXX This is not o-1-space for GHC-8.10+        , benchPureSink value "showsPrec pure streams" showInstance+        ]+    ]++{-# INLINE foldrMReduce #-}+foldrMReduce :: Monad m => SerialT m Int -> m Int+foldrMReduce = S.foldrM (\x xs -> (x +) <$> xs) (return 0)++o_n_space_elimination_foldr :: Int -> [Benchmark]+o_n_space_elimination_foldr value =+    -- Head recursive strict right folds.+    [ bgroup "foldr"+        -- accumulation due to strictness of IO monad+        [ benchIOSink value "foldrM/build/IO (toList)" foldrMBuild+        -- Right folds for reducing are inherently non-streaming as the+        -- expression needs to be fully built before it can be reduced.+        , benchIdentitySink value "foldrM/reduce/Identity (sum)" foldrMReduce+        , benchIOSink value "foldrM/reduce/IO (sum)" foldrMReduce+        ]+    ]++o_n_heap_elimination_toList :: Int -> [Benchmark]+o_n_heap_elimination_toList value =+    [ bgroup "toList"+        -- Converting the stream to a list or pure stream in a strict monad+        [ benchIOSink value "toListRev" Internal.toListRev+        , benchIOSink value "toStreamRev" Internal.toStreamRev+        ]+    ]++o_n_space_elimination_toList :: Int -> [Benchmark]+o_n_space_elimination_toList value =+    [ bgroup "toList"+        -- Converting the stream to a list or pure stream in a strict monad+        [ benchIOSink value "toList" S.toList+        , benchIOSink value "toStream" Internal.toStream+        ]+    ]++-------------------------------------------------------------------------------+-- Multi-stream folds+-------------------------------------------------------------------------------++-------------------------------------------------------------------------------+-- Multi-stream pure+-------------------------------------------------------------------------------++{-# INLINE eqBy' #-}+eqBy' :: (Monad m, Eq a) => SerialT m a -> m Bool+eqBy' src = S.eqBy (==) src src++{-# INLINE eqByPure #-}+eqByPure :: Int -> Int -> Identity Bool+eqByPure value n = eqBy' (sourceUnfoldr value n)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'eqByPure+inspect $ 'eqByPure `hasNoType` ''SPEC+inspect $ 'eqByPure `hasNoType` ''D.Step+#endif++{-# INLINE eqInstance #-}+eqInstance :: SerialT Identity Int -> Bool+eqInstance src = src == src++{-# INLINE eqInstanceNotEq #-}+eqInstanceNotEq :: SerialT Identity Int -> Bool+eqInstanceNotEq src = src /= src++{-# INLINE cmpBy' #-}+cmpBy' :: (Monad m, Ord a) => SerialT m a -> m Ordering+cmpBy' src = S.cmpBy compare src src++{-# INLINE cmpByPure #-}+cmpByPure :: Int -> Int -> Identity Ordering+cmpByPure value n = cmpBy' (sourceUnfoldr value n)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'cmpByPure+inspect $ 'cmpByPure `hasNoType` ''SPEC+inspect $ 'cmpByPure `hasNoType` ''D.Step+#endif++{-# INLINE ordInstance #-}+ordInstance :: SerialT Identity Int -> Bool+ordInstance src = src < src++o_1_space_elimination_multi_stream_pure :: Int -> [Benchmark]+o_1_space_elimination_multi_stream_pure value =+    [ bgroup "multi-stream-pure"+        [ benchPureSink1 "eqBy" (eqByPure value)+        , benchPureSink value "==" eqInstance+        , benchPureSink value "/=" eqInstanceNotEq+        , benchPureSink1 "cmpBy" (cmpByPure value)+        , benchPureSink value "<" ordInstance+        ]+    ]++{-# INLINE isPrefixOf #-}+isPrefixOf :: Monad m => SerialT m Int -> m Bool+isPrefixOf src = S.isPrefixOf src src++{-# INLINE isSubsequenceOf #-}+isSubsequenceOf :: Monad m => SerialT m Int -> m Bool+isSubsequenceOf src = S.isSubsequenceOf src src++{-# INLINE stripPrefix #-}+stripPrefix :: Monad m => SerialT m Int -> m ()+stripPrefix src = do+    _ <- S.stripPrefix src src+    return ()++{-# INLINE eqBy #-}+eqBy :: Int -> Int -> IO Bool+eqBy value n = eqBy' (sourceUnfoldrM value n)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'eqBy+inspect $ 'eqBy `hasNoType` ''SPEC+inspect $ 'eqBy `hasNoType` ''D.Step+#endif++{-# INLINE cmpBy #-}+cmpBy :: Int -> Int -> IO Ordering+cmpBy value n = cmpBy' (sourceUnfoldrM value n)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'cmpBy+inspect $ 'cmpBy `hasNoType` ''SPEC+inspect $ 'cmpBy `hasNoType` ''D.Step+#endif++o_1_space_elimination_multi_stream :: Int -> [Benchmark]+o_1_space_elimination_multi_stream value =+    [ bgroup "multi-stream"+        [ benchIOSink1 "eqBy" (eqBy value)+        , benchIOSink1 "cmpBy" (cmpBy value)+        , benchIOSink value "isPrefixOf" isPrefixOf+        , benchIOSink value "isSubsequenceOf" isSubsequenceOf+        , benchIOSink value "stripPrefix" stripPrefix+        ]+    ]++-------------------------------------------------------------------------------+-- Main+-------------------------------------------------------------------------------++-- In addition to gauge options, the number of elements in the stream can be+-- passed using the --stream-size option.+--+benchmarks :: String -> Int -> [Benchmark]+benchmarks moduleName size =+        [ bgroup (o_1_space_prefix moduleName) $ concat+            [ o_1_space_elimination_foldable size+            , o_1_space_elimination_folds size+            , o_1_space_elimination_multi_stream_pure size+            , o_1_space_elimination_multi_stream size+            ]+        , bgroup (o_n_heap_prefix moduleName) $ concat+            [ o_n_heap_elimination_foldl size+            , o_n_heap_elimination_toList size+            , o_n_heap_elimination_buffered size+            ]+        , bgroup (o_n_space_prefix moduleName) $ concat+            [ o_n_space_elimination_foldable size+            , o_n_space_elimination_toList size+            , o_n_space_elimination_foldr size+            ]+        ]
+ benchmark/Streamly/Benchmark/Prelude/Serial/Exceptions.hs view
@@ -0,0 +1,240 @@+-- |+-- Module      : Streamly.Benchmark.Prelude.Serial.Exceptions+-- Copyright   : (c) 2019 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}++#ifdef __HADDOCK_VERSION__+#undef INSPECTION+#endif++#ifdef INSPECTION+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}+#endif++module Serial.Exceptions (benchmarks) where++import Control.Exception (SomeException)+import System.IO (Handle, hClose, hPutChar)++import qualified Streamly.FileSystem.Handle as FH+import qualified Streamly.Internal.Data.Unfold as IUF+import qualified Streamly.Internal.FileSystem.Handle as IFH+import qualified Streamly.Internal.Data.Stream.IsStream as IP+import qualified Streamly.Prelude as S++import Gauge hiding (env)+import Prelude hiding (last, length)+import Streamly.Benchmark.Common+import Streamly.Benchmark.Common.Handle++#ifdef INSPECTION+import Test.Inspection++import qualified Streamly.Internal.Data.Stream.StreamD as D+#endif++-------------------------------------------------------------------------------+-- stream exceptions+-------------------------------------------------------------------------------++-- | Send the file contents to /dev/null with exception handling+readWriteOnExceptionStream :: Handle -> Handle -> IO ()+readWriteOnExceptionStream inh devNull =+    let readEx = S.onException (hClose inh) (S.unfold FH.read inh)+    in S.fold (FH.write devNull) $ readEx++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'readWriteOnExceptionStream+#endif++-- | Send the file contents to /dev/null with exception handling+readWriteHandleExceptionStream :: Handle -> Handle -> IO ()+readWriteHandleExceptionStream inh devNull =+    let handler (_e :: SomeException) = S.fromEffect (hClose inh >> return 10)+        readEx = S.handle handler (S.unfold FH.read inh)+    in S.fold (FH.write devNull) $ readEx++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'readWriteHandleExceptionStream+#endif++-- | Send the file contents to /dev/null with exception handling+readWriteFinally_Stream :: Handle -> Handle -> IO ()+readWriteFinally_Stream inh devNull =+    let readEx = IP.finally_ (hClose inh) (S.unfold FH.read inh)+    in S.fold (FH.write devNull) readEx++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'readWriteFinally_Stream+#endif++readWriteFinallyStream :: Handle -> Handle -> IO ()+readWriteFinallyStream inh devNull =+    let readEx = S.finally (hClose inh) (S.unfold FH.read inh)+    in S.fold (FH.write devNull) readEx++-- | Send the file contents to /dev/null with exception handling+fromToBytesBracket_Stream :: Handle -> Handle -> IO ()+fromToBytesBracket_Stream inh devNull =+    let readEx = IP.bracket_ (return ()) (\_ -> hClose inh)+                    (\_ -> IFH.toBytes inh)+    in IFH.putBytes devNull $ readEx++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'fromToBytesBracket_Stream+#endif++fromToBytesBracketStream :: Handle -> Handle -> IO ()+fromToBytesBracketStream inh devNull =+    let readEx = S.bracket (return ()) (\_ -> hClose inh)+                    (\_ -> IFH.toBytes inh)+    in IFH.putBytes devNull $ readEx++readWriteBeforeAfterStream :: Handle -> Handle -> IO ()+readWriteBeforeAfterStream inh devNull =+    let readEx =+            IP.after (hClose inh)+                $ IP.before (hPutChar devNull 'A') (S.unfold FH.read inh)+     in S.fold (FH.write devNull) readEx++#ifdef INSPECTION+inspect $ 'readWriteBeforeAfterStream `hasNoType` ''D.Step+#endif++readWriteAfterStream :: Handle -> Handle -> IO ()+readWriteAfterStream inh devNull =+    let readEx = IP.after (hClose inh) (S.unfold FH.read inh)+     in S.fold (FH.write devNull) readEx++#ifdef INSPECTION+inspect $ 'readWriteAfterStream `hasNoType` ''D.Step+#endif++readWriteAfter_Stream :: Handle -> Handle -> IO ()+readWriteAfter_Stream inh devNull =+    let readEx = IP.after_ (hClose inh) (S.unfold FH.read inh)+     in S.fold (FH.write devNull) readEx++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'readWriteAfter_Stream+inspect $ 'readWriteAfter_Stream `hasNoType` ''D.Step+#endif++o_1_space_copy_stream_exceptions :: BenchEnv -> [Benchmark]+o_1_space_copy_stream_exceptions env =+    [ bgroup "exceptions"+       [ mkBenchSmall "S.onException" env $ \inh _ ->+           readWriteOnExceptionStream inh (nullH env)+       , mkBenchSmall "S.handle" env $ \inh _ ->+           readWriteHandleExceptionStream inh (nullH env)+       , mkBenchSmall "S.finally_" env $ \inh _ ->+           readWriteFinally_Stream inh (nullH env)+       , mkBenchSmall "S.finally" env $ \inh _ ->+           readWriteFinallyStream inh (nullH env)+       , mkBenchSmall "S.after . S.before" env $ \inh _ ->+           readWriteBeforeAfterStream inh (nullH env)+       , mkBenchSmall "S.after" env $ \inh _ ->+           readWriteAfterStream inh (nullH env)+       , mkBenchSmall "S.after_" env $ \inh _ ->+           readWriteAfter_Stream inh (nullH env)+       ]+    , bgroup "exceptions/fromToBytes"+       [ mkBenchSmall "S.bracket_" env $ \inh _ ->+           fromToBytesBracket_Stream inh (nullH env)+       , mkBenchSmall "S.bracket" env $ \inh _ ->+           fromToBytesBracketStream inh (nullH env)+        ]+    ]++ -------------------------------------------------------------------------------+-- Exceptions readChunks+-------------------------------------------------------------------------------++-- | Send the file contents to /dev/null with exception handling+readChunksOnException :: Handle -> Handle -> IO ()+readChunksOnException inh devNull =+    let readEx = IUF.onException (\_ -> hClose inh) FH.readChunks+    in IUF.fold (IFH.writeChunks devNull) readEx inh++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'readChunksOnException+#endif++-- | Send the file contents to /dev/null with exception handling+readChunksBracket_ :: Handle -> Handle -> IO ()+readChunksBracket_ inh devNull =+    let readEx = IUF.bracket_ return (\_ -> hClose inh) FH.readChunks+    in IUF.fold (IFH.writeChunks devNull) readEx inh++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'readChunksBracket_+#endif++readChunksBracket :: Handle -> Handle -> IO ()+readChunksBracket inh devNull =+    let readEx = IUF.bracket return (\_ -> hClose inh) FH.readChunks+    in IUF.fold (IFH.writeChunks devNull) readEx inh++o_1_space_copy_exceptions_readChunks :: BenchEnv -> [Benchmark]+o_1_space_copy_exceptions_readChunks env =+    [ bgroup "exceptions/readChunks"+        [ mkBench "UF.onException" env $ \inH _ ->+            readChunksOnException inH (nullH env)+        , mkBench "UF.bracket_" env $ \inH _ ->+            readChunksBracket_ inH (nullH env)+        , mkBench "UF.bracket" env $ \inH _ ->+            readChunksBracket inH (nullH env)+        ]+    ]++-------------------------------------------------------------------------------+-- Exceptions toChunks+-------------------------------------------------------------------------------++-- | Send the file contents to /dev/null with exception handling+toChunksBracket_ :: Handle -> Handle -> IO ()+toChunksBracket_ inh devNull =+    let readEx = IP.bracket_+            (return ())+            (\_ -> hClose inh)+            (\_ -> IFH.toChunks inh)+    in S.fold (IFH.writeChunks devNull) $ readEx++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'toChunksBracket_+#endif++toChunksBracket :: Handle -> Handle -> IO ()+toChunksBracket inh devNull =+    let readEx = S.bracket+            (return ())+            (\_ -> hClose inh)+            (\_ -> IFH.toChunks inh)+    in S.fold (IFH.writeChunks devNull) $ readEx++o_1_space_copy_exceptions_toChunks :: BenchEnv -> [Benchmark]+o_1_space_copy_exceptions_toChunks env =+    [ bgroup "exceptions/toChunks"+        [ mkBench "S.bracket_" env $ \inH _ ->+            toChunksBracket_ inH (nullH env)+        , mkBench "S.bracket" env $ \inH _ ->+            toChunksBracket inH (nullH env)+        ]+    ]+++benchmarks :: String -> BenchEnv -> [Benchmark]+benchmarks moduleName env =+        [ bgroup (o_1_space_prefix moduleName) $ concat+            [ o_1_space_copy_exceptions_readChunks env+            , o_1_space_copy_exceptions_toChunks env+            , o_1_space_copy_stream_exceptions env+            ]+        ]
+ benchmark/Streamly/Benchmark/Prelude/Serial/Generation.hs view
@@ -0,0 +1,179 @@+-- |+-- Module      : Serial.Generation+-- Copyright   : (c) 2018 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}++module Serial.Generation (benchmarks) where++import Data.Functor.Identity (Identity)++import qualified Prelude+import qualified GHC.Exts as GHC++import qualified Streamly.Prelude  as S++import Gauge+import Streamly.Prelude (SerialT, fromSerial, MonadAsync)+import Streamly.Benchmark.Common+import Streamly.Benchmark.Prelude+import Prelude hiding (repeat, replicate, iterate)++-------------------------------------------------------------------------------+-- Generation+-------------------------------------------------------------------------------++-------------------------------------------------------------------------------+-- fromList+-------------------------------------------------------------------------------++{-# INLINE sourceIsList #-}+sourceIsList :: Int -> Int -> SerialT Identity Int+sourceIsList value n = GHC.fromList [n..n+value]++{-# INLINE sourceIsString #-}+sourceIsString :: Int -> Int -> SerialT Identity Char+sourceIsString value n = GHC.fromString (Prelude.replicate (n + value) 'a')++{-# INLINE readInstance #-}+readInstance :: String -> SerialT Identity Int+readInstance str =+    let r = reads str+    in case r of+        [(x,"")] -> x+        _ -> error "readInstance: no parse"++-- For comparisons+{-# INLINE readInstanceList #-}+readInstanceList :: String -> [Int]+readInstanceList str =+    let r = reads str+    in case r of+        [(x,"")] -> x+        _ -> error "readInstance: no parse"++{-# INLINE repeat #-}+repeat :: (Monad m, S.IsStream t) => Int -> Int -> t m Int+repeat count = S.take count . S.repeat++{-# INLINE repeatM #-}+repeatM :: (MonadAsync m, S.IsStream t) => Int -> Int -> t m Int+repeatM count = S.take count . S.repeatM . return++{-# INLINE replicate #-}+replicate :: (Monad m, S.IsStream t) => Int -> Int -> t m Int+replicate = S.replicate++{-# INLINE replicateM #-}+replicateM :: (MonadAsync m, S.IsStream t) => Int -> Int -> t m Int+replicateM count = S.replicateM count . return++{-# INLINE enumerateFrom #-}+enumerateFrom :: (Monad m, S.IsStream t) => Int -> Int -> t m Int+enumerateFrom count = S.take count . S.enumerateFrom++{-# INLINE enumerateFromTo #-}+enumerateFromTo :: (Monad m, S.IsStream t) => Int -> Int -> t m Int+enumerateFromTo = sourceIntFromTo++{-# INLINE enumerateFromThen #-}+enumerateFromThen :: (Monad m, S.IsStream t) => Int -> Int -> t m Int+enumerateFromThen count inp = S.take count $ S.enumerateFromThen inp (inp + 1)++{-# INLINE enumerateFromThenTo #-}+enumerateFromThenTo :: (Monad m, S.IsStream t) => Int -> Int -> t m Int+enumerateFromThenTo = sourceIntFromThenTo++-- n ~ 1+{-# INLINE enumerate #-}+enumerate :: (Monad m, S.IsStream t) => Int -> Int -> t m Int+enumerate count n = S.take (count + n) S.enumerate++-- n ~ 1+{-# INLINE enumerateTo #-}+enumerateTo :: (Monad m, S.IsStream t) => Int -> Int -> t m Int+enumerateTo count n = S.enumerateTo (minBound + count + n)++{-# INLINE iterate #-}+iterate :: (Monad m, S.IsStream t) => Int -> Int -> t m Int+iterate count = S.take count . S.iterate (+1)++{-# INLINE iterateM #-}+iterateM :: (MonadAsync m, S.IsStream t) => Int -> Int -> t m Int+iterateM count = S.take count . S.iterateM (return . (+1)) . return++{-# INLINE fromIndices #-}+fromIndices :: (Monad m, S.IsStream t) => Int -> Int -> t m Int+fromIndices value n = S.take value $ S.fromIndices (+ n)++{-# INLINE fromIndicesM #-}+fromIndicesM :: (MonadAsync m, S.IsStream t) => Int -> Int -> t m Int+fromIndicesM value n = S.take value $ S.fromIndicesM (return <$> (+ n))++o_1_space_generation :: Int -> [Benchmark]+o_1_space_generation value =+    [ bgroup "generation"+        [ benchIOSrc fromSerial "unfoldr" (sourceUnfoldr value)+        , benchIOSrc fromSerial "unfoldrM" (sourceUnfoldrM value)+        , benchIOSrc fromSerial "repeat" (repeat value)+        , benchIOSrc fromSerial "repeatM" (repeatM value)+        , benchIOSrc fromSerial "replicate" (replicate value)+        , benchIOSrc fromSerial "replicateM" (replicateM value)+        , benchIOSrc fromSerial "iterate" (iterate value)+        , benchIOSrc fromSerial "iterateM" (iterateM value)+        , benchIOSrc fromSerial "fromIndices" (fromIndices value)+        , benchIOSrc fromSerial "fromIndicesM" (fromIndicesM value)+        , benchIOSrc fromSerial "intFromTo" (sourceIntFromTo value)+        , benchIOSrc fromSerial "intFromThenTo" (sourceIntFromThenTo value)+        , benchIOSrc fromSerial "integerFromStep" (sourceIntegerFromStep value)+        , benchIOSrc fromSerial "fracFromThenTo" (sourceFracFromThenTo value)+        , benchIOSrc fromSerial "fracFromTo" (sourceFracFromTo value)+        , benchIOSrc fromSerial "fromList" (sourceFromList value)+        , benchPureSrc "IsList.fromList" (sourceIsList value)+        , benchPureSrc "IsString.fromString" (sourceIsString value)+        , benchIOSrc fromSerial "fromListM" (sourceFromListM value)+        , benchIOSrc fromSerial "enumerateFrom" (enumerateFrom value)+        , benchIOSrc fromSerial "enumerateFromTo" (enumerateFromTo value)+        , benchIOSrc fromSerial "enumerateFromThen" (enumerateFromThen value)+        , benchIOSrc fromSerial "enumerateFromThenTo" (enumerateFromThenTo value)+        , benchIOSrc fromSerial "enumerate" (enumerate value)+        , benchIOSrc fromSerial "enumerateTo" (enumerateTo value)++          -- These essentially test cons and consM+        , benchIOSrc fromSerial "fromFoldable" (sourceFromFoldable value)+        , benchIOSrc fromSerial "fromFoldableM" (sourceFromFoldableM value)++        , benchIOSrc fromSerial "absTimes" $ absTimes value+        ]+    ]++o_n_heap_generation :: Int -> [Benchmark]+o_n_heap_generation value =+    [ bgroup "buffered"+    -- Buffers the output of show/read.+    -- XXX can the outputs be streaming? Can we have special read/show+    -- style type classes, readM/showM supporting streaming effects?+        [ bench "readsPrec pure streams" $+          nf readInstance (mkString value)+        , bench "readsPrec Haskell lists" $+          nf readInstanceList (mkListString value)+        ]+    ]++-------------------------------------------------------------------------------+-- Main+-------------------------------------------------------------------------------++-- In addition to gauge options, the number of elements in the stream can be+-- passed using the --stream-size option.+--+benchmarks :: String -> Int -> [Benchmark]+benchmarks moduleName size =+        [ bgroup (o_1_space_prefix moduleName) (o_1_space_generation size)+        , bgroup (o_n_heap_prefix moduleName) (o_n_heap_generation size)+        ]
+ benchmark/Streamly/Benchmark/Prelude/Serial/Nested.hs view
@@ -0,0 +1,486 @@+-- |+-- Module      : Serial.Nested+-- Copyright   : (c) 2018 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}++#ifdef __HADDOCK_VERSION__+#undef INSPECTION+#endif++#ifdef INSPECTION+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}+#endif++module Serial.Nested (benchmarks) where++import Control.Monad.Trans.Class (lift)++import qualified Control.Applicative as AP++#ifdef INSPECTION+import GHC.Types (SPEC(..))+import Test.Inspection++import qualified Streamly.Internal.Data.Stream.StreamD as D+#endif++import qualified Streamly.Prelude  as S+import qualified Streamly.Internal.Data.Stream.IsStream as Internal+import qualified Streamly.Internal.Data.Unfold as UF++import Gauge+import Streamly.Prelude (SerialT, fromSerial, serial)+import Streamly.Benchmark.Common+import Streamly.Benchmark.Prelude+import Prelude hiding (concatMap)++-------------------------------------------------------------------------------+-- Iteration/looping utilities+-------------------------------------------------------------------------------++{-# INLINE iterateN #-}+iterateN :: (Int -> a -> a) -> a -> Int -> a+iterateN g initial count = f count initial++    where++    f (0 :: Int) x = x+    f i x = f (i - 1) (g i x)++-- Iterate a transformation over a singleton stream+{-# INLINE iterateSingleton #-}+iterateSingleton :: S.MonadAsync m+    => (Int -> SerialT m Int -> SerialT m Int)+    -> Int+    -> Int+    -> SerialT m Int+iterateSingleton g count n = iterateN g (return n) count++-- XXX need to check why this is slower than the explicit recursion above, even+-- if the above code is written in a foldr like head recursive way. We also+-- need to try this with foldlM' once #150 is fixed.+-- However, it is perhaps best to keep the iteration benchmarks independent of+-- foldrM and any related fusion issues.+{-# INLINE _iterateSingleton #-}+_iterateSingleton ::+       S.MonadAsync m+    => (Int -> SerialT m Int -> SerialT m Int)+    -> Int+    -> Int+    -> SerialT m Int+_iterateSingleton g value n = S.foldrM g (return n) $ sourceIntFromTo value n++-------------------------------------------------------------------------------+-- Multi-Stream+-------------------------------------------------------------------------------++-------------------------------------------------------------------------------+-- Appending+-------------------------------------------------------------------------------++{-# INLINE serial2 #-}+serial2 :: Int -> Int -> IO ()+serial2 count n =+    S.drain $+        S.serial (sourceUnfoldrM count n) (sourceUnfoldrM count (n + 1))++{-# INLINE serial4 #-}+serial4 :: Int -> Int -> IO ()+serial4 count n =+    S.drain $+    S.serial+        (S.serial (sourceUnfoldrM count n) (sourceUnfoldrM count (n + 1)))+        (S.serial+              (sourceUnfoldrM count (n + 2))+              (sourceUnfoldrM count (n + 3)))++{-# INLINE append2 #-}+append2 :: Int -> Int -> IO ()+append2 count n =+    S.drain $+    Internal.append (sourceUnfoldrM count n) (sourceUnfoldrM count (n + 1))++{-# INLINE append4 #-}+append4 :: Int -> Int -> IO ()+append4 count n =+    S.drain $+    Internal.append+        (Internal.append+              (sourceUnfoldrM count n)+              (sourceUnfoldrM count (n + 1)))+        (Internal.append+              (sourceUnfoldrM count (n + 2))+              (sourceUnfoldrM count (n + 3)))++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'append2+inspect $ 'append2 `hasNoType` ''SPEC+inspect $ 'append2 `hasNoType` ''D.AppendState+#endif++-------------------------------------------------------------------------------+-- Merging+-------------------------------------------------------------------------------++{-# INLINE mergeBy #-}+mergeBy :: Int -> Int -> IO ()+mergeBy count n =+    S.drain $+    S.mergeBy+        compare+        (sourceUnfoldrM count n)+        (sourceUnfoldrM count (n + 1))++{-# INLINE mergeByM #-}+mergeByM :: Int -> Int -> IO ()+mergeByM count n =+    S.drain $+    S.mergeByM+        (\a b -> return $ compare a b)+        (sourceUnfoldrM count n)+        (sourceUnfoldrM count (n + 1))++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'mergeBy+inspect $ 'mergeBy `hasNoType` ''SPEC+inspect $ 'mergeBy `hasNoType` ''D.Step++inspect $ hasNoTypeClasses 'mergeByM+inspect $ 'mergeByM `hasNoType` ''SPEC+inspect $ 'mergeByM `hasNoType` ''D.Step+#endif++o_1_space_joining :: Int -> [Benchmark]+o_1_space_joining value =+    [ bgroup "joining"+        [ benchIOSrc1 "serial (2,x/2)" (serial2 (value `div` 2))+        , benchIOSrc1 "append (2,x/2)" (append2 (value `div` 2))+        , benchIOSrc1 "serial (2,2,x/4)" (serial4 (value `div` 4))+        , benchIOSrc1 "append (2,2,x/4)" (append4 (value `div` 4))+        , benchIOSrc1 "mergeBy (2,x/2)" (mergeBy (value `div` 2))+        , benchIOSrc1 "mergeByM (2,x/2)" (mergeByM (value `div` 2))+        ]+    ]++-------------------------------------------------------------------------------+-- Concat Foldable containers+-------------------------------------------------------------------------------++o_1_space_concatFoldable :: Int -> [Benchmark]+o_1_space_concatFoldable value =+    [ bgroup "concat-foldable"+        [ benchIOSrc fromSerial "foldMapWith (<>) (List)"+            (sourceFoldMapWith value)+        , benchIOSrc fromSerial "foldMapWith (<>) (Stream)"+            (sourceFoldMapWithStream value)+        , benchIOSrc fromSerial "foldMapWithM (<>) (List)"+            (sourceFoldMapWithM value)+        , benchIOSrc fromSerial "S.concatFoldableWith (<>) (List)"+            (concatFoldableWith value)+        , benchIOSrc fromSerial "S.concatForFoldableWith (<>) (List)"+            (concatForFoldableWith value)+        , benchIOSrc fromSerial "foldMapM (List)" (sourceFoldMapM value)+        ]+    ]++-------------------------------------------------------------------------------+-- Concat+-------------------------------------------------------------------------------++-- concatMap unfoldrM/unfoldrM++{-# INLINE concatMap #-}+concatMap :: Int -> Int -> Int -> IO ()+concatMap outer inner n =+    S.drain $ S.concatMap+        (\_ -> sourceUnfoldrM inner n)+        (sourceUnfoldrM outer n)++{-# INLINE concatMapM #-}+concatMapM :: Int -> Int -> Int -> IO ()+concatMapM outer inner n =+    S.drain $ S.concatMapM+        (\_ -> return $ sourceUnfoldrM inner n)+        (sourceUnfoldrM outer n)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'concatMap+inspect $ 'concatMap `hasNoType` ''SPEC+#endif++-- concatMap unfoldr/unfoldr++{-# INLINE concatMapPure #-}+concatMapPure :: Int -> Int -> Int -> IO ()+concatMapPure outer inner n =+    S.drain $ S.concatMap+        (\_ -> sourceUnfoldr inner n)+        (sourceUnfoldr outer n)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'concatMapPure+inspect $ 'concatMapPure `hasNoType` ''SPEC+#endif++-- concatMap replicate/unfoldrM++{-# INLINE concatMapRepl #-}+concatMapRepl :: Int -> Int -> Int -> IO ()+concatMapRepl outer inner n =+    S.drain $ S.concatMap (S.replicate inner) (sourceUnfoldrM outer n)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'concatMapRepl+inspect $ 'concatMapRepl `hasNoType` ''SPEC+#endif++-- concatMapWith++{-# INLINE concatMapWithSerial #-}+concatMapWithSerial :: Int -> Int -> Int -> IO ()+concatMapWithSerial = concatStreamsWith S.serial++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'concatMapWithSerial+inspect $ 'concatMapWithSerial `hasNoType` ''SPEC+#endif++{-# INLINE concatMapWithAppend #-}+concatMapWithAppend :: Int -> Int -> Int -> IO ()+concatMapWithAppend = concatStreamsWith Internal.append++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'concatMapWithAppend+inspect $ 'concatMapWithAppend `hasNoType` ''SPEC+#endif++-- concatPairWith++{-# INLINE concatPairWithAppend #-}+concatPairWithAppend :: Int -> Int -> Int -> IO ()+concatPairWithAppend = concatPairsWith Internal.append++{-# INLINE concatPairWithInterleave #-}+concatPairWithInterleave :: Int -> Int -> Int -> IO ()+concatPairWithInterleave = concatPairsWith Internal.interleave++{-# INLINE concatPairWithInterleaveSuffix #-}+concatPairWithInterleaveSuffix :: Int -> Int -> Int -> IO ()+concatPairWithInterleaveSuffix = concatPairsWith Internal.interleaveSuffix++{-# INLINE concatPairWithInterleaveInfix #-}+concatPairWithInterleaveInfix :: Int -> Int -> Int -> IO ()+concatPairWithInterleaveInfix = concatPairsWith Internal.interleaveInfix++{-# INLINE concatPairWithInterleaveMin #-}+concatPairWithInterleaveMin :: Int -> Int -> Int -> IO ()+concatPairWithInterleaveMin = concatPairsWith Internal.interleaveMin++{-# INLINE concatPairWithRoundrobin #-}+concatPairWithRoundrobin :: Int -> Int -> Int -> IO ()+concatPairWithRoundrobin = concatPairsWith Internal.roundrobin++-- unfoldMany++-- unfoldMany replicate/unfoldrM++{-# INLINE unfoldManyRepl #-}+unfoldManyRepl :: Int -> Int -> Int -> IO ()+unfoldManyRepl outer inner n =+    S.drain+         $ S.unfoldMany+               (UF.lmap return (UF.replicateM inner))+               (sourceUnfoldrM outer n)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'unfoldManyRepl+inspect $ 'unfoldManyRepl `hasNoType` ''D.ConcatMapUState+inspect $ 'unfoldManyRepl `hasNoType` ''SPEC+#endif++o_1_space_concat :: Int -> [Benchmark]+o_1_space_concat value = sqrtVal `seq`+    [ bgroup "concat"+        [ benchIOSrc1 "concatMapPure (n of 1)"+            (concatMapPure value 1)+        , benchIOSrc1 "concatMapPure (sqrt n of sqrt n)"+            (concatMapPure sqrtVal sqrtVal)+        , benchIOSrc1 "concatMapPure (1 of n)"+            (concatMapPure 1 value)++        -- This is for comparison with foldMapWith+        , benchIOSrc fromSerial "concatMapId (n of 1) (fromFoldable)"+            (S.concatMap id . sourceConcatMapId value)++        , benchIOSrc1 "concatMap (n of 1)"+            (concatMap value 1)+        , benchIOSrc1 "concatMap (sqrt n of sqrt n)"+            (concatMap sqrtVal sqrtVal)+        , benchIOSrc1 "concatMap (1 of n)"+            (concatMap 1 value)++        , benchIOSrc1 "concatMapM (n of 1)"+            (concatMapM value 1)+        , benchIOSrc1 "concatMapM (sqrt n of sqrt n)"+            (concatMapM sqrtVal sqrtVal)+        , benchIOSrc1 "concatMapM (1 of n)"+            (concatMapM 1 value)++        -- This is for comparison with foldMapWith+        , benchIOSrc fromSerial "concatMapWithId (n of 1) (fromFoldable)"+            (S.concatMapWith serial id . sourceConcatMapId value)++        , benchIOSrc1 "concatMapWith (n of 1)"+            (concatMapWithSerial value 1)+        , benchIOSrc1 "concatMapWith (sqrt n of sqrt n)"+            (concatMapWithSerial sqrtVal sqrtVal)+        , benchIOSrc1 "concatMapWith (1 of n)"+            (concatMapWithSerial 1 value)++        -- quadratic with number of outer streams+        , benchIOSrc1 "concatMapWithAppend (2 of n/2)"+            (concatMapWithAppend 2 (value `div` 2))++        -- concatMap vs unfoldMany+        , benchIOSrc1 "concatMapRepl (sqrt n of sqrt n)"+            (concatMapRepl sqrtVal sqrtVal)+        , benchIOSrc1 "unfoldManyRepl (sqrt n of sqrt n)"+            (unfoldManyRepl sqrtVal sqrtVal)++        -------------------concatPairsWith-----------------++        , benchIOSrc1 "concatPairWithAppend"+            (concatPairWithAppend 2 (value `div` 2))+        , benchIOSrc1 "concatPairWithInterleave"+        (concatPairWithInterleave 2 (value `div` 2))++        , benchIOSrc1 "concatPairWithInterleaveSuffix"+        (concatPairWithInterleaveSuffix 2 (value `div` 2))++        , benchIOSrc1 "concatPairWithInterleaveInfix"+        (concatPairWithInterleaveInfix 2 (value `div` 2))++        , benchIOSrc1 "concatPairWithInterleaveMin"+        (concatPairWithInterleaveMin 2 (value `div` 2))++        , benchIOSrc1 "concatPairWithRoundrobin"+        (concatPairWithRoundrobin 2 (value `div` 2))++        ]+    ]++    where++    sqrtVal = round $ sqrt (fromIntegral value :: Double)++-------------------------------------------------------------------------------+-- Applicative+-------------------------------------------------------------------------------++o_1_space_applicative :: Int -> [Benchmark]+o_1_space_applicative value =+    [ bgroup "Applicative"+        [ benchIO "(*>) (sqrt n x sqrt n)" $ apDiscardFst value fromSerial+        , benchIO "(<*) (sqrt n x sqrt n)" $ apDiscardSnd value fromSerial+        , benchIO "(<*>) (sqrt n x sqrt n)" $ toNullAp value fromSerial+        , benchIO "liftA2 (sqrt n x sqrt n)" $ apLiftA2 value fromSerial+        ]+    ]++o_n_space_applicative :: Int -> [Benchmark]+o_n_space_applicative value =+    [ bgroup "Applicative"+        [ benchIOSrc fromSerial "(*>) (n times)" $+            iterateSingleton ((*>) . pure) value+        , benchIOSrc fromSerial "(<*) (n times)" $+            iterateSingleton (\x xs -> xs <* pure x) value+        , benchIOSrc fromSerial "(<*>) (n times)" $+            iterateSingleton (\x xs -> pure (+ x) <*> xs) value+        , benchIOSrc fromSerial "liftA2 (n times)" $+            iterateSingleton (AP.liftA2 (+) . pure) value+        ]+    ]++-------------------------------------------------------------------------------+-- Monad+-------------------------------------------------------------------------------++o_1_space_monad :: Int -> [Benchmark]+o_1_space_monad value =+    [ bgroup "Monad"+        [ benchIO "(>>) (sqrt n x sqrt n)" $ monadThen value fromSerial+        , benchIO "(>>=) (sqrt n x sqrt n)" $ toNullM value fromSerial+        , benchIO "(>>=) (sqrt n x sqrt n) (filterAllOut)" $+            filterAllOutM value fromSerial+        , benchIO "(>>=) (sqrt n x sqrt n) (filterAllIn)" $+            filterAllInM value fromSerial+        , benchIO "(>>=) (sqrt n x sqrt n) (filterSome)" $+            filterSome value fromSerial+        , benchIO "(>>=) (sqrt n x sqrt n) (breakAfterSome)" $+            breakAfterSome value fromSerial+        , benchIO "(>>=) (cubert n x cubert n x cubert n)" $+            toNullM3 value fromSerial+        ]+    ]++-- This is a good benchmark but inefficient way to compute primes. As we see a+-- new prime we keep appending a division filter for all the future numbers.+{-# INLINE sieve #-}+sieve :: Monad m => SerialT m Int -> SerialT m Int+sieve s = do+    r <- lift $ S.uncons s+    case r of+        Just (prime, rest) ->+            prime `S.cons` sieve (S.filter (\n -> n `mod` prime /= 0) rest)+        Nothing -> S.nil++o_n_space_monad :: Int -> [Benchmark]+o_n_space_monad value =+    [ bgroup "Monad"+        [ benchIOSrc fromSerial "(>>) (n times)" $+            iterateSingleton ((>>) . pure) value+        , benchIOSrc fromSerial "(>>=) (n times)" $+            iterateSingleton (\x xs -> xs >>= \y -> return (x + y)) value+        , benchIO "(>>=) (sqrt n x sqrt n) (toList)" $+            toListM value fromSerial+        , benchIO "(>>=) (sqrt n x sqrt n) (toListSome)" $+            toListSome value fromSerial+        , benchIO "naive prime sieve (n/4)"+            (\n -> S.sum $ sieve $ S.enumerateFromTo 2 (value `div` 4 + n))+        ]+    ]++-------------------------------------------------------------------------------+-- Main+-------------------------------------------------------------------------------++-- In addition to gauge options, the number of elements in the stream can be+-- passed using the --stream-size option.+--+benchmarks :: String -> Int -> [Benchmark]+benchmarks moduleName size =+        [ bgroup (o_1_space_prefix moduleName) $ Prelude.concat+            [+            -- multi-stream+              o_1_space_joining size+            , o_1_space_concatFoldable size+            , o_1_space_concat size++            , o_1_space_applicative size+            , o_1_space_monad size++            ]+        , bgroup (o_n_space_prefix moduleName) $ Prelude.concat+            [+            -- multi-stream+              o_n_space_applicative size+            , o_n_space_monad size+            ]+        ]
− benchmark/Streamly/Benchmark/Prelude/Serial/O_1_Space.hs 
@@ -1,59 +0,0 @@--- |--- Module      : Main--- Copyright   : (c) 2018 Harendra Kumar------ License     : BSD3--- Maintainer  : streamly@composewell.com--import Streamly.Benchmark.Common-import Streamly.Benchmark.Prelude--import Gauge---- In addition to gauge options, the number of elements in the stream can be--- passed using the --stream-size option.----main :: IO ()-main = do-    (value, cfg, benches) <- parseCLIOpts defaultStreamSize-    value `seq` runMode (mode cfg) cfg benches (allBenchmarks value)--    where--    allBenchmarks value =-        concat-            [ serial value-            , wSerial value-            , zipSerial value-            ]--    serial value =-        concat-            [ o_1_space_serial_pure value-            , o_1_space_serial_foldable value-            , o_1_space_serial_generation value-            , o_1_space_serial_elimination value-            , o_1_space_serial_foldMultiStream value-            , o_1_space_serial_pipes value-            , o_1_space_serial_pipesX4 value-            , o_1_space_serial_transformer value-            , o_1_space_serial_transformation value-            , o_1_space_serial_transformationX4 value-            , o_1_space_serial_filtering value-            , o_1_space_serial_filteringX4 value-            , o_1_space_serial_joining value-            , o_1_space_serial_concatFoldable value-            , o_1_space_serial_concatSerial value-            , o_1_space_serial_outerProductStreams value-            , o_1_space_serial_mixed value-            , o_1_space_serial_mixedX4 value-            ]--    wSerial value =-        concat-            [ o_1_space_wSerial_transformation value-            , o_1_space_wSerial_concatMap value-            , o_1_space_wSerial_outerProduct value-            ]--    zipSerial value = concat [o_1_space_zipSerial_transformation value]
− benchmark/Streamly/Benchmark/Prelude/Serial/O_n_Heap.hs 
@@ -1,30 +0,0 @@--- |--- Module      : Main--- Copyright   : (c) 2018 Harendra Kumar------ License     : BSD3--- Maintainer  : streamly@composewell.com--import Streamly.Benchmark.Common-import Streamly.Benchmark.Prelude--import Gauge---- In addition to gauge options, the number of elements in the stream can be--- passed using the --stream-size option.----main :: IO ()-main = do-    (value, cfg, benches) <- parseCLIOpts defaultStreamSize-    size <- limitStreamSize value-    size `seq` runMode (mode cfg) cfg benches (allBenchmarks size)--    where--    -- Operations using O(1) stack space and O(n) heap space.-    -- Tail recursive left folds-    allBenchmarks size =-        concat-            [ o_n_heap_serial_foldl size-            , o_n_heap_serial_buffering size-            ]
− benchmark/Streamly/Benchmark/Prelude/Serial/O_n_Space.hs 
@@ -1,31 +0,0 @@--- |--- Module      : Main--- Copyright   : (c) 2018 Harendra Kumar------ License     : BSD3--- Maintainer  : streamly@composewell.com--import Streamly.Benchmark.Common-import Streamly.Benchmark.Prelude--import Gauge---- In addition to gauge options, the number of elements in the stream can be--- passed using the --stream-size option.----main :: IO ()-main = do-    (value, cfg, benches) <- parseCLIOpts defaultStreamSize-    size <- limitStreamSize value-    size `seq` runMode (mode cfg) cfg benches (allBenchmarks size)--    where--    allBenchmarks size =-        concat-            [ o_n_space_serial_toList size -- < 2MB-            , o_n_space_serial_outerProductStreams size-            , o_n_space_wSerial_outerProductStreams size-            , o_n_space_serial_traversable size -- < 2MB-            , o_n_space_serial_foldr size-            ]
− benchmark/Streamly/Benchmark/Prelude/Serial/O_n_Stack.hs 
@@ -1,26 +0,0 @@--- |--- Module      : Main--- Copyright   : (c) 2018 Harendra Kumar------ License     : BSD3--- Maintainer  : streamly@composewell.com--import Streamly.Benchmark.Common-import Streamly.Benchmark.Prelude--import Gauge---- In addition to gauge options, the number of elements in the stream can be--- passed using the --stream-size option.----main :: IO ()-main = do-    (value, cfg, benches) <- parseCLIOpts defaultStreamSize-    size <- limitStreamSize value-    size `seq` runMode (mode cfg) cfg benches (allBenchmarks size)--    where--    -- Operations using O(n) stack space but O(1) heap space.-    -- Head recursive operations.-    allBenchmarks = o_n_stack_serial_iterated
+ benchmark/Streamly/Benchmark/Prelude/Serial/Split.hs view
@@ -0,0 +1,231 @@+-- |+-- Module      : Streamly.Benchmark.Prelude.Serial.Split+-- Copyright   : (c) 2019 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}++#ifdef __HADDOCK_VERSION__+#undef INSPECTION+#endif++#ifdef INSPECTION+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}+#endif++module Serial.Split (benchmarks) where++import Data.Char (ord)+import Data.Word (Word8)+import System.IO (Handle)++import qualified Streamly.FileSystem.Handle as FH+import qualified Streamly.Internal.Data.Array.Foreign as A+import qualified Streamly.Internal.Data.Fold as FL+import qualified Streamly.Internal.Data.Parser as PR+import qualified Streamly.Internal.Data.Stream.IsStream as IP+import qualified Streamly.Internal.FileSystem.Handle as IFH+import qualified Streamly.Internal.Unicode.Stream as IUS+import qualified Streamly.Prelude as S++import Gauge hiding (env)+import Prelude hiding (last, length)+import Streamly.Benchmark.Common+import Streamly.Benchmark.Common.Handle++#ifdef INSPECTION+import Streamly.Internal.Data.Stream.StreamD.Type (Step(..))++import qualified Streamly.Internal.Data.Array.Foreign.Mut.Type as MA+import qualified Streamly.Internal.Data.Unfold as IUF++import Test.Inspection+#endif++ -------------------------------------------------------------------------------+-- reduce with splitting transformations+-------------------------------------------------------------------------------++lf :: Word8+lf = fromIntegral (ord '\n')++toarr :: String -> A.Array Word8+toarr = A.fromList . map (fromIntegral . ord)++-- | Split on line feed.+splitOn :: Handle -> IO Int+splitOn inh =+    (S.length $ S.splitOn (== lf) FL.drain+        $ S.unfold FH.read inh) -- >>= print++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'splitOn+inspect $ 'splitOn `hasNoType` ''Step+inspect $ 'splitOn `hasNoType` ''IUF.ConcatState -- FH.read/UF.many+inspect $ 'splitOn `hasNoType` ''MA.ReadUState  -- FH.read/A.read+#endif++-- | Split suffix on line feed.+splitOnSuffix :: Handle -> IO Int+splitOnSuffix inh =+    (S.length $ S.splitOnSuffix (== lf) FL.drain+        $ S.unfold FH.read inh) -- >>= print++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'splitOnSuffix+inspect $ 'splitOnSuffix `hasNoType` ''Step+inspect $ 'splitOnSuffix `hasNoType` ''IUF.ConcatState -- FH.read/UF.many+inspect $ 'splitOnSuffix `hasNoType` ''MA.ReadUState  -- FH.read/A.read+#endif++-- | Split suffix with line feed.+splitWithSuffix :: Handle -> IO Int+splitWithSuffix inh =+    (S.length $ S.splitWithSuffix (== lf) FL.drain+        $ S.unfold FH.read inh) -- >>= print++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'splitWithSuffix+inspect $ 'splitWithSuffix `hasNoType` ''Step+inspect $ 'splitWithSuffix `hasNoType` ''IUF.ConcatState -- FH.read/UF.many+inspect $ 'splitWithSuffix `hasNoType` ''MA.ReadUState  -- FH.read/A.read+#endif++-- | Split on line feed.+foldManySepBy :: Handle -> IO Int+foldManySepBy inh =+    (S.length+        $ IP.foldMany+            (FL.takeEndBy_ (== lf) FL.drain)+            (S.unfold FH.read inh)+    ) -- >>= print++-- | Split on line feed.+parseManySepBy :: Handle -> IO Int+parseManySepBy inh =+    (S.length+        $ IP.parseMany+            (PR.fromFold $ FL.takeEndBy_ (== lf) FL.drain)+            (S.unfold FH.read inh)+    ) -- >>= print++-- | Words by space+wordsBy :: Handle -> IO Int+wordsBy inh =+    (S.length $ S.wordsBy isSp FL.drain+        $ S.unfold FH.read inh) -- >>= print++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'wordsBy+inspect $ 'wordsBy `hasNoType` ''Step+inspect $ 'wordsBy `hasNoType` ''IUF.ConcatState -- FH.read/UF.many+inspect $ 'wordsBy `hasNoType` ''MA.ReadUState  -- FH.read/A.read+#endif++-- | Split on a word8 sequence.+splitOnSeq :: String -> Handle -> IO Int+splitOnSeq str inh =+    (S.length $ IP.splitOnSeq (toarr str) FL.drain+        $ S.unfold FH.read inh) -- >>= print++#ifdef INSPECTION+-- inspect $ hasNoTypeClasses 'splitOnSeq+-- inspect $ 'splitOnSeq `hasNoType` ''Step+#endif++-- | Split on a word8 sequence.+splitOnSeq100k :: Handle -> IO Int+splitOnSeq100k inh = do+    arr <- A.fromStream $ S.replicate 100000 123+    (S.length $ IP.splitOnSeq arr FL.drain+        $ S.unfold FH.read inh) -- >>= print++-- | Split on suffix sequence.+splitOnSuffixSeq :: String -> Handle -> IO Int+splitOnSuffixSeq str inh =+    (S.length $ IP.splitOnSuffixSeq (toarr str) FL.drain+        $ S.unfold FH.read inh) -- >>= print++#ifdef INSPECTION+-- inspect $ hasNoTypeClasses 'splitOnSuffixSeq+-- inspect $ 'splitOnSuffixSeq `hasNoType` ''Step+#endif++o_1_space_reduce_read_split :: BenchEnv -> [Benchmark]+o_1_space_reduce_read_split env =+    [ bgroup "split"+        [ mkBench "S.foldMany (FL.takeEndBy_ (== lf) FL.drain)" env+            $ \inh _ -> foldManySepBy inh+        , mkBench "S.parseMany (FL.takeEndBy_ (== lf) FL.drain)" env+            $ \inh _ -> parseManySepBy inh+        , mkBench "S.wordsBy isSpace FL.drain" env $ \inh _ ->+            wordsBy inh+        , mkBench "S.splitOn (== lf) FL.drain" env $ \inh _ ->+            splitOn inh+        , mkBench "S.splitOnSuffix (== lf) FL.drain" env $ \inh _ ->+            splitOnSuffix inh+        , mkBench "S.splitWithSuffix (== lf) FL.drain" env $ \inh _ ->+            splitWithSuffix inh+        , mkBench "S.splitOnSeq \"\" FL.drain" env $ \inh _ ->+            splitOnSeq "" inh+        , mkBench "S.splitOnSuffixSeq \"\" FL.drain" env $ \inh _ ->+            splitOnSuffixSeq "" inh+        , mkBench "S.splitOnSeq \"\\n\" FL.drain" env $ \inh _ ->+            splitOnSeq "\n" inh+        , mkBench "S.splitOnSuffixSeq \"\\n\" FL.drain" env $ \inh _ ->+            splitOnSuffixSeq "\n" inh+        , mkBench "S.splitOnSeq \"a\" FL.drain" env $ \inh _ ->+            splitOnSeq "a" inh+        , mkBench "S.splitOnSeq \"\\r\\n\" FL.drain" env $ \inh _ ->+            splitOnSeq "\r\n" inh+        , mkBench "S.splitOnSuffixSeq \"\\r\\n\" FL.drain" env $ \inh _ ->+            splitOnSuffixSeq "\r\n" inh+        , mkBench "S.splitOnSeq \"aa\" FL.drain" env $ \inh _ ->+            splitOnSeq "aa" inh+        , mkBench "S.splitOnSeq \"aaaa\" FL.drain" env $ \inh _ ->+            splitOnSeq "aaaa" inh+        , mkBench "S.splitOnSeq \"abcdefgh\" FL.drain" env $ \inh _ ->+            splitOnSeq "abcdefgh" inh+        , mkBench "S.splitOnSeq \"abcdefghi\" FL.drain" env $ \inh _ ->+            splitOnSeq "abcdefghi" inh+        , mkBench "S.splitOnSeq \"catcatcatcatcat\" FL.drain" env $ \inh _ ->+            splitOnSeq "catcatcatcatcat" inh+        , mkBench "S.splitOnSeq \"abcdefghijklmnopqrstuvwxyz\" FL.drain"+            env $ \inh _ -> splitOnSeq "abcdefghijklmnopqrstuvwxyz" inh+        , mkBench "S.splitOnSeq 100k long pattern"+            env $ \inh _ -> splitOnSeq100k inh+        , mkBenchSmall "S.splitOnSuffixSeq \"abcdefghijklmnopqrstuvwxyz\" FL.drain"+            env $ \inh _ -> splitOnSuffixSeq "abcdefghijklmnopqrstuvwxyz" inh+        ]+    ]++-- | Split on a character sequence.+splitOnSeqUtf8 :: String -> Handle -> IO Int+splitOnSeqUtf8 str inh =+    (S.length $ IP.splitOnSeq (A.fromList str) FL.drain+        $ IUS.decodeUtf8Arrays+        $ IFH.toChunks inh) -- >>= print++o_1_space_reduce_toChunks_split :: BenchEnv -> [Benchmark]+o_1_space_reduce_toChunks_split env =+    [ bgroup "split/toChunks"+        [ mkBenchSmall ("S.splitOnSeqUtf8 \"abcdefgh\" FL.drain "+            ++ ". US.decodeUtf8Arrays") env $ \inh _ ->+                splitOnSeqUtf8 "abcdefgh" inh+        , mkBenchSmall "S.splitOnSeqUtf8 \"abcdefghijklmnopqrstuvwxyz\" FL.drain"+            env $ \inh _ -> splitOnSeqUtf8 "abcdefghijklmnopqrstuvwxyz" inh+        ]+    ]++benchmarks :: String -> BenchEnv -> [Benchmark]+benchmarks moduleName env =+        [ bgroup (o_1_space_prefix moduleName) $ concat+            [ o_1_space_reduce_read_split env+            , o_1_space_reduce_toChunks_split env+            ]+        ]
+ benchmark/Streamly/Benchmark/Prelude/Serial/Transformation1.hs view
@@ -0,0 +1,567 @@+-- |+-- Module      : Serial.Transformation1+-- Copyright   : (c) 2018 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}++#ifdef __HADDOCK_VERSION__+#undef INSPECTION+#endif++#ifdef INSPECTION+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}+#endif++module Serial.Transformation1 (benchmarks) where++import Control.DeepSeq (NFData(..))+import Control.Monad.IO.Class (MonadIO(..))+import Data.Functor.Identity (Identity)+import Data.IORef (newIORef, modifyIORef')+import System.Random (randomRIO)++#ifdef INSPECTION+import Test.Inspection+#endif++import qualified Streamly.Prelude  as S+import qualified Streamly.Internal.Data.Stream.IsStream as Internal+import qualified Streamly.Internal.Data.Fold as FL+import qualified Streamly.Internal.Data.Unfold as Unfold+import qualified Prelude++import Gauge+import Streamly.Prelude (SerialT, fromSerial, MonadAsync)+import Streamly.Benchmark.Common+import Streamly.Benchmark.Prelude+import Streamly.Internal.Data.Time.Units+import Prelude hiding (sequence, mapM, fmap)++-------------------------------------------------------------------------------+-- Pipelines (stream-to-stream transformations)+-------------------------------------------------------------------------------++-------------------------------------------------------------------------------+-- one-to-one transformations+-------------------------------------------------------------------------------++-------------------------------------------------------------------------------+-- Traversable Instance+-------------------------------------------------------------------------------++{-# INLINE traversableTraverse #-}+traversableTraverse :: SerialT Identity Int -> IO (SerialT Identity Int)+traversableTraverse = traverse return++{-# INLINE traversableSequenceA #-}+traversableSequenceA :: SerialT Identity Int -> IO (SerialT Identity Int)+traversableSequenceA = sequenceA . Prelude.fmap return++{-# INLINE traversableMapM #-}+traversableMapM :: SerialT Identity Int -> IO (SerialT Identity Int)+traversableMapM = Prelude.mapM return++{-# INLINE traversableSequence #-}+traversableSequence :: SerialT Identity Int -> IO (SerialT Identity Int)+traversableSequence = Prelude.sequence . Prelude.fmap return++{-# INLINE benchPureSinkIO #-}+benchPureSinkIO+    :: NFData b+    => Int -> String -> (SerialT Identity Int -> IO b) -> Benchmark+benchPureSinkIO value name f =+    bench name $ nfIO $ randomRIO (1, 1) >>= f . sourceUnfoldr value++o_n_space_traversable :: Int -> [Benchmark]+o_n_space_traversable value =+    -- Buffering operations using heap proportional to number of elements.+    [ bgroup "traversable"+        -- Traversable instance+        [ benchPureSinkIO value "traverse" traversableTraverse+        , benchPureSinkIO value "sequenceA" traversableSequenceA+        , benchPureSinkIO value "mapM" traversableMapM+        , benchPureSinkIO value "sequence" traversableSequence+        ]+    ]++-------------------------------------------------------------------------------+-- maps and scans+-------------------------------------------------------------------------------++{-# INLINE scanl' #-}+scanl' :: MonadIO m => Int -> SerialT m Int -> m ()+scanl' n = composeN n $ S.scanl' (+) 0++{-# INLINE scanlM' #-}+scanlM' :: MonadIO m => Int -> SerialT m Int -> m ()+scanlM' n = composeN n $ S.scanlM' (\b a -> return $ b + a) (return 0)++{-# INLINE scanl1' #-}+scanl1' :: MonadIO m => Int -> SerialT m Int -> m ()+scanl1' n = composeN n $ S.scanl1' (+)++{-# INLINE scanl1M' #-}+scanl1M' :: MonadIO m => Int -> SerialT m Int -> m ()+scanl1M' n = composeN n $ S.scanl1M' (\b a -> return $ b + a)++{-# INLINE scan #-}+scan :: MonadIO m => Int -> SerialT m Int -> m ()+scan n = composeN n $ S.scan FL.sum++{-# INLINE postscanl' #-}+postscanl' :: MonadIO m => Int -> SerialT m Int -> m ()+postscanl' n = composeN n $ S.postscanl' (+) 0++{-# INLINE postscanlM' #-}+postscanlM' :: MonadIO m => Int -> SerialT m Int -> m ()+postscanlM' n = composeN n $ S.postscanlM' (\b a -> return $ b + a) (return 0)++{-# INLINE postscan #-}+postscan :: MonadIO m => Int -> SerialT m Int -> m ()+postscan n = composeN n $ S.postscan FL.sum++{-# INLINE sequence #-}+sequence ::+       (S.IsStream t, S.MonadAsync m)+    => (t m Int -> S.SerialT m Int)+    -> t m (m Int)+    -> m ()+sequence t = S.drain . t . S.sequence++{-# INLINE tap #-}+tap :: MonadIO m => Int -> SerialT m Int -> m ()+tap n = composeN n $ S.tap FL.sum++{-# INLINE tapRate #-}+tapRate :: Int -> SerialT IO Int -> IO ()+tapRate n str = do+    cref <- newIORef 0+    composeN n (Internal.tapRate 1 (\c -> modifyIORef' cref (c +))) str++{-# INLINE pollCounts #-}+pollCounts :: Int -> SerialT IO Int -> IO ()+pollCounts n =+    composeN n (Internal.pollCounts (const True) f FL.drain)++    where++    f = Internal.rollingMap (-) . Internal.delayPost 1++{-# INLINE timestamped #-}+timestamped :: (S.MonadAsync m) => SerialT m Int -> m ()+timestamped = S.drain . Internal.timestamped++{-# INLINE foldrS #-}+foldrS :: MonadIO m => Int -> SerialT m Int -> m ()+foldrS n = composeN n $ Internal.foldrS S.cons S.nil++{-# INLINE foldrSMap #-}+foldrSMap :: MonadIO m => Int -> SerialT m Int -> m ()+foldrSMap n = composeN n $ Internal.foldrS (\x xs -> x + 1 `S.cons` xs) S.nil++{-# INLINE foldrT #-}+foldrT :: MonadIO m => Int -> SerialT m Int -> m ()+foldrT n = composeN n $ Internal.foldrT S.cons S.nil++{-# INLINE foldrTMap #-}+foldrTMap :: MonadIO m => Int -> SerialT m Int -> m ()+foldrTMap n = composeN n $ Internal.foldrT (\x xs -> x + 1 `S.cons` xs) S.nil+++{-# INLINE trace #-}+trace :: MonadAsync m => Int -> SerialT m Int -> m ()+trace n = composeN n $ Internal.trace return++o_1_space_mapping :: Int -> [Benchmark]+o_1_space_mapping value =+    [ bgroup+        "mapping"+        [+        -- Right folds+          benchIOSink value "foldrS" (foldrS 1)+        , benchIOSink value "foldrSMap" (foldrSMap 1)+        , benchIOSink value "foldrT" (foldrT 1)+        , benchIOSink value "foldrTMap" (foldrTMap 1)++        -- Mapping+        , benchIOSink value "map" (mapN fromSerial 1)+        , bench "sequence" $ nfIO $ randomRIO (1, 1000) >>= \n ->+              sequence fromSerial (sourceUnfoldrAction value n)+        , benchIOSink value "mapM" (mapM fromSerial 1)+        , benchIOSink value "tap" (tap 1)+        , benchIOSink value "tapRate 1 second" (tapRate 1)+        , benchIOSink value "pollCounts 1 second" (pollCounts 1)+        , benchIOSink value "timestamped" timestamped++        -- Scanning+        , benchIOSink value "scanl'" (scanl' 1)+        , benchIOSink value "scanl1'" (scanl1' 1)+        , benchIOSink value "scanlM'" (scanlM' 1)+        , benchIOSink value "scanl1M'" (scanl1M' 1)+        , benchIOSink value "postscanl'" (postscanl' 1)+        , benchIOSink value "postscanlM'" (postscanlM' 1)++        , benchIOSink value "scan" (scan 1)+        , benchIOSink value "postscan" (postscan 1)+        ]+    ]++o_1_space_mappingX4 :: Int -> [Benchmark]+o_1_space_mappingX4 value =+    [ bgroup "mappingX4"+        [ benchIOSink value "map" (mapN fromSerial 4)+        , benchIOSink value "mapM" (mapM fromSerial 4)+        , benchIOSink value "trace" (trace 4)++        , benchIOSink value "scanl'" (scanl' 4)+        , benchIOSink value "scanl1'" (scanl1' 4)+        , benchIOSink value "scanlM'" (scanlM' 4)+        , benchIOSink value "scanl1M'" (scanl1M' 4)+        , benchIOSink value "postscanl'" (postscanl' 4)+        , benchIOSink value "postscanlM'" (postscanlM' 4)++        ]+    ]++{-# INLINE sieveScan #-}+sieveScan :: Monad m => SerialT m Int -> SerialT m Int+sieveScan =+      S.mapMaybe snd+    . S.scanlM' (\(primes, _) n -> do+            return $+                let ps = takeWhile (\p -> p * p <= n) primes+                 in if all (\p -> n `mod` p /= 0) ps+                    then (primes ++ [n], Just n)+                    else (primes, Nothing)) (return ([2], Just 2))++o_n_space_mapping :: Int -> [Benchmark]+o_n_space_mapping value =+    [ bgroup "mapping"+        [ benchIO "naive prime sieve"+            (\n -> S.sum $ sieveScan $ S.enumerateFromTo 2 (value + n))+        ]+    ]++-------------------------------------------------------------------------------+-- Functor+-------------------------------------------------------------------------------++o_1_space_functor :: Int -> [Benchmark]+o_1_space_functor value =+    [ bgroup "Functor"+        [ benchIOSink value "fmap" (fmapN fromSerial 1)+        , benchIOSink value "fmap x 4" (fmapN fromSerial 4)+        ]+    ]++-------------------------------------------------------------------------------+-- Size reducing transformations (filtering)+-------------------------------------------------------------------------------++{-# INLINE filterEven #-}+filterEven :: MonadIO m => Int -> SerialT m Int -> m ()+filterEven n = composeN n $ S.filter even++{-# INLINE filterAllOut #-}+filterAllOut :: MonadIO m => Int -> Int -> SerialT m Int -> m ()+filterAllOut value n = composeN n $ S.filter (> (value + 1))++{-# INLINE filterAllIn #-}+filterAllIn :: MonadIO m => Int -> Int -> SerialT m Int -> m ()+filterAllIn value n = composeN n $ S.filter (<= (value + 1))++{-# INLINE filterMEven #-}+filterMEven :: MonadIO m => Int -> SerialT m Int -> m ()+filterMEven n = composeN n $ S.filterM (return . even)++{-# INLINE filterMAllOut #-}+filterMAllOut :: MonadIO m => Int -> Int -> SerialT m Int -> m ()+filterMAllOut value n = composeN n $ S.filterM (\x -> return $ x > (value + 1))++{-# INLINE filterMAllIn #-}+filterMAllIn :: MonadIO m => Int -> Int -> SerialT m Int -> m ()+filterMAllIn value n = composeN n $ S.filterM (\x -> return $ x <= (value + 1))++{-# INLINE _takeOne #-}+_takeOne :: MonadIO m => Int -> SerialT m Int -> m ()+_takeOne n = composeN n $ S.take 1++{-# INLINE takeAll #-}+takeAll :: MonadIO m => Int -> Int -> SerialT m Int -> m ()+takeAll value n = composeN n $ S.take (value + 1)++{-# INLINE takeWhileTrue #-}+takeWhileTrue :: MonadIO m => Int -> Int -> SerialT m Int -> m ()+takeWhileTrue value n = composeN n $ S.takeWhile (<= (value + 1))++{-# INLINE takeWhileMTrue #-}+takeWhileMTrue :: MonadIO m => Int -> Int -> SerialT m Int -> m ()+takeWhileMTrue value n = composeN n $ S.takeWhileM (return . (<= (value + 1)))++{-# INLINE takeInterval #-}+takeInterval :: NanoSecond64 -> Int -> SerialT IO Int -> IO ()+takeInterval i n = composeN n (Internal.takeInterval i)++#ifdef INSPECTION+-- inspect $ hasNoType 'takeInterval ''SPEC+inspect $ hasNoTypeClasses 'takeInterval+-- inspect $ 'takeInterval `hasNoType` ''D.Step+#endif++{-# INLINE dropOne #-}+dropOne :: MonadIO m => Int -> SerialT m Int -> m ()+dropOne n = composeN n $ S.drop 1++{-# INLINE dropAll #-}+dropAll :: MonadIO m => Int -> Int -> SerialT m Int -> m ()+dropAll value n = composeN n $ S.drop (value + 1)++{-# INLINE dropWhileTrue #-}+dropWhileTrue :: MonadIO m => Int -> Int -> SerialT m Int -> m ()+dropWhileTrue value n = composeN n $ S.dropWhile (<= (value + 1))++{-# INLINE dropWhileMTrue #-}+dropWhileMTrue :: MonadIO m => Int -> Int -> SerialT m Int -> m ()+dropWhileMTrue value n = composeN n $ S.dropWhileM (return . (<= (value + 1)))++{-# INLINE dropWhileFalse #-}+dropWhileFalse :: MonadIO m => Int -> Int -> SerialT m Int -> m ()+dropWhileFalse value n = composeN n $ S.dropWhile (> (value + 1))++-- XXX Decide on the time interval+{-# INLINE _intervalsOfSum #-}+_intervalsOfSum :: MonadAsync m => Double -> Int -> SerialT m Int -> m ()+_intervalsOfSum i n = composeN n (S.intervalsOf i FL.sum)++{-# INLINE dropInterval #-}+dropInterval :: NanoSecond64 -> Int -> SerialT IO Int -> IO ()+dropInterval i n = composeN n (Internal.dropInterval i)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'dropInterval+-- inspect $ 'dropInterval `hasNoType` ''D.Step+#endif++{-# INLINE findIndices #-}+findIndices :: MonadIO m => Int -> Int -> SerialT m Int -> m ()+findIndices value n = composeN n $ S.findIndices (== (value + 1))++{-# INLINE elemIndices #-}+elemIndices :: MonadIO m => Int -> Int -> SerialT m Int -> m ()+elemIndices value n = composeN n $ S.elemIndices (value + 1)++{-# INLINE deleteBy #-}+deleteBy :: MonadIO m => Int -> Int -> SerialT m Int -> m ()+deleteBy value n = composeN n $ S.deleteBy (>=) (value + 1)++-- uniq . uniq == uniq, composeN 2 ~ composeN 1+{-# INLINE uniq #-}+uniq :: MonadIO m => Int -> SerialT m Int -> m ()+uniq n = composeN n S.uniq++{-# INLINE mapMaybe #-}+mapMaybe :: MonadIO m => Int -> SerialT m Int -> m ()+mapMaybe n =+    composeN n $+    S.mapMaybe+        (\x ->+             if odd x+             then Nothing+             else Just x)++{-# INLINE mapMaybeM #-}+mapMaybeM :: S.MonadAsync m => Int -> SerialT m Int -> m ()+mapMaybeM n =+    composeN n $+    S.mapMaybeM+        (\x ->+             if odd x+             then return Nothing+             else return $ Just x)++o_1_space_filtering :: Int -> [Benchmark]+o_1_space_filtering value =+    [ bgroup "filtering"+        [ benchIOSink value "filter-even" (filterEven 1)+        , benchIOSink value "filter-all-out" (filterAllOut value 1)+        , benchIOSink value "filter-all-in" (filterAllIn value 1)++        , benchIOSink value "filterM-even" (filterMEven 1)+        , benchIOSink value "filterM-all-out" (filterMAllOut value 1)+        , benchIOSink value "filterM-all-in" (filterMAllIn value 1)++        -- Trimming+        , benchIOSink value "take-all" (takeAll value 1)+        , benchIOSink+              value+              "takeInterval-all"+              (takeInterval (NanoSecond64 maxBound) 1)+        , benchIOSink value "takeWhile-true" (takeWhileTrue value 1)+     -- , benchIOSink value "takeWhileM-true" (_takeWhileMTrue value 1)+        , benchIOSink value "drop-one" (dropOne 1)+        , benchIOSink value "drop-all" (dropAll value 1)+        , benchIOSink+              value+              "dropInterval-all"+              (dropInterval (NanoSecond64 maxBound) 1)+        , benchIOSink value "dropWhile-true" (dropWhileTrue value 1)+     -- , benchIOSink value "dropWhileM-true" (_dropWhileMTrue value 1)+        , benchIOSink+              value+              "dropWhile-false"+              (dropWhileFalse value 1)+        , benchIOSink value "deleteBy" (deleteBy value 1)++        , benchIOSink value "uniq" (uniq 1)++        -- Map and filter+        , benchIOSink value "mapMaybe" (mapMaybe 1)+        , benchIOSink value "mapMaybeM" (mapMaybeM 1)++        -- Searching (stateful map and filter)+        , benchIOSink value "findIndices" (findIndices value 1)+        , benchIOSink value "elemIndices" (elemIndices value 1)+        ]+    ]++o_1_space_filteringX4 :: Int -> [Benchmark]+o_1_space_filteringX4 value =+    [ bgroup "filteringX4"+        [ benchIOSink value "filter-even" (filterEven 4)+        , benchIOSink value "filter-all-out" (filterAllOut value 4)+        , benchIOSink value "filter-all-in" (filterAllIn value 4)++        , benchIOSink value "filterM-even" (filterMEven 4)+        , benchIOSink value "filterM-all-out" (filterMAllOut value 4)+        , benchIOSink value "filterM-all-in" (filterMAllIn value 4)++        -- trimming+        , benchIOSink value "take-all" (takeAll value 4)+        , benchIOSink value "takeWhile-true" (takeWhileTrue value 4)+        , benchIOSink value "takeWhileM-true" (takeWhileMTrue value 4)+        , benchIOSink value "drop-one" (dropOne 4)+        , benchIOSink value "drop-all" (dropAll value 4)+        , benchIOSink value "dropWhile-true" (dropWhileTrue value 4)+        , benchIOSink value "dropWhileM-true" (dropWhileMTrue value 4)+        , benchIOSink+              value+              "dropWhile-false"+              (dropWhileFalse value 4)+        , benchIOSink value "deleteBy" (deleteBy value 4)++        , benchIOSink value "uniq" (uniq 4)++        -- map and filter+        , benchIOSink value "mapMaybe" (mapMaybe 4)+        , benchIOSink value "mapMaybeM" (mapMaybeM 4)++        -- searching+        , benchIOSink value "findIndices" (findIndices value 4)+        , benchIOSink value "elemIndices" (elemIndices value 4)+        ]+    ]++-------------------------------------------------------------------------------+-- Size increasing transformations (insertions)+-------------------------------------------------------------------------------++{-# INLINE intersperse #-}+intersperse :: S.MonadAsync m => Int -> Int -> SerialT m Int -> m ()+intersperse value n = composeN n $ S.intersperse (value + 1)++{-# INLINE intersperseM #-}+intersperseM :: S.MonadAsync m => Int -> Int -> SerialT m Int -> m ()+intersperseM value n = composeN n $ S.intersperseM (return $ value + 1)++{-# INLINE insertBy #-}+insertBy :: MonadIO m => Int -> Int -> SerialT m Int -> m ()+insertBy value n = composeN n $ S.insertBy compare (value + 1)++{-# INLINE interposeSuffix #-}+interposeSuffix :: S.MonadAsync m => Int -> Int -> SerialT m Int -> m ()+interposeSuffix value n =+    composeN n $ Internal.interposeSuffix (value + 1) Unfold.identity++{-# INLINE intercalateSuffix #-}+intercalateSuffix :: S.MonadAsync m => Int -> Int -> SerialT m Int -> m ()+intercalateSuffix value n =+    composeN n $ Internal.intercalateSuffix Unfold.identity (value + 1)++o_1_space_inserting :: Int -> [Benchmark]+o_1_space_inserting value =+    [ bgroup "inserting"+        [ benchIOSink value "intersperse" (intersperse value 1)+        , benchIOSink value "intersperseM" (intersperseM value 1)+        , benchIOSink value "insertBy" (insertBy value 1)+        , benchIOSink value "interposeSuffix" (interposeSuffix value 1)+        , benchIOSink value "intercalateSuffix" (intercalateSuffix value 1)+        ]+    ]++o_1_space_insertingX4 :: Int -> [Benchmark]+o_1_space_insertingX4 value =+    [ bgroup "insertingX4"+        [ benchIOSink value "intersperse" (intersperse value 4)+        , benchIOSink value "insertBy" (insertBy value 4)+        ]+    ]++-------------------------------------------------------------------------------+-- Indexing+-------------------------------------------------------------------------------++{-# INLINE indexed #-}+indexed :: MonadIO m => Int -> SerialT m Int -> m ()+indexed n = composeN n (S.map snd . S.indexed)++{-# INLINE indexedR #-}+indexedR :: MonadIO m => Int -> Int -> SerialT m Int -> m ()+indexedR value n = composeN n (S.map snd . S.indexedR value)++o_1_space_indexing :: Int -> [Benchmark]+o_1_space_indexing value =+    [ bgroup "indexing"+        [ benchIOSink value "indexed" (indexed 1)+        , benchIOSink value "indexedR" (indexedR value 1)+        ]+    ]++o_1_space_indexingX4 :: Int -> [Benchmark]+o_1_space_indexingX4 value =+    [ bgroup "indexingx4"+        [ benchIOSink value "indexed" (indexed 4)+        , benchIOSink value "indexedR" (indexedR value 4)+        ]+    ]++-------------------------------------------------------------------------------+-- Main+-------------------------------------------------------------------------------++-- In addition to gauge options, the number of elements in the stream can be+-- passed using the --stream-size option.+--+benchmarks :: String -> Int -> [Benchmark]+benchmarks moduleName size =+        [ bgroup (o_1_space_prefix moduleName) $ Prelude.concat+            [ o_1_space_functor size+            , o_1_space_mapping size+            , o_1_space_mappingX4 size+            , o_1_space_filtering size+            , o_1_space_filteringX4 size+            , o_1_space_inserting size+            , o_1_space_insertingX4 size+            , o_1_space_indexing size+            , o_1_space_indexingX4 size+            ]+        , bgroup (o_n_space_prefix moduleName) $ Prelude.concat+            [ o_n_space_traversable size+            , o_n_space_mapping size+            ]+        ]
+ benchmark/Streamly/Benchmark/Prelude/Serial/Transformation2.hs view
@@ -0,0 +1,449 @@+-- |+-- Module      : Serial.Transformation2+-- Copyright   : (c) 2018 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}++module Serial.Transformation2 (benchmarks) where++import Control.DeepSeq (NFData(..))+import Control.Monad (when)+import Control.Monad.IO.Class (MonadIO(..))+import Data.Monoid (Sum(..))+import GHC.Generics (Generic)++import qualified Data.List as List+import qualified Streamly.Internal.Data.Fold as FL+import qualified Streamly.Internal.Data.Stream.IsStream as Internal+import qualified Streamly.Prelude  as S++import Gauge+import Streamly.Prelude (SerialT, fromSerial)+import Streamly.Benchmark.Common+import Streamly.Benchmark.Prelude+import Prelude hiding (reverse, tail)++-------------------------------------------------------------------------------+-- Iteration/looping utilities+-------------------------------------------------------------------------------++{-# INLINE iterateN #-}+iterateN :: (Int -> a -> a) -> a -> Int -> a+iterateN g initial count = f count initial++    where++    f (0 :: Int) x = x+    f i x = f (i - 1) (g i x)++-- Iterate a transformation over a singleton stream+{-# INLINE iterateSingleton #-}+iterateSingleton :: S.MonadAsync m+    => (Int -> SerialT m Int -> SerialT m Int)+    -> Int+    -> Int+    -> SerialT m Int+iterateSingleton g count n = iterateN g (return n) count++-- XXX need to check why this is slower than the explicit recursion above, even+-- if the above code is written in a foldr like head recursive way. We also+-- need to try this with foldlM' once #150 is fixed.+-- However, it is perhaps best to keep the iteration benchmarks independent of+-- foldrM and any related fusion issues.+{-# INLINE _iterateSingleton #-}+_iterateSingleton ::+       S.MonadAsync m+    => (Int -> SerialT m Int -> SerialT m Int)+    -> Int+    -> Int+    -> SerialT m Int+_iterateSingleton g value n = S.foldrM g (return n) $ sourceIntFromTo value n++-- Apply transformation g count times on a stream of length len+{-# INLINE iterateSource #-}+iterateSource ::+       S.MonadAsync m+    => (SerialT m Int -> SerialT m Int)+    -> Int+    -> Int+    -> Int+    -> SerialT m Int+iterateSource g count len n = f count (sourceUnfoldrM len n)++    where++    f (0 :: Int) stream = stream+    f i stream = f (i - 1) (g stream)++-------------------------------------------------------------------------------+-- Functor+-------------------------------------------------------------------------------++o_n_space_functor :: Int -> [Benchmark]+o_n_space_functor value =+    [ bgroup "Functor"+        [ benchIO "(+) (n times) (baseline)" $ \i0 ->+            iterateN (\i acc -> acc >>= \n -> return $ i + n) (return i0) value+        , benchIOSrc fromSerial "(<$) (n times)" $+            iterateSingleton (<$) value+        , benchIOSrc fromSerial "fmap (n times)" $+            iterateSingleton (fmap . (+)) value+        {-+        , benchIOSrc fromSerial "_(<$) (n times)" $+            _iterateSingleton (<$) value+        , benchIOSrc fromSerial "_fmap (n times)" $+            _iterateSingleton (fmap . (+)) value+        -}+        ]+    ]++-------------------------------------------------------------------------------+-- Grouping transformations+-------------------------------------------------------------------------------++{-# INLINE groups #-}+groups :: MonadIO m => SerialT m Int -> m ()+groups = S.drain . S.groups FL.drain++-- XXX Change this test when the order of comparison is later changed+{-# INLINE groupsByGT #-}+groupsByGT :: MonadIO m => SerialT m Int -> m ()+groupsByGT = S.drain . S.groupsBy (>) FL.drain++{-# INLINE groupsByEq #-}+groupsByEq :: MonadIO m => SerialT m Int -> m ()+groupsByEq = S.drain . S.groupsBy (==) FL.drain++-- XXX Change this test when the order of comparison is later changed+{-# INLINE groupsByRollingLT #-}+groupsByRollingLT :: MonadIO m => SerialT m Int -> m ()+groupsByRollingLT =+    S.drain . S.groupsByRolling (<) FL.drain++{-# INLINE groupsByRollingEq #-}+groupsByRollingEq :: MonadIO m => SerialT m Int -> m ()+groupsByRollingEq =+    S.drain . S.groupsByRolling (==) FL.drain++{-# INLINE foldMany #-}+foldMany :: Monad m => SerialT m Int -> m ()+foldMany =+      S.drain+    . S.map getSum+    . Internal.foldMany (FL.take 2 FL.mconcat)+    . S.map Sum++{-# INLINE foldIterateM #-}+foldIterateM :: Monad m => SerialT m Int -> m ()+foldIterateM =+    S.drain+        . S.map getSum+        . Internal.foldIterateM (return . FL.take 2 . FL.sconcat) (Sum 0)+        . S.map Sum++o_1_space_grouping :: Int -> [Benchmark]+o_1_space_grouping value =+    -- Buffering operations using heap proportional to group/window sizes.+    [ bgroup "grouping"+        [ benchIOSink value "groups" groups+        , benchIOSink value "groupsByGT" groupsByGT+        , benchIOSink value "groupsByEq" groupsByEq+        , benchIOSink value "groupsByRollingLT" groupsByRollingLT+        , benchIOSink value "groupsByRollingEq" groupsByRollingEq+        , benchIOSink value "foldMany" foldMany+        , benchIOSink value "foldIterateM" foldIterateM+        ]+    ]++-------------------------------------------------------------------------------+-- Size conserving transformations (reordering, buffering, etc.)+-------------------------------------------------------------------------------++{-# INLINE reverse #-}+reverse :: MonadIO m => Int -> SerialT m Int -> m ()+reverse n = composeN n S.reverse++{-# INLINE reverse' #-}+reverse' :: MonadIO m => Int -> SerialT m Int -> m ()+reverse' n = composeN n Internal.reverse'++{-# INLINE sortBy #-}+sortBy :: MonadIO m => Int -> SerialT m Int -> m ()+sortBy n = composeN n (Internal.sortBy compare)++o_n_heap_buffering :: Int -> [Benchmark]+o_n_heap_buffering value =+    [ bgroup "buffered"+        [+        -- Reversing/sorting a stream+          benchIOSink value "reverse" (reverse 1)+        , benchIOSink value "reverse'" (reverse' 1)+        , benchIOSink value "sortBy" (sortBy 1)+        , bench "sort Lists" $ nf (\x -> List.sort [1..x]) value++        , benchIOSink value "mkAsync" (mkAsync fromSerial)+        ]+    ]++-------------------------------------------------------------------------------+-- Grouping/Splitting+-------------------------------------------------------------------------------++{-# INLINE classifySessionsOf #-}+classifySessionsOf :: (S.MonadAsync m) => SerialT m Int -> m ()+classifySessionsOf =+      S.drain+    . Internal.classifySessionsOf (const (return False)) 3 FL.drain+    . Internal.timestamped+    . S.concatMap (\x -> S.map (x,) (S.enumerateFromTo 1 (10 :: Int)))++o_n_space_grouping :: Int -> [Benchmark]+o_n_space_grouping value =+    -- Buffering operations using heap proportional to group/window sizes.+    [ bgroup "grouping"+        [ benchIOSink (value `div` 10) "classifySessionsOf" classifySessionsOf+        ]+    ]++-------------------------------------------------------------------------------+-- Mixed Transformation+-------------------------------------------------------------------------------++{-# INLINE scanMap #-}+scanMap :: MonadIO m => Int -> SerialT m Int -> m ()+scanMap n = composeN n $ S.map (subtract 1) . S.scanl' (+) 0++{-# INLINE dropMap #-}+dropMap :: MonadIO m => Int -> SerialT m Int -> m ()+dropMap n = composeN n $ S.map (subtract 1) . S.drop 1++{-# INLINE dropScan #-}+dropScan :: MonadIO m => Int -> SerialT m Int -> m ()+dropScan n = composeN n $ S.scanl' (+) 0 . S.drop 1++{-# INLINE takeDrop #-}+takeDrop :: MonadIO m => Int -> Int -> SerialT m Int -> m ()+takeDrop value n = composeN n $ S.drop 1 . S.take (value + 1)++{-# INLINE takeScan #-}+takeScan :: MonadIO m => Int -> Int -> SerialT m Int -> m ()+takeScan value n = composeN n $ S.scanl' (+) 0 . S.take (value + 1)++{-# INLINE takeMap #-}+takeMap :: MonadIO m => Int -> Int -> SerialT m Int -> m ()+takeMap value n = composeN n $ S.map (subtract 1) . S.take (value + 1)++{-# INLINE filterDrop #-}+filterDrop :: MonadIO m => Int -> Int -> SerialT m Int -> m ()+filterDrop value n = composeN n $ S.drop 1 . S.filter (<= (value + 1))++{-# INLINE filterTake #-}+filterTake :: MonadIO m => Int -> Int -> SerialT m Int -> m ()+filterTake value n = composeN n $ S.take (value + 1) . S.filter (<= (value + 1))++{-# INLINE filterScan #-}+filterScan :: MonadIO m => Int -> SerialT m Int -> m ()+filterScan n = composeN n $ S.scanl' (+) 0 . S.filter (<= maxBound)++{-# INLINE filterScanl1 #-}+filterScanl1 :: MonadIO m => Int -> SerialT m Int -> m ()+filterScanl1 n = composeN n $ S.scanl1' (+) . S.filter (<= maxBound)++{-# INLINE filterMap #-}+filterMap :: MonadIO m => Int -> Int -> SerialT m Int -> m ()+filterMap value n = composeN n $ S.map (subtract 1) . S.filter (<= (value + 1))++-------------------------------------------------------------------------------+-- Scan and fold+-------------------------------------------------------------------------------++data Pair a b =+    Pair !a !b+    deriving (Generic, NFData)++{-# INLINE sumProductFold #-}+sumProductFold :: Monad m => SerialT m Int -> m (Int, Int)+sumProductFold = S.foldl' (\(s, p) x -> (s + x, p * x)) (0, 1)++{-# INLINE sumProductScan #-}+sumProductScan :: Monad m => SerialT m Int -> m (Pair Int Int)+sumProductScan =+    S.foldl' (\(Pair _ p) (s0, x) -> Pair s0 (p * x)) (Pair 0 1) .+    S.scanl' (\(s, _) x -> (s + x, x)) (0, 0)++{-# INLINE foldl'ReduceMap #-}+foldl'ReduceMap :: Monad m => SerialT m Int -> m Int+foldl'ReduceMap = fmap (+ 1) . S.foldl' (+) 0++o_1_space_transformations_mixed :: Int -> [Benchmark]+o_1_space_transformations_mixed value =+    -- scanl-map and foldl-map are equivalent to the scan and fold in the foldl+    -- library. If scan/fold followed by a map is efficient enough we may not+    -- need monolithic implementations of these.+    [ bgroup "mixed"+        [ benchIOSink value "scanl-map" (scanMap 1)+        , benchIOSink value "foldl-map" foldl'ReduceMap+        , benchIOSink value "sum-product-fold" sumProductFold+        , benchIOSink value "sum-product-scan" sumProductScan+        ]+    ]++o_1_space_transformations_mixedX4 :: Int -> [Benchmark]+o_1_space_transformations_mixedX4 value =+    [ bgroup "mixedX4"+        [ benchIOSink value "scan-map" (scanMap 4)+        , benchIOSink value "drop-map" (dropMap 4)+        , benchIOSink value "drop-scan" (dropScan 4)+        , benchIOSink value "take-drop" (takeDrop value 4)+        , benchIOSink value "take-scan" (takeScan value 4)+        , benchIOSink value "take-map" (takeMap value 4)+        , benchIOSink value "filter-drop" (filterDrop value 4)+        , benchIOSink value "filter-take" (filterTake value 4)+        , benchIOSink value "filter-scan" (filterScan 4)+        , benchIOSink value "filter-scanl1" (filterScanl1 4)+        , benchIOSink value "filter-map" (filterMap value 4)+        ]+    ]++-------------------------------------------------------------------------------+-- Iterating a transformation over and over again+-------------------------------------------------------------------------------++-- this is quadratic+{-# INLINE iterateScan #-}+iterateScan :: S.MonadAsync m => Int -> Int -> Int -> SerialT m Int+iterateScan = iterateSource (S.scanl' (+) 0)++-- this is quadratic+{-# INLINE iterateScanl1 #-}+iterateScanl1 :: S.MonadAsync m => Int -> Int -> Int -> SerialT m Int+iterateScanl1 = iterateSource (S.scanl1' (+))++{-# INLINE iterateMapM #-}+iterateMapM :: S.MonadAsync m => Int -> Int -> Int -> SerialT m Int+iterateMapM = iterateSource (S.mapM return)++{-# INLINE iterateFilterEven #-}+iterateFilterEven :: S.MonadAsync m => Int -> Int -> Int -> SerialT m Int+iterateFilterEven = iterateSource (S.filter even)++{-# INLINE iterateTakeAll #-}+iterateTakeAll :: S.MonadAsync m => Int -> Int -> Int -> Int -> SerialT m Int+iterateTakeAll value = iterateSource (S.take (value + 1))++{-# INLINE iterateDropOne #-}+iterateDropOne :: S.MonadAsync m => Int -> Int -> Int -> SerialT m Int+iterateDropOne = iterateSource (S.drop 1)++{-# INLINE iterateDropWhileFalse #-}+iterateDropWhileFalse :: S.MonadAsync m+    => Int -> Int -> Int -> Int -> SerialT m Int+iterateDropWhileFalse value = iterateSource (S.dropWhile (> (value + 1)))++{-# INLINE iterateDropWhileTrue #-}+iterateDropWhileTrue :: S.MonadAsync m+    => Int -> Int -> Int -> Int -> SerialT m Int+iterateDropWhileTrue value = iterateSource (S.dropWhile (<= (value + 1)))++{-# INLINE tail #-}+tail :: Monad m => SerialT m a -> m ()+tail s = S.tail s >>= mapM_ tail++{-# INLINE nullHeadTail #-}+nullHeadTail :: Monad m => SerialT m Int -> m ()+nullHeadTail s = do+    r <- S.null s+    when (not r) $ do+        _ <- S.head s+        S.tail s >>= mapM_ nullHeadTail++-- Head recursive operations.+o_n_stack_iterated :: Int -> [Benchmark]+o_n_stack_iterated value = by10 `seq` by100 `seq`+    [ bgroup "iterated"+        [ benchIOSrc fromSerial "mapM (n/10 x 10)" $ iterateMapM by10 10+        , benchIOSrc fromSerial "scanl' (quadratic) (n/100 x 100)" $+            iterateScan by100 100+        , benchIOSrc fromSerial "scanl1' (n/10 x 10)" $ iterateScanl1 by10 10+        , benchIOSrc fromSerial "filterEven (n/10 x 10)" $+            iterateFilterEven by10 10+        , benchIOSrc fromSerial "takeAll (n/10 x 10)" $+            iterateTakeAll value by10 10+        , benchIOSrc fromSerial "dropOne (n/10 x 10)" $ iterateDropOne by10 10+        , benchIOSrc fromSerial "dropWhileFalse (n/10 x 10)" $+            iterateDropWhileFalse value by10 10+        , benchIOSrc fromSerial "dropWhileTrue (n/10 x 10)" $+            iterateDropWhileTrue value by10 10+        , benchIOSink value "tail" tail+        , benchIOSink value "nullHeadTail" nullHeadTail+        ]+    ]++    where++    by10 = value `div` 10+    by100 = value `div` 100++-------------------------------------------------------------------------------+-- Pipes+-------------------------------------------------------------------------------++o_1_space_pipes :: Int -> [Benchmark]+o_1_space_pipes value =+    [ bgroup "pipes"+        [ benchIOSink value "mapM" (transformMapM fromSerial 1)+        , benchIOSink value "compose" (transformComposeMapM fromSerial 1)+        , benchIOSink value "tee" (transformTeeMapM fromSerial 1)+#ifdef DEVBUILD+        -- XXX this take 1 GB memory to compile+        , benchIOSink value "zip" (transformZipMapM fromSerial 1)+#endif+        ]+    ]++o_1_space_pipesX4 :: Int -> [Benchmark]+o_1_space_pipesX4 value =+    [ bgroup "pipesX4"+        [ benchIOSink value "mapM" (transformMapM fromSerial 4)+        , benchIOSink value "compose" (transformComposeMapM fromSerial 4)+        , benchIOSink value "tee" (transformTeeMapM fromSerial 4)+#ifdef DEVBUILD+        -- XXX this take 1 GB memory to compile+        , benchIOSink value "zip" (transformZipMapM fromSerial 4)+#endif+        ]+    ]++-------------------------------------------------------------------------------+-- Main+-------------------------------------------------------------------------------++-- In addition to gauge options, the number of elements in the stream can be+-- passed using the --stream-size option.+--+benchmarks :: String -> Int -> [Benchmark]+benchmarks moduleName size =+        [ bgroup (o_1_space_prefix moduleName) $ Prelude.concat+            [ o_1_space_grouping size+            , o_1_space_transformations_mixed size+            , o_1_space_transformations_mixedX4 size++            -- pipes+            , o_1_space_pipes size+            , o_1_space_pipesX4 size+            ]+        , bgroup (o_n_stack_prefix moduleName) (o_n_stack_iterated size)+        , bgroup (o_n_heap_prefix moduleName) $ Prelude.concat+            [ o_n_space_grouping size+            , o_n_space_functor size+            , o_n_heap_buffering size+            ]+        ]
+ benchmark/Streamly/Benchmark/Prelude/Serial/Transformation3.hs view
@@ -0,0 +1,122 @@+-- |+-- Module      : Serial.Transformation3+-- Copyright   : (c) 2018 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}++module Serial.Transformation3 (benchmarks) where++import Control.Monad.State.Strict (StateT, get, put, MonadState)+import qualified Control.Monad.State.Strict as State+import Control.Monad.Trans.Class (lift)++import qualified Streamly.Prelude  as S+import qualified Streamly.Internal.Data.Stream.IsStream as Internal++import Gauge+import Streamly.Prelude (SerialT, fromSerial)+import Streamly.Benchmark.Common+import Streamly.Benchmark.Prelude+import Prelude hiding (reverse, tail)++-------------------------------------------------------------------------------+-- Monad transformation (hoisting etc.)+-------------------------------------------------------------------------------++{-# INLINE sourceUnfoldrState #-}+sourceUnfoldrState :: (S.IsStream t, S.MonadAsync m)+                   => Int -> Int -> t (StateT Int m) Int+sourceUnfoldrState value n = S.unfoldrM step n+    where+    step cnt =+        if cnt > n + value+        then return Nothing+        else do+            s <- get+            put (s + 1)+            return (Just (s, cnt + 1))++{-# INLINE evalStateT #-}+evalStateT :: S.MonadAsync m => Int -> Int -> SerialT m Int+evalStateT value n =+    Internal.evalStateT (return 0) (sourceUnfoldrState value n)++{-# INLINE withState #-}+withState :: S.MonadAsync m => Int -> Int -> SerialT m Int+withState value n =+    Internal.evalStateT+        (return (0 :: Int)) (Internal.liftInner (sourceUnfoldrM value n))++o_1_space_hoisting :: Int -> [Benchmark]+o_1_space_hoisting value =+    [ bgroup "hoisting"+        [ benchIOSrc fromSerial "evalState" (evalStateT value)+        , benchIOSrc fromSerial "withState" (withState value)+        ]+    ]++{-# INLINE iterateStateIO #-}+iterateStateIO ::+       (S.MonadAsync m)+    => Int+    -> StateT Int m Int+iterateStateIO n = do+    x <- get+    if x > n+    then do+        put (x - 1)+        iterateStateIO n+    else return x++{-# INLINE iterateStateT #-}+iterateStateT :: Int -> SerialT (StateT Int IO) Int+iterateStateT n = do+    x <- lift get+    if x > n+    then do+        lift $ put (x - 1)+        iterateStateT n+    else return x++{-# INLINE iterateState #-}+iterateState ::+       (S.MonadAsync m, MonadState Int m)+    => Int+    -> SerialT m Int+iterateState n = do+    x <- get+    if x > n+    then do+        put (x - 1)+        iterateState n+    else return x++o_n_heap_transformer :: Int -> [Benchmark]+o_n_heap_transformer value =+    [ bgroup "transformer"+        [ benchIO "StateT Int IO (n times) (baseline)" $ \n ->+            State.evalStateT (iterateStateIO n) value+        , benchIO "SerialT (StateT Int IO) (n times)" $ \n ->+            State.evalStateT (S.drain (iterateStateT n)) value+        , benchIO "MonadState Int m => SerialT m Int" $ \n ->+            State.evalStateT (S.drain (iterateState n)) value+        ]+    ]++-------------------------------------------------------------------------------+-- Main+-------------------------------------------------------------------------------++-- In addition to gauge options, the number of elements in the stream can be+-- passed using the --stream-size option.+--+benchmarks :: String -> Int -> [Benchmark]+benchmarks moduleName size =+        [ bgroup (o_1_space_prefix moduleName) (o_1_space_hoisting size)+        , bgroup (o_n_heap_prefix moduleName) (o_n_heap_transformer size)+        ]
+ benchmark/Streamly/Benchmark/Prelude/WAsync.hs view
@@ -0,0 +1,184 @@+-- |+-- Module      : Main+-- Copyright   : (c) 2018 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com++import Prelude hiding (mapM)++import Streamly.Prelude (fromWAsync, fromSerial, wAsync, maxBuffer, maxThreads)+import qualified Streamly.Prelude as S++import Streamly.Benchmark.Common+import Streamly.Benchmark.Prelude++import Gauge++moduleName :: String+moduleName = "Prelude.WAsync"++-------------------------------------------------------------------------------+-- Generation+-------------------------------------------------------------------------------++o_1_space_generation :: Int -> [Benchmark]+o_1_space_generation value =+    [ bgroup "generation"+        [ benchIOSrc fromWAsync "unfoldr" (sourceUnfoldr value)+        , benchIOSrc fromWAsync "unfoldrM" (sourceUnfoldrM value)+        , benchIOSrc fromWAsync "fromFoldable" (sourceFromFoldable value)+        , benchIOSrc fromWAsync "fromFoldableM" (sourceFromFoldableM value)+        , benchIOSrc fromWAsync "unfoldrM maxThreads 1"+            (maxThreads 1 . sourceUnfoldrM value)+        , benchIOSrc fromWAsync "unfoldrM maxBuffer 1 (x/10 ops)"+            (maxBuffer 1 . sourceUnfoldrM (value `div` 10))+        ]+    ]++-------------------------------------------------------------------------------+-- Mapping+-------------------------------------------------------------------------------++o_1_space_mapping :: Int -> [Benchmark]+o_1_space_mapping value =+    [ bgroup "mapping"+        [ benchIOSink value "map" $ mapN fromWAsync 1+        , benchIOSink value "fmap" $ fmapN fromWAsync 1+        , benchIOSink value "mapM" $ mapM fromWAsync 1 . fromSerial+        ]+    ]++-------------------------------------------------------------------------------+-- Joining+-------------------------------------------------------------------------------++{-# INLINE wAsync2 #-}+wAsync2 :: Int -> Int -> IO ()+wAsync2 count n =+    S.drain $+        (sourceUnfoldrM count n) `wAsync` (sourceUnfoldrM count (n + 1))++{-# INLINE wAsync4 #-}+wAsync4 :: Int -> Int -> IO ()+wAsync4 count n =+    S.drain $+                  (sourceUnfoldrM count (n + 0))+        `wAsync` (sourceUnfoldrM count (n + 1))+        `wAsync` (sourceUnfoldrM count (n + 2))+        `wAsync` (sourceUnfoldrM count (n + 3))++{-# INLINE wAsync2n2 #-}+wAsync2n2 :: Int -> Int -> IO ()+wAsync2n2 count n =+    S.drain $+        ((sourceUnfoldrM count (n + 0))+            `wAsync` (sourceUnfoldrM count (n + 1)))+        `wAsync` ((sourceUnfoldrM count (n + 2))+            `wAsync` (sourceUnfoldrM count (n + 3)))++o_1_space_joining :: Int -> [Benchmark]+o_1_space_joining value =+    [ bgroup "joining"+        [ benchIOSrc1 "wAsync (2 of n/2)" (wAsync2 (value `div` 2))+        , benchIOSrc1 "wAsync (4 of n/4)" (wAsync4 (value `div` 4))+        , benchIOSrc1 "wAsync (2 of (2 of n/4)" (wAsync2n2 (value `div` 4))+        ]+    ]++-------------------------------------------------------------------------------+-- Concat+-------------------------------------------------------------------------------++o_1_space_concatFoldable :: Int -> [Benchmark]+o_1_space_concatFoldable value =+    [ bgroup "concat-foldable"+        [ benchIOSrc fromWAsync "foldMapWith (<>) (List)"+            (sourceFoldMapWith value)+        , benchIOSrc fromWAsync "foldMapWith (<>) (Stream)"+            (sourceFoldMapWithStream value)+        , benchIOSrc fromWAsync "foldMapWithM (<>) (List)"+            (sourceFoldMapWithM value)+        , benchIOSrc fromSerial "S.concatFoldableWith (<>) (List)"+            (concatFoldableWith value)+        , benchIOSrc fromSerial "S.concatForFoldableWith (<>) (List)"+            (concatForFoldableWith value)+        , benchIOSrc fromWAsync "foldMapM (List)" (sourceFoldMapM value)+        ]+    ]++-- When we merge streams using wAsync the size of the queue increases+-- slowly because of the binary composition adding just one more item+-- to the work queue only after every scheduling pass through the+-- work queue.+--+-- We should see the memory consumption increasing slowly if these+-- benchmarks are left to run on infinite number of streams of infinite+-- sizes.+o_1_space_concatMap :: Int -> [Benchmark]+o_1_space_concatMap value =+    value2 `seq`+        [ bgroup "concat"+            -- This is for comparison with foldMapWith+            [ benchIOSrc fromSerial "concatMapWithId (n of 1) (fromFoldable)"+                (S.concatMapWith wAsync id . sourceConcatMapId value)++            , benchIO "concatMapWith (n of 1)"+                  (concatStreamsWith wAsync value 1)+            , benchIO "concatMapWith (sqrt x of sqrt x)"+                  (concatStreamsWith wAsync value2 value2)+            , benchIO "concatMapWith (1 of n)"+                  (concatStreamsWith wAsync 1 value)+            ]+        ]++    where++    value2 = round $ sqrt (fromIntegral value :: Double)++-------------------------------------------------------------------------------+-- Monadic outer product+-------------------------------------------------------------------------------++o_n_heap_outerProduct :: Int -> [Benchmark]+o_n_heap_outerProduct value =+    [ bgroup "monad-outer-product"+        [ benchIO "toNullAp"       $ toNullAp value fromWAsync+        , benchIO "toNull"         $ toNullM value fromWAsync+        , benchIO "toNull3"        $ toNullM3 value fromWAsync+        , benchIO "filterAllOut"   $ filterAllOutM value fromWAsync+        , benchIO "filterAllIn"    $ filterAllInM value fromWAsync+        , benchIO "filterSome"     $ filterSome value fromWAsync+        , benchIO "breakAfterSome" $ breakAfterSome value fromWAsync++        ]+    ]++o_n_space_outerProduct :: Int -> [Benchmark]+o_n_space_outerProduct value =+    [ bgroup "monad-outer-product"+        [ benchIO "toList"         $ toListM value fromWAsync+        , benchIO "toListSome"     $ toListSome value fromWAsync+        ]+    ]++-------------------------------------------------------------------------------+-- Main+-------------------------------------------------------------------------------++main :: IO ()+main = runWithCLIOpts defaultStreamSize allBenchmarks++    where++    allBenchmarks value =+        [ bgroup (o_1_space_prefix moduleName) $ concat+            [ o_1_space_generation value+            , o_1_space_mapping value+            , o_1_space_joining value+            , o_1_space_concatFoldable value+            , o_1_space_concatMap value+            ]+        , bgroup (o_n_heap_prefix moduleName) (o_n_heap_outerProduct value)+        , bgroup (o_n_space_prefix moduleName) (o_n_space_outerProduct value)+        ]
+ benchmark/Streamly/Benchmark/Prelude/WSerial.hs view
@@ -0,0 +1,218 @@+-- |+-- Module      : Main+-- Copyright   : (c) 2018 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}++#ifdef __HADDOCK_VERSION__+#undef INSPECTION+#endif++#ifdef INSPECTION+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}+#endif++import Streamly.Prelude (wSerial, fromWSerial)+import qualified Streamly.Prelude as S+import qualified Streamly.Internal.Data.Stream.IsStream as Internal+import qualified Streamly.Internal.Data.Unfold as UF++import Streamly.Benchmark.Common+import Streamly.Benchmark.Prelude++import Gauge++#ifdef INSPECTION+import GHC.Types (SPEC(..))+import Test.Inspection++import qualified Streamly.Internal.Data.Stream.StreamD as D+#endif++moduleName :: String+moduleName = "Prelude.WSerial"++-------------------------------------------------------------------------------+-- Mapping+-------------------------------------------------------------------------------++o_1_space_mapping :: Int -> [Benchmark]+o_1_space_mapping value =+    [ bgroup "mapping"+        [ benchIOSink value "fmap" $ fmapN fromWSerial 1 ]+    ]++-------------------------------------------------------------------------------+-- Interleaving+-------------------------------------------------------------------------------++{-# INLINE wSerial2 #-}+wSerial2 :: Int -> Int -> IO ()+wSerial2 value n =+    S.drain $ wSerial+        (sourceUnfoldrM (value `div` 2) n)+        (sourceUnfoldrM (value `div` 2) (n + 1))++{-# INLINE interleave2 #-}+interleave2 :: Int -> Int -> IO ()+interleave2 value n =+    S.drain $+    Internal.interleave+        (sourceUnfoldrM (value `div` 2) n)+        (sourceUnfoldrM (value `div` 2) (n + 1))++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'interleave2+inspect $ 'interleave2 `hasNoType` ''SPEC+inspect $ 'interleave2 `hasNoType` ''D.InterleaveState+#endif++{-# INLINE roundRobin2 #-}+roundRobin2 :: Int -> Int -> IO ()+roundRobin2 value n =+    S.drain $+    Internal.roundrobin+        (sourceUnfoldrM (value `div` 2) n)+        (sourceUnfoldrM (value `div` 2) (n + 1))++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'roundRobin2+inspect $ 'roundRobin2 `hasNoType` ''SPEC+inspect $ 'roundRobin2 `hasNoType` ''D.InterleaveState+#endif++o_1_space_joining :: Int -> [Benchmark]+o_1_space_joining value =+    [ bgroup "joining"+        [ benchIOSrc1 "wSerial (2,x/2)" (wSerial2 value)+        , benchIOSrc1 "interleave (2,x/2)" (interleave2 value)+        , benchIOSrc1 "roundRobin (2,x/2)" (roundRobin2 value)+        ]+    ]++-------------------------------------------------------------------------------+-- Concat+-------------------------------------------------------------------------------++{-# INLINE concatMapWithWSerial #-}+concatMapWithWSerial :: Int -> Int -> Int -> IO ()+concatMapWithWSerial = concatStreamsWith wSerial++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'concatMapWithWSerial+inspect $ 'concatMapWithWSerial `hasNoType` ''SPEC+#endif++o_1_space_concat :: Int -> [Benchmark]+o_1_space_concat value =+    [ bgroup "concat"+        [ benchIOSrc1+              "concatMapWithWSerial (2,x/2)"+              (concatMapWithWSerial 2 (value `div` 2))+        , benchIOSrc1+              "concatMapWithWSerial (x/2,2)"+              (concatMapWithWSerial (value `div` 2) 2)+        ]+    ]++{-# INLINE unfoldManyInterleaveRepl4xN #-}+unfoldManyInterleaveRepl4xN :: Int -> Int -> IO ()+unfoldManyInterleaveRepl4xN value n =+    S.drain $ Internal.unfoldManyInterleave+        (UF.lmap return (UF.replicateM 4))+        (sourceUnfoldrM (value `div` 4) n)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'unfoldManyInterleaveRepl4xN+-- inspect $ 'unfoldManyInterleaveRepl4xN `hasNoType` ''SPEC+-- inspect $ 'unfoldManyInterleaveRepl4xN `hasNoType`+--      ''D.ConcatUnfoldInterleaveState+#endif++{-# INLINE unfoldManyRoundRobinRepl4xN #-}+unfoldManyRoundRobinRepl4xN :: Int -> Int -> IO ()+unfoldManyRoundRobinRepl4xN value n =+    S.drain $ Internal.unfoldManyRoundRobin+        (UF.lmap return (UF.replicateM 4))+        (sourceUnfoldrM (value `div` 4) n)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'unfoldManyRoundRobinRepl4xN+-- inspect $ 'unfoldManyRoundRobinRepl4xN `hasNoType` ''SPEC+-- inspect $ 'unfoldManyRoundRobinRepl4xN `hasNoType`+--      ''D.ConcatUnfoldInterleaveState+#endif++o_n_heap_concat :: Int -> [Benchmark]+o_n_heap_concat value =+    [ bgroup "concat"+        [+          -- interleave x/4 streams of 4 elements each. Needs to buffer+          -- proportional to x/4. This is different from WSerial because+          -- WSerial expands slowly because of binary interleave behavior and+          -- this expands immediately because of Nary interleave behavior.+          benchIOSrc1+              "unfoldManyInterleaveRepl (x/4,4)"+              (unfoldManyInterleaveRepl4xN value)+        , benchIOSrc1+              "unfoldManyRoundRobinRepl (x/4,4)"+              (unfoldManyRoundRobinRepl4xN value)+        ]+    ]++-------------------------------------------------------------------------------+-- Monad+-------------------------------------------------------------------------------++o_1_space_outerProduct :: Int -> [Benchmark]+o_1_space_outerProduct value =+    [ bgroup "monad-outer-product"+        [ benchIO "toNullAp" $ toNullAp value fromWSerial+        , benchIO "toNullM" $ toNullM value fromWSerial+        , benchIO "toNullM3" $ toNullM3 value fromWSerial+        , benchIO "filterAllOutM" $ filterAllOutM value fromWSerial+        , benchIO "filterAllInM" $ filterAllInM value fromWSerial+        , benchIO "filterSome" $ filterSome value fromWSerial+        , benchIO "breakAfterSome" $ breakAfterSome value fromWSerial+        ]+    ]++o_n_space_outerProduct :: Int -> [Benchmark]+o_n_space_outerProduct value =+    [ bgroup+        "monad-outer-product"+        [ benchIO "toList" $ toListM value fromWSerial+        , benchIO "toListSome" $ toListSome value fromWSerial+        ]+    ]++-------------------------------------------------------------------------------+-- Main+-------------------------------------------------------------------------------++-- In addition to gauge options, the number of elements in the stream can be+-- passed using the --stream-size option.+--+main :: IO ()+main = runWithCLIOpts defaultStreamSize allBenchmarks+++    where++    allBenchmarks size =+        [ bgroup (o_1_space_prefix moduleName) $ concat+            [ o_1_space_mapping size+            , o_1_space_joining size+            , o_1_space_concat size+            , o_1_space_outerProduct size+            ]+        , bgroup (o_n_heap_prefix moduleName) (o_n_heap_concat size)+        , bgroup (o_n_space_prefix moduleName) (o_n_space_outerProduct size)+        ]
+ benchmark/Streamly/Benchmark/Prelude/ZipAsync.hs view
@@ -0,0 +1,81 @@+-- |+-- Module      : Main+-- Copyright   : (c) 2018 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com++{-# LANGUAGE FlexibleContexts #-}++import Streamly.Prelude (fromSerial)+import qualified Streamly.Prelude  as S++import Streamly.Benchmark.Common+import Streamly.Benchmark.Prelude++import Gauge++moduleName :: String+moduleName = "Prelude.ZipAsync"++-------------------------------------------------------------------------------+-- Zipping+-------------------------------------------------------------------------------++{-# INLINE zipAsyncWith #-}+zipAsyncWith :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m (Int, Int)+zipAsyncWith count n =+    S.zipAsyncWith (,) (sourceUnfoldrM count n) (sourceUnfoldrM count (n + 1))++{-# INLINE zipAsyncWithM #-}+zipAsyncWithM :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m (Int, Int)+zipAsyncWithM count n =+    S.zipAsyncWithM+        (curry return)+        (sourceUnfoldrM count n)+        (sourceUnfoldrM count (n + 1))++{-# INLINE zipAsyncAp #-}+zipAsyncAp :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m (Int, Int)+zipAsyncAp count n =+    S.fromZipAsync $+        (,) <$> sourceUnfoldrM count n <*> sourceUnfoldrM count (n + 1)++o_1_space_joining :: Int -> [Benchmark]+o_1_space_joining value =+    [ bgroup "joining"+        [ benchIOSrc fromSerial "zipAsyncWith (2,x/2)" (zipAsyncWith+                                                      (value `div` 2))+        , benchIOSrc fromSerial "zipAsyncWithM (2,x/2)" (zipAsyncWithM+                                                       (value `div` 2))+        , benchIOSrc fromSerial "zipAsyncAp (2,x/2)" (zipAsyncAp (value `div` 2))+        , benchIOSink value "fmap zipAsyncly" $ fmapN S.fromZipAsync 1+        ]+    ]++-------------------------------------------------------------------------------+-- Monad outer product+-------------------------------------------------------------------------------++o_1_space_outerProduct :: Int -> [Benchmark]+o_1_space_outerProduct value =+    [ bgroup "monad-outer-product"+        [ benchIO "toNullAp" $ toNullAp value S.fromZipAsync+        ]+    ]++-------------------------------------------------------------------------------+-- Main+-------------------------------------------------------------------------------++main :: IO ()+main = runWithCLIOpts defaultStreamSize allBenchmarks++    where++    allBenchmarks size =+        [ bgroup (o_1_space_prefix moduleName) $ concat+            [ o_1_space_joining size+            , o_1_space_outerProduct size+            ]+        ]
+ benchmark/Streamly/Benchmark/Prelude/ZipSerial.hs view
@@ -0,0 +1,139 @@+-- |+-- Module      : Main+-- Copyright   : (c) 2018 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}++#ifdef __HADDOCK_VERSION__+#undef INSPECTION+#endif++#ifdef INSPECTION+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}+#endif++import Prelude hiding (zipWith)++import Streamly.Prelude (MonadAsync)+import qualified Streamly.Prelude  as S++import Streamly.Benchmark.Common+import Streamly.Benchmark.Prelude hiding (sourceUnfoldrM)++import Gauge++#ifdef INSPECTION+import GHC.Types (SPEC(..))+import Test.Inspection++import qualified Streamly.Internal.Data.Stream.StreamD as D+#endif++moduleName :: String+moduleName = "Prelude.ZipSerial"++-------------------------------------------------------------------------------+-- Zipping+-------------------------------------------------------------------------------++-- XXX somehow copying this definition here instead of importing it performs+-- better. Need to investigate why.+{-# INLINE sourceUnfoldrM #-}+sourceUnfoldrM :: (S.IsStream t, MonadAsync m) => Int -> Int -> t m Int+sourceUnfoldrM count start = S.unfoldrM step start+    where+    step cnt =+        if cnt > start + count+        then return Nothing+        else return (Just (cnt, cnt + 1))++{-# INLINE zipWith #-}+zipWith :: Int -> Int -> IO ()+zipWith count n =+    S.drain $+    S.zipWith+        (,)+        (S.fromSerial $ sourceUnfoldrM count n)+        (S.fromSerial $ sourceUnfoldrM count (n + 1))++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'zipWith+inspect $ 'zipWith `hasNoType` ''SPEC+inspect $ 'zipWith `hasNoType` ''D.Step+#endif++{-# INLINE zipWithM #-}+zipWithM :: Int -> Int -> IO ()+zipWithM count n =+    S.drain $+    S.zipWithM+        (curry return)+        (sourceUnfoldrM count n)+        (sourceUnfoldrM count (n + 1))++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'zipWithM+inspect $ 'zipWithM `hasNoType` ''SPEC+inspect $ 'zipWithM `hasNoType` ''D.Step+#endif++o_1_space_joining :: Int -> [Benchmark]+o_1_space_joining value =+    [ bgroup "joining"+        [ benchIOSrc1 "zip (2,x/2)" (zipWith (value `div` 2))+        , benchIOSrc1 "zipM (2,x/2)" (zipWithM (value `div` 2))+        ]+    ]++-------------------------------------------------------------------------------+-- Mapping+-------------------------------------------------------------------------------++o_1_space_mapping :: Int -> [Benchmark]+o_1_space_mapping value =+    [ bgroup "mapping"+        [ benchIOSink value "fmap" $ fmapN S.fromZipSerial 1+        ]+    ]++-------------------------------------------------------------------------------+-- Monad outer product+-------------------------------------------------------------------------------++{-+o_1_space_outerProduct :: Int -> [Benchmark]+o_1_space_outerProduct value =+    [ bgroup "monad-outer-product"+        -- XXX needs fixing+        [ benchIO "toNullAp" $ toNullAp value S.zipSerially+        ]+    ]+-}++-------------------------------------------------------------------------------+-- Main+-------------------------------------------------------------------------------++-- In addition to gauge options, the number of elements in the stream can be+-- passed using the --stream-size option.+--+main :: IO ()+main = runWithCLIOpts defaultStreamSize allBenchmarks++    where++    allBenchmarks size =+        [ bgroup (o_1_space_prefix moduleName) $ concat+            [ o_1_space_joining size+            , o_1_space_mapping size+            -- XXX need to fix, timing in ns+            -- , o_1_space_outerProduct size+            ]+        ]
+ benchmark/Streamly/Benchmark/Unicode/Stream.hs view
@@ -0,0 +1,302 @@+--+-- Module      : Streamly.Unicode.Stream+-- Copyright   : (c) 2019 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}++#ifdef __HADDOCK_VERSION__+#undef INSPECTION+#endif++#ifdef INSPECTION+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}+#endif++import Prelude hiding (last, length)+import System.IO (Handle)++import qualified Streamly.Data.Array.Foreign as Array+import qualified Streamly.Data.Fold as Fold+import qualified Streamly.FileSystem.Handle as Handle+import qualified Streamly.Internal.Data.Stream.IsStream as Stream+import qualified Streamly.Internal.Data.Unfold as Unfold+import qualified Streamly.Internal.FileSystem.Handle as Handle+import qualified Streamly.Internal.Unicode.Array.Char as UnicodeArr+import qualified Streamly.Internal.Unicode.Stream as Unicode++import Gauge hiding (env)+import Streamly.Benchmark.Common+import Streamly.Benchmark.Common.Handle++#ifdef INSPECTION+import Foreign.Storable (Storable)+import Streamly.Internal.Data.Stream.StreamD.Type (Step(..))+import qualified Streamly.Internal.Data.Fold.Type as Fold+import qualified Streamly.Internal.Data.Tuple.Strict as Strict+import qualified Streamly.Internal.Data.Array.Foreign.Type as Array+import qualified Streamly.Internal.Data.Array.Foreign.Mut.Type as MArray++import Test.Inspection+#endif++moduleName :: String+moduleName = "Unicode.Stream"++-- | Copy file+{-# NOINLINE copyCodecUtf8ArraysLenient #-}+copyCodecUtf8ArraysLenient :: Handle -> Handle -> IO ()+copyCodecUtf8ArraysLenient inh outh =+   Stream.fold (Handle.write outh)+     $ Unicode.encodeUtf8'+     $ Unicode.decodeUtf8Arrays+     $ Handle.toChunks inh++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'copyCodecUtf8ArraysLenient+-- inspect $ 'copyCodecUtf8ArraysLenient `hasNoType` ''Step+#endif++o_1_space_decode_encode_chunked :: BenchEnv -> [Benchmark]+o_1_space_decode_encode_chunked env =+    [ bgroup "decode-encode/toChunks"+        [+        mkBenchSmall "encodeUtf8' . decodeUtf8Arrays" env $ \inH outH ->+            copyCodecUtf8ArraysLenient inH outH+        ]+    ]++-------------------------------------------------------------------------------+-- copy with group/ungroup transformations+-------------------------------------------------------------------------------++{-# NOINLINE linesUnlinesCopy #-}+linesUnlinesCopy :: Handle -> Handle -> IO ()+linesUnlinesCopy inh outh =+    Stream.fold (Handle.write outh)+      $ Unicode.encodeLatin1'+      $ Unicode.unlines Unfold.fromList+      $ Stream.splitOnSuffix (== '\n') Fold.toList+      $ Unicode.decodeLatin1+      $ Stream.unfold Handle.read inh++{-# NOINLINE linesUnlinesArrayWord8Copy #-}+linesUnlinesArrayWord8Copy :: Handle -> Handle -> IO ()+linesUnlinesArrayWord8Copy inh outh =+    Stream.fold (Handle.write outh)+      $ Stream.interposeSuffix 10 Array.read+      $ Stream.splitOnSuffix (== 10) Array.write+      $ Stream.unfold Handle.read inh++-- XXX splitSuffixOn requires -funfolding-use-threshold=150 for better fusion+-- | Lines and unlines+{-# NOINLINE linesUnlinesArrayCharCopy #-}+linesUnlinesArrayCharCopy :: Handle -> Handle -> IO ()+linesUnlinesArrayCharCopy inh outh =+    Stream.fold (Handle.write outh)+      $ Unicode.encodeLatin1'+      $ UnicodeArr.unlines+      $ UnicodeArr.lines+      $ Unicode.decodeLatin1+      $ Stream.unfold Handle.read inh++#ifdef INSPECTION+inspect $ hasNoTypeClassesExcept 'linesUnlinesArrayCharCopy [''Storable]+-- inspect $ 'linesUnlinesArrayCharCopy `hasNoType` ''Step+#endif++-- XXX to write this we need to be able to map decodeUtf8 on the Array.read fold.+-- For that we have to write decodeUtf8 as a Pipe.+{-+{-# INLINE linesUnlinesArrayUtf8Copy #-}+linesUnlinesArrayUtf8Copy :: Handle -> Handle -> IO ()+linesUnlinesArrayUtf8Copy inh outh =+    Stream.fold (Handle.write outh)+      $ Unicode.encodeLatin1'+      $ Stream.intercalate (Array.fromList [10]) (pipe Unicode.decodeUtf8P Array.read)+      $ Stream.splitOnSuffix (== '\n') (IFold.map Unicode.encodeUtf8' Array.write)+      $ Unicode.decodeLatin1+      $ Stream.unfold Handle.read inh+-}++-- | Word, unwords and copy+{-# NOINLINE wordsUnwordsCopyWord8 #-}+wordsUnwordsCopyWord8 :: Handle -> Handle -> IO ()+wordsUnwordsCopyWord8 inh outh =+    Stream.fold (Handle.write outh)+        $ Stream.interposeSuffix 32 Unfold.fromList+        $ Stream.wordsBy isSp Fold.toList+        $ Stream.unfold Handle.read inh++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'wordsUnwordsCopyWord8+-- inspect $ 'wordsUnwordsCopyWord8 `hasNoType` ''Step+#endif++-- | Word, unwords and copy+{-# NOINLINE wordsUnwordsCopy #-}+wordsUnwordsCopy :: Handle -> Handle -> IO ()+wordsUnwordsCopy inh outh =+    Stream.fold (Handle.write outh)+      $ Unicode.encodeLatin1'+      $ Unicode.unwords Unfold.fromList+      -- XXX This pipeline does not fuse with wordsBy but fuses with splitOn+      -- with -funfolding-use-threshold=300.  With wordsBy it does not fuse+      -- even with high limits for inlining and spec-constr ghc options. With+      -- -funfolding-use-threshold=400 it performs pretty well and there+      -- is no evidence in the core that a join point involving Step+      -- constructors is not getting inlined. Not being able to fuse at all in+      -- this case could be an unknown issue, need more investigation.+      $ Stream.wordsBy isSpace Fold.toList+      -- -- $ Stream.splitOn isSpace Fold.toList+      $ Unicode.decodeLatin1+      $ Stream.unfold Handle.read inh++#ifdef INSPECTION+-- inspect $ hasNoTypeClasses 'wordsUnwordsCopy+-- inspect $ 'wordsUnwordsCopy `hasNoType` ''Step+#endif++{-# NOINLINE wordsUnwordsCharArrayCopy #-}+wordsUnwordsCharArrayCopy :: Handle -> Handle -> IO ()+wordsUnwordsCharArrayCopy inh outh =+    Stream.fold (Handle.write outh)+      $ Unicode.encodeLatin1'+      $ UnicodeArr.unwords+      $ UnicodeArr.words+      $ Unicode.decodeLatin1+      $ Stream.unfold Handle.read inh++o_1_space_copy_read_group_ungroup :: BenchEnv -> [Benchmark]+o_1_space_copy_read_group_ungroup env =+    [ bgroup "ungroup-group"+        [ mkBenchSmall "unlines . splitOnSuffix ([Word8])" env+            $ \inh outh -> linesUnlinesCopy inh outh+        , mkBenchSmall "interposeSuffix . splitOnSuffix (Array Word8)" env+            $ \inh outh -> linesUnlinesArrayWord8Copy inh outh+        , mkBenchSmall "UnicodeArr.unlines . UnicodeArr.lines (Array Char)" env+            $ \inh outh -> linesUnlinesArrayCharCopy inh outh++        , mkBenchSmall "interposeSuffix . wordsBy ([Word8])" env+            $ \inh outh -> wordsUnwordsCopyWord8 inh outh+        , mkBenchSmall "unwords . wordsBy ([Char])" env+            $ \inh outh -> wordsUnwordsCopy inh outh+        , mkBenchSmall "UnicodeArr.unwords . UnicodeArr.words (Array Char)" env+            $ \inh outh -> wordsUnwordsCharArrayCopy inh outh+        ]+    ]++-------------------------------------------------------------------------------+-- copy unfold+-------------------------------------------------------------------------------++-- | Copy file (encodeLatin1')+{-# NOINLINE copyStreamLatin1' #-}+copyStreamLatin1' :: Handle -> Handle -> IO ()+copyStreamLatin1' inh outh =+   Stream.fold (Handle.write outh)+     $ Unicode.encodeLatin1'+     $ Unicode.decodeLatin1+     $ Stream.unfold Handle.read inh++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'copyStreamLatin1'+inspect $ 'copyStreamLatin1' `hasNoType` ''Step+inspect $ 'copyStreamLatin1' `hasNoType` ''Unfold.ConcatState -- Handle.read/UF.many+inspect $ 'copyStreamLatin1' `hasNoType` ''MArray.ReadUState  -- Handle.read/Array.read++inspect $ 'copyStreamLatin1' `hasNoType` ''Fold.Step+inspect $ 'copyStreamLatin1' `hasNoType` ''Array.ArrayUnsafe -- Handle.write/writeNUnsafe+inspect $ 'copyStreamLatin1' `hasNoType` ''Strict.Tuple3' -- Handle.write/chunksOf+#endif++-- | Copy file (encodeLatin1)+{-# NOINLINE copyStreamLatin1 #-}+copyStreamLatin1 :: Handle -> Handle -> IO ()+copyStreamLatin1 inh outh =+   Stream.fold (Handle.write outh)+     $ Unicode.encodeLatin1+     $ Unicode.decodeLatin1+     $ Stream.unfold Handle.read inh++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'copyStreamLatin1+inspect $ 'copyStreamLatin1 `hasNoType` ''Step+inspect $ 'copyStreamLatin1 `hasNoType` ''Unfold.ConcatState -- Handle.read/UF.many+inspect $ 'copyStreamLatin1 `hasNoType` ''MArray.ReadUState  -- Handle.read/Array.read++inspect $ 'copyStreamLatin1 `hasNoType` ''Fold.ManyState+inspect $ 'copyStreamLatin1 `hasNoType` ''Fold.Step+inspect $ 'copyStreamLatin1 `hasNoType` ''Array.ArrayUnsafe -- Handle.write/writeNUnsafe+inspect $ 'copyStreamLatin1 `hasNoType` ''Strict.Tuple3' -- Handle.write/chunksOf+#endif++-- | Copy file+_copyStreamUtf8' :: Handle -> Handle -> IO ()+_copyStreamUtf8' inh outh =+   Stream.fold (Handle.write outh)+     $ Unicode.encodeUtf8'+     $ Unicode.decodeUtf8'+     $ Stream.unfold Handle.read inh++#ifdef INSPECTION+inspect $ hasNoTypeClasses '_copyStreamUtf8'+-- inspect $ '_copyStreamUtf8 `hasNoType` ''Step+-- inspect $ '_copyStreamUtf8 `hasNoType` ''Array.FlattenState+-- inspect $ '_copyStreamUtf8 `hasNoType` ''D.ConcatMapUState+#endif++-- | Copy file+{-# NOINLINE copyStreamUtf8 #-}+copyStreamUtf8 :: Handle -> Handle -> IO ()+copyStreamUtf8 inh outh =+   Stream.fold (Handle.write outh)+     $ Unicode.encodeUtf8+     $ Unicode.decodeUtf8+     $ Stream.unfold Handle.read inh++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'copyStreamUtf8+-- inspect $ 'copyStreamUtf8Lax `hasNoType` ''Step+-- inspect $ 'copyStreamUtf8Lax `hasNoType` ''Array.FlattenState+-- inspect $ 'copyStreamUtf8Lax `hasNoType` ''D.ConcatMapUState+#endif++o_1_space_decode_encode_read :: BenchEnv -> [Benchmark]+o_1_space_decode_encode_read env =+    [ bgroup "decode-encode"+        [+        -- This needs an ascii file, as decode just errors out.+          mkBench "encodeLatin1' . decodeLatin1" env $ \inh outh ->+            copyStreamLatin1' inh outh+        , mkBench "encodeLatin1 . decodeLatin1" env $ \inh outh ->+            copyStreamLatin1 inh outh+#ifdef DEVBUILD+        -- Requires valid unicode input+        , mkBench "encodeUtf8' . decodeUtf8'" env $ \inh outh ->+            _copyStreamUtf8' inh outh+#endif+        , mkBenchSmall "encodeUtf8 . decodeUtf8" env $ \inh outh ->+            copyStreamUtf8 inh outh+        ]+    ]++main :: IO ()+main = do+    env <- mkHandleBenchEnv+    defaultMain (allBenchmarks env)++    where++    allBenchmarks env =+        [ bgroup (o_1_space_prefix moduleName) $ Prelude.concat+            [ o_1_space_copy_read_group_ungroup env+            , o_1_space_decode_encode_chunked env+            , o_1_space_decode_encode_read env+            ]+        ]
+ benchmark/bench-report/BenchReport.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main where++import Control.Exception (catch, ErrorCall(..))+import Control.Monad.Trans.State+import Control.Monad.Trans.Maybe+import Data.Char (toLower)+import Data.List+import System.Environment (getArgs)+import Control.Monad.IO.Class (liftIO)+import Control.Monad (mzero)++import BenchShow++------------------------------------------------------------------------------+-- Command line parsing+------------------------------------------------------------------------------++data BenchType+    = Compare String+    | Standard String+    deriving Show++data Options = Options+    { genGraphs :: Bool+    , sortByName :: Bool+    , benchType :: Maybe BenchType+    , fields :: [String]+    } deriving Show++defaultOptions :: Options+defaultOptions = Options False False Nothing ["time"]++setGenGraphs :: Monad m => Bool -> StateT (a, Options) m ()+setGenGraphs val = do+    (args, opts) <- get+    put (args, opts { genGraphs = val })++setSortByName :: Monad m => Bool -> StateT (a, Options) m ()+setSortByName val = do+    (args, opts) <- get+    put (args, opts { sortByName = val })++setBenchType :: Monad m => BenchType -> StateT (a, Options) m ()+setBenchType val = do+    (args, opts) <- get+    put (args, opts { benchType = Just val })++setFields :: Monad m => [String] -> StateT (a, Options) m ()+setFields val = do+    (args, opts) <- get+    put (args, opts { fields = val })++-- Like the shell "shift" to shift the command line arguments+shift :: StateT ([String], Options) (MaybeT IO) (Maybe String)+shift = do+    s <- get+    case s of+        ([], _) -> return Nothing+        (x : xs, opts) -> put (xs, opts) >> return (Just x)++parseBench :: StateT ([String], Options) (MaybeT IO) ()+parseBench = do+    x <- shift+    case x of+        Just str | "_cmp" `isSuffixOf` str -> setBenchType (Compare str)+        Just str -> setBenchType (Standard str)+        Nothing -> do+                liftIO $ putStrLn "please provide a benchmark type "+                mzero++parseFields :: StateT ([String], Options) (MaybeT IO) ()+parseFields = do+    x <- shift+    case x of+        Just str -> setFields (words str)+        Nothing -> do+                liftIO $ putStrLn+                    "please provide a list of fields after --fields"+                mzero++-- totally imperative style option parsing+parseOptions :: IO (Maybe Options)+parseOptions = do+    args <- getArgs+    runMaybeT $ flip evalStateT (args, defaultOptions) $ do+        parseLoop+        fmap snd get++    where++    parseOpt opt =+        case opt of+            "--graphs"    -> setGenGraphs True+            "--sort-by-name" -> setSortByName True+            "--benchmark" -> parseBench+            "--fields"    -> parseFields+            str -> do+                liftIO $ putStrLn $ "Unrecognized option " <> str+                mzero++    parseLoop = do+        next <- shift+        case next of+            Just opt -> parseOpt opt >> parseLoop+            Nothing -> return ()++ignoringErr :: IO () -> IO ()+ignoringErr a = catch a (\(ErrorCall err :: ErrorCall) ->+    putStrLn $ "Failed with error:\n" <> err <> "\nSkipping.")++------------------------------------------------------------------------------+-- Generic+------------------------------------------------------------------------------++makeGraphs :: String -> Config -> String -> IO ()+makeGraphs name cfg@Config{..} inputFile =+    ignoringErr $ graph inputFile name cfg++------------------------------------------------------------------------------+-- Arrays+------------------------------------------------------------------------------++showComparisons :: Options -> Config -> FilePath -> FilePath -> IO ()+showComparisons Options{..} cfg inp out =+    let cfg1 = cfg { classifyBenchmark = classifyComparison }+     in if genGraphs+        then ignoringErr $ graph inp "comparison"+                cfg1 { outputDir = Just out+                     , presentation = Groups Absolute+                     }+        else ignoringErr $ report inp Nothing cfg1++    where++    dropComponent = dropWhile (== '/') . dropWhile (/= '/')++    classifyComparison b = Just+        ( takeWhile (/= '/') b+        , dropComponent b+        )++------------------------------------------------------------------------------+-- text reports+------------------------------------------------------------------------------++selectBench+    :: Bool+    -> (SortColumn -> Maybe GroupStyle -> Either String [(String, Double)])+    -> [String]+selectBench sortName f =+    reverse+    $ fmap fst+    $ either+      (const $ either error sortFunc $ f (ColumnIndex 0) (Just PercentDiff))+      sortFunc+      $ f (ColumnIndex 1) (Just PercentDiff)++    where++    sortFunc = if sortName then sortOn fst else sortOn snd++benchShow ::+       Options+    -> Config+    -> (Config -> String -> IO ())+    -> String+    -> FilePath+    -> IO ()+benchShow Options{..} cfg func inp out =+    if genGraphs+    then func cfg {outputDir = Just out} inp+    else ignoringErr $ report inp Nothing cfg++main :: IO ()+main = do+    res <- parseOptions+    case res of+        Nothing -> do+            putStrLn "cannot parse options"+            return ()+        Just opts@Options{fields = fs, benchType = btype} ->+            let cfg = defaultConfig+                    { presentation = Groups PercentDiff+                    , selectBenchmarks = selectBench (sortByName opts)+                    , selectFields = filter+                        ( flip elem (fmap (fmap toLower) fs)+                        . fmap toLower+                        )+                    }+            in case btype of+                Just (Compare str) ->+                    showComparisons opts cfg+                        { title = Just str }+                        ("charts/" ++ str ++ "/results.csv")+                        ("charts/" ++ str)+                Just (Standard str) ->+                    benchShow opts cfg+                        { title = Just str }+                        (makeGraphs str)+                        ("charts/" ++ str ++ "/results.csv")+                        ("charts/" ++ str)+                Nothing ->+                    error "Please specify a benchmark using --benchmark."
+ benchmark/bench-report/bench-report.cabal view
@@ -0,0 +1,23 @@+cabal-version:      2.2+name:               bench-report+version:            0.0.0+synopsis:           Benchmark report generation+description: Benchmark reporting application is not included in the overall+  cabal project so that the dependencies of both can remain independent.+  Benchmark reporting has a lot of dependencies that usually lag behind+  when new GHC releases arrive.++-------------------------------------------------------------------------------+-- benchmark comparison and presentation+-------------------------------------------------------------------------------++executable bench-report+  default-language: Haskell2010+  ghc-options: -Wall+  hs-source-dirs: .+  main-is: BenchReport.hs+  buildable: True+  build-Depends:+    base >= 4.9 && < 5+    , bench-show >= 0.3 && < 0.4+    , transformers >= 0.4  && < 0.6
+ benchmark/bench-report/cabal.project view
@@ -0,0 +1,1 @@+packages: .
+ benchmark/bench-report/default.nix view
@@ -0,0 +1,50 @@+{+  nixpkgs ?+    # nixpkgs 21.05 needs a revised version of bench-show and we do not+    # know how to use a revised version in nix.+    #import (builtins.fetchTarball https://github.com/NixOS/nixpkgs/archive/refs/tags/21.05.tar.gz)+    import (builtins.fetchTarball https://github.com/composewell/nixpkgs/archive/01dd2b4e738.tar.gz)+        {}+#, compiler ? "ghc884" # For nix 21.05+, compiler ? "default"+}:+let haskellPackages =+        if compiler == "default"+        then nixpkgs.haskellPackages+        else nixpkgs.haskell.packages.${compiler};++    mkPackage = super: pkg: path: opts: inShell:+                let orig = super.callCabal2nixWithOptions pkg path opts {};+                 in if inShell+                    # Avoid copying the source directory to nix store by using+                    # src = null.+                    then orig.overrideAttrs (oldAttrs: { src = null; })+                    else orig;++    mkHaskellPackages = inShell:+        haskellPackages.override {+            overrides = self: super:+                with nixpkgs.haskell.lib;+                {+                    bench-report = mkPackage super "bench-report" ./. "" inShell;+                };+        };++    drv = mkHaskellPackages true;++    shell = drv.shellFor {+        packages = p:+          [ p.bench-report+          ];+        # Use a better prompt+        shellHook = ''+          export CABAL_DIR="$(pwd)/.cabal.nix"+          if test -n "$PS_SHELL"+          then+            export PS1="$PS_SHELL\[$bldred\](nix)\[$txtrst\] "+          fi+        '';+    };+in if nixpkgs.lib.inNixShell+   then shell+   else (mkHaskellPackages false).streamly
benchmark/lib/Streamly/Benchmark/Common.hs view
@@ -11,8 +11,14 @@ -- Maintainer  : streamly@composewell.com  module Streamly.Benchmark.Common-    ( parseCLIOpts+    ( o_1_space_prefix+    , o_n_space_prefix+    , o_n_heap_prefix+    , o_n_stack_prefix +    , runWithCLIOptsEnv+    , runWithCLIOpts+     , benchIOSink1     , benchPure     , benchPureSink1@@ -26,28 +32,51 @@     , mkListString      , defaultStreamSize-    , limitStreamSize     ) where -import Control.DeepSeq (NFData(..))+#ifdef MIN_VERSION_gauge import Control.Exception (evaluate) import Control.Monad (when)-import Data.Functor.Identity (Identity, runIdentity)+import Text.Read (readMaybe) import Data.List (scanl')-import Data.Maybe (catMaybes)+import Data.Maybe (mapMaybe) import System.Console.GetOpt        (OptDescr(..), ArgDescr(..), ArgOrder(..), getOpt') import System.Environment (getArgs, lookupEnv, setEnv)-import Text.Read (readMaybe)+#else+import Data.Proxy (Proxy(..))+import Test.Tasty.Ingredients.Basic (includingOptions)+import Test.Tasty.Options+    (IsOption(..), OptionDescription(..), lookupOption, safeRead)+import Test.Tasty.Runners (Ingredient, defaultMainWithIngredients, parseOptions)+#endif+import Control.DeepSeq (NFData(..))+import Data.Functor.Identity (Identity, runIdentity) import System.Random (randomRIO)  import qualified Streamly.Prelude as S -import Streamly+import Streamly.Prelude (SerialT) import Gauge  -------------------------------------------------------------------------------+-- Benchmark Prefixes+-------------------------------------------------------------------------------++o_1_space_prefix :: String -> String+o_1_space_prefix name = name ++ "/o-1-space"++o_n_space_prefix :: String -> String+o_n_space_prefix name = name ++ "/o-n-space"++o_n_heap_prefix :: String -> String+o_n_heap_prefix name = name ++ "/o-n-heap"++o_n_stack_prefix :: String -> String+o_n_stack_prefix name = name ++ "/o-n-stack"++------------------------------------------------------------------------------- -- Benchmarking utilities ------------------------------------------------------------------------------- @@ -110,21 +139,13 @@ defaultStreamSize :: Int defaultStreamSize = 100000 -limitStreamSize :: Int -> IO Int-limitStreamSize value = do-    let val = min value defaultStreamSize-    when (val /= value) $-        putStrLn $ "Limiting stream size to "-                   ++ show defaultStreamSize-                   ++ " for non O(1) space operations"-    return val- ------------------------------------------------------------------------------- -- Parse custom CLI options ------------------------------------------------------------------------------- -data BenchOpts = StreamSize Int deriving Show+newtype BenchOpts = StreamSize Int deriving Show +#ifdef MIN_VERSION_gauge getStreamSize :: String -> Int getStreamSize size =     case (readMaybe size :: Maybe Int) of@@ -134,7 +155,7 @@ options :: [OptDescr BenchOpts] options =     [-      Option [] ["stream-size"] (ReqArg getSize "COUNT") "Stream element count"+        System.Console.GetOpt.Option [] ["stream-size"] (ReqArg getSize "COUNT") "Stream element count"     ]      where@@ -158,13 +179,13 @@ parseCLIOpts :: Int -> IO (Int, Config, [String]) parseCLIOpts defStreamSize = do     args <- getArgs-     -- Parse custom options     let (opts, _, _, errs) = getOpt' Permute options args     when (not $ null errs) $ error $ concat errs     (streamSize, args') <-         case opts of             StreamSize x : _ -> do+                putStrLn $ "Stream size: " ++ show x                 -- When using the gauge "--measure-with" option we need to make                 -- sure that we pass the stream size to child process forked by                 -- gauge. So we use this env var for that purpose.@@ -174,8 +195,7 @@                 -- correct order.                 newArgs <-                           evaluate-                        $ catMaybes-                        $ map snd+                        $ mapMaybe snd                         $ scanl' deleteOptArgs (Nothing, Nothing) args                 return (x, newArgs)             _ -> do@@ -184,7 +204,9 @@                     Just x -> do                         s <- evaluate $ getStreamSize x                         return (s, args)-                    Nothing -> return (defStreamSize, args)+                    Nothing -> do+                        setEnv "STREAM_SIZE" (show defStreamSize)+                        return (defStreamSize, args)      -- Parse gauge options     let config = defaultConfig@@ -194,3 +216,43 @@                 }     let (cfg, benches) = parseWith config args'     streamSize `seq` return (streamSize, cfg, benches)++#else+instance IsOption BenchOpts where+    defaultValue = StreamSize defaultStreamSize+    parseValue = fmap StreamSize . safeRead+    optionName = pure "stream-size"+    optionHelp = pure "Size of the stream to be used in benchmarks"++parseCLIOpts :: Int -> Benchmark -> IO (Int, [Ingredient])+parseCLIOpts defStreamSize benches = do+    let customOpts  = [Test.Tasty.Options.Option (Proxy :: Proxy BenchOpts)]+        ingredients = includingOptions customOpts : benchIngredients+    opts <- parseOptions ingredients benches -- (TestGroup "" [])+    let StreamSize size = lookupOption opts+    -- putStrLn $ "Stream size: " ++ show size+    if size == defaultStreamSize+    then return (defStreamSize, ingredients)+    else return (size, ingredients)+#endif++runWithCLIOptsEnv :: Int -> (Int -> IO a) -> (a -> Int -> [Benchmark]) -> IO ()+runWithCLIOptsEnv defStreamSize alloc mkBench = do++#ifdef MIN_VERSION_gauge+    (value, cfg, benches) <- parseCLIOpts defStreamSize+    r <- alloc value+    value `seq` runMode (mode cfg) cfg benches (mkBench r value)+#else+    (value, ingredients) <-+        parseCLIOpts defStreamSize $ bgroup "All" (mkBench undefined 0)+    r <- alloc value+    value `seq` defaultMainWithIngredients ingredients+        $ bgroup "All" (mkBench r value)+#endif++runWithCLIOpts :: Int -> (Int -> [Benchmark]) -> IO ()+runWithCLIOpts defStreamSize f =+    runWithCLIOptsEnv defStreamSize+        (const $ return undefined)+        (\_ v -> f v)
+ benchmark/lib/Streamly/Benchmark/Common/Handle.hs view
@@ -0,0 +1,217 @@+-- |+-- Module      : Streamly.Benchmark.Common.Handle+-- Copyright   : (c) 2019 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}++#ifdef __HADDOCK_VERSION__+#undef INSPECTION+#endif++#ifdef INSPECTION+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}+#endif++module Streamly.Benchmark.Common.Handle+    ( BenchEnv (..)+    , RefHandles (..)+    , scratchDir+    , inFileSmall+    , inFileBig+    , outfile+    , mkBench+    , mkBenchSmall+    , isSpace+    , isSp+    , mkHandleBenchEnv+    )+where++import Control.DeepSeq (NFData(rnf))+import Data.Char (ord, chr)+import Data.Word (Word8)+import System.Directory (getFileSize)+import System.Environment (lookupEnv)+import System.IO (openFile, IOMode(..), Handle, hClose, stderr, hPutStrLn)+import System.Process.Typed (shell, runProcess_)++import Data.IORef+import Prelude hiding (last, length)+import Gauge hiding (env)+++scratchDir :: String+scratchDir = "benchmark-tmp/"++outfile :: String+outfile = scratchDir ++ "out.txt"++inFileSmall :: String+inFileSmall = scratchDir ++ "in-10MB.txt"++inFileBig :: String+inFileBig = scratchDir ++ "in-100MB.txt"++data RefHandles = RefHandles+    { smallInH :: Handle+    , bigInH :: Handle+    , outputH :: Handle+    }++data Handles = Handles !Handle !Handle++instance NFData Handles where+    rnf _ = ()++data BenchEnv = BenchEnv+    { href :: IORef RefHandles+    , smallSize :: Int+    , bigSize :: Int+    , nullH :: Handle+    , smallInFile :: String+    , bigInFile :: String+    }++withScaling :: BenchEnv -> String -> String+withScaling env str =+    let factor = round (fromIntegral (bigSize env)+                    / (fromIntegral (smallSize env) :: Double)) :: Int+    in if factor == 1+       then str+       else str ++ " (1/" ++ show factor ++ ")"++getHandles :: BenchEnv -> (RefHandles -> Handles) -> IO Handles+getHandles env mkHandles = do+    r <- readIORef $ href env+    -- close old handles+    hClose $ smallInH r+    hClose $ bigInH r+    hClose $ outputH r++    -- reopen+    smallInHandle <- openFile (smallInFile env) ReadMode+    bigInHandle <- openFile (bigInFile env) ReadMode+    outHandle <- openFile outfile WriteMode++    let refHandles = RefHandles+            { smallInH = smallInHandle+            , bigInH = bigInHandle+            , outputH = outHandle+            }++    -- update+    writeIORef (href env) refHandles+    return $ mkHandles refHandles++mkBenchCommon ::+       NFData b+    => (RefHandles -> Handles)+    -> String+    -> BenchEnv+    -> (Handle -> Handle -> IO b)+    -> Benchmark+mkBenchCommon mkHandles name env action =+     bench name $ nfIO $ do+        -- XXX adds significant cpu time to the benchmarks+        -- tasty-bench should provide a better way to do this+        (Handles h1 h2) <- getHandles env mkHandles+        action h1 h2++mkBench ::+    NFData b => String -> BenchEnv -> (Handle -> Handle -> IO b) -> Benchmark+mkBench name env action = mkBenchCommon useBigH name env action++    where++    useBigH (RefHandles {bigInH = inh, outputH = outh}) = Handles inh outh++mkBenchSmall ::+    NFData b => String -> BenchEnv -> (Handle -> Handle -> IO b) -> Benchmark+mkBenchSmall name env action =+    mkBenchCommon useSmallH (withScaling env name) env action++    where++    useSmallH (RefHandles {smallInH = inh, outputH = outh}) = Handles inh outh++foreign import ccall unsafe "u_iswspace"+  iswspace :: Int -> Int++-- Code copied from base/Data.Char to INLINE it+{-# INLINE isSpace #-}+isSpace                 :: Char -> Bool+-- isSpace includes non-breaking space+-- The magic 0x377 isn't really that magical. As of 2014, all the codepoints+-- at or below 0x377 have been assigned, so we shouldn't have to worry about+-- any new spaces appearing below there. It would probably be best to+-- use branchless ||, but currently the eqLit transformation will undo that,+-- so we'll do it like this until there's a way around that.+isSpace c+  | uc <= 0x377 = uc == 32 || uc - 0x9 <= 4 || uc == 0xa0+  | otherwise = iswspace (ord c) /= 0+  where+    uc = fromIntegral (ord c) :: Word++{-# INLINE isSp #-}+isSp :: Word8 -> Bool+isSp = isSpace . chr . fromIntegral++smallFileSize :: Int+smallFileSize = 10 * 1024 * 1024++bigFileSize :: Int+bigFileSize = 100 * 1024 * 1024++mkHandleBenchEnv :: IO BenchEnv+mkHandleBenchEnv = do+    r <- lookupEnv "Benchmark_FileSystem_Handle_InputFile"+    (small, big) <-+        case r of+            Just inFileName -> return (inFileName, inFileName)+            Nothing -> do+                -- XXX will this work on windows/msys?+                let cmd infile size =+                        "mkdir -p " ++ scratchDir+                            ++ "; test -e " ++ infile+                            ++ " || { echo \"creating input file " ++ infile+                            ++ "\" && head -c " ++ show size+                            ++ " </dev/urandom >" ++ infile+                            ++ ";}"+                runProcess_ (shell (cmd inFileSmall smallFileSize))+                runProcess_ (shell (cmd inFileBig bigFileSize))+                return (inFileSmall, inFileBig)++    hPutStrLn stderr $ "Using small input file: " ++ small+    smallHandle <- openFile small ReadMode++    hPutStrLn stderr $ "Using big input file: " ++ big+    bigHandle <- openFile big ReadMode++    hPutStrLn stderr $ "Using output file: " ++ outfile+    outHandle <- openFile outfile WriteMode+    devNull <- openFile "/dev/null" WriteMode++    ssize <- fromIntegral <$> getFileSize small+    bsize <- fromIntegral <$> getFileSize big++    ref <- newIORef $ RefHandles+        { smallInH = smallHandle+        , bigInH = bigHandle+        , outputH = outHandle+        }++    let env = BenchEnv+            { href = ref+            , smallSize = ssize+            , bigSize = bsize+            , nullH = devNull+            , smallInFile = small+            , bigInFile = big+            }+    return env
benchmark/lib/Streamly/Benchmark/Prelude.hs view
@@ -1,2700 +1,543 @@ -- | -- Module      : Streamly.Benchmark.Prelude--- Copyright   : (c) 2018 Harendra Kumar------ License     : MIT--- Maintainer  : streamly@composewell.com--{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE RankNTypes #-}--#ifdef __HADDOCK_VERSION__-#undef INSPECTION-#endif--#ifdef INSPECTION-{-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}-#endif--module Streamly.Benchmark.Prelude-    -- TODO: export a single bench group for o_1_space_serial-    ( o_1_space_serial_pure-    , o_1_space_serial_foldable-    , o_1_space_serial_generation-    , o_1_space_serial_elimination-    , o_1_space_serial_foldMultiStream-    , o_1_space_serial_pipes-    , o_1_space_serial_pipesX4-    , o_1_space_serial_transformer-    , o_1_space_serial_transformation-    , o_1_space_serial_transformationX4-    , o_1_space_serial_filtering-    , o_1_space_serial_filteringX4-    , o_1_space_serial_joining-    , o_1_space_serial_concatFoldable-    , o_1_space_serial_concatSerial-    , o_1_space_serial_outerProductStreams-    , o_1_space_serial_mixed-    , o_1_space_serial_mixedX4--    , o_1_space_wSerial_transformation-    , o_1_space_wSerial_concatMap-    , o_1_space_wSerial_outerProduct--    , o_1_space_zipSerial_transformation--    , o_n_space_serial_toList-    , o_n_space_serial_outerProductStreams--    , o_n_space_wSerial_outerProductStreams--    , o_n_space_serial_traversable-    , o_n_space_serial_foldr--    , o_n_heap_serial_foldl-    , o_n_heap_serial_buffering--    , o_n_stack_serial_iterated--    , o_1_space_async_generation-    , o_1_space_async_concatFoldable-    , o_1_space_async_concatMap-    , o_1_space_async_transformation--    , o_1_space_wAsync_generation-    , o_1_space_wAsync_concatFoldable-    , o_1_space_wAsync_concatMap-    , o_1_space_wAsync_transformation--    , o_1_space_ahead_generation-    , o_1_space_ahead_concatFoldable-    , o_1_space_ahead_concatMap-    , o_1_space_ahead_transformation--    , o_1_space_async_zip--    -- TODO: rename to o_n_*-    , o_1_space_parallel_generation-    , o_1_space_parallel_concatFoldable-    , o_1_space_parallel_concatMap-    , o_1_space_parallel_transformation-    , o_1_space_parallel_outerProductStreams-    , o_n_space_parallel_outerProductStreams--    , o_1_space_async_avgRate--    , o_1_space_ahead_avgRate-    ) where--import Control.DeepSeq (NFData(..))-import Control.Monad (when)-import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad.State.Strict (StateT, get, put)-import Data.Functor.Identity (Identity, runIdentity)-import Data.IORef (newIORef, modifyIORef')-import GHC.Generics (Generic)-import System.Random (randomRIO)-import Prelude-       (Monad, String, Int, (+), ($), (.), return, even, (>), (<=), (==), (>=),-        subtract, undefined, Maybe(..), Bool, not, (>>=), curry,-        maxBound, div, IO, compare, Double, fromIntegral, Integer, (<$>),-        (<*>), flip, sqrt, round, (*), seq)-import qualified Prelude as P-import qualified Data.Foldable as F-import qualified GHC.Exts as GHC--#ifdef INSPECTION-import GHC.Types (SPEC(..))-import Test.Inspection--import qualified Streamly.Internal.Data.Stream.StreamD as D-#endif--import qualified Streamly as S hiding (runStream)-import qualified Streamly.Prelude  as S-import qualified Streamly.Internal.Prelude as Internal-import qualified Streamly.Internal.Data.Fold as FL-import qualified Streamly.Internal.Data.Unfold as UF-import qualified Streamly.Internal.Data.Pipe as Pipe-import qualified Streamly.Internal.Data.Stream.Parallel as Par-import Streamly.Internal.Data.Time.Units--import qualified Streamly.Internal.Prelude as IP--import qualified Streamly.Benchmark.Prelude.NestedOps as Nested--import Gauge-import Streamly hiding (runStream)-import Streamly.Benchmark.Common--type Stream m a = S.SerialT m a------------------------------------------------------------------------------------ Stream generation------------------------------------------------------------------------------------ enumerate--{-# INLINE sourceIntFromTo #-}-sourceIntFromTo :: (Monad m, S.IsStream t) => Int -> Int -> t m Int-sourceIntFromTo value n = S.enumerateFromTo n (n + value)--{-# INLINE sourceIntFromThenTo #-}-sourceIntFromThenTo :: (Monad m, S.IsStream t) => Int -> Int -> t m Int-sourceIntFromThenTo value n = S.enumerateFromThenTo n (n + 1) (n + value)--{-# INLINE sourceFracFromTo #-}-sourceFracFromTo :: (Monad m, S.IsStream t) => Int -> Int -> t m Double-sourceFracFromTo value n =-    S.enumerateFromTo (fromIntegral n) (fromIntegral (n + value))--{-# INLINE sourceFracFromThenTo #-}-sourceFracFromThenTo :: (Monad m, S.IsStream t) => Int -> Int -> t m Double-sourceFracFromThenTo value n = S.enumerateFromThenTo (fromIntegral n)-    (fromIntegral n + 1.0001) (fromIntegral (n + value))--{-# INLINE sourceIntegerFromStep #-}-sourceIntegerFromStep :: (Monad m, S.IsStream t) => Int -> Int -> t m Integer-sourceIntegerFromStep value n =-    S.take value $ S.enumerateFromThen (fromIntegral n) (fromIntegral n + 1)---- unfoldr--{-# INLINE sourceUnfoldr #-}-sourceUnfoldr :: (Monad m, S.IsStream t) => Int -> Int -> t m Int-sourceUnfoldr value n = S.unfoldr step n-    where-    step cnt =-        if cnt > n + value-        then Nothing-        else Just (cnt, cnt + 1)--{-# INLINE sourceUnfoldrN #-}-sourceUnfoldrN :: (Monad m, S.IsStream t) => Int -> Int -> t m Int-sourceUnfoldrN upto start = S.unfoldr step start-    where-    step cnt =-        if cnt > start + upto-        then Nothing-        else Just (cnt, cnt + 1)--{-# INLINE sourceUnfoldrM #-}-sourceUnfoldrM :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int-sourceUnfoldrM value n = S.unfoldrM step n-    where-    step cnt =-        if cnt > n + value-        then return Nothing-        else return (Just (cnt, cnt + 1))--{-# INLINE source #-}-source :: (S.MonadAsync m, S.IsStream t) => Int -> Int -> t m Int-source = sourceUnfoldrM--{-# INLINE sourceUnfoldrMN #-}-sourceUnfoldrMN :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int-sourceUnfoldrMN upto start = S.unfoldrM step start-    where-    step cnt =-        if cnt > start + upto-        then return Nothing-        else return (Just (cnt, cnt + 1))--{-# INLINE sourceUnfoldrMAction #-}-sourceUnfoldrMAction :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m (m Int)-sourceUnfoldrMAction value n = S.serially $ S.unfoldrM step n-    where-    step cnt =-        if cnt > n + value-        then return Nothing-        else return (Just (return cnt, cnt + 1))--{-# INLINE sourceUnfoldrAction #-}-sourceUnfoldrAction :: (S.IsStream t, Monad m, Monad m1)-    => Int -> Int -> t m (m1 Int)-sourceUnfoldrAction value n = S.serially $ S.unfoldr step n-    where-    step cnt =-        if cnt > n + value-        then Nothing-        else (Just (return cnt, cnt + 1))---- fromIndices--{-# INLINE _sourceFromIndices #-}-_sourceFromIndices :: (Monad m, S.IsStream t) => Int -> Int -> t m Int-_sourceFromIndices value n = S.take value $ S.fromIndices (+ n)--{-# INLINE _sourceFromIndicesM #-}-_sourceFromIndicesM :: (S.MonadAsync m, S.IsStream t) => Int -> Int -> t m Int-_sourceFromIndicesM value n = S.take value $ S.fromIndicesM (P.fmap return (+ n))---- fromList--{-# INLINE sourceFromList #-}-sourceFromList :: (Monad m, S.IsStream t) => Int -> Int -> t m Int-sourceFromList value n = S.fromList [n..n+value]--{-# INLINE sourceFromListM #-}-sourceFromListM :: (S.MonadAsync m, S.IsStream t) => Int -> Int -> t m Int-sourceFromListM value n = S.fromListM (P.fmap return [n..n+value])--{-# INLINE sourceIsList #-}-sourceIsList :: Int -> Int -> S.SerialT Identity Int-sourceIsList value n = GHC.fromList [n..n+value]--{-# INLINE sourceIsString #-}-sourceIsString :: Int -> Int -> S.SerialT Identity P.Char-sourceIsString value n = GHC.fromString (P.replicate (n + value) 'a')---- fromFoldable--{-# INLINE sourceFromFoldable #-}-sourceFromFoldable :: S.IsStream t => Int -> Int -> t m Int-sourceFromFoldable value n = S.fromFoldable [n..n+value]--{-# INLINE sourceFromFoldableM #-}-sourceFromFoldableM :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int-sourceFromFoldableM value n = S.fromFoldableM (P.fmap return [n..n+value])--{-# INLINE currentTime #-}-currentTime :: (S.IsStream t, S.MonadAsync m)-    => Int -> Double -> Int -> t m AbsTime-currentTime value g _ = S.take value $ Internal.currentTime g------------------------------------------------------------------------------------ Elimination----------------------------------------------------------------------------------{-# INLINE runStream #-}-runStream :: Monad m => Stream m a -> m ()-runStream = S.drain--{-# INLINE toNull #-}-toNull :: Monad m => (t m a -> S.SerialT m a) -> t m a -> m ()-toNull t = runStream . t--{-# INLINE uncons #-}-uncons :: Monad m => Stream m Int -> m ()-uncons s = do-    r <- S.uncons s-    case r of-        Nothing -> return ()-        Just (_, t) -> uncons t--{-# INLINE init #-}-init :: Monad m => Stream m a -> m ()-init s = S.init s >>= P.mapM_ S.drain--{-# INLINE tail #-}-tail :: Monad m => Stream m a -> m ()-tail s = S.tail s >>= P.mapM_ tail--{-# INLINE nullHeadTail #-}-nullHeadTail :: Monad m => Stream m Int -> m ()-nullHeadTail s = do-    r <- S.null s-    when (not r) $ do-        _ <- S.head s-        S.tail s >>= P.mapM_ nullHeadTail--{-# INLINE mapM_ #-}-mapM_ :: Monad m => Stream m Int -> m ()-mapM_ = S.mapM_ (\_ -> return ())--{-# INLINE toList #-}-toList :: Monad m => Stream m Int -> m [Int]-toList = S.toList--{-# INLINE toListRev #-}-toListRev :: Monad m => Stream m Int -> m [Int]-toListRev = Internal.toListRev--{-# INLINE foldrMElem #-}-foldrMElem :: Monad m => Int -> Stream m Int -> m Bool-foldrMElem e m =-    S.foldrM-        (\x xs ->-             if x == e-                 then return P.True-                 else xs)-        (return P.False)-        m--{-# INLINE foldrMToStream #-}-foldrMToStream :: Monad m => Stream m Int -> m (Stream Identity Int)-foldrMToStream = S.foldr S.cons S.nil--{-# INLINE foldrMBuild #-}-foldrMBuild :: Monad m => Stream m Int -> m [Int]-foldrMBuild = S.foldrM (\x xs -> xs >>= return . (x :)) (return [])--{-# INLINE foldl'Build #-}-foldl'Build :: Monad m => Stream m Int -> m [Int]-foldl'Build = S.foldl' (flip (:)) []--{-# INLINE foldlM'Build #-}-foldlM'Build :: Monad m => Stream m Int -> m [Int]-foldlM'Build = S.foldlM' (\xs x -> return $ x : xs) []--{-# INLINE foldrMReduce #-}-foldrMReduce :: Monad m => Stream m Int -> m Int-foldrMReduce = S.foldrM (\x xs -> xs >>= return . (x +)) (return 0)--{-# INLINE foldl'Reduce #-}-foldl'Reduce :: Monad m => Stream m Int -> m Int-foldl'Reduce = S.foldl' (+) 0--{-# INLINE foldl'ReduceMap #-}-foldl'ReduceMap :: Monad m => Stream m Int -> m Int-foldl'ReduceMap = P.fmap (+ 1) . S.foldl' (+) 0--{-# INLINE foldl1'Reduce #-}-foldl1'Reduce :: Monad m => Stream m Int -> m (Maybe Int)-foldl1'Reduce = S.foldl1' (+)--{-# INLINE foldlM'Reduce #-}-foldlM'Reduce :: Monad m => Stream m Int -> m Int-foldlM'Reduce = S.foldlM' (\xs a -> return $ a + xs) 0--{-# INLINE last #-}-last :: Monad m => Stream m Int -> m (Maybe Int)-last = S.last--{-# INLINE _null #-}-_null :: Monad m => Stream m Int -> m Bool-_null = S.null--{-# INLINE _head #-}-_head :: Monad m => Stream m Int -> m (Maybe Int)-_head = S.head--{-# INLINE elem #-}-elem :: Monad m => Int -> Stream m Int -> m Bool-elem value = S.elem (value + 1)--{-# INLINE notElem #-}-notElem :: Monad m => Int -> Stream m Int -> m Bool-notElem value = S.notElem (value + 1)--{-# INLINE length #-}-length :: Monad m => Stream m Int -> m Int-length = S.length--{-# INLINE all #-}-all :: Monad m => Int -> Stream m Int -> m Bool-all value = S.all (<= (value + 1))--{-# INLINE any #-}-any :: Monad m => Int -> Stream m Int -> m Bool-any value = S.any (> (value + 1))--{-# INLINE and #-}-and :: Monad m => Int -> Stream m Int -> m Bool-and value = S.and . S.map (<= (value + 1))--{-# INLINE or #-}-or :: Monad m => Int -> Stream m Int -> m Bool-or value = S.or . S.map (> (value + 1))--{-# INLINE find #-}-find :: Monad m => Int -> Stream m Int -> m (Maybe Int)-find value = S.find (== (value + 1))--{-# INLINE findIndex #-}-findIndex :: Monad m => Int -> Stream m Int -> m (Maybe Int)-findIndex value = S.findIndex (== (value + 1))--{-# INLINE elemIndex #-}-elemIndex :: Monad m => Int -> Stream m Int -> m (Maybe Int)-elemIndex value = S.elemIndex (value + 1)--{-# INLINE maximum #-}-maximum :: Monad m => Stream m Int -> m (Maybe Int)-maximum = S.maximum--{-# INLINE minimum #-}-minimum :: Monad m => Stream m Int -> m (Maybe Int)-minimum = S.minimum--{-# INLINE sum #-}-sum :: Monad m => Stream m Int -> m Int-sum = S.sum--{-# INLINE product #-}-product :: Monad m => Stream m Int -> m Int-product = S.product--{-# INLINE minimumBy #-}-minimumBy :: Monad m => Stream m Int -> m (Maybe Int)-minimumBy = S.minimumBy compare--{-# INLINE maximumBy #-}-maximumBy :: Monad m => Stream m Int -> m (Maybe Int)-maximumBy = S.maximumBy compare------------------------------------------------------------------------------------ Transformation----------------------------------------------------------------------------------{-# INLINE transform #-}-transform :: Monad m => Stream m a -> m ()-transform = runStream--{-# INLINE composeN #-}-composeN ::-       MonadIO m-    => Int-    -> (Stream m Int -> Stream m Int)-    -> Stream m Int-    -> m ()-composeN n f =-    case n of-        1 -> transform . f-        2 -> transform . f . f-        3 -> transform . f . f . f-        4 -> transform . f . f . f . f-        _ -> undefined---- polymorphic stream version of composeN-{-# INLINE composeN' #-}-composeN' ::-       (S.IsStream t, Monad m)-    => Int-    -> (t m Int -> Stream m Int)-    -> t m Int-    -> m ()-composeN' n f =-    case n of-        1 -> transform . f-        2 -> transform . f . S.adapt . f-        3 -> transform . f . S.adapt . f . S.adapt . f-        4 -> transform . f . S.adapt . f . S.adapt . f . S.adapt . f-        _ -> undefined--{-# INLINE scan #-}-scan :: MonadIO m => Int -> Stream m Int -> m ()-scan n = composeN n $ S.scanl' (+) 0--{-# INLINE scanl1' #-}-scanl1' :: MonadIO m => Int -> Stream m Int -> m ()-scanl1' n = composeN n $ S.scanl1' (+)--{-# INLINE fmap #-}-fmap :: MonadIO m => Int -> Stream m Int -> m ()-fmap n = composeN n $ P.fmap (+ 1)--{-# INLINE fmap' #-}-fmap' ::-       (S.IsStream t, S.MonadAsync m, P.Functor (t m))-    => (t m Int -> S.SerialT m Int)-    -> Int-    -> t m Int-    -> m ()-fmap' t n = composeN' n $ t . P.fmap (+ 1)--{-# INLINE map #-}-map :: MonadIO m => Int -> Stream m Int -> m ()-map n = composeN n $ S.map (+ 1)--{-# INLINE map' #-}-map' ::-       (S.IsStream t, S.MonadAsync m)-    => (t m Int -> S.SerialT m Int)-    -> Int-    -> t m Int-    -> m ()-map' t n = composeN' n $ t . S.map (+ 1)--{-# INLINE mapM #-}-mapM ::-       (S.IsStream t, S.MonadAsync m)-    => (t m Int -> S.SerialT m Int)-    -> Int-    -> t m Int-    -> m ()-mapM t n = composeN' n $ t . S.mapM return--{-# INLINE tap #-}-tap :: MonadIO m => Int -> Stream m Int -> m ()-tap n = composeN n $ S.tap FL.sum--{-# INLINE tapRate #-}-tapRate :: Int -> Stream IO Int -> IO ()-tapRate n str = do-    cref <- newIORef 0-    composeN n (Internal.tapRate 1 (\c -> modifyIORef' cref (c +))) str--{-# INLINE pollCounts #-}-pollCounts :: Int -> Stream IO Int -> IO ()-pollCounts n str = do-    composeN n (Internal.pollCounts (P.const P.True) f FL.drain) str-  where-    f = Internal.rollingMap (P.-) . Internal.delayPost 1--{-# INLINE tapAsyncS #-}-tapAsyncS :: S.MonadAsync m => Int -> Stream m Int -> m ()-tapAsyncS n = composeN n $ Par.tapAsync S.sum--{-# INLINE tapAsync #-}-tapAsync :: S.MonadAsync m => Int -> Stream m Int -> m ()-tapAsync n = composeN n $ Internal.tapAsync FL.sum--{-# INLINE mapMaybe #-}-mapMaybe :: MonadIO m => Int -> Stream m Int -> m ()-mapMaybe n =-    composeN n $-    S.mapMaybe-        (\x ->-             if P.odd x-                 then Nothing-                 else Just x)--{-# INLINE mapMaybeM #-}-mapMaybeM :: S.MonadAsync m => Int -> Stream m Int -> m ()-mapMaybeM n =-    composeN n $-    S.mapMaybeM-        (\x ->-             if P.odd x-                 then return Nothing-                 else return $ Just x)--{-# INLINE sequence #-}-sequence ::-       (S.IsStream t, S.MonadAsync m)-    => (t m Int -> S.SerialT m Int)-    -> t m (m Int)-    -> m ()-sequence t = transform . t . S.sequence--{-# INLINE filterEven #-}-filterEven :: MonadIO m => Int -> Stream m Int -> m ()-filterEven n = composeN n $ S.filter even--{-# INLINE filterAllOut #-}-filterAllOut :: MonadIO m => Int -> Int -> Stream m Int -> m ()-filterAllOut value n = composeN n $ S.filter (> (value + 1))--{-# INLINE filterAllIn #-}-filterAllIn :: MonadIO m => Int -> Int -> Stream m Int -> m ()-filterAllIn value n = composeN n $ S.filter (<= (value + 1))--{-# INLINE _takeOne #-}-_takeOne :: MonadIO m => Int -> Stream m Int -> m ()-_takeOne n = composeN n $ S.take 1--{-# INLINE takeAll #-}-takeAll :: MonadIO m => Int -> Int -> Stream m Int -> m ()-takeAll value n = composeN n $ S.take (value + 1)--{-# INLINE takeWhileTrue #-}-takeWhileTrue :: MonadIO m => Int -> Int -> Stream m Int -> m ()-takeWhileTrue value n = composeN n $ S.takeWhile (<= (value + 1))--{-# INLINE _takeWhileMTrue #-}-_takeWhileMTrue :: MonadIO m => Int -> Int -> Stream m Int -> m ()-_takeWhileMTrue value n = composeN n $ S.takeWhileM (return . (<= (value + 1)))--{-# INLINE dropOne #-}-dropOne :: MonadIO m => Int -> Stream m Int -> m ()-dropOne n = composeN n $ S.drop 1--{-# INLINE dropAll #-}-dropAll :: MonadIO m => Int -> Int -> Stream m Int -> m ()-dropAll value n = composeN n $ S.drop (value + 1)--{-# INLINE dropWhileTrue #-}-dropWhileTrue :: MonadIO m => Int -> Int -> Stream m Int -> m ()-dropWhileTrue value n = composeN n $ S.dropWhile (<= (value + 1))--{-# INLINE _dropWhileMTrue #-}-_dropWhileMTrue :: MonadIO m => Int -> Int -> Stream m Int -> m ()-_dropWhileMTrue value n = composeN n $ S.dropWhileM (return . (<= (value + 1)))--{-# INLINE dropWhileFalse #-}-dropWhileFalse :: MonadIO m => Int -> Int -> Stream m Int -> m ()-dropWhileFalse value n = composeN n $ S.dropWhile (> (value + 1))--{-# INLINE findIndices #-}-findIndices :: MonadIO m => Int -> Int -> Stream m Int -> m ()-findIndices value n = composeN n $ S.findIndices (== (value + 1))--{-# INLINE elemIndices #-}-elemIndices :: MonadIO m => Int -> Int -> Stream m Int -> m ()-elemIndices value n = composeN n $ S.elemIndices (value + 1)--{-# INLINE intersperse #-}-intersperse :: S.MonadAsync m => Int -> Int -> Stream m Int -> m ()-intersperse value n = composeN n $ S.intersperse (value + 1)--{-# INLINE insertBy #-}-insertBy :: MonadIO m => Int -> Int -> Stream m Int -> m ()-insertBy value n = composeN n $ S.insertBy compare (value + 1)--{-# INLINE deleteBy #-}-deleteBy :: MonadIO m => Int -> Int -> Stream m Int -> m ()-deleteBy value n = composeN n $ S.deleteBy (>=) (value + 1)--{-# INLINE reverse #-}-reverse :: MonadIO m => Int -> Stream m Int -> m ()-reverse n = composeN n $ S.reverse--{-# INLINE reverse' #-}-reverse' :: MonadIO m => Int -> Stream m Int -> m ()-reverse' n = composeN n $ Internal.reverse'--{-# INLINE foldrS #-}-foldrS :: MonadIO m => Int -> Stream m Int -> m ()-foldrS n = composeN n $ Internal.foldrS S.cons S.nil--{-# INLINE foldrSMap #-}-foldrSMap :: MonadIO m => Int -> Stream m Int -> m ()-foldrSMap n = composeN n $ Internal.foldrS (\x xs -> x + 1 `S.cons` xs) S.nil--{-# INLINE foldrT #-}-foldrT :: MonadIO m => Int -> Stream m Int -> m ()-foldrT n = composeN n $ Internal.foldrT S.cons S.nil--{-# INLINE foldrTMap #-}-foldrTMap :: MonadIO m => Int -> Stream m Int -> m ()-foldrTMap n = composeN n $ Internal.foldrT (\x xs -> x + 1 `S.cons` xs) S.nil--{-# INLINE takeByTime #-}-takeByTime :: NanoSecond64 -> Int -> Stream IO Int -> IO ()-takeByTime i n = composeN n (Internal.takeByTime i)--#ifdef INSPECTION--- inspect $ hasNoType 'takeByTime ''SPEC-inspect $ hasNoTypeClasses 'takeByTime--- inspect $ 'takeByTime `hasNoType` ''D.Step-#endif--{-# INLINE dropByTime #-}-dropByTime :: NanoSecond64 -> Int -> Stream IO Int -> IO ()-dropByTime i n = composeN n (Internal.dropByTime i)--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'dropByTime--- inspect $ 'dropByTime `hasNoType` ''D.Step-#endif------------------------------------------------------------------------------------ Pipes----------------------------------------------------------------------------------{-# INLINE transformMapM #-}-transformMapM ::-       (S.IsStream t, S.MonadAsync m)-    => (t m Int -> S.SerialT m Int)-    -> Int-    -> t m Int-    -> m ()-transformMapM t n = composeN' n $ t . Internal.transform (Pipe.mapM return)--{-# INLINE transformComposeMapM #-}-transformComposeMapM ::-       (S.IsStream t, S.MonadAsync m)-    => (t m Int -> S.SerialT m Int)-    -> Int-    -> t m Int-    -> m ()-transformComposeMapM t n =-    composeN' n $-    t .-    Internal.transform-        (Pipe.mapM (\x -> return (x + 1)) `Pipe.compose`-         Pipe.mapM (\x -> return (x + 2)))--{-# INLINE transformTeeMapM #-}-transformTeeMapM ::-       (S.IsStream t, S.MonadAsync m)-    => (t m Int -> S.SerialT m Int)-    -> Int-    -> t m Int-    -> m ()-transformTeeMapM t n =-    composeN' n $-    t .-    Internal.transform-        (Pipe.mapM (\x -> return (x + 1)) `Pipe.tee`-         Pipe.mapM (\x -> return (x + 2)))--{-# INLINE transformZipMapM #-}-transformZipMapM ::-       (S.IsStream t, S.MonadAsync m)-    => (t m Int -> S.SerialT m Int)-    -> Int-    -> t m Int-    -> m ()-transformZipMapM t n =-    composeN' n $-    t .-    Internal.transform-        (Pipe.zipWith-             (+)-             (Pipe.mapM (\x -> return (x + 1)))-             (Pipe.mapM (\x -> return (x + 2))))------------------------------------------------------------------------------------ Mixed Transformation----------------------------------------------------------------------------------{-# INLINE scanMap #-}-scanMap :: MonadIO m => Int -> Stream m Int -> m ()-scanMap n = composeN n $ S.map (subtract 1) . S.scanl' (+) 0--{-# INLINE dropMap #-}-dropMap :: MonadIO m => Int -> Stream m Int -> m ()-dropMap n = composeN n $ S.map (subtract 1) . S.drop 1--{-# INLINE dropScan #-}-dropScan :: MonadIO m => Int -> Stream m Int -> m ()-dropScan n = composeN n $ S.scanl' (+) 0 . S.drop 1--{-# INLINE takeDrop #-}-takeDrop :: MonadIO m => Int -> Int -> Stream m Int -> m ()-takeDrop value n = composeN n $ S.drop 1 . S.take (value + 1)--{-# INLINE takeScan #-}-takeScan :: MonadIO m => Int -> Int -> Stream m Int -> m ()-takeScan value n = composeN n $ S.scanl' (+) 0 . S.take (value + 1)--{-# INLINE takeMap #-}-takeMap :: MonadIO m => Int -> Int -> Stream m Int -> m ()-takeMap value n = composeN n $ S.map (subtract 1) . S.take (value + 1)--{-# INLINE filterDrop #-}-filterDrop :: MonadIO m => Int -> Int -> Stream m Int -> m ()-filterDrop value n = composeN n $ S.drop 1 . S.filter (<= (value + 1))--{-# INLINE filterTake #-}-filterTake :: MonadIO m => Int -> Int -> Stream m Int -> m ()-filterTake value n = composeN n $ S.take (value + 1) . S.filter (<= (value + 1))--{-# INLINE filterScan #-}-filterScan :: MonadIO m => Int -> Stream m Int -> m ()-filterScan n = composeN n $ S.scanl' (+) 0 . S.filter (<= maxBound)--{-# INLINE filterScanl1 #-}-filterScanl1 :: MonadIO m => Int -> Stream m Int -> m ()-filterScanl1 n = composeN n $ S.scanl1' (+) . S.filter (<= maxBound)--{-# INLINE filterMap #-}-filterMap :: MonadIO m => Int -> Int -> Stream m Int -> m ()-filterMap value n = composeN n $ S.map (subtract 1) . S.filter (<= (value + 1))------------------------------------------------------------------------------------ Scan and fold----------------------------------------------------------------------------------data Pair a b =-    Pair !a !b-    deriving (Generic, NFData)--{-# INLINE sumProductFold #-}-sumProductFold :: Monad m => Stream m Int -> m (Int, Int)-sumProductFold = S.foldl' (\(s, p) x -> (s + x, p P.* x)) (0, 1)--{-# INLINE sumProductScan #-}-sumProductScan :: Monad m => Stream m Int -> m (Pair Int Int)-sumProductScan =-    S.foldl' (\(Pair _ p) (s0, x) -> Pair s0 (p P.* x)) (Pair 0 1) .-    S.scanl' (\(s, _) x -> (s + x, x)) (0, 0)------------------------------------------------------------------------------------ Iteration----------------------------------------------------------------------------------{-# INLINE iterStreamLen #-}-iterStreamLen :: Int-iterStreamLen = 10--{-# INLINE maxIters #-}-maxIters :: Int-maxIters = 10000--{-# INLINE iterateSource #-}-iterateSource ::-       S.MonadAsync m-    => (Stream m Int -> Stream m Int)-    -> Int-    -> Int-    -> Stream m Int-iterateSource g i n = f i (sourceUnfoldrMN iterStreamLen n)-  where-    f (0 :: Int) m = g m-    f x m = g (f (x P.- 1) m)---- this is quadratic-{-# INLINE iterateScan #-}-iterateScan :: S.MonadAsync m => Int -> Stream m Int-iterateScan = iterateSource (S.scanl' (+) 0) (maxIters `div` 10)---- this is quadratic-{-# INLINE iterateScanl1 #-}-iterateScanl1 :: S.MonadAsync m => Int -> Stream m Int-iterateScanl1 = iterateSource (S.scanl1' (+)) (maxIters `div` 10)--{-# INLINE iterateMapM #-}-iterateMapM :: S.MonadAsync m => Int -> Stream m Int-iterateMapM = iterateSource (S.mapM return) maxIters--{-# INLINE iterateFilterEven #-}-iterateFilterEven :: S.MonadAsync m => Int -> Stream m Int-iterateFilterEven = iterateSource (S.filter even) maxIters--{-# INLINE iterateTakeAll #-}-iterateTakeAll :: S.MonadAsync m => Int -> Int -> Stream m Int-iterateTakeAll value = iterateSource (S.take (value + 1)) maxIters--{-# INLINE iterateDropOne #-}-iterateDropOne :: S.MonadAsync m => Int -> Stream m Int-iterateDropOne = iterateSource (S.drop 1) maxIters--{-# INLINE iterateDropWhileFalse #-}-iterateDropWhileFalse :: S.MonadAsync m => Int -> Int -> Stream m Int-iterateDropWhileFalse value =-    iterateSource (S.dropWhile (> (value + 1))) maxIters--{-# INLINE iterateDropWhileTrue #-}-iterateDropWhileTrue :: S.MonadAsync m => Int -> Int -> Stream m Int-iterateDropWhileTrue value =-    iterateSource (S.dropWhile (<= (value + 1))) maxIters------------------------------------------------------------------------------------ Combining streams-------------------------------------------------------------------------------------------------------------------------------------------------------------------- Appending----------------------------------------------------------------------------------{-# INLINE serial2 #-}-serial2 :: Int -> Int -> IO ()-serial2 count n =-    S.drain $ S.serial (sourceUnfoldrMN count n) (sourceUnfoldrMN count (n + 1))--{-# INLINE serial4 #-}-serial4 :: Int -> Int -> IO ()-serial4 count n =-    S.drain $-    S.serial-        ((S.serial (sourceUnfoldrMN count n) (sourceUnfoldrMN count (n + 1))))-        ((S.serial-              (sourceUnfoldrMN count (n + 2))-              (sourceUnfoldrMN count (n + 3))))--{-# INLINE append2 #-}-append2 :: Int -> Int -> IO ()-append2 count n =-    S.drain $-    Internal.append (sourceUnfoldrMN count n) (sourceUnfoldrMN count (n + 1))--{-# INLINE append4 #-}-append4 :: Int -> Int -> IO ()-append4 count n =-    S.drain $-    Internal.append-        ((Internal.append-              (sourceUnfoldrMN count n)-              (sourceUnfoldrMN count (n + 1))))-        ((Internal.append-              (sourceUnfoldrMN count (n + 2))-              (sourceUnfoldrMN count (n + 3))))--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'append2-inspect $ 'append2 `hasNoType` ''SPEC-inspect $ 'append2 `hasNoType` ''D.AppendState-#endif------------------------------------------------------------------------------------ Interleaving----------------------------------------------------------------------------------{-# INLINE wSerial2 #-}-wSerial2 :: Int -> Int -> IO ()-wSerial2 value n =-    S.drain $-    S.wSerial-        (sourceUnfoldrMN (value `div` 2) n)-        (sourceUnfoldrMN (value `div` 2) (n + 1))--{-# INLINE interleave2 #-}-interleave2 :: Int -> Int -> IO ()-interleave2 value n =-    S.drain $-    Internal.interleave-        (sourceUnfoldrMN (value `div` 2) n)-        (sourceUnfoldrMN (value `div` 2) (n + 1))--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'interleave2-inspect $ 'interleave2 `hasNoType` ''SPEC-inspect $ 'interleave2 `hasNoType` ''D.InterleaveState-#endif--{-# INLINE roundRobin2 #-}-roundRobin2 :: Int -> Int -> IO ()-roundRobin2 value n =-    S.drain $-    Internal.roundrobin-        (sourceUnfoldrMN (value `div` 2) n)-        (sourceUnfoldrMN (value `div` 2) (n + 1))--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'roundRobin2-inspect $ 'roundRobin2 `hasNoType` ''SPEC-inspect $ 'roundRobin2 `hasNoType` ''D.InterleaveState-#endif------------------------------------------------------------------------------------ Merging----------------------------------------------------------------------------------{-# INLINE mergeBy #-}-mergeBy :: Int -> Int -> IO ()-mergeBy count n =-    S.drain $-    S.mergeBy-        P.compare-        (sourceUnfoldrMN count n)-        (sourceUnfoldrMN count (n + 1))--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'mergeBy-inspect $ 'mergeBy `hasNoType` ''SPEC-inspect $ 'mergeBy `hasNoType` ''D.Step-#endif------------------------------------------------------------------------------------ Zipping----------------------------------------------------------------------------------{-# INLINE zip #-}-zip :: Int -> Int -> IO ()-zip count n =-    S.drain $-    S.zipWith (,) (sourceUnfoldrMN count n) (sourceUnfoldrMN count (n + 1))--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'zip-inspect $ 'zip `hasNoType` ''SPEC-inspect $ 'zip `hasNoType` ''D.Step-#endif--{-# INLINE zipM #-}-zipM :: Int -> Int -> IO ()-zipM count n =-    S.drain $-    S.zipWithM-        (curry return)-        (sourceUnfoldrMN count n)-        (sourceUnfoldrMN count (n + 1))--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'zipM-inspect $ 'zipM `hasNoType` ''SPEC-inspect $ 'zipM `hasNoType` ''D.Step-#endif--{-# INLINE zipAsync #-}-zipAsync :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m (Int, Int)-zipAsync count n = do-    S.zipAsyncWith (,) (sourceUnfoldrMN count n) (sourceUnfoldrMN count (n + 1))--{-# INLINE zipAsyncM #-}-zipAsyncM :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m (Int, Int)-zipAsyncM count n = do-    S.zipAsyncWithM-        (curry return)-        (sourceUnfoldrMN count n)-        (sourceUnfoldrMN count (n + 1))--{-# INLINE zipAsyncAp #-}-zipAsyncAp :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m (Int, Int)-zipAsyncAp count n = do-    S.zipAsyncly $-        (,) <$> (sourceUnfoldrMN count n) <*> (sourceUnfoldrMN count (n + 1))--{-# INLINE mergeAsyncByM #-}-mergeAsyncByM :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int-mergeAsyncByM count n = do-    S.mergeAsyncByM-        (\a b -> return (a `compare` b))-        (sourceUnfoldrMN count n)-        (sourceUnfoldrMN count (n + 1))--{-# INLINE mergeAsyncBy #-}-mergeAsyncBy :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int-mergeAsyncBy count n = do-    S.mergeAsyncBy-        compare-        (sourceUnfoldrMN count n)-        (sourceUnfoldrMN count (n + 1))------------------------------------------------------------------------------------ Multi-stream folds----------------------------------------------------------------------------------{-# INLINE isPrefixOf #-}-isPrefixOf :: Monad m => Stream m Int -> m Bool-isPrefixOf src = S.isPrefixOf src src--{-# INLINE isSubsequenceOf #-}-isSubsequenceOf :: Monad m => Stream m Int -> m Bool-isSubsequenceOf src = S.isSubsequenceOf src src--{-# INLINE stripPrefix #-}-stripPrefix :: Monad m => Stream m Int -> m ()-stripPrefix src = do-    _ <- S.stripPrefix src src-    return ()--{-# INLINE eqBy' #-}-eqBy' :: (Monad m, P.Eq a) => Stream m a -> m P.Bool-eqBy' src = S.eqBy (==) src src--{-# INLINE eqBy #-}-eqBy :: Int -> Int -> IO Bool-eqBy value n = eqBy' (source value n)--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'eqBy-inspect $ 'eqBy `hasNoType` ''SPEC-inspect $ 'eqBy `hasNoType` ''D.Step-#endif---{-# INLINE eqByPure #-}-eqByPure :: Int -> Int -> Identity Bool-eqByPure value n = eqBy' (sourceUnfoldr value n)--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'eqByPure-inspect $ 'eqByPure `hasNoType` ''SPEC-inspect $ 'eqByPure `hasNoType` ''D.Step-#endif--{-# INLINE cmpBy' #-}-cmpBy' :: (Monad m, P.Ord a) => Stream m a -> m P.Ordering-cmpBy' src = S.cmpBy P.compare src src--{-# INLINE cmpBy #-}-cmpBy :: Int -> Int -> IO P.Ordering-cmpBy value n = cmpBy' (source value n)--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'cmpBy-inspect $ 'cmpBy `hasNoType` ''SPEC-inspect $ 'cmpBy `hasNoType` ''D.Step-#endif--{-# INLINE cmpByPure #-}-cmpByPure :: Int -> Int -> Identity P.Ordering-cmpByPure value n = cmpBy' (sourceUnfoldr value n)--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'cmpByPure-inspect $ 'cmpByPure `hasNoType` ''SPEC-inspect $ 'cmpByPure `hasNoType` ''D.Step-#endif------------------------------------------------------------------------------------ Streams of streams------------------------------------------------------------------------------------ Special cases of concatMap--{-# INLINE sourceFoldMapWith #-}-sourceFoldMapWith :: (S.IsStream t, S.Semigroup (t m Int))-                  => Int -> Int -> t m Int-sourceFoldMapWith value n = S.foldMapWith (S.<>) S.yield [n..n+value]--{-# INLINE sourceFoldMapWithM #-}-sourceFoldMapWithM :: (S.IsStream t, Monad m, S.Semigroup (t m Int))-                   => Int -> Int -> t m Int-sourceFoldMapWithM value n = S.foldMapWith (S.<>) (S.yieldM . return) [n..n+value]--{-# INLINE sourceFoldMapM #-}-sourceFoldMapM :: (S.IsStream t, Monad m, P.Monoid (t m Int))-               => Int -> Int -> t m Int-sourceFoldMapM value n = F.foldMap (S.yieldM . return) [n..n+value]--{-# INLINE sourceConcatMapId #-}-sourceConcatMapId :: (S.IsStream t, Monad m)-                  => Int -> Int -> t m Int-sourceConcatMapId value n =-    S.concatMap P.id $ S.fromFoldable $ P.map (S.yieldM . return) [n..n+value]---- concatMap unfoldrM/unfoldrM--{-# INLINE concatMap #-}-concatMap :: Int -> Int -> Int -> IO ()-concatMap outer inner n =-    S.drain $ S.concatMap-        (\_ -> sourceUnfoldrMN inner n)-        (sourceUnfoldrMN outer n)--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'concatMap-inspect $ 'concatMap `hasNoType` ''SPEC-#endif---- concatMap unfoldr/unfoldr--{-# INLINE concatMapPure #-}-concatMapPure :: Int -> Int -> Int -> IO ()-concatMapPure outer inner n =-    S.drain $ S.concatMap-        (\_ -> sourceUnfoldrN inner n)-        (sourceUnfoldrN outer n)--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'concatMapPure-inspect $ 'concatMapPure `hasNoType` ''SPEC-#endif---- concatMap replicate/unfoldrM--{-# INLINE concatMapRepl4xN #-}-concatMapRepl4xN :: Int -> Int -> IO ()-concatMapRepl4xN value n = S.drain $ S.concatMap (S.replicate 4)-                          (sourceUnfoldrMN (value `div` 4) n)--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'concatMapRepl4xN-inspect $ 'concatMapRepl4xN `hasNoType` ''SPEC-#endif---- concatMapWith--{-# INLINE concatStreamsWith #-}-concatStreamsWith-    :: (forall c. S.SerialT IO c -> S.SerialT IO c -> S.SerialT IO c)-    -> Int-    -> Int-    -> Int-    -> IO ()-concatStreamsWith op outer inner n =-    S.drain $ S.concatMapWith op-        (\i -> sourceUnfoldrMN inner i)-        (sourceUnfoldrMN outer n)--{-# INLINE concatMapWithSerial #-}-concatMapWithSerial :: Int -> Int -> Int -> IO ()-concatMapWithSerial = concatStreamsWith S.serial--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'concatMapWithSerial-inspect $ 'concatMapWithSerial `hasNoType` ''SPEC-#endif--{-# INLINE concatMapWithAppend #-}-concatMapWithAppend :: Int -> Int -> Int -> IO ()-concatMapWithAppend = concatStreamsWith Internal.append--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'concatMapWithAppend-inspect $ 'concatMapWithAppend `hasNoType` ''SPEC-#endif--{-# INLINE concatMapWithWSerial #-}-concatMapWithWSerial :: Int -> Int -> Int -> IO ()-concatMapWithWSerial = concatStreamsWith S.wSerial--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'concatMapWithWSerial-inspect $ 'concatMapWithSerial `hasNoType` ''SPEC-#endif---- concatUnfold---- concatUnfold replicate/unfoldrM--{-# INLINE concatUnfoldRepl4xN #-}-concatUnfoldRepl4xN :: Int -> Int -> IO ()-concatUnfoldRepl4xN value n =-    S.drain $ S.concatUnfold-        (UF.replicateM 4)-        (sourceUnfoldrMN (value `div` 4) n)--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'concatUnfoldRepl4xN-inspect $ 'concatUnfoldRepl4xN `hasNoType` ''D.ConcatMapUState-inspect $ 'concatUnfoldRepl4xN `hasNoType` ''SPEC-#endif--{-# INLINE concatUnfoldInterleaveRepl4xN #-}-concatUnfoldInterleaveRepl4xN :: Int -> Int -> IO ()-concatUnfoldInterleaveRepl4xN value n =-    S.drain $ Internal.concatUnfoldInterleave-        (UF.replicateM 4)-        (sourceUnfoldrMN (value `div` 4) n)--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'concatUnfoldInterleaveRepl4xN--- inspect $ 'concatUnfoldInterleaveRepl4xN `hasNoType` ''SPEC--- inspect $ 'concatUnfoldInterleaveRepl4xN `hasNoType` ''D.ConcatUnfoldInterleaveState-#endif--{-# INLINE concatUnfoldRoundrobinRepl4xN #-}-concatUnfoldRoundrobinRepl4xN :: Int -> Int -> IO ()-concatUnfoldRoundrobinRepl4xN value n =-    S.drain $ Internal.concatUnfoldRoundrobin-        (UF.replicateM 4)-        (sourceUnfoldrMN (value `div` 4) n)--#ifdef INSPECTION-inspect $ hasNoTypeClasses 'concatUnfoldRoundrobinRepl4xN--- inspect $ 'concatUnfoldRoundrobinRepl4xN `hasNoType` ''SPEC--- inspect $ 'concatUnfoldRoundrobinRepl4xN `hasNoType` ''D.ConcatUnfoldInterleaveState-#endif------------------------------------------------------------------------------------ Monad transformation (hoisting etc.)----------------------------------------------------------------------------------{-# INLINE sourceUnfoldrState #-}-sourceUnfoldrState :: (S.IsStream t, S.MonadAsync m)-                   => Int -> Int -> t (StateT Int m) Int-sourceUnfoldrState value n = S.unfoldrM step n-    where-    step cnt =-        if cnt > n + value-        then return Nothing-        else do-            s <- get-            put (s + 1)-            return (Just (s, cnt + 1))--{-# INLINE evalStateT #-}-evalStateT :: S.MonadAsync m => Int -> Int -> Stream m Int-evalStateT value n = Internal.evalStateT 0 (sourceUnfoldrState value n)--{-# INLINE withState #-}-withState :: S.MonadAsync m => Int -> Int -> Stream m Int-withState value n =-    Internal.evalStateT (0 :: Int) (Internal.liftInner (sourceUnfoldrM value n))------------------------------------------------------------------------------------ Concurrent application/fold----------------------------------------------------------------------------------{-# INLINE parAppMap #-}-parAppMap :: S.MonadAsync m => Stream m Int -> m ()-parAppMap src = S.drain $ S.map (+1) S.|$ src--{-# INLINE parAppSum #-}-parAppSum :: S.MonadAsync m => Stream m Int -> m ()-parAppSum src = (S.sum S.|$. src) >>= \x -> P.seq x (return ())------------------------------------------------------------------------------------ Type class instances----------------------------------------------------------------------------------{-# INLINE eqInstance #-}-eqInstance :: Stream Identity Int -> Bool-eqInstance src = src == src--{-# INLINE eqInstanceNotEq #-}-eqInstanceNotEq :: Stream Identity Int -> Bool-eqInstanceNotEq src = src P./= src--{-# INLINE ordInstance #-}-ordInstance :: Stream Identity Int -> Bool-ordInstance src = src P.< src--{-# INLINE ordInstanceMin #-}-ordInstanceMin :: Stream Identity Int -> Stream Identity Int-ordInstanceMin src = P.min src src--{-# INLINE showInstance #-}-showInstance :: Stream Identity Int -> P.String-showInstance src = P.show src--{-# INLINE showInstanceList #-}-showInstanceList :: [Int] -> P.String-showInstanceList src = P.show src--{-# INLINE readInstance #-}-readInstance :: P.String -> Stream Identity Int-readInstance str =-    let r = P.reads str-    in case r of-        [(x,"")] -> x-        _ -> P.error "readInstance: no parse"--{-# INLINE readInstanceList #-}-readInstanceList :: P.String -> [Int]-readInstanceList str =-    let r = P.reads str-    in case r of-        [(x,"")] -> x-        _ -> P.error "readInstance: no parse"------------------------------------------------------------------------------------ Pure (Identity) streams----------------------------------------------------------------------------------{-# INLINE pureFoldl' #-}-pureFoldl' :: Stream Identity Int -> Int-pureFoldl' = runIdentity . S.foldl' (+) 0------------------------------------------------------------------------------------ Foldable Instance----------------------------------------------------------------------------------{-# INLINE foldableFoldl' #-}-foldableFoldl' :: Int -> Int -> Int-foldableFoldl' value n =-    F.foldl' (+) 0 (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableFoldrElem #-}-foldableFoldrElem :: Int -> Int -> Bool-foldableFoldrElem value n =-    F.foldr (\x xs -> if x == value then P.True else xs)-            (P.False)-            (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableSum #-}-foldableSum :: Int -> Int -> Int-foldableSum value n =-    P.sum (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableProduct #-}-foldableProduct :: Int -> Int -> Int-foldableProduct value n =-    P.product (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE _foldableNull #-}-_foldableNull :: Int -> Int -> Bool-_foldableNull value n =-    P.null (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableElem #-}-foldableElem :: Int -> Int -> Bool-foldableElem value n =-    P.elem value (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableNotElem #-}-foldableNotElem :: Int -> Int -> Bool-foldableNotElem value n =-    P.notElem value (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableFind #-}-foldableFind :: Int -> Int -> Maybe Int-foldableFind value n =-    F.find (== (value + 1)) (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableAll #-}-foldableAll :: Int -> Int -> Bool-foldableAll value n =-    P.all (<= (value + 1)) (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableAny #-}-foldableAny :: Int -> Int -> Bool-foldableAny value n =-    P.any (> (value + 1)) (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableAnd #-}-foldableAnd :: Int -> Int -> Bool-foldableAnd value n =-    P.and $ S.map (<= (value + 1)) (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableOr #-}-foldableOr :: Int -> Int -> Bool-foldableOr value n =-    P.or $ S.map (> (value + 1)) (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableLength #-}-foldableLength :: Int -> Int -> Int-foldableLength value n =-    P.length (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableMin #-}-foldableMin :: Int -> Int -> Int-foldableMin value n =-    P.minimum (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableMax #-}-foldableMax :: Int -> Int -> Int-foldableMax value n =-    P.maximum (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableMinBy #-}-foldableMinBy :: Int -> Int -> Int-foldableMinBy value n =-    F.minimumBy compare (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableListMinBy #-}-foldableListMinBy :: Int -> Int -> Int-foldableListMinBy value n = F.minimumBy compare [1..value+n]--{-# INLINE foldableMaxBy #-}-foldableMaxBy :: Int -> Int -> Int-foldableMaxBy value n =-    F.maximumBy compare (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableToList #-}-foldableToList :: Int -> Int -> [Int]-foldableToList value n =-    F.toList (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableMapM_ #-}-foldableMapM_ :: Monad m => Int -> Int -> m ()-foldableMapM_ value n =-    F.mapM_ (\_ -> return ()) (sourceUnfoldr value n :: S.SerialT Identity Int)--{-# INLINE foldableSequence_ #-}-foldableSequence_ :: Int -> Int -> IO ()-foldableSequence_ value n =-    F.sequence_ (sourceUnfoldrAction value n :: S.SerialT Identity (IO Int))--{-# INLINE _foldableMsum #-}-_foldableMsum :: Int -> Int -> IO Int-_foldableMsum value n =-    F.msum (sourceUnfoldrAction value n :: S.SerialT Identity (IO Int))------------------------------------------------------------------------------------ Traversable Instance----------------------------------------------------------------------------------{-# INLINE traversableTraverse #-}-traversableTraverse :: Stream Identity Int -> IO (Stream Identity Int)-traversableTraverse = P.traverse return--{-# INLINE traversableSequenceA #-}-traversableSequenceA :: Stream Identity Int -> IO (Stream Identity Int)-traversableSequenceA = P.sequenceA . P.fmap return--{-# INLINE traversableMapM #-}-traversableMapM :: Stream Identity Int -> IO (Stream Identity Int)-traversableMapM = P.mapM return--{-# INLINE traversableSequence #-}-traversableSequence :: Stream Identity Int -> IO (Stream Identity Int)-traversableSequence = P.sequence . P.fmap return------------------------------------------------------------------------------------ Benchmark groups------------------------------------------------------------------------------------ We need a monadic bind here to make sure that the function f does not get--- completely optimized out by the compiler in some cases.---- | Takes a fold method, and uses it with a default source.-{-# INLINE benchIOSink #-}-benchIOSink-    :: (IsStream t, NFData b)-    => Int -> String -> (t IO Int -> IO b) -> Benchmark-benchIOSink value name f = bench name $ nfIO $ randomRIO (1,1) >>= f . source value--{-# INLINE benchHoistSink #-}-benchHoistSink-    :: (IsStream t, NFData b)-    => Int -> String -> (t Identity Int -> IO b) -> Benchmark-benchHoistSink value name f =-    bench name $ nfIO $ randomRIO (1,1) >>= f .  sourceUnfoldr value---- XXX We should be using sourceUnfoldrM for fair comparison with IO monad, but--- we can't use it as it requires MonadAsync constraint.-{-# INLINE benchIdentitySink #-}-benchIdentitySink-    :: (IsStream t, NFData b)-    => Int -> String -> (t Identity Int -> Identity b) -> Benchmark-benchIdentitySink value name f = bench name $ nf (f . sourceUnfoldr value) 1---- | Takes a source, and uses it with a default drain/fold method.-{-# INLINE benchIOSrc #-}-benchIOSrc-    :: (t IO a -> SerialT IO a)-    -> String-    -> (Int -> t IO a)-    -> Benchmark-benchIOSrc t name f =-    bench name $ nfIO $ randomRIO (1,1) >>= toNull t . f--{-# INLINE benchPureSink #-}-benchPureSink :: NFData b => Int -> String -> (SerialT Identity Int -> b) -> Benchmark-benchPureSink value name f = benchPure name (sourceUnfoldr value) f--{-# INLINE benchPureSinkIO #-}-benchPureSinkIO-    :: NFData b-    => Int -> String -> (SerialT Identity Int -> IO b) -> Benchmark-benchPureSinkIO value name f =-    bench name $ nfIO $ randomRIO (1, 1) >>= f . sourceUnfoldr value--{-# INLINE benchIO #-}-benchIO :: (NFData b) => String -> (Int -> IO b) -> Benchmark-benchIO name f = bench name $ nfIO $ randomRIO (1,1) >>= f---- | Takes a source, and uses it with a default drain/fold method.-{-# INLINE benchSrcIO #-}-benchSrcIO-    :: (t IO a -> SerialT IO a)-    -> String-    -> (Int -> t IO a)-    -> Benchmark-benchSrcIO t name f-    = bench name $ nfIO $ randomRIO (1,1) >>= toNull t . f--{-# INLINE benchMonadicSrcIO #-}-benchMonadicSrcIO :: String -> (Int -> IO ()) -> Benchmark-benchMonadicSrcIO name f = bench name $ nfIO $ randomRIO (1,1) >>= f------------------------------------------------------------------------------------- Serial : O(1) Space----------------------------------------------------------------------------------o_1_space_serial_pure :: Int -> [Benchmark]-o_1_space_serial_pure value =-    [ bgroup-          "serially"-          [ bgroup-                "pure"-                [ benchPureSink value "id" P.id-                , benchPureSink1 "eqBy" (eqByPure value)-                , benchPureSink value "==" eqInstance-                , benchPureSink value "/=" eqInstanceNotEq-                , benchPureSink1 "cmpBy" (cmpByPure value)-                , benchPureSink value "<" ordInstance-                , benchPureSink value "min" ordInstanceMin-                , benchPureSrc "IsList.fromList" (sourceIsList value)-            -- length is used to check for foldr/build fusion-                , benchPureSink-                      value-                      "length . IsList.toList"-                      (P.length . GHC.toList)-                , benchPureSrc "IsString.fromString" (sourceIsString value)-                , benchPureSink value "showsPrec pure streams" showInstance-                , benchPureSink value "foldl'" pureFoldl'-                ]-          ]-    ]--o_1_space_serial_foldable :: Int -> [Benchmark]-o_1_space_serial_foldable value =-    [ bgroup-          "serially"-          [ bgroup-                "foldable"-              -- Foldable instance-              -- type class operations-                [ bench "foldl'" $ nf (foldableFoldl' value) 1-                , bench "foldrElem" $ nf (foldableFoldrElem value) 1-            -- , bench "null" $ nf (_foldableNull value) 1-                , bench "elem" $ nf (foldableElem value) 1-                , bench "length" $ nf (foldableLength value) 1-                , bench "sum" $ nf (foldableSum value) 1-                , bench "product" $ nf (foldableProduct value) 1-                , bench "minimum" $ nf (foldableMin value) 1-                , bench "maximum" $ nf (foldableMax value) 1-                , bench "length . toList" $-                  nf (P.length . foldableToList value) 1-            -- folds-                , bench "notElem" $ nf (foldableNotElem value) 1-                , bench "find" $ nf (foldableFind value) 1-                , bench "all" $ nf (foldableAll value) 1-                , bench "any" $ nf (foldableAny value) 1-                , bench "and" $ nf (foldableAnd value) 1-                , bench "or" $ nf (foldableOr value) 1-            -- Note: minimumBy/maximumBy do not work in constant memory they are in-            -- the O(n) group of benchmarks down below in this file.-            -- Applicative and Traversable operations-            -- TBD: traverse_-                , benchIOSink1 "mapM_" (foldableMapM_ value)-            -- TBD: for_-            -- TBD: forM_-                , benchIOSink1 "sequence_" (foldableSequence_ value)-            -- TBD: sequenceA_-            -- TBD: asum-            -- , benchIOSink1 "msum" (_foldableMsum value)-                ]-          ]-    ]--o_1_space_serial_generation :: Int -> [Benchmark]-o_1_space_serial_generation value =-    [ bgroup-          "serially"-          [ bgroup-                "generation"-              -- Most basic, barely stream continuations running-                [ benchIOSrc serially "unfoldr" (sourceUnfoldr value)-                , benchIOSrc serially "unfoldrM" (sourceUnfoldrM value)-                , benchIOSrc serially "intFromTo" (sourceIntFromTo value)-                , benchIOSrc-                      serially-                      "intFromThenTo"-                      (sourceIntFromThenTo value)-                , benchIOSrc-                      serially-                      "integerFromStep"-                      (sourceIntegerFromStep value)-                , benchIOSrc-                      serially-                      "fracFromThenTo"-                      (sourceFracFromThenTo value)-                , benchIOSrc serially "fracFromTo" (sourceFracFromTo value)-                , benchIOSrc serially "fromList" (sourceFromList value)-                , benchIOSrc serially "fromListM" (sourceFromListM value)-            -- These are essentially cons and consM-                , benchIOSrc-                      serially-                      "fromFoldable"-                      (sourceFromFoldable value)-                , benchIOSrc-                      serially-                      "fromFoldableM"-                      (sourceFromFoldableM value)-                , benchIOSrc serially "currentTime/0.00001s" $-                  currentTime value 0.00001-                ]-          ]-    ]--o_1_space_serial_elimination :: Int -> [Benchmark]-o_1_space_serial_elimination value =-    [ bgroup-          "serially"-          [ bgroup-                "elimination"-                [ bgroup-                      "reduce"-                      [ bgroup-                            "IO"-                            [ benchIOSink value "foldl'" foldl'Reduce-                            , benchIOSink value "foldl1'" foldl1'Reduce-                            , benchIOSink value "foldlM'" foldlM'Reduce-                            ]-                      , bgroup-                            "Identity"-                            [ benchIdentitySink value "foldl'" foldl'Reduce-                            , benchIdentitySink-                                  value-                                  "foldl1'"-                                  foldl1'Reduce-                            , benchIdentitySink-                                  value-                                  "foldlM'"-                                  foldlM'Reduce-                            ]-                      ]-                , bgroup-                      "build"-                      [ bgroup-                            "IO"-                            [ benchIOSink-                                  value-                                  "foldrMElem"-                                  (foldrMElem value)-                            ]-                      , bgroup-                            "Identity"-                            [ benchIdentitySink-                                  value-                                  "foldrMElem"-                                  (foldrMElem value)-                            , benchIdentitySink-                                  value-                                  "foldrMToStreamLength"-                                  (S.length . runIdentity . foldrMToStream)-                            , benchPureSink-                                  value-                                  "foldrMToListLength"-                                  (P.length . runIdentity . foldrMBuild)-                            ]-                      ]-                , benchIOSink value "uncons" uncons-                , benchIOSink value "toNull" $ toNull serially-                , benchIOSink value "mapM_" mapM_-                , benchIOSink value "init" init-            -- this is too low and causes all benchmarks reported in ns-            -- , benchIOSink value "head" head-                , benchIOSink value "last" last-            -- , benchIOSink value "lookup" lookup-                , benchIOSink value "find" (find value)-                , benchIOSink value "findIndex" (findIndex value)-                , benchIOSink value "elemIndex" (elemIndex value)-            -- this is too low and causes all benchmarks reported in ns-            -- , benchIOSink value "null" null-                , benchIOSink value "elem" (elem value)-                , benchIOSink value "notElem" (notElem value)-                , benchIOSink value "all" (all value)-                , benchIOSink value "any" (any value)-                , benchIOSink value "and" (and value)-                , benchIOSink value "or" (or value)-                , benchIOSink value "length" length-                , benchHoistSink-                      value-                      "length . generally"-                      (length . IP.generally)-                , benchIOSink value "sum" sum-                , benchIOSink value "product" product-                , benchIOSink value "maximumBy" maximumBy-                , benchIOSink value "maximum" maximum-                , benchIOSink value "minimumBy" minimumBy-                , benchIOSink value "minimum" minimum-                ]-          ]-    ]--o_1_space_serial_foldMultiStream :: Int -> [Benchmark]-o_1_space_serial_foldMultiStream value =-    [ bgroup-          "serially"-          [ bgroup-                "fold-multi-stream"-                [ benchIOSink1 "eqBy" (eqBy value)-                , benchIOSink1 "cmpBy" (cmpBy value)-                , benchIOSink value "isPrefixOf" isPrefixOf-                , benchIOSink value "isSubsequenceOf" isSubsequenceOf-                , benchIOSink value "stripPrefix" stripPrefix-                ]-          ]-    ]--o_1_space_serial_pipes :: Int -> [Benchmark]-o_1_space_serial_pipes value =-    [ bgroup-          "serially"-          [ bgroup-                "pipes"-                [ benchIOSink value "mapM" (transformMapM serially 1)-                , benchIOSink-                      value-                      "compose"-                      (transformComposeMapM serially 1)-                , benchIOSink value "tee" (transformTeeMapM serially 1)-                , benchIOSink value "zip" (transformZipMapM serially 1)-                ]-          ]-    ]--o_1_space_serial_pipesX4 :: Int -> [Benchmark]-o_1_space_serial_pipesX4 value =-    [ bgroup-          "serially"-          [ bgroup-                "pipesX4"-                [ benchIOSink value "mapM" (transformMapM serially 4)-                , benchIOSink-                      value-                      "compose"-                      (transformComposeMapM serially 4)-                , benchIOSink value "tee" (transformTeeMapM serially 4)-                , benchIOSink value "zip" (transformZipMapM serially 4)-                ]-          ]-    ]---o_1_space_serial_transformer :: Int -> [Benchmark]-o_1_space_serial_transformer value =-    [ bgroup-          "serially"-          [ bgroup-                "transformer"-                [ benchIOSrc serially "evalState" (evalStateT value)-                , benchIOSrc serially "withState" (withState value)-                ]-          ]-    ]--o_1_space_serial_transformation :: Int -> [Benchmark]-o_1_space_serial_transformation value =-    [ bgroup-          "serially"-          [ bgroup-                "transformation"-                [ benchIOSink value "scanl" (scan 1)-                , benchIOSink value "scanl1'" (scanl1' 1)-                , benchIOSink value "map" (map 1)-                , benchIOSink value "fmap" (fmap 1)-                , benchIOSink value "mapM" (mapM serially 1)-                , benchIOSink value "mapMaybe" (mapMaybe 1)-                , benchIOSink value "mapMaybeM" (mapMaybeM 1)-                , bench "sequence" $-                  nfIO $-                  randomRIO (1, 1000) >>= \n ->-                      sequence serially (sourceUnfoldrMAction value n)-                , benchIOSink value "findIndices" (findIndices value 1)-                , benchIOSink value "elemIndices" (elemIndices value 1)-                , benchIOSink value "foldrS" (foldrS 1)-                , benchIOSink value "foldrSMap" (foldrSMap 1)-                , benchIOSink value "foldrT" (foldrT 1)-                , benchIOSink value "foldrTMap" (foldrTMap 1)-                , benchIOSink value "tap" (tap 1)-                , benchIOSink value "tapRate 1 second" (tapRate 1)-                , benchIOSink value "pollCounts 1 second" (pollCounts 1)-                , benchIOSink value "tapAsync" (tapAsync 1)-                , benchIOSink value "tapAsyncS" (tapAsyncS 1)-                ]-          ]-    ]--o_1_space_serial_transformationX4 :: Int -> [Benchmark]-o_1_space_serial_transformationX4 value =-    [ bgroup-          "serially"-          [ bgroup-                "transformationX4"-                [ benchIOSink value "scan" (scan 4)-                , benchIOSink value "scanl1'" (scanl1' 4)-                , benchIOSink value "map" (map 4)-                , benchIOSink value "fmap" (fmap 4)-                , benchIOSink value "mapM" (mapM serially 4)-                , benchIOSink value "mapMaybe" (mapMaybe 4)-                , benchIOSink value "mapMaybeM" (mapMaybeM 4)-            -- , bench "sequence" $ nfIO $ randomRIO (1,1000) >>= \n ->-                -- sequence serially (sourceUnfoldrMAction n)-                , benchIOSink value "findIndices" (findIndices value 4)-                , benchIOSink value "elemIndices" (elemIndices value 4)-                ]-          ]-    ]--o_1_space_serial_filtering :: Int -> [Benchmark]-o_1_space_serial_filtering value =-    [ bgroup-          "serially"-          [ bgroup-                "filtering"-                [ benchIOSink value "filter-even" (filterEven 1)-                , benchIOSink value "filter-all-out" (filterAllOut value 1)-                , benchIOSink value "filter-all-in" (filterAllIn value 1)-                , benchIOSink value "take-all" (takeAll value 1)-                , benchIOSink-                      value-                      "takeByTime-all"-                      (takeByTime (NanoSecond64 maxBound) 1)-                , benchIOSink value "takeWhile-true" (takeWhileTrue value 1)-            --, benchIOSink value "takeWhileM-true" (_takeWhileMTrue 1)-            -- "drop-one" is dual to "last"-                , benchIOSink value "drop-one" (dropOne 1)-                , benchIOSink value "drop-all" (dropAll value 1)-                , benchIOSink-                      value-                      "dropByTime-all"-                      (dropByTime (NanoSecond64 maxBound) 1)-                , benchIOSink value "dropWhile-true" (dropWhileTrue value 1)-            --, benchIOSink value "dropWhileM-true" (_dropWhileMTrue 1)-                , benchIOSink-                      value-                      "dropWhile-false"-                      (dropWhileFalse value 1)-                , benchIOSink value "deleteBy" (deleteBy value 1)-                , benchIOSink value "intersperse" (intersperse value 1)-                , benchIOSink value "insertBy" (insertBy value 1)-                ]-          ]-    ]--o_1_space_serial_filteringX4 :: Int -> [Benchmark]-o_1_space_serial_filteringX4 value =-    [ bgroup-          "serially"-          [ bgroup-                "filteringX4"-                [ benchIOSink value "filter-even" (filterEven 4)-                , benchIOSink value "filter-all-out" (filterAllOut value 4)-                , benchIOSink value "filter-all-in" (filterAllIn value 4)-                , benchIOSink value "take-all" (takeAll value 4)-                , benchIOSink value "takeWhile-true" (takeWhileTrue value 4)-            --, benchIOSink value "takeWhileM-true" (_takeWhileMTrue 4)-                , benchIOSink value "drop-one" (dropOne 4)-                , benchIOSink value "drop-all" (dropAll value 4)-                , benchIOSink value "dropWhile-true" (dropWhileTrue value 4)-            --, benchIOSink value "dropWhileM-true" (_dropWhileMTrue 4)-                , benchIOSink-                      value-                      "dropWhile-false"-                      (dropWhileFalse value 4)-                , benchIOSink value "deleteBy" (deleteBy value 4)-                , benchIOSink value "intersperse" (intersperse value 4)-                , benchIOSink value "insertBy" (insertBy value 4)-                ]-          ]-    ]--o_1_space_serial_joining :: Int -> [Benchmark]-o_1_space_serial_joining value =-    [ bgroup-          "serially"-          [ bgroup-                "joining"-                [ benchIOSrc1 "zip (2,x/2)" (zip (value `div` 2))-                , benchIOSrc1 "zipM (2,x/2)" (zipM (value `div` 2))-                , benchIOSrc1 "mergeBy (2,x/2)" (mergeBy (value `div` 2))-                , benchIOSrc1 "serial (2,x/2)" (serial2 (value `div` 2))-                , benchIOSrc1 "append (2,x/2)" (append2 (value `div` 2))-                , benchIOSrc1 "serial (2,2,x/4)" (serial4 (value `div` 4))-                , benchIOSrc1 "append (2,2,x/4)" (append4 (value `div` 4))-                , benchIOSrc1 "wSerial (2,x/2)" (wSerial2 value) -- XXX Move this elsewhere?-                , benchIOSrc1 "interleave (2,x/2)" (interleave2 value)-                , benchIOSrc1 "roundRobin (2,x/2)" (roundRobin2 value)-                ]-          ]-    ]--o_1_space_serial_concatFoldable :: Int -> [Benchmark]-o_1_space_serial_concatFoldable value =-    [ bgroup-          "serially"-          [ bgroup-                "concat-foldable"-                [ benchIOSrc-                      serially-                      "foldMapWith"-                      (sourceFoldMapWith value)-                , benchIOSrc-                      serially-                      "foldMapWithM"-                      (sourceFoldMapWithM value)-                , benchIOSrc serially "foldMapM" (sourceFoldMapM value)-                , benchIOSrc-                      serially-                      "foldWithConcatMapId"-                      (sourceConcatMapId value)-                ]-          ]-    ]--o_1_space_serial_concatSerial :: Int -> [Benchmark]-o_1_space_serial_concatSerial value =-    [ bgroup-          "serially"-          [ bgroup-                "concat-serial"-                [ benchIOSrc1-                      "concatMapPure (2,x/2)"-                      (concatMapPure 2 (value `div` 2))-                , benchIOSrc1-                      "concatMap (2,x/2)"-                      (concatMap 2 (value `div` 2))-                , benchIOSrc1-                      "concatMap (x/2,2)"-                      (concatMap (value `div` 2) 2)-                , benchIOSrc1-                      "concatMapRepl (x/4,4)"-                      (concatMapRepl4xN value)-                , benchIOSrc1-                      "concatUnfoldRepl (x/4,4)"-                      (concatUnfoldRepl4xN value)-                , benchIOSrc1-                      "concatMapWithSerial (2,x/2)"-                      (concatMapWithSerial 2 (value `div` 2))-                , benchIOSrc1-                      "concatMapWithSerial (x/2,2)"-                      (concatMapWithSerial (value `div` 2) 2)-                , benchIOSrc1-                      "concatMapWithAppend (2,x/2)"-                      (concatMapWithAppend 2 (value `div` 2))-                ]-          ]-    ]--o_1_space_serial_outerProductStreams :: Int -> [Benchmark]-o_1_space_serial_outerProductStreams value =-    [ bgroup-          "serially"-          [ bgroup-                "outer-product-streams"-                [ benchIO "toNullAp" $ Nested.toNullAp value serially-                , benchIO "toNull" $ Nested.toNull value serially-                , benchIO "toNull3" $ Nested.toNull3 value serially-                , benchIO "filterAllOut" $ Nested.filterAllOut value serially-                , benchIO "filterAllIn" $ Nested.filterAllIn value serially-                , benchIO "filterSome" $ Nested.filterSome value serially-                , benchIO "breakAfterSome" $-                  Nested.breakAfterSome value serially-                ]-          ]-    ]--o_1_space_serial_mixed :: Int -> [Benchmark]-o_1_space_serial_mixed value =-    [ bgroup-          "serially"-          -- scanl-map and foldl-map are equivalent to the scan and fold in the foldl-          -- library. If scan/fold followed by a map is efficient enough we may not-          -- need monolithic implementations of these.-          [ bgroup-                "mixed"-                [ benchIOSink value "scanl-map" (scanMap 1)-                , benchIOSink value "foldl-map" foldl'ReduceMap-                , benchIOSink value "sum-product-fold" sumProductFold-                , benchIOSink value "sum-product-scan" sumProductScan-                ]-          ]-    ]--o_1_space_serial_mixedX4 :: Int -> [Benchmark]-o_1_space_serial_mixedX4 value =-    [ bgroup-          "serially"-          [ bgroup-                "mixedX4"-                [ benchIOSink value "scan-map" (scanMap 4)-                , benchIOSink value "drop-map" (dropMap 4)-                , benchIOSink value "drop-scan" (dropScan 4)-                , benchIOSink value "take-drop" (takeDrop value 4)-                , benchIOSink value "take-scan" (takeScan value 4)-                , benchIOSink value "take-map" (takeMap value 4)-                , benchIOSink value "filter-drop" (filterDrop value 4)-                , benchIOSink value "filter-take" (filterTake value 4)-                , benchIOSink value "filter-scan" (filterScan 4)-                , benchIOSink value "filter-scanl1" (filterScanl1 4)-                , benchIOSink value "filter-map" (filterMap value 4)-                ]-          ]-    ]--o_1_space_wSerial_transformation :: Int -> [Benchmark]-o_1_space_wSerial_transformation value =-    [ bgroup-          "wSerially"-          [ bgroup-                "transformation"-                [benchIOSink value "fmap" $ fmap' wSerially 1]-          ]-    ]--o_1_space_wSerial_concatMap :: Int -> [Benchmark]-o_1_space_wSerial_concatMap value =-    [ bgroup-          "wSerially"-          [ bgroup-                "concatMap"-                [ benchIOSrc1-                      "concatMapWithWSerial (2,x/2)"-                      (concatMapWithWSerial 2 (value `div` 2))-                , benchIOSrc1-                      "concatMapWithWSerial (x/2,2)"-                      (concatMapWithWSerial (value `div` 2) 2)-                ]-          ]-    ]--o_1_space_wSerial_outerProduct :: Int -> [Benchmark]-o_1_space_wSerial_outerProduct value =-    [ bgroup-          "wSerially"-          [ bgroup-                "outer-product"-                [ benchIO "toNullAp" $ Nested.toNullAp value wSerially-                , benchIO "toNull" $ Nested.toNull value wSerially-                , benchIO "toNull3" $ Nested.toNull3 value wSerially-                , benchIO "filterAllOut" $ Nested.filterAllOut value wSerially-                , benchIO "filterAllIn" $ Nested.filterAllIn value wSerially-                , benchIO "filterSome" $ Nested.filterSome value wSerially-                , benchIO "breakAfterSome" $-                  Nested.breakAfterSome value wSerially-                ]-          ]-    ]--o_1_space_zipSerial_transformation :: Int -> [Benchmark]-o_1_space_zipSerial_transformation value =-    [ bgroup-          "zipSerially"-          [ bgroup-                "transformation"-                [benchIOSink value "fmap" $ fmap' zipSerially 1]-            -- XXX needs fixing-            {--          , bgroup "outer-product"-            [ benchIO "toNullAp"  $ Nested.toNullAp value  zipSerially-            ]-            -}-          ]-    ]------------------------------------------------------------------------------------ Serial : O(n) Space----------------------------------------------------------------------------------o_n_space_serial_toList :: Int -> [Benchmark]-o_n_space_serial_toList value =-    [ bgroup-          "serially"-          [ bgroup-                "toList" -- < 2MB-          -- Converting the stream to a list or pure stream in a strict monad-                [ benchIOSink value "foldrMToList" foldrMBuild-                , benchIOSink value "toList" toList-                , benchIOSink value "toListRev" toListRev-          -- , benchIOSink value "toPure" toPure-          -- , benchIOSink value "toPureRev" toPureRev-                ]-          ]-    ]--o_n_space_serial_outerProductStreams :: Int -> [Benchmark]-o_n_space_serial_outerProductStreams value =-    [ bgroup-          "serially"-          [ bgroup-                "outer-product-streams"-                [ benchIO "toList" $ Nested.toList value serially-                , benchIO "toListSome" $ Nested.toListSome value serially-                ]-          ]-    ]--o_n_space_wSerial_outerProductStreams :: Int -> [Benchmark]-o_n_space_wSerial_outerProductStreams value =-    [ bgroup-          "wSerially"-          [ bgroup-                "outer-product-streams"-                [ benchIO "toList" $ Nested.toList value wSerially-                , benchIO "toListSome" $ Nested.toListSome value wSerially-                ]-          ]-    ]--o_n_space_serial_traversable :: Int -> [Benchmark]-o_n_space_serial_traversable value =-    [ bgroup-          "serially"-        -- Buffering operations using heap proportional to number of elements.-          [ bgroup-                "traversable" -- < 2MB-            -- Traversable instance-                [ benchPureSinkIO value "traverse" traversableTraverse-                , benchPureSinkIO value "sequenceA" traversableSequenceA-                , benchPureSinkIO value "mapM" traversableMapM-                , benchPureSinkIO value "sequence" traversableSequence-                ]-          ]-    ]--o_n_space_serial_foldr :: Int -> [Benchmark]-o_n_space_serial_foldr value =-    [ bgroup-          "serially"-        -- Head recursive strict right folds.-          [ bgroup-                "foldr"-            -- < 2MB-          -- accumulation due to strictness of IO monad-                [ benchIOSink value "foldrM/build/IO" foldrMBuild-          -- Right folds for reducing are inherently non-streaming as the-          -- expression needs to be fully built before it can be reduced.-                , benchIdentitySink-                      value-                      "foldrM/reduce/Identity"-                      foldrMReduce-          -- takes < 4MB-                , benchIOSink value "foldrM/reduce/IO" foldrMReduce-          -- XXX the definitions of minimumBy and maximumBy in Data.Foldable use-          -- foldl1 which does not work in constant memory for our implementation.-          -- It works in constant memory for lists but even for lists it takes 15x-          -- more time compared to our foldl' based implementation.-          -- XXX these take < 16M stack space-                , bench "minimumBy" $ nf (flip foldableMinBy 1) value-                , bench "maximumBy" $ nf (flip foldableMaxBy 1) value-                , bench "minimumByList" $ nf (flip foldableListMinBy 1) value-                ]-          ]-    ]---o_n_heap_serial_foldl :: Int -> [Benchmark]-o_n_heap_serial_foldl value =-    [ bgroup-          "serially"-          [ bgroup-                "foldl"-          -- Left folds for building a structure are inherently non-streaming-          -- as the structure cannot be lazily consumed until fully built.-                [ benchIOSink value "foldl'/build/IO" foldl'Build-                , benchIdentitySink value "foldl'/build/Identity" foldl'Build-                , benchIOSink value "foldlM'/build/IO" foldlM'Build-                , benchIdentitySink-                      value-                      "foldlM'/build/Identity"-                      foldlM'Build-          -- Reversing/sorting a stream-                , benchIOSink value "reverse" (reverse 1)-                , benchIOSink value "reverse'" (reverse' 1)-                ]-          ]-    ]--o_n_heap_serial_buffering :: Int -> [Benchmark]-o_n_heap_serial_buffering value =-    [ bgroup-          "serially"-          [ bgroup-                "buffering"-            -- Buffers the output of show/read.-            -- XXX can the outputs be streaming? Can we have special read/show-            -- style type classes, readM/showM supporting streaming effects?-                [ bench "readsPrec pure streams" $-                  nf readInstance (mkString value)-                , bench "readsPrec Haskell lists" $-                  nf readInstanceList (mkListString value)-                , bench "showPrec Haskell lists" $-                  nf showInstanceList (mkList value)-          -- interleave x/4 streams of 4 elements each. Needs to buffer-          -- proportional to x/4. This is different from WSerial because-          -- WSerial expands slowly because of binary interleave behavior and-          -- this expands immediately because of Nary interleave behavior.-                , benchIOSrc1-                      "concatUnfoldInterleaveRepl (x/4,4)"-                      (concatUnfoldInterleaveRepl4xN value)-                , benchIOSrc1-                      "concatUnfoldRoundrobinRepl (x/4,4)"-                      (concatUnfoldRoundrobinRepl4xN value)-                ]-          ]-    ]---- Head recursive operations.-o_n_stack_serial_iterated :: Int -> [Benchmark]-o_n_stack_serial_iterated value =-    [ bgroup-          "serially"-          [ bgroup-                "iterated"-                [ benchIOSrc serially "mapMx10K" iterateMapM-                , benchIOSrc serially "scanx100" iterateScan-                , benchIOSrc serially "scanl1x100" iterateScanl1-                , benchIOSrc serially "filterEvenx10K" iterateFilterEven-                , benchIOSrc serially "takeAllx10K" (iterateTakeAll value)-                , benchIOSrc serially "dropOnex10K" iterateDropOne-                , benchIOSrc-                      serially-                      "dropWhileFalsex10K"-                      (iterateDropWhileFalse value)-                , benchIOSrc-                      serially-                      "dropWhileTruex10K"-                      (iterateDropWhileTrue value)-                , benchIOSink value "tail" tail-                , benchIOSink value "nullHeadTail" nullHeadTail-                ]-          ]-    ]--o_1_space_async_generation :: Int -> [Benchmark]-o_1_space_async_generation value =-    [ bgroup-          "asyncly"-          [ bgroup-                "generation"-                [ benchSrcIO asyncly "unfoldr" (sourceUnfoldr value)-                , benchSrcIO asyncly "unfoldrM" (sourceUnfoldrM value)-                , benchSrcIO asyncly "fromFoldable" (sourceFromFoldable value)-                , benchSrcIO asyncly "fromFoldableM" (sourceFromFoldableM value)-                , benchSrcIO-                      asyncly-                      "unfoldrM maxThreads 1"-                      (maxThreads 1 . sourceUnfoldrM value)-                , benchSrcIO-                      asyncly-                      "unfoldrM maxBuffer 1 (x/10 ops)"-                      (maxBuffer 1 . sourceUnfoldrMN (value `div` 10))-                ]-          ]-    ]--o_1_space_async_concatFoldable :: Int -> [Benchmark]-o_1_space_async_concatFoldable value =-    [ bgroup-          "asyncly"-          [ bgroup-                "concat-foldable"-                [ benchSrcIO asyncly "foldMapWith" (sourceFoldMapWith value)-                , benchSrcIO-                      asyncly-                      "foldMapWithM"-                      (sourceFoldMapWithM value)-                , benchSrcIO asyncly "foldMapM" (sourceFoldMapM value)-                ]-          ]-    ]--o_1_space_async_concatMap :: Int -> [Benchmark]-o_1_space_async_concatMap value =-    value2 `seq`-    [ bgroup-          "asyncly"-          [ bgroup-                "concatMap"-                [ benchMonadicSrcIO-                      "concatMapWith (2,x/2)"-                      (concatStreamsWith async 2 (value `div` 2))-                , benchMonadicSrcIO-                      "concatMapWith (sqrt x,sqrt x)"-                      (concatStreamsWith async value2 value2)-                , benchMonadicSrcIO-                      "concatMapWith (sqrt x * 2,sqrt x / 2)"-                      (concatStreamsWith async (value2 * 2) (value2 `div` 2))-                ]-          ]-    ]-  where-    value2 = round $ sqrt $ (fromIntegral value :: Double)--o_1_space_async_transformation :: Int -> [Benchmark]-o_1_space_async_transformation value =-    [ bgroup-          "asyncly"-          [ bgroup-                "transformation"-                [ benchIOSink value "map" $ map' asyncly 1-                , benchIOSink value "fmap" $ fmap' asyncly 1-                , benchIOSink value "mapM" $ mapM asyncly 1-                ]-          ]-    ]--o_1_space_wAsync_generation :: Int -> [Benchmark]-o_1_space_wAsync_generation value =-    [ bgroup-          "wAsyncly"-          [ bgroup-                "generation"-                [ benchSrcIO wAsyncly "unfoldr" (sourceUnfoldr value)-                , benchSrcIO wAsyncly "unfoldrM" (sourceUnfoldrM value)-                , benchSrcIO wAsyncly "fromFoldable" (sourceFromFoldable value)-                , benchSrcIO-                      wAsyncly-                      "fromFoldableM"-                      (sourceFromFoldableM value)-                , benchSrcIO-                      wAsyncly-                      "unfoldrM maxThreads 1"-                      (maxThreads 1 . sourceUnfoldrM value)-                , benchSrcIO-                      wAsyncly-                      "unfoldrM maxBuffer 1 (x/10 ops)"-                      (maxBuffer 1 . sourceUnfoldrMN (value `div` 10))-                ]-          ]-    ]--o_1_space_wAsync_concatFoldable :: Int -> [Benchmark]-o_1_space_wAsync_concatFoldable value =-    [ bgroup-          "wAsyncly"-          [ bgroup-                "concat-foldable"-                [ benchSrcIO wAsyncly "foldMapWith" (sourceFoldMapWith value)-                , benchSrcIO wAsyncly "foldMapWithM" (sourceFoldMapWithM value)-                , benchSrcIO wAsyncly "foldMapM" (sourceFoldMapM value)-                ]-          ]-    ]---- When we merge streams using wAsync the size of the queue increases--- slowly because of the binary composition adding just one more item--- to the work queue only after every scheduling pass through the--- work queue.------ We should see the memory consumption increasing slowly if these--- benchmarks are left to run on infinite number of streams of infinite--- sizes.-o_1_space_wAsync_concatMap :: Int -> [Benchmark]-o_1_space_wAsync_concatMap value =-    value2 `seq`-    [ bgroup-          "wAsyncly"-          [ benchMonadicSrcIO-                "concatMapWith (2,x/2)"-                (concatStreamsWith wAsync 2 (value `div` 2))-          , benchMonadicSrcIO-                "concatMapWith (sqrt x,sqrt x)"-                (concatStreamsWith wAsync value2 value2)-          , benchMonadicSrcIO-                "concatMapWith (sqrt x * 2,sqrt x / 2)"-                (concatStreamsWith wAsync (value2 * 2) (value2 `div` 2))-          ]-    ]-  where-    value2 = round $ sqrt $ (fromIntegral value :: Double)--o_1_space_wAsync_transformation :: Int -> [Benchmark]-o_1_space_wAsync_transformation value =-    [ bgroup-          "wAsyncly"-          [ bgroup-                "transformation"-                [ benchIOSink value "map" $ map' wAsyncly 1-                , benchIOSink value "fmap" $ fmap' wAsyncly 1-                , benchIOSink value "mapM" $ mapM wAsyncly 1-                ]-          ]-    ]---- unfoldr and fromFoldable are always serial and therefore the same for--- all stream types. They can be removed to reduce the number of benchmarks.-o_1_space_ahead_generation :: Int -> [Benchmark]-o_1_space_ahead_generation value =-    [ bgroup-          "aheadly"-          [ bgroup-                "generation"-                [ benchSrcIO aheadly "unfoldr" (sourceUnfoldr value)-                , benchSrcIO aheadly "unfoldrM" (sourceUnfoldrM value)---                , benchSrcIO aheadly "fromFoldable" (sourceFromFoldable value)-                , benchSrcIO-                      aheadly-                      "fromFoldableM"-                      (sourceFromFoldableM value)-                , benchSrcIO-                      aheadly-                      "unfoldrM maxThreads 1"-                      (maxThreads 1 . sourceUnfoldrM value)-                , benchSrcIO-                      aheadly-                      "unfoldrM maxBuffer 1 (x/10 ops)"-                      (maxBuffer 1 . sourceUnfoldrMN (value `div` 10))-                ]-          ]-    ]--o_1_space_ahead_concatFoldable :: Int -> [Benchmark]-o_1_space_ahead_concatFoldable value =-    [ bgroup-          "aheadly"-          [ bgroup-                "concat-foldable"-                [ benchSrcIO aheadly "foldMapWith" (sourceFoldMapWith value)-                , benchSrcIO aheadly "foldMapWithM" (sourceFoldMapWithM value)-                , benchSrcIO aheadly "foldMapM" (sourceFoldMapM value)-                ]-          ]-    ]--o_1_space_ahead_concatMap :: Int -> [Benchmark]-o_1_space_ahead_concatMap value =-    value2 `seq`-    [ bgroup-          "aheadly"-          [ benchMonadicSrcIO-                "concatMapWith (2,x/2)"-                (concatStreamsWith ahead 2 (value `div` 2))-          , benchMonadicSrcIO-                "concatMapWith (sqrt x,sqrt x)"-                (concatStreamsWith ahead value2 value2)-          , benchMonadicSrcIO-                "concatMapWith (sqrt x * 2,sqrt x / 2)"-                (concatStreamsWith ahead (value2 * 2) (value2 `div` 2))-          ]-    ]-  where-    value2 = round $ sqrt $ (fromIntegral value :: Double)---o_1_space_ahead_transformation :: Int -> [Benchmark]-o_1_space_ahead_transformation value =-    [ bgroup-          "aheadly"-          [ bgroup-                "transformation"-                [ benchIOSink value "map" $ map' aheadly 1-                , benchIOSink value "fmap" $ fmap' aheadly 1-                , benchIOSink value "mapM" $ mapM aheadly 1-                ]-          ]-    ]--o_1_space_async_zip :: Int -> [Benchmark]-o_1_space_async_zip value =-    [ bgroup-          "asyncly"-          [ bgroup-                "zip"-                [ benchSrcIO-                      serially-                      "zipAsync (2,x/2)"-                      (zipAsync (value `div` 2))-                , benchSrcIO-                      serially-                      "zipAsyncM (2,x/2)"-                      (zipAsyncM (value `div` 2))-                , benchSrcIO-                      serially-                      "zipAsyncAp (2,x/2)"-                      (zipAsyncAp (value `div` 2))-                , benchIOSink value "fmap zipAsyncly" $ fmap' S.zipAsyncly 1-                , benchSrcIO-                      serially-                      "mergeAsyncBy (2,x/2)"-                      (mergeAsyncBy (value `div` 2))-                , benchSrcIO-                      serially-                      "mergeAsyncByM (2,x/2)"-                      (mergeAsyncByM (value `div` 2))-        -- Parallel stages in a pipeline-                , benchIOSink value "parAppMap" parAppMap-                , benchIOSink value "parAppSum" parAppSum-                ]-          ]-    ]--o_1_space_parallel_generation :: Int -> [Benchmark]-o_1_space_parallel_generation value =-    [ bgroup-          "parallely"-          [ bgroup-                "generation"-                [ benchSrcIO parallely "unfoldr" (sourceUnfoldr value)-                , benchSrcIO parallely "unfoldrM" (sourceUnfoldrM value)---                , benchSrcIO parallely "fromFoldable" (sourceFromFoldable value)-                , benchSrcIO-                      parallely-                      "fromFoldableM"-                      (sourceFromFoldableM value)-                , benchSrcIO-                      parallely-                      "unfoldrM maxThreads 1"-                      (maxThreads 1 . sourceUnfoldrM value)-                , benchSrcIO-                      parallely-                      "unfoldrM maxBuffer 1 (x/10 ops)"-                      (maxBuffer 1 . sourceUnfoldrMN (value `div` 10))-                ]-          ]-    ]--o_1_space_parallel_concatFoldable :: Int -> [Benchmark]-o_1_space_parallel_concatFoldable value =-    [ bgroup-          "parallely"-          [ bgroup-                "concat-foldable"-                [ benchSrcIO parallely "foldMapWith" (sourceFoldMapWith value)-                , benchSrcIO parallely "foldMapWithM" (sourceFoldMapWithM value)-                , benchSrcIO parallely "foldMapM" (sourceFoldMapM value)-                ]-          ]-    ]--o_1_space_parallel_concatMap :: Int -> [Benchmark]-o_1_space_parallel_concatMap value =-    value2 `seq`-    [ bgroup-          "parallely"-          [ benchMonadicSrcIO-                "concatMapWith (2,x/2)"-                (concatStreamsWith parallel 2 (value `div` 2))-          , benchMonadicSrcIO-                "concatMapWith (sqrt x,sqrt x)"-                (concatStreamsWith parallel value2 value2)-          , benchMonadicSrcIO-                "concatMapWith (sqrt x * 2,sqrt x / 2)"-                (concatStreamsWith parallel (value2 * 2) (value2 `div` 2))-          ]-    ]-  where-    value2 = round $ sqrt $ (fromIntegral value :: Double)---o_1_space_parallel_transformation :: Int -> [Benchmark]-o_1_space_parallel_transformation value =-    [ bgroup-          "parallely"-          [ bgroup-                "transformation"-                [ benchIOSink value "map" $ map' parallely 1-                , benchIOSink value "fmap" $ fmap' parallely 1-                , benchIOSink value "mapM" $ mapM parallely 1-                ]-          ]-    ]--o_1_space_parallel_outerProductStreams :: Int -> [Benchmark]-o_1_space_parallel_outerProductStreams value =-    [ bgroup-          "parallely"-          [ bgroup-                "outer-product-streams"-                [ benchIO "toNullAp" $ Nested.toNullAp value parallely-                , benchIO "toNull" $ Nested.toNull value parallely-                , benchIO "toNull3" $ Nested.toNull3 value parallely-                , benchIO "filterAllOut" $ Nested.filterAllOut value parallely-                , benchIO "filterAllIn" $ Nested.filterAllIn value parallely-                , benchIO "filterSome" $ Nested.filterSome value parallely-                , benchIO "breakAfterSome" $-                  Nested.breakAfterSome value parallely-                ]-          ]-    ]--o_n_space_parallel_outerProductStreams :: Int -> [Benchmark]-o_n_space_parallel_outerProductStreams value =-    [ bgroup-          "parallely"-          [ bgroup-                "outer-product-streams"-                [ benchIO "toList" $ Nested.toList value parallely-                , benchIO "toListSome" $ Nested.toListSome value parallely-                ]-          ]-    ]---- XXX arbitrarily large rate should be the same as rate Nothing-o_1_space_async_avgRate :: Int -> [Benchmark]-o_1_space_async_avgRate value =-    [ bgroup-          "asyncly"-          [ bgroup-                "avgRate"-          -- benchIO "unfoldr" $ toNull asyncly-          -- benchSrcIO asyncly "unfoldrM" (sourceUnfoldrM value)-                [ benchSrcIO-                      asyncly-                      "unfoldrM/Nothing"-                      (S.rate Nothing . sourceUnfoldrM value)-                , benchSrcIO-                      asyncly-                      "unfoldrM/1,000,000"-                      (S.avgRate 1000000 . sourceUnfoldrM value)-                , benchSrcIO-                      asyncly-                      "unfoldrM/3,000,000"-                      (S.avgRate 3000000 . sourceUnfoldrM value)-                , benchSrcIO-                      asyncly-                      "unfoldrM/10,000,000/maxThreads1"-                      (maxThreads 1 .-                       S.avgRate 10000000 . sourceUnfoldrM value)-                , benchSrcIO-                      asyncly-                      "unfoldrM/10,000,000"-                      (S.avgRate 10000000 . sourceUnfoldrM value)-                , benchSrcIO-                      asyncly-                      "unfoldrM/20,000,000"-                      (S.avgRate 20000000 . sourceUnfoldrM value)-                ]-          ]-    ]--o_1_space_ahead_avgRate :: Int -> [Benchmark]-o_1_space_ahead_avgRate value =-    [ bgroup-          "aheadly"-          [ bgroup-                "avgRate"-                [ benchSrcIO-                      aheadly-                      "unfoldrM/1,000,000"-                      (S.avgRate 1000000 . sourceUnfoldrM value)-                ]-          ]-    ]+-- Copyright   : (c) 2018 Composewell Technologies+--+-- License     : MIT+-- Maintainer  : streamly@composewell.com++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}++module Streamly.Benchmark.Prelude where++import Control.Applicative (liftA2)+import Control.DeepSeq (NFData(..))+import Control.Exception (try)+import Data.Functor.Identity (Identity)+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup (Semigroup((<>)))+#endif+import GHC.Exception (ErrorCall)+import System.Random (randomRIO)++import qualified Data.Foldable as F+import qualified Data.List as List+import qualified Streamly.Prelude  as S+import qualified Streamly.Internal.Data.Stream.IsStream as Internal+import qualified Streamly.Internal.Data.Pipe as Pipe+import qualified Streamly.Internal.Data.Stream.Serial as Serial++import Gauge+import Streamly.Internal.Data.Time.Units++-- Common polymorphic stream APIs used across multiple stream modules++-------------------------------------------------------------------------------+-- Generation+-------------------------------------------------------------------------------++-------------------------------------------------------------------------------+-- enumerate+-------------------------------------------------------------------------------++{-# INLINE sourceIntFromTo #-}+sourceIntFromTo :: (Monad m, S.IsStream t) => Int -> Int -> t m Int+sourceIntFromTo value n = S.enumerateFromTo n (n + value)++{-# INLINE sourceIntFromThenTo #-}+sourceIntFromThenTo :: (Monad m, S.IsStream t) => Int -> Int -> t m Int+sourceIntFromThenTo value n = S.enumerateFromThenTo n (n + 1) (n + value)++{-# INLINE sourceFracFromTo #-}+sourceFracFromTo :: (Monad m, S.IsStream t) => Int -> Int -> t m Double+sourceFracFromTo value n =+    S.enumerateFromTo (fromIntegral n) (fromIntegral (n + value))++{-# INLINE sourceFracFromThenTo #-}+sourceFracFromThenTo :: (Monad m, S.IsStream t) => Int -> Int -> t m Double+sourceFracFromThenTo value n = S.enumerateFromThenTo (fromIntegral n)+    (fromIntegral n + 1.0001) (fromIntegral (n + value))++{-# INLINE sourceIntegerFromStep #-}+sourceIntegerFromStep :: (Monad m, S.IsStream t) => Int -> Int -> t m Integer+sourceIntegerFromStep value n =+    S.take value $ S.enumerateFromThen (fromIntegral n) (fromIntegral n + 1)++-------------------------------------------------------------------------------+-- unfold+-------------------------------------------------------------------------------++{-# INLINE sourceUnfoldr #-}+sourceUnfoldr :: (Monad m, S.IsStream t) => Int -> Int -> t m Int+sourceUnfoldr count start = S.unfoldr step start+    where+    step cnt =+        if cnt > start + count+        then Nothing+        else Just (cnt, cnt + 1)++{-# INLINE sourceUnfoldrM #-}+sourceUnfoldrM :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int+sourceUnfoldrM count start = S.unfoldrM step start+    where+    step cnt =+        if cnt > start + count+        then return Nothing+        else return (Just (cnt, cnt + 1))++{-# INLINE sourceUnfoldrMSerial #-}+sourceUnfoldrMSerial :: (S.IsStream t, Monad m) => Int -> Int -> t m Int+sourceUnfoldrMSerial count start = Serial.unfoldrM step start+    where+    step cnt =+        if cnt > start + count+        then return Nothing+        else return (Just (cnt, cnt + 1))++-------------------------------------------------------------------------------+-- fromList+-------------------------------------------------------------------------------++{-# INLINE sourceFromList #-}+sourceFromList :: (Monad m, S.IsStream t) => Int -> Int -> t m Int+sourceFromList value n = S.fromList [n..n+value]++{-# INLINE sourceFromListM #-}+sourceFromListM :: (S.MonadAsync m, S.IsStream t) => Int -> Int -> t m Int+sourceFromListM value n = S.fromListM (fmap return [n..n+value])++-------------------------------------------------------------------------------+-- fromFoldable+-------------------------------------------------------------------------------++{-# INLINE sourceFromFoldable #-}+sourceFromFoldable :: S.IsStream t => Int -> Int -> t m Int+sourceFromFoldable value n = S.fromFoldable [n..n+value]++{-# INLINE sourceFromFoldableM #-}+sourceFromFoldableM :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int+sourceFromFoldableM value n = S.fromFoldableM (fmap return [n..n+value])++-------------------------------------------------------------------------------+-- Time enumeration+-------------------------------------------------------------------------------++{-# INLINE absTimes #-}+absTimes :: (S.IsStream t, S.MonadAsync m, Functor (t m))+    => Int -> Int -> t m AbsTime+absTimes value _ = S.take value Internal.absTimes++-------------------------------------------------------------------------------+-- Buffering+-------------------------------------------------------------------------------++{-# INLINE mkAsync #-}+mkAsync :: (S.MonadAsync m, S.IsStream t) => (t m a -> S.SerialT m a) -> t m a -> m ()+mkAsync adapter = S.drain . adapter . S.mkAsync++-------------------------------------------------------------------------------+-- Elimination+-------------------------------------------------------------------------------++{-# INLINE toNull #-}+toNull :: Monad m => (t m a -> S.SerialT m a) -> t m a -> m ()+toNull t = S.drain . t++-- We need a monadic bind here to make sure that the function f does not get+-- completely optimized out by the compiler in some cases.++-- | Takes a fold method, and uses it with a default source.+{-# INLINE benchIOSink #-}+benchIOSink+    :: (S.IsStream t, NFData b)+    => Int -> String -> (t IO Int -> IO b) -> Benchmark+benchIOSink value name f =+    bench name $ nfIO $ randomRIO (1,1) >>= f . sourceUnfoldrM value++-- | Takes a source, and uses it with a default drain/fold method.+{-# INLINE benchIOSrc #-}+benchIOSrc+    :: (t IO a -> S.SerialT IO a)+    -> String+    -> (Int -> t IO a)+    -> Benchmark+benchIOSrc t name f =+    bench name $ nfIO $ randomRIO (1,1) >>= toNull t . f++{-# NOINLINE benchIO #-}+benchIO :: (NFData b) => String -> (Int -> IO b) -> Benchmark+benchIO name f = bench name $ nfIO $ randomRIO (1,1) >>= f++-------------------------------------------------------------------------------+-- Mapping+-------------------------------------------------------------------------------++{-# INLINE sourceUnfoldrAction #-}+sourceUnfoldrAction :: (S.IsStream t, Monad m, Monad m1)+    => Int -> Int -> t m (m1 Int)+sourceUnfoldrAction value n = S.fromSerial $ S.unfoldr step n+    where+    step cnt =+        if cnt > n + value+        then Nothing+        else Just (return cnt, cnt + 1)++{-# INLINE composeN #-}+composeN ::+       (S.IsStream t, Monad m)+    => Int+    -> (t m Int -> S.SerialT m Int)+    -> t m Int+    -> m ()+composeN n f =+    case n of+        1 -> S.drain . f+        2 -> S.drain . f . S.adapt . f+        3 -> S.drain . f . S.adapt . f . S.adapt . f+        4 -> S.drain . f . S.adapt . f . S.adapt . f . S.adapt . f+        _ -> undefined++{-# INLINE fmapN #-}+fmapN ::+       (S.IsStream t, S.MonadAsync m, Functor (t m))+    => (t m Int -> S.SerialT m Int)+    -> Int+    -> t m Int+    -> m ()+fmapN t n = composeN n $ t . fmap (+ 1)++{-# INLINE mapN #-}+mapN ::+       (S.IsStream t, S.MonadAsync m)+    => (t m Int -> S.SerialT m Int)+    -> Int+    -> t m Int+    -> m ()+mapN t n = composeN n $ t . S.map (+ 1)++{-# INLINE mapM #-}+mapM ::+       (S.IsStream t, S.MonadAsync m)+    => (t m Int -> S.SerialT m Int)+    -> Int+    -> t m Int+    -> m ()+mapM t n = composeN n $ t . S.mapM return++-------------------------------------------------------------------------------+-- Pipes+-------------------------------------------------------------------------------++{-# INLINE transformMapM #-}+transformMapM ::+       (S.IsStream t, S.MonadAsync m)+    => (t m Int -> S.SerialT m Int)+    -> Int+    -> t m Int+    -> m ()+transformMapM t n = composeN n $ t . Internal.transform (Pipe.mapM return)++{-# INLINE transformComposeMapM #-}+transformComposeMapM ::+       (S.IsStream t, S.MonadAsync m)+    => (t m Int -> S.SerialT m Int)+    -> Int+    -> t m Int+    -> m ()+transformComposeMapM t n =+    composeN n $+    t .+    Internal.transform+        (Pipe.mapM (\x -> return (x + 1)) `Pipe.compose`+         Pipe.mapM (\x -> return (x + 2)))++{-# INLINE transformTeeMapM #-}+transformTeeMapM ::+       (S.IsStream t, S.MonadAsync m)+    => (t m Int -> S.SerialT m Int)+    -> Int+    -> t m Int+    -> m ()+transformTeeMapM t n =+    composeN n $+    t .+    Internal.transform+        (Pipe.mapM (\x -> return (x + 1)) `Pipe.tee`+         Pipe.mapM (\x -> return (x + 2)))++{-# INLINE transformZipMapM #-}+transformZipMapM ::+       (S.IsStream t, S.MonadAsync m)+    => (t m Int -> S.SerialT m Int)+    -> Int+    -> t m Int+    -> m ()+transformZipMapM t n =+    composeN n $+    t .+    Internal.transform+        (Pipe.zipWith+             (+)+             (Pipe.mapM (\x -> return (x + 1)))+             (Pipe.mapM (\x -> return (x + 2))))++-------------------------------------------------------------------------------+-- Streams of streams+-------------------------------------------------------------------------------++-------------------------------------------------------------------------------+-- Concat foldable+-------------------------------------------------------------------------------++{-# INLINE sourceFoldMapWith #-}+sourceFoldMapWith :: (S.IsStream t, Semigroup (t m Int))+    => Int -> Int -> t m Int+sourceFoldMapWith value n = S.concatMapFoldableWith (<>) S.fromPure [n..n+value]++{-# INLINE concatForFoldableWith #-}+concatForFoldableWith :: (S.IsStream t, Semigroup (t m Int))+    => Int -> Int -> t m Int+concatForFoldableWith value n =+    S.concatForFoldableWith (<>) [n..n+value] S.fromPure++{-# INLINE concatFoldableWith #-}+concatFoldableWith :: (S.IsStream t, Semigroup (t m Int))+    => Int -> Int -> t m Int+concatFoldableWith value n =+    let step x =+            if x <= n + value+            then Just (S.fromPure x, x + 1)+            else Nothing+        list = List.unfoldr step n+     in S.concatFoldableWith (<>) list++{-# INLINE sourceFoldMapWithStream #-}+sourceFoldMapWithStream :: (S.IsStream t, Semigroup (t m Int))+    => Int -> Int -> t m Int+sourceFoldMapWithStream value n = S.concatMapFoldableWith (<>) S.fromPure+    $ (S.enumerateFromTo n (n + value) :: S.SerialT Identity Int)++{-# INLINE sourceFoldMapWithM #-}+sourceFoldMapWithM :: (S.IsStream t, Monad m, Semigroup (t m Int))+    => Int -> Int -> t m Int+sourceFoldMapWithM value n =+    S.concatMapFoldableWith (<>) (S.fromEffect . return) [n..n+value]++{-# INLINE sourceFoldMapM #-}+sourceFoldMapM :: (S.IsStream t, Monad m, Monoid (t m Int))+    => Int -> Int -> t m Int+sourceFoldMapM value n = F.foldMap (S.fromEffect . return) [n..n+value]++-------------------------------------------------------------------------------+-- Concat+-------------------------------------------------------------------------------++{-# INLINE sourceConcatMapId #-}+sourceConcatMapId :: (S.IsStream t, Monad m)+    => Int -> Int -> t m (t m Int)+sourceConcatMapId value n =+    S.fromFoldable $ fmap (S.fromEffect . return) [n..n+value]++-- concatMapWith++{-# INLINE concatStreamsWith #-}+concatStreamsWith+    :: (forall c. S.SerialT IO c -> S.SerialT IO c -> S.SerialT IO c)+    -> Int+    -> Int+    -> Int+    -> IO ()+concatStreamsWith op outer inner n =+    S.drain $ S.concatMapWith op+        (S.fromSerial . sourceUnfoldrM inner)+        (S.fromSerial $ sourceUnfoldrM outer n)++{-# INLINE concatPairsWith #-}+concatPairsWith+    :: (forall c. S.SerialT IO c -> S.SerialT IO c -> S.SerialT IO c)+    -> Int+    -> Int+    -> Int+    -> IO ()+concatPairsWith op outer inner n =+    S.drain $ Internal.concatPairsWith op+        (S.fromSerial . sourceUnfoldrM inner)+        (S.fromSerial $ sourceUnfoldrM outer n)++-------------------------------------------------------------------------------+-- Monadic outer product+-------------------------------------------------------------------------------++{-# INLINE runToList #-}+runToList :: Monad m => S.SerialT m a -> m [a]+runToList = S.toList++{-# INLINE apDiscardFst #-}+apDiscardFst+    :: (S.IsStream t, S.MonadAsync m, Applicative (t m))+    => Int -> (t m Int -> S.SerialT m Int) -> Int -> m ()+apDiscardFst linearCount t start = S.drain . t $+    S.fromSerial (sourceUnfoldrM nestedCount2 start)+        *> S.fromSerial (sourceUnfoldrM nestedCount2 start)++    where++    nestedCount2 = round (fromIntegral linearCount**(1/2::Double))++{-# INLINE apDiscardSnd #-}+apDiscardSnd+    :: (S.IsStream t, S.MonadAsync m, Applicative (t m))+    => Int -> (t m Int -> S.SerialT m Int) -> Int -> m ()+apDiscardSnd linearCount t start = S.drain . t $+    S.fromSerial (sourceUnfoldrM nestedCount2 start)+        <* S.fromSerial (sourceUnfoldrM nestedCount2 start)++    where++    nestedCount2 = round (fromIntegral linearCount**(1/2::Double))++{-# INLINE apLiftA2 #-}+apLiftA2+    :: (S.IsStream t, S.MonadAsync m, Applicative (t m))+    => Int -> (t m Int -> S.SerialT m Int) -> Int -> m ()+apLiftA2 linearCount t start = S.drain . t $+    liftA2 (+) (S.fromSerial (sourceUnfoldrM nestedCount2 start))+        (S.fromSerial (sourceUnfoldrM nestedCount2 start))++    where++    nestedCount2 = round (fromIntegral linearCount**(1/2::Double))++{-# INLINE toNullAp #-}+toNullAp+    :: (S.IsStream t, S.MonadAsync m, Applicative (t m))+    => Int -> (t m Int -> S.SerialT m Int) -> Int -> m ()+toNullAp linearCount t start = S.drain . t $+    (+) <$> S.fromSerial (sourceUnfoldrM nestedCount2 start)+        <*> S.fromSerial (sourceUnfoldrM nestedCount2 start)++    where++    nestedCount2 = round (fromIntegral linearCount**(1/2::Double))++{-# INLINE monadThen #-}+monadThen+    :: (S.IsStream t, S.MonadAsync m, Monad (t m))+    => Int -> (t m Int -> S.SerialT m Int) -> Int -> m ()+monadThen linearCount t start = S.drain . t $ do+    (S.fromSerial $ sourceUnfoldrM nestedCount2 start) >>+        (S.fromSerial $ sourceUnfoldrM nestedCount2 start)++    where++    nestedCount2 = round (fromIntegral linearCount**(1/2::Double))++{-# INLINE toNullM #-}+toNullM+    :: (S.IsStream t, S.MonadAsync m, Monad (t m))+    => Int -> (t m Int -> S.SerialT m Int) -> Int -> m ()+toNullM linearCount t start = S.drain . t $ do+    x <- S.fromSerial $ sourceUnfoldrM nestedCount2 start+    y <- S.fromSerial $ sourceUnfoldrM nestedCount2 start+    return $ x + y++    where++    nestedCount2 = round (fromIntegral linearCount**(1/2::Double))++{-# INLINE toNullM3 #-}+toNullM3+    :: (S.IsStream t, S.MonadAsync m, Monad (t m))+    => Int -> (t m Int -> S.SerialT m Int) -> Int -> m ()+toNullM3 linearCount t start = S.drain . t $ do+    x <- S.fromSerial $ sourceUnfoldrM nestedCount3 start+    y <- S.fromSerial $ sourceUnfoldrM nestedCount3 start+    z <- S.fromSerial $ sourceUnfoldrM nestedCount3 start+    return $ x + y + z+  where+    nestedCount3 = round (fromIntegral linearCount**(1/3::Double))++{-# INLINE toListM #-}+toListM+    :: (S.IsStream t, S.MonadAsync m, Monad (t m))+    => Int -> (t m Int -> S.SerialT m Int) -> Int -> m [Int]+toListM linearCount t start = runToList . t $ do+    x <- S.fromSerial $ sourceUnfoldrM nestedCount2 start+    y <- S.fromSerial $ sourceUnfoldrM nestedCount2 start+    return $ x + y+  where+    nestedCount2 = round (fromIntegral linearCount**(1/2::Double))++-- Taking a specified number of elements is very expensive in logict so we have+-- a test to measure the same.+{-# INLINE toListSome #-}+toListSome+    :: (S.IsStream t, S.MonadAsync m, Monad (t m))+    => Int -> (t m Int -> S.SerialT m Int) -> Int -> m [Int]+toListSome linearCount t start =+    runToList . t $ S.take 10000 $ do+        x <- S.fromSerial $ sourceUnfoldrM nestedCount2 start+        y <- S.fromSerial $ sourceUnfoldrM nestedCount2 start+        return $ x + y+  where+    nestedCount2 = round (fromIntegral linearCount**(1/2::Double))++{-# INLINE filterAllOutM #-}+filterAllOutM+    :: (S.IsStream t, S.MonadAsync m, Monad (t m))+    => Int -> (t m Int -> S.SerialT m Int) -> Int -> m ()+filterAllOutM linearCount t start = S.drain . t $ do+    x <- S.fromSerial $ sourceUnfoldrM nestedCount2 start+    y <- S.fromSerial $ sourceUnfoldrM nestedCount2 start+    let s = x + y+    if s < 0+    then return s+    else S.nil+  where+    nestedCount2 = round (fromIntegral linearCount**(1/2::Double))++{-# INLINE filterAllInM #-}+filterAllInM+    :: (S.IsStream t, S.MonadAsync m, Monad (t m))+    => Int -> (t m Int -> S.SerialT m Int) -> Int -> m ()+filterAllInM linearCount t start = S.drain . t $ do+    x <- S.fromSerial $ sourceUnfoldrM nestedCount2 start+    y <- S.fromSerial $ sourceUnfoldrM nestedCount2 start+    let s = x + y+    if s > 0+    then return s+    else S.nil+  where+    nestedCount2 = round (fromIntegral linearCount**(1/2::Double))++{-# INLINE filterSome #-}+filterSome+    :: (S.IsStream t, S.MonadAsync m, Monad (t m))+    => Int -> (t m Int -> S.SerialT m Int) -> Int -> m ()+filterSome linearCount t start = S.drain . t $ do+    x <- S.fromSerial $ sourceUnfoldrM nestedCount2 start+    y <- S.fromSerial $ sourceUnfoldrM nestedCount2 start+    let s = x + y+    if s > 1100000+    then return s+    else S.nil+  where+    nestedCount2 = round (fromIntegral linearCount**(1/2::Double))++{-# INLINE breakAfterSome #-}+breakAfterSome+    :: (S.IsStream t, Monad (t IO))+    => Int -> (t IO Int -> S.SerialT IO Int) -> Int -> IO ()+breakAfterSome linearCount t start = do+    (_ :: Either ErrorCall ()) <- try $ S.drain . t $ do+        x <- S.fromSerial $ sourceUnfoldrM nestedCount2 start+        y <- S.fromSerial $ sourceUnfoldrM nestedCount2 start+        let s = x + y+        if s > 1100000+        then error "break"+        else return s+    return ()+  where+    nestedCount2 = round (fromIntegral linearCount**(1/2::Double))
benchmark/streamly-benchmarks.cabal view
@@ -9,8 +9,8 @@   for serial, async, ahead style streams, therefore, we need to use   the common code in several benchmarks, just changing the type of   the stream. It takes a long time to compile this file and it gets-  compiled for each benchmarks once if we do not have a library.  Cabal-  does no support internal libraries without per-component builds and+  compiled for each benchmark once if we do not have a library.  Cabal+  does not support internal libraries without per-component builds and   per-component builds are not supported with Configure, so we are not   left with any other choice. @@ -19,6 +19,11 @@   manual: True   default: False +flag limit-build-mem+  description: Limits memory when building the executables+  manual: True+  default: False+ flag inspection   description: Enable inspection testing   manual: True@@ -39,9 +44,14 @@   manual: True   default: False -flag no-charts-  description: Disable benchmark charts in development build+flag opt+  description: off=-O0 (faster builds), on=-O2   manual: True+  default: True++flag use-gauge+  description: Use gauge instead of tasty-bench for benchmarking+  manual: True   default: False  -------------------------------------------------------------------------------@@ -58,6 +68,14 @@       cpp-options:    -DINSPECTION      ghc-options:      -Wall+                      -Wcompat+                      -Wunrecognised-warning-flags+                      -Widentities+                      -Wincomplete-record-updates+                      -Wincomplete-uni-patterns+                      -Wredundant-constraints+                      -Wnoncanonical-monad-instances+                      -Rghc-timing      if flag(has-llvm)       ghc-options: -fllvm@@ -69,29 +87,17 @@     if flag(dev) || flag(debug)       ghc-options:    -fno-ignore-asserts -    if impl(ghc >= 8.0)-      ghc-options:    -Wcompat-                      -Wunrecognised-warning-flags-                      -Widentities-                      -Wincomplete-record-updates-                      -Wincomplete-uni-patterns-                      -Wredundant-constraints-                      -Wnoncanonical-monad-instances- common optimization-options-  ghc-options: -O2-               -fdicts-strict-               -fspec-constr-recursive=16-               -fmax-worker-args=16-  if flag(fusion-plugin) && !impl(ghcjs) && !impl(ghc < 8.6)-    ghc-options: -fplugin Fusion.Plugin+  if flag(opt)+    ghc-options: -O2+                 -fdicts-strict+                 -fspec-constr-recursive=16+                 -fmax-worker-args=16+    if flag(fusion-plugin) && !impl(ghcjs) && !impl(ghc < 8.6)+      ghc-options: -fplugin Fusion.Plugin+  else+    ghc-options: -O0 --- 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 @@ -100,23 +106,36 @@     -- Core libraries shipped with ghc, the min and max     -- constraints of these libraries should match with     -- the GHC versions we support-      base                >= 4.8   && < 5+      base                >= 4.9   && < 5     , deepseq             >= 1.4.1 && < 1.5     , mtl                 >= 2.2   && < 3      -- other libraries     , streamly            >= 0.7.0     , random              >= 1.0   && < 2.0-    , gauge               >= 0.2.4 && < 0.3+    , transformers        >= 0.4   && < 0.6+    , containers          >= 0.5   && < 0.7+    , typed-process     >= 0.2.3 && < 0.3+    , directory         >= 1.2.2 && < 1.4+    , ghc-prim          >= 0.4   && < 0.8++  if flag(use-gauge)+    build-depends:  gauge >= 0.2.4 && < 0.3+  else+    build-depends:    tasty-bench >= 0.2.5 && < 0.3+                    , tasty     >= 1.4.1+    mixins: tasty-bench+      (Test.Tasty.Bench as Gauge+      , Test.Tasty.Bench as Gauge.Main+      )+   if flag(fusion-plugin) && !impl(ghcjs) && !impl(ghc < 8.6)     build-depends:         fusion-plugin     >= 0.2   && < 0.3-  if impl(ghc < 8.0)-    build-depends:-        transformers  >= 0.4 && < 0.6   if flag(inspection)     build-depends:     template-haskell   >= 2.14  && < 2.17                      , inspection-testing >= 0.4   && < 0.5+                     , ghc-prim           >= 0.2   && < 0.7   -- Array uses a Storable constraint in dev build making several inspection   -- tests fail   if flag(dev) && flag(inspection)@@ -128,261 +147,261 @@  library     import: lib-options, bench-depends-    hs-source-dirs:    lib-    exposed-modules:-                       Streamly.Benchmark.Common--library lib-prelude-    import: lib-options, bench-depends-    hs-source-dirs:    lib, .-    exposed-modules:-                       Streamly.Benchmark.Prelude-    other-modules:     Streamly.Benchmark.Common-                     , Streamly.Benchmark.Prelude.NestedOps-    -- XXX GHCJS build fails for this library.-    if impl(ghcjs)-      buildable: False-    else-      build-depends: ghc-prim-      buildable: True+    hs-source-dirs: lib+    exposed-modules: Streamly.Benchmark.Common+                   , Streamly.Benchmark.Common.Handle+                   , Streamly.Benchmark.Prelude  ------------------------------------------------------------------------------- -- Benchmarks ------------------------------------------------------------------------------- --- Whatever stack size below 32K we use GHC seems to report the stack size as--- 32K at crash. Even K0K works. Therefore it probably does not make sense to--- set it to lower than 32K.- common bench-options   import: compile-options, optimization-options, bench-depends-  ghc-options: -with-rtsopts "-T -K32K -M16M"-  build-depends: streamly-benchmarks+  ghc-options: -rtsopts+  if flag(limit-build-mem)+    ghc-options: +RTS -M512M -RTS+  build-depends: streamly-benchmarks == 0.0.0  -- Some benchmarks are threaded some are not common bench-options-threaded   import: compile-options, optimization-options, bench-depends   -- -threaded and -N2 is important because some GC and space leak issues   -- trigger only with these options.-  ghc-options: -threaded -with-rtsopts "-T -N2 -K32K -M16M"-  build-depends: streamly-benchmarks---- XXX the individual modules can just export a bunch of gauge Benchmark--- grouped by space usage and then we can combine the groups in just four--- different top level drivers.+  ghc-options: -threaded -rtsopts -with-rtsopts "-N2"+  if flag(limit-build-mem)+    ghc-options: +RTS -M512M -RTS+  build-depends: streamly-benchmarks == 0.0.0  ------------------------------------------------------------------------------- -- Serial Streams ------------------------------------------------------------------------------- -benchmark linear--- benchmark serial-o-1-space+benchmark Prelude.Serial   import: bench-options   type: exitcode-stdio-1.0-  ghc-options: -with-rtsopts "-T -K36K -M16M"-  hs-source-dirs: Streamly/Benchmark/Prelude/Serial-  main-is: O_1_Space.hs+  hs-source-dirs: Streamly/Benchmark/Prelude+  main-is: Serial.hs+  other-modules:+        Serial.Generation+      , Serial.Elimination+      , Serial.Transformation1+      , Serial.Transformation2+      , Serial.Transformation3+      , Serial.Nested+      , Serial.Exceptions+      , Serial.Split   if impl(ghcjs)     buildable: False   else-    build-depends: lib-prelude     buildable: True+  if flag(limit-build-mem)+    ghc-options: +RTS -M2000M -RTS -benchmark serial-o-n-heap++benchmark Prelude.WSerial   import: bench-options   type: exitcode-stdio-1.0-  ghc-options: -with-rtsopts "-T -K36K -M128M"-  hs-source-dirs: Streamly/Benchmark/Prelude/Serial-  main-is: O_n_Heap.hs+  hs-source-dirs: Streamly/Benchmark/Prelude+  main-is: WSerial.hs   if impl(ghcjs)     buildable: False   else-    build-depends: lib-prelude     buildable: True -benchmark serial-o-n-stack+benchmark Prelude.ZipSerial   import: bench-options   type: exitcode-stdio-1.0-  ghc-options: -with-rtsopts "-T -K1M -M16M"-  hs-source-dirs: Streamly/Benchmark/Prelude/Serial-  main-is: O_n_Stack.hs+  hs-source-dirs: Streamly/Benchmark/Prelude+  main-is: ZipSerial.hs   if impl(ghcjs)     buildable: False   else-    build-depends: lib-prelude     buildable: True -benchmark serial-o-n-space+benchmark Prelude.ZipAsync   import: bench-options   type: exitcode-stdio-1.0-  ghc-options: -with-rtsopts "-T -K16M -M64M"-  hs-source-dirs: Streamly/Benchmark/Prelude/Serial-  main-is: O_n_Space.hs+  hs-source-dirs: Streamly/Benchmark/Prelude+  main-is: ZipAsync.hs   if impl(ghcjs)     buildable: False   else-    build-depends: lib-prelude     buildable: True+  if flag(limit-build-mem)+    ghc-options: +RTS -M1000M -RTS -benchmark fold-  import: bench-options++benchmark Prelude.Ahead+  import: bench-options-threaded   type: exitcode-stdio-1.0-  ghc-options: -rtsopts-  hs-source-dirs: Streamly/Benchmark/Data-  main-is: Fold.hs+  hs-source-dirs: Streamly/Benchmark/Prelude+  main-is: Ahead.hs   if impl(ghcjs)     buildable: False   else     buildable: True -benchmark unfold-  import: bench-options+benchmark Prelude.Async+  import: bench-options-threaded   type: exitcode-stdio-1.0-  ghc-options: -rtsopts-  hs-source-dirs: ., Streamly/Benchmark/Data-  main-is: Unfold.hs-  other-modules: Streamly.Benchmark.Data.NestedUnfoldOps+  hs-source-dirs: Streamly/Benchmark/Prelude+  main-is: Async.hs   if impl(ghcjs)     buildable: False   else     buildable: True -benchmark parser-  import: bench-options+benchmark Prelude.WAsync+  import: bench-options-threaded   type: exitcode-stdio-1.0-  ghc-options: -with-rtsopts "-T -K36K -M16M"-  hs-source-dirs: ., Streamly/Benchmark/Data-  main-is: Parser.hs+  hs-source-dirs: Streamly/Benchmark/Prelude+  main-is: WAsync.hs   if impl(ghcjs)     buildable: False   else     buildable: True-    build-depends: exceptions >= 0.8   && < 0.11 ----------------------------------------------------------------------------------- Raw Streams--------------------------------------------------------------------------------+benchmark Prelude.Parallel+  import: bench-options-threaded+  type: exitcode-stdio-1.0+  hs-source-dirs: Streamly/Benchmark/Prelude+  main-is: Parallel.hs+  if impl(ghcjs)+    buildable: False+  else+    buildable: True+  if flag(limit-build-mem)+    ghc-options: +RTS -M2000M -RTS -library lib-base-    import: lib-options, bench-depends-    hs-source-dirs: .-    exposed-modules:-                       Streamly.Benchmark.Data.Stream.StreamD-                     , Streamly.Benchmark.Data.Stream.StreamK-                     , Streamly.Benchmark.Data.Stream.StreamDK-    if impl(ghcjs)-      buildable: False-    else-      build-depends: streamly-benchmarks-      buildable: True -benchmark base--- benchmark base-o-1-space+benchmark Data.Unfold   import: bench-options   type: exitcode-stdio-1.0-  cpp-options: -DO_1_SPACE-  ghc-options: -with-rtsopts "-T -K36K -M16M"-  hs-source-dirs: Streamly/Benchmark/Data/Stream-  main-is: BaseStreams.hs+  hs-source-dirs: .+  main-is: Streamly/Benchmark/Data/Unfold.hs   if impl(ghcjs)     buildable: False   else-    build-depends: lib-base     buildable: True -benchmark base-o-n-heap+benchmark Data.Fold   import: bench-options   type: exitcode-stdio-1.0-  cpp-options: -DO_N_HEAP-  ghc-options: -with-rtsopts "-T -K36K -M64M"-  hs-source-dirs: Streamly/Benchmark/Data/Stream-  main-is: BaseStreams.hs+  hs-source-dirs: Streamly/Benchmark/Data+  main-is: Fold.hs   if impl(ghcjs)     buildable: False   else-    build-depends: lib-base     buildable: True -benchmark base-o-n-stack+benchmark Data.Parser.ParserD   import: bench-options   type: exitcode-stdio-1.0-  cpp-options: -DO_N_STACK-  ghc-options: -with-rtsopts "-T -K1M -M16M"-  hs-source-dirs: Streamly/Benchmark/Data/Stream-  main-is: BaseStreams.hs+  hs-source-dirs: Streamly/Benchmark/Data/Parser+  main-is: ParserD.hs   if impl(ghcjs)     buildable: False   else-    build-depends: lib-base     buildable: True+    build-depends: exceptions >= 0.8   && < 0.11+  if flag(limit-build-mem)+    ghc-options: +RTS -M750M -RTS -benchmark base-o-n-space+benchmark Data.Parser.ParserK   import: bench-options   type: exitcode-stdio-1.0-  cpp-options: -DO_N_SPACE-  ghc-options: -with-rtsopts "-T -K32M -M32M"-  hs-source-dirs: Streamly/Benchmark/Data/Stream-  main-is: BaseStreams.hs+  hs-source-dirs: Streamly/Benchmark/Data/Parser+  main-is: ParserK.hs   if impl(ghcjs)     buildable: False   else-    build-depends: lib-base     buildable: True+    build-depends: exceptions >= 0.8   && < 0.11 -executable nano-bench+-- Note: to use this we have to set DISABLE_FUSION in ParserD.hs so that+-- the rewrite rules are disabled. We can also use the "no-fusion" build+-- flag but we need to keep in mind that it disables fusion for streams+-- as well.+benchmark Data.Parser.FromParserK   import: bench-options-  hs-source-dirs: .-  main-is: NanoBenchmarks.hs-  if flag(dev)-    buildable: True+  type: exitcode-stdio-1.0+  hs-source-dirs: Streamly/Benchmark/Data/Parser+  cpp-options: -DFROM_PARSERK+  main-is: ParserK.hs+  if impl(ghcjs)+    buildable: False   else+    buildable: True+    build-depends: exceptions >= 0.8   && < 0.11++benchmark Data.Parser+  import: bench-options+  type: exitcode-stdio-1.0+  hs-source-dirs: Streamly/Benchmark/Data+  main-is: Parser.hs+  if impl(ghcjs)     buildable: False+  else+    buildable: True+    build-depends: exceptions >= 0.8   && < 0.11+  if flag(limit-build-mem)+    ghc-options: +RTS -M1000M -RTS  ---------------------------------------------------------------------------------- Concurrent Streams+-- Raw Streams ------------------------------------------------------------------------------- -benchmark linear-async-  import: bench-options-threaded+benchmark Data.Stream.StreamD+  import: bench-options   type: exitcode-stdio-1.0-  ghc-options: -with-rtsopts "-T -N2 -K64K -M16M"-  hs-source-dirs: Streamly/Benchmark/Prelude-  main-is: LinearAsync.hs+  hs-source-dirs: Streamly/Benchmark/Data/Stream+  main-is: StreamD.hs   if impl(ghcjs)     buildable: False   else-    build-depends: lib-prelude     buildable: True -benchmark nested-concurrent-  import: bench-options-threaded+benchmark Data.Stream.StreamK+  import: bench-options   type: exitcode-stdio-1.0-  -- XXX this can be lowered once we split out the finite benchmarks-  ghc-options: -with-rtsopts "-T -N2 -K256K -M128M"-  hs-source-dirs: ., Streamly/Benchmark/Prelude-  main-is: NestedConcurrent.hs-  other-modules: Streamly.Benchmark.Prelude.NestedOps+  hs-source-dirs: Streamly/Benchmark/Data/Stream+  main-is: StreamK.hs+  if impl(ghcjs)+    buildable: False+  else+    buildable: True -benchmark parallel-  import: bench-options-threaded+benchmark Data.Stream.StreamDK+  import: bench-options   type: exitcode-stdio-1.0-  ghc-options: -with-rtsopts "-T -N2 -K128K -M256M"-  hs-source-dirs: Streamly/Benchmark/Prelude-  main-is: Parallel.hs+  hs-source-dirs: Streamly/Benchmark/Data/Stream+  main-is: StreamDK.hs   if impl(ghcjs)     buildable: False   else-    build-depends: lib-prelude     buildable: True -benchmark concurrent+executable nano-bench+  import: bench-options+  hs-source-dirs: .+  main-is: NanoBenchmarks.hs+  if flag(dev)+    buildable: True+  else+    buildable: False++-------------------------------------------------------------------------------+-- Concurrent Streams+-------------------------------------------------------------------------------++benchmark Prelude.Concurrent   import: bench-options-threaded   type: exitcode-stdio-1.0   hs-source-dirs: Streamly/Benchmark/Prelude   main-is: Concurrent.hs-  ghc-options: -with-rtsopts "-T -N2 -K256K -M384M" -benchmark adaptive+benchmark Prelude.Adaptive   import: bench-options-threaded   type: exitcode-stdio-1.0   hs-source-dirs: Streamly/Benchmark/Prelude@@ -392,82 +411,94 @@   else     buildable: True -benchmark linear-rate+benchmark Prelude.Rate   import: bench-options-threaded   type: exitcode-stdio-1.0   hs-source-dirs: Streamly/Benchmark/Prelude-  main-is: LinearRate.hs+  main-is: Rate.hs   if impl(ghcjs)     buildable: False   else-    build-depends: lib-prelude     buildable: True  ------------------------------------------------------------------------------- -- Array Benchmarks ------------------------------------------------------------------------------- -benchmark unpinned-array+benchmark Data.Array   import: bench-options   type: exitcode-stdio-1.0-  ghc-options: -with-rtsopts "-T -K1K -M128M"   hs-source-dirs: .   main-is: Streamly/Benchmark/Data/Array.hs   other-modules: Streamly.Benchmark.Data.ArrayOps+  cpp-options: -DDATA_ARRAY -benchmark prim-array+benchmark Data.Array.Prim   import: bench-options   type: exitcode-stdio-1.0-  ghc-options: -with-rtsopts "-T -K64K -M32M"   hs-source-dirs: .-  main-is: Streamly/Benchmark/Data/Prim/Array.hs-  other-modules: Streamly.Benchmark.Data.Prim.ArrayOps+  main-is: Streamly/Benchmark/Data/Array.hs+  other-modules: Streamly.Benchmark.Data.ArrayOps+  cpp-options: -DDATA_ARRAY_PRIM+  build-depends: primitive -benchmark small-array+benchmark Data.SmallArray   import: bench-options   type: exitcode-stdio-1.0-  ghc-options: -with-rtsopts "-T -K128K -M16M"   hs-source-dirs: .-  main-is: Streamly/Benchmark/Data/SmallArray.hs-  other-modules: Streamly.Benchmark.Data.SmallArrayOps+  main-is: Streamly/Benchmark/Data/Array.hs+  other-modules: Streamly.Benchmark.Data.ArrayOps+  cpp-options: -DDATA_SMALLARRAY -benchmark array+benchmark Data.Array.Prim.Pinned   import: bench-options   type: exitcode-stdio-1.0-  ghc-options: -with-rtsopts "-T -K64K -M128M"   hs-source-dirs: .-  main-is: Streamly/Benchmark/Memory/Array.hs-  other-modules: Streamly.Benchmark.Memory.ArrayOps+  main-is: Streamly/Benchmark/Data/Array.hs+  other-modules: Streamly.Benchmark.Data.ArrayOps+  cpp-options: -DDATA_ARRAY_PRIM_PINNED +benchmark Data.Array.Foreign+  import: bench-options+  type: exitcode-stdio-1.0+  hs-source-dirs: .+  main-is: Streamly/Benchmark/Data/Array.hs+  other-modules: Streamly.Benchmark.Data.ArrayOps+  cpp-options: -DMEMORY_ARRAY+ ---------------------------------------------------------------------------------- FileIO Benchmarks+-- Array Stream Benchmarks ------------------------------------------------------------------------------- -benchmark fileio+benchmark Data.Array.Stream.Foreign   import: bench-options   type: exitcode-stdio-1.0-  hs-source-dirs: .-  main-is: FileIO.hs-  other-modules: Streamly.Benchmark.FileIO.Array-               , Streamly.Benchmark.FileIO.Stream-  build-depends:-                 typed-process       >= 0.2.3 && < 0.3+  hs-source-dirs: Streamly/Benchmark/Data/Array/Stream+  main-is: Foreign.hs+  if impl(ghcjs)+    buildable: False+  else+    buildable: True+    build-depends: exceptions >= 0.8   && < 0.11  ---------------------------------------------------------------------------------- benchmark comparison and presentation+-- FileIO Benchmarks ------------------------------------------------------------------------------- -executable chart-  default-language: Haskell2010-  ghc-options: -Wall-  hs-source-dirs: .-  main-is: Chart.hs-  if flag(dev) && !flag(no-charts) && !impl(ghcjs)-    buildable: True-    build-Depends:-        base >= 4.8 && < 5-      , bench-show >= 0.3 && < 0.4-      , split-      , transformers >= 0.4   && < 0.6-  else-    buildable: False+benchmark FileSystem.Handle+  import: bench-options+  type: exitcode-stdio-1.0+  hs-source-dirs: Streamly/Benchmark/FileSystem+  main-is: Handle.hs+  other-modules:+      Handle.Read+    , Handle.ReadWrite++-------------------------------------------------------------------------------+-- Unicode Benchmarks+-------------------------------------------------------------------------------+benchmark Unicode.Stream+  import: bench-options+  type: exitcode-stdio-1.0+  hs-source-dirs: Streamly/Benchmark/Unicode+  main-is: Stream.hs
+ bin/bench-exec-one.sh view
@@ -0,0 +1,275 @@+#!/usr/bin/env bash++# Environment passed:+# BENCH_EXEC_PATH: the benchmark executable+# RTS_OPTIONS: additional RTS options+# QUICK_MODE: whether we are in quick mode+# USE_GAUGE: whether to use gauge or tasty-bench+# LONG: whether to use a large stream size++set -e+set -o pipefail++# $1: message+die () {+  >&2 echo -e "Error: $1"+  exit 1+}++warn () {+  >&2 echo -e "Warning: $1"+}++test -n "$BENCH_EXEC_PATH" || die "BENCH_EXEC_PATH env var must be set"+test -n "$QUICK_MODE" || warn "QUICK_MODE env var not set (to 0 or 1)"++#------------------------------------------------------------------------------+# RTS Options+#------------------------------------------------------------------------------++# RTS options based on the benchmark executable+bench_exe_rts_opts () {+  case "$1" in+    Prelude.Concurrent*) echo -n "-K256K -M384M" ;;+    *) echo -n "" ;;+  esac+}++# General RTS options for different classes of benchmarks+bench_rts_opts_default () {+  case "$1" in+    */o-1-sp*) echo -n "-K36K -M16M" ;;+    */o-n-h*) echo -n "-K36K -M32M" ;;+    */o-n-st*) echo -n "-K1M -M16M" ;;+    */o-n-sp*) echo -n "-K1M -M32M" ;;+    *) echo -n "" ;;+  esac+}++# Overrides for specific benchmarks+# XXX Note: for tasty-bench we replace the "." separator in the benchmark names+# with "/" for matching with this. It may not work reliably if the benchmark+# name already contains ".".+bench_rts_opts_specific () {+  case "$1" in+    Data.Stream.StreamD/o-n-space/elimination/toList) echo -n "-K2M" ;;+    Data.Stream.StreamK/o-n-space/elimination/toList) echo -n "-K2M" ;;++    Prelude.Parallel/o-n-heap/mapping/mapM) echo -n "-M256M" ;;+    Prelude.Parallel/o-n-heap/monad-outer-product/*) echo -n "-M256M" ;;+    Prelude.Parallel/o-n-space/monad-outer-product/*) echo -n "-K4M -M256M" ;;++    Prelude.Rate/o-1-space/*) echo -n "-K128K" ;;+    Prelude.Rate/o-1-space/asyncly/*) echo -n "-K128K" ;;++    # XXX For GHC-9.0+    Prelude.Serial/o-1-space/mixed/sum-product-fold) echo -n "-K64M" ;;++    # XXX These should be moved to o-n-space?+    Prelude.Serial/o-n-heap/grouping/classifySessionsOf) echo -n "-K1M -M32M" ;;+    Prelude.Serial/o-n-heap/Functor/*) echo -n "-K4M -M32M" ;;+    Prelude.Serial/o-n-heap/transformer/*) echo -n "-K8M -M64M" ;;++    Prelude.Serial/o-n-space/Functor/*) echo -n "-K4M -M64M" ;;+    Prelude.Serial/o-n-space/Applicative/*) echo -n "-K8M -M128M" ;;+    Prelude.Serial/o-n-space/Monad/*) echo -n "-K8M -M64M" ;;++    # Use -K4M for o-n-space except for grouping+    Prelude.Serial/o-n-space/grouping/*) echo -n "" ;;+    Prelude.Serial/o-n-space/*) echo -n "-K4M" ;;++    Prelude.WSerial/o-n-space/*) echo -n "-K4M" ;;++    Prelude.Async/o-n-space/monad-outer-product/*) echo -n "-K4M" ;;+    Prelude.Ahead/o-n-space/monad-outer-product/*) echo -n "-K4M" ;;+    Prelude.Ahead/o-1-space/*) echo -n "-K128K" ;;++    Prelude.WAsync/o-n-heap/monad-outer-product/toNull3) echo -n "-M64M" ;;+    Prelude.WAsync/o-n-space/monad-outer-product/*) echo -n "-K4M" ;;++    # XXX need to investigate these, taking too much stack+    Data.Parser.ParserD/o-1-space/some) echo -n "-K8M" ;;+    Data.Parser/o-1-space/some) echo -n "-K8M" ;;+    Data.Parser.ParserD/o-1-space/manyTill) echo -n "-K4M" ;;+    Data.Parser/o-1-space/manyTill) echo -n "-K4M" ;;+    Data.Parser/o-n-heap/manyAlt) echo -n "-K4M -M128M" ;;+    Data.Parser/o-n-heap/someAlt) echo -n "-K4M -M128M" ;;+    Data.Parser.ParserK/o-n-heap/manyAlt) echo -n "-K4M -M128M" ;;+    Data.Parser.ParserK/o-n-heap/someAlt) echo -n "-K4M -M128M" ;;+    Data.Parser.ParserK/o-n-heap/sequence) echo -n "-M64M";;+    Data.Parser.ParserK/o-n-heap/sequenceA) echo -n "-M64M";;++    Data.SmallArray/o-1-sp*) echo -n "-K128K" ;;+    # For tasty-bench+    Data.Array*/o-1-space/generation/show) echo -n "-M32M" ;;+    # XXX For GHC-8.10+    Data.Array/o-1-space/transformationX4/map) echo -n "-M32M" ;;+    # DEVBUILD only benchmarks - array foldable instance+    Data.Array.Foreign/o-1-space/elimination/foldable/foldl*) echo -n "-K8M" ;;+    Data.Array.Foreign/o-1-space/elimination/foldable/sum) echo -n "-K8M" ;;+    *) echo -n "" ;;+  esac+}++#------------------------------------------------------------------------------+# Speed options+#------------------------------------------------------------------------------++if test "$USE_GAUGE" -eq 0+then+  SUPER_QUICK_OPTIONS="--stdev 1000000"+  QUICKER_OPTIONS="--stdev 100"+else+  # Do not keep time limit as 0 otherwise GC stats may remain 0 in some cases.+  SUPER_QUICK_OPTIONS="--quick --min-duration 0 --time-limit 0.01 --include-first-iter"+  QUICKER_OPTIONS="--min-samples 3 --time-limit 1"+fi++# tasty-bench does not like an option set twice+set_super_quick_mode () {+    echo -n super_quick+}++# For certain long benchmarks if the user has not requested super quick+# mode we anyway use a slightly quicker mode.+use_quicker_mode () {+  if test "$QUICK_MODE" -eq 0+  then+    echo quicker+  fi+}++bench_exe_quick_opts () {+  case "$1" in+    Prelude.Concurrent) set_super_quick_mode ;;+    Prelude.Rate) set_super_quick_mode ;;+    Prelude.Adaptive) set_super_quick_mode;;+    *) echo -n "" ;;+  esac+}++# XXX Note: for tasty-bench we replace the "." separator in the benchmark names+# with "/" for matching with this. It may not work reliably if the benchmark+# name already contains ".".++# Use quick options for benchmarks that take too long+bench_quick_opts () {+  case "$1" in+    Prelude.Parallel/o-n-heap/mapping/mapM) set_super_quick_mode ;;+    Prelude.Parallel/o-n-heap/monad-outer-product/*) set_super_quick_mode ;;+    Prelude.Parallel/o-n-space/monad-outer-product/*) set_super_quick_mode ;;+    Prelude.Parallel/o-n-heap/generation/*) use_quicker_mode ;;+    Prelude.Parallel/o-n-heap/mapping/*) use_quicker_mode ;;+    Prelude.Parallel/o-n-heap/concat-foldable/*) use_quicker_mode ;;++    Prelude.Async/o-1-space/monad-outer-product/*) use_quicker_mode ;;+    Prelude.Async/o-n-space/monad-outer-product/*) use_quicker_mode ;;++    Prelude.Ahead/o-1-space/monad-outer-product/*) use_quicker_mode ;;+    Prelude.Ahead/o-n-space/monad-outer-product/*) use_quicker_mode ;;++    Prelude.WAsync/o-n-heap/monad-outer-product/*) use_quicker_mode ;;+    Prelude.WAsync/o-n-space/monad-outer-product/*) use_quicker_mode ;;++    FileSystem.Handle/*) use_quicker_mode ;;+    *) echo -n "" ;;+  esac+}++bench_output_file() {+    local bench_name=$1+    echo "charts/$bench_name/results.csv"+}++#------------------------------------------------------------------------------+# Determine options from benchmark name+#------------------------------------------------------------------------------++BENCH_NAME_ORIG="$1"+shift++if test "$USE_GAUGE" -eq 0+then+  # XXX this is a hack to make the "/" separated names used in the functions+  # determining options based on benchmark name. For tasty-bench the benchmark+  # names are separated by "." instead of "/".+  BENCH_NAME0=$(echo $BENCH_NAME_ORIG | sed -e s/^All\.//)+  BENCH_NAME1=$(echo $BENCH_NAME0 | cut -f1 -d '/')+  BENCH_NAME2=$(echo $BENCH_NAME0 | cut -f2- -d '/' | sed -e 's/\./\//g')+  BENCH_NAME="$BENCH_NAME1/$BENCH_NAME2"+else+  BENCH_NAME=$BENCH_NAME_ORIG+fi++RTS_OPTIONS=\+"+RTS -T \+$(bench_exe_rts_opts $(basename $BENCH_EXEC_PATH)) \+$(bench_rts_opts_default $BENCH_NAME) \+$(bench_rts_opts_specific $BENCH_NAME) \+$RTS_OPTIONS \+-RTS"++QUICK_MODE_TYPE="\+$(if test "$QUICK_MODE" -ne 0; then set_super_quick_mode; fi) \+$(bench_exe_quick_opts $(basename $BENCH_EXEC_PATH)) \+$(bench_quick_opts $BENCH_NAME)"++for i in $QUICK_MODE_TYPE+do+  case "$i" in+    super_quick) QUICK_BENCH_OPTIONS="$SUPER_QUICK_OPTIONS"; break ;;+    quicker) QUICK_BENCH_OPTIONS="$QUICKER_OPTIONS"; break ;;+  esac+done++if test "$LONG" -ne 0+then+  STREAM_SIZE=10000000+  STREAM_LEN=$(env LC_ALL=en_US.UTF-8 printf "--stream-size %'.f\n" $STREAM_SIZE)+  STREAM_SIZE_OPT="--stream-size $STREAM_SIZE"+fi++echo "$BENCH_NAME_ORIG: \+$RTS_OPTIONS \+$STREAM_LEN \+$QUICK_BENCH_OPTIONS" \+"$@"++#------------------------------------------------------------------------------+# Run benchmark with options and collect results+#------------------------------------------------------------------------------++output_file=$(bench_output_file $(basename $BENCH_EXEC_PATH))+mkdir -p `dirname $output_file`+rm -f ${output_file}.tmp++if test $USE_GAUGE -eq 0+then+  # Escape "\" and double quotes in benchmark names+  BENCH_NAME_ESC=$(echo "$BENCH_NAME_ORIG" | sed -e 's/\\/\\\\/g' | sed -e 's/"/\\"/g')+  $BENCH_EXEC_PATH \+    -j 1 \+    $RTS_OPTIONS \+    $STREAM_SIZE_OPT \+    $QUICK_BENCH_OPTIONS \+    "$@" \+    --csv=${output_file}.tmp \+    -p '$0 == "'"$BENCH_NAME_ESC"'"'++  # Convert cpuTime field from picoseconds to seconds+  awk --version 2>&1 | grep -q "GNU Awk" \+    || die "Need GNU awk. [$(which awk)] is not GNU awk."+  tail -n +2 ${output_file}.tmp | \+    awk 'BEGIN {FPAT = "([^,]+)|(\"[^\"]+\")";OFS=","} {$2=$2/1000000000000;print}' \+    >> $output_file+else+  $BENCH_EXEC_PATH \+    $RTS_OPTIONS \+    $STREAM_SIZE_OPT \+    $QUICK_BENCH_OPTIONS \+    "$@" \+    --csvraw=${output_file}.tmp \+    -m exact "$BENCH_NAME"+  tail -n +2 ${output_file}.tmp \+    >> $output_file+fi
+ bin/bench.sh view
@@ -0,0 +1,475 @@+#!/usr/bin/env bash++set -o pipefail++SCRIPT_DIR=$(cd `dirname $0`; pwd)++RUNNING_BENCHMARKS=y+source $SCRIPT_DIR/build-lib.sh++print_help () {+  echo "Usage: $0 "+  echo "       [--benchmarks <"bench1 bench2 ..." | help>]"+  echo "       [--prefix <benchmark name prefix to match>"+  echo "       [--fields <"field1 field2 ..." | help>]"+  echo "       [--sort-by-name]"+  echo "       [--graphs]"+  echo "       [--no-measure]"+  echo "       [--append]"+  echo "       [--long]"+  echo "       [--slow]"+  echo "       [--quick]"+  echo "       [--raw]"+  echo "       [--dev-build]"+  echo "       [--use-nix]"+  echo "       [--with-compiler <compiler exe name>]"+  echo "       [--cabal-build-options <options>]"+  echo "       [--rtsopts <opts>]"+  echo "       [--compare] [--base <commit>] [--candidate <commit>]"+  echo "       -- <gauge options or benchmarks>"+  echo+  echo "--benchmarks: benchmarks to run, use 'help' for list of benchmarks"+  echo "--fields: measurement fields to report, use 'help' for a list"+  echo "--graphs: Generate graphical reports"+  echo "--no-measure: Don't run benchmarks, run reports from previous results"+  echo "--append: Don't overwrite previous results, append for comparison"+  echo "--long: Use much longer stream size for infinite stream benchmarks"+  echo "--slow: Slightly more accurate results at the expense of speed"+  echo "--quick: Faster results, useful for longer benchmarks"+  echo "--raw: Run the benchmarks but don't report them. This is useful when"+  echo "       you only want to work with the csv files generated."+  echo "--cabal-build-options: Pass any cabal build options to be used for build"+  echo "       e.g. --cabal-build-options \"--flag dev\""+  echo+  echo "When specific space complexity group is chosen then (and only then) "+  echo "RTS memory restrictions are used accordingly. For example, "+  echo "bench.sh --benchmarks Data.Parser -- Data.Parser/o-1-space "+  echo "restricts Heap/Stack space for O(1) characterstics"+  echo+  echo "When using --compare, by default comparative chart of HEAD^ vs HEAD"+  echo "commit is generated, in the 'charts' directory."+  echo "Use --base and --candidate to select the commits to compare."+  echo+  echo "Any arguments after a '--' are passed directly to gauge"+  exit+}++#-----------------------------------------------------------------------------+# Reporting utility functions+#-----------------------------------------------------------------------------++list_comparisons ()  {+  echo "Comparison groups:"+  for i in $COMPARISONS+  do+    echo -n "$i ["+    eval "echo -n \$$i"+    echo "]"+  done+  echo+}++# chart is expensive to build and usually not required to be rebuilt+cabal_which_report() {+    local path="./bin/$1"+    if test -e "$path"+    then+      echo $path+    fi+}++find_report_prog() {+    local prog_name="bench-report"+    hash -r+    local prog_path=$(cabal_which_report $prog_name)+    if test -x "$prog_path"+    then+      echo $prog_path+    else+      return 1+    fi+}++build_report_prog() {+    local prog_name="bench-report"+    local prog_path=$(cabal_which_report $prog_name)++    hash -r+    if test ! -x "$prog_path" -a "$BUILD_ONCE" = "0"+    then+      echo "Building bench-report executables"+      BUILD_ONCE=1+      pushd benchmark/bench-report+      local cmd+      cmd="$CABAL_EXECUTABLE install --installdir ../../bin bench-report"+      if test "$USE_NIX" -eq 0+      then+        $cmd || die "bench-report build failed"+      else+        nix-shell --run "$cmd" || die "bench-report build failed"+      fi+      popd++    elif test ! -x "$prog_path"+    then+      return 1+    fi+    return 0+}++build_report_progs() {+  if test "$RAW" = "0"+  then+      build_report_prog || exit 1+      local prog+      prog=$(find_report_prog) || \+          die "Cannot find bench-report executable"+      echo "Using bench-report executable [$prog]"+  fi+}++# We run the benchmarks in isolation in a separate process so that different+# benchmarks do not interfere with other. To enable that we need to pass the+# benchmark exe path to gauge as an argument. Unfortunately it cannot find its+# own path currently.++# The path is dependent on the architecture and cabal version.++bench_output_file() {+    local bench_name=$1+    echo "charts/$bench_name/results.csv"+}++invoke_gauge () {+    local target_prog="$1"+    local target_name="$2"+    local output_file="$3"++    local MATCH=""+    if test "$LONG" -ne 0+    then+      MATCH="$target_name/o-1-space"+    else+      MATCH="$BENCH_PREFIX"+    fi+    echo "name,iters,time,cycles,cpuTime,utime,stime,maxrss,minflt,majflt,nvcsw,nivcsw,allocated,numGcs,bytesCopied,mutatorWallSeconds,mutatorCpuSeconds,gcWallSeconds,gcCpuSeconds" >> $output_file+    # keep only benchmark names with shortest prefix e.g. "a/b/c" and "a/b", we+    # should only keep "a/b" otherwise benchmarks will run multiple times. why?+    $target_prog -l \+      | grep "^$MATCH" \+      | while read -r name; \+  do bin/bench-exec-one.sh "$name" "${GAUGE_ARGS[@]}" || exit 1; done \+      || die "Benchmark execution failed."+}++invoke_tasty_bench () {+    local target_prog="$1"+    local target_name="$2"+    local output_file="$3"++    local MATCH=""+    if test "$LONG" -ne 0+    then+      MATCH="-p /$target_name\/o-1-space/"+    else+        if test -n "$BENCH_PREFIX"+        then+          # escape "/"+          local escaped_name=$(echo "$BENCH_PREFIX" | sed -e 's/\//\\\//g')+          MATCH="-p /$escaped_name/"+        fi+    fi+    echo "Name,cpuTime,2*Stdev (ps),Allocated,bytesCopied" >> $output_file+    $target_prog -l $MATCH \+      | grep "^All" \+      | while read -r name; \+          do bin/bench-exec-one.sh "$name" "${GAUGE_ARGS[@]}" || exit 1; done \+      || die "Benchmark execution failed."+}++run_bench_target () {+  local package_name=$1+  local component=$2+  local target_name=$3++  local target_prog+  target_prog=$(cabal_target_prog $package_name $component $target_name) || \+    die "Cannot find executable for target $target_name"++  echo "Running executable $target_name ..."++  # Needed by bench-exec-one.sh+  export BENCH_EXEC_PATH=$target_prog+  export RTS_OPTIONS+  export QUICK_MODE+  export USE_GAUGE+  export LONG++  local output_file=$(bench_output_file $target_name)+  mkdir -p `dirname $output_file`+  if test "$USE_GAUGE" -eq 0+  then invoke_tasty_bench "$target_prog" "$target_name" "$output_file"+  else invoke_gauge "$target_prog" "$target_name" "$output_file"+  fi+}++# $1: package name+# $2: component+# $3: targets+run_bench_targets() {+    for i in $3+    do+      run_bench_target $1 $2 $i+    done+}++run_benches_comparing() {+    local bench_list=$1++    if test -z "$CANDIDATE"+    then+      CANDIDATE=$(git rev-parse HEAD)+    fi+    if test -z "$BASE"+    then+      # XXX Should be where the current branch is forked from master+      BASE="$CANDIDATE^"+    fi+    echo "Comparing baseline commit [$BASE] with candidate [$CANDIDATE]"+    echo "Checking out base commit [$BASE] for benchmarking"+    git checkout "$BASE" || die "Checkout of base commit [$BASE] failed"++    $BUILD_BENCH || die "build failed"+    run_bench_targets streamly-benchmarks b "$bench_list" target_exe_extra_args++    echo "Checking out candidate commit [$CANDIDATE] for benchmarking"+    git checkout "$CANDIDATE" || \+        die "Checkout of candidate [$CANDIDATE] commit failed"++    $BUILD_BENCH || die "build failed"+    run_bench_targets streamly-benchmarks b "$bench_list" target_exe_extra_args+    # XXX reset back to the original commit+}++backup_output_file() {+  local bench_name=$1+  local output_file=$(bench_output_file $bench_name)++  if test -e $output_file -a "$APPEND" != 1+  then+      mv -f -v $output_file ${output_file}.prev+  fi+}++run_measurements() {+  local bench_list=$1++  for i in $bench_list+  do+      backup_output_file $i+  done++  if test "$COMPARE" = "0"+  then+    run_bench_targets streamly-benchmarks b "$bench_list" target_exe_extra_args+  else+    run_benches_comparing "$bench_list"+  fi+}++run_reports() {+    local prog+    prog=$(find_report_prog) || \+      die "Cannot find bench-graph executable"+    echo++    for i in $1+    do+        echo "Generating reports for ${i}..."+        $prog \+            --benchmark $i \+            $(test "$GRAPH" = 1 && echo "--graphs") \+            $(test "$SORT_BY_NAME" = 1 && echo "--sort-by-name") \+            --fields "$FIELDS"+    done+}++#-----------------------------------------------------------------------------+# Execution starts here+#-----------------------------------------------------------------------------++cd $SCRIPT_DIR/..++USE_GAUGE=0+USE_GIT_CABAL=1+USE_NIX=0+set_common_vars++DEFAULT_FIELDS="allocated bytescopied cputime"+ALL_FIELDS="$FIELDS time cycles utime stime minflt majflt nvcsw nivcsw"+FIELDS=$DEFAULT_FIELDS++COMPARE=0+BASE=+CANDIDATE=++APPEND=0+LONG=0+RAW=0+SORT_BY_NAME=0+GRAPH=0+MEASURE=1++GAUGE_ARGS=+BUILD_ONCE=0++CABAL_BUILD_OPTIONS="--flag fusion-plugin "++#-----------------------------------------------------------------------------+# Read command line+#-----------------------------------------------------------------------------++while test -n "$1"+do+  case $1 in+    -h|--help|help) print_help ;;+    # options with arguments+    --benchmarks) shift; TARGETS=$1; shift ;;+    --targets) shift; TARGETS=$1; shift ;;+    --prefix) shift; BENCH_PREFIX="$1"; shift ;;+    --fields) shift; FIELDS=$1; shift ;;+    --base) shift; BASE=$1; shift ;;+    --candidate) shift; CANDIDATE=$1; shift ;;+    --with-compiler) shift; CABAL_WITH_COMPILER=$1; shift ;;+    --cabal-build-flags) shift; CABAL_BUILD_OPTIONS+=$1; shift ;;+    --cabal-build-options) shift; CABAL_BUILD_OPTIONS+=$1; shift ;;+    --rtsopts) shift; RTS_OPTIONS=$1; shift ;;+    # flags+    --slow) SLOW=1; shift ;;+    --quick) QUICK_MODE=1; shift ;;+    --compare) COMPARE=1; shift ;;+    --raw) RAW=1; shift ;;+    --append) APPEND=1; shift ;;+    --long) LONG=1; shift ;;+    --sort-by-name) SORT_BY_NAME=1; shift ;;+    --graphs) GRAPH=1; shift ;;+    --no-measure) MEASURE=0; shift ;;+    --dev-build) RUNNING_DEVBUILD=1; shift ;;+    --use-nix) USE_NIX=1; shift ;;+    --use-gauge) USE_GAUGE=1; shift ;;+    --) shift; break ;;+    *) echo "Unknown flags: $*"; echo; print_help ;;+  esac+done+GAUGE_ARGS=("$@")++set_derived_vars++#-----------------------------------------------------------------------------+# Determine targets+#-----------------------------------------------------------------------------++only_real_benchmarks () {+  for i in $TARGETS+  do+    local SKIP=0+    for j in $COMPARISONS+    do+      if test $i == $j+      then+        SKIP=1+      fi+    done+    if test "$SKIP" -eq 0+    then+      echo -n "$i "+    fi+  done+}++# Requires RUNNING_DEVBUILD var+source $SCRIPT_DIR/targets.sh++if test "$(has_item "$TARGETS" help)" = "help"+then+  list_target_groups+  list_comparisons+  list_targets+  exit+fi++if test "$(has_item "$FIELDS" help)" = "help"+then+  echo "Supported fields: $ALL_FIELDS"+  echo "Default fields: $DEFAULT_FIELDS"+  exit+fi++if test "$LONG" -ne 0+then+  if test -n "$TARGETS"+  then+    echo "Cannot specify benchmarks [$TARGETS] with --long"+    exit+  fi+  TARGETS=$infinite_grp+fi++DEFAULT_TARGETS="$(all_grp)"+TARGETS=$(set_targets)++TARGETS_ORIG=$TARGETS+TARGETS=$(only_real_benchmarks)++echo "Using benchmark suites [$TARGETS]"++#-----------------------------------------------------------------------------+# Build reporting utility+#-----------------------------------------------------------------------------++# We need to build the report progs first at the current (latest) commit before+# checking out any other commit for benchmarking.+build_report_progs++#-----------------------------------------------------------------------------+# Build and run targets+#-----------------------------------------------------------------------------++if test "$USE_GAUGE" -eq 1+then+  BUILD_FLAGS="--flag use-gauge"+fi++BUILD_BENCH="$CABAL_EXECUTABLE v2-build $BUILD_FLAGS $CABAL_BUILD_OPTIONS --enable-benchmarks"+if test "$MEASURE" = "1"+then+  run_build "$BUILD_BENCH" streamly-benchmarks bench "$TARGETS"+  run_measurements "$TARGETS"+fi++#-----------------------------------------------------------------------------+# Run reports+#-----------------------------------------------------------------------------++COMPARISON_REPORTS=""+for i in $COMPARISONS+do+  if test "$(has_item "$TARGETS_ORIG" $i)" = $i+  then+    COMPARISON_REPORTS="$COMPARISON_REPORTS $i"+    mkdir -p "charts/$i"+    constituents=$(eval "echo -n \$${i}")+    dest_file="charts/$i/results.csv"+    : > $dest_file+    for j in $constituents+    do+      cat "charts/$j/results.csv" >> $dest_file+    done+  fi+done++if test "$RAW" = "0"+then+  run_reports "$TARGETS"+  run_reports "$COMPARISON_REPORTS"+fi
+ bin/build-lib.sh view
@@ -0,0 +1,246 @@+# $1: message+die () {+  >&2 echo -e "Error: $1"+  exit 1+}++# $1: command+function run_verbose() {+  echo "$*"+  bash -c "$*"+}++has_item () {+  for i in $1+  do+    if test "$i" = "$2"+    then+      echo "$i"+      break+    fi+  done+}++#------------------------------------------------------------------------------+# target groups+#------------------------------------------------------------------------------++test_only () {+  if test -n "$RUNNING_TESTS"+  then+    echo $1+  fi+}++bench_only () {+  if test -n "$RUNNING_BENCHMARKS"+  then+    echo $1+  fi+}++dev_build () {+  if test -n "$RUNNING_DEVBUILD"+  then+    echo $1+  fi+}++# A group consisting of all known individual targets+all_grp () {+  { for i in $GROUP_TARGETS+    do+      for j in $(eval "echo \$$i")+      do+        echo $j+      done+    done+    for i in $INDIVIDUAL_TARGETS+    do+      echo $i+    done+  } | sort | uniq+}++# All groups+all_target_groups () {+  echo $GROUP_TARGETS+}++# XXX pass as arg+list_targets ()  {+  echo "Individual targets:"+  for i in $(all_grp)+  do+    echo "$i"+  done+  echo+}++# XXX pass as arg+list_target_groups ()  {+  echo "All Targets: all_grp"+  echo "Target groups:"+  for i in $(all_target_groups)+  do+    echo -n "$i ["+    eval "echo -n \$$i"+    echo "]"+  done+  echo+}++# XXX pass as arg+set_targets() {+  if test -z "$TARGETS"+  then+    echo $DEFAULT_TARGETS+  else+    for i in $(echo $TARGETS)+    do+        case $i in+          *_grp) eval "echo -n \$${i}" ;;+          *_cmp) eval "echo -n \$${i} $i" ;;+          *) echo -n $i ;;+        esac+        echo -n " "+    done+  fi+}++# We run the benchmarks in isolation in a separate process so that different+# benchmarks do not interfere with other. To enable that we need to pass the+# benchmark exe path to gauge as an argument. Unfortunately it cannot find its+# own path currently.++# The path is dependent on the architecture and cabal version.++# $1: package name+# $2: component+# $3: target+cabal_target_prog () {+  local target_prog=`cabal_which $1 $2 $3`+  if test -x "$target_prog"+  then+    echo $target_prog+  else+    return 1+  fi+}++set_common_vars () {+  SLOW=0+  QUICK_MODE=0++  RUNNING_DEVBUILD=++  TARGET_EXE_ARGS=+  RTS_OPTIONS=++  CABAL_BUILD_OPTIONS=""+  CABAL_EXECUTABLE=cabal++  # Use branch specific builds if git-cabal is present in PATH+  BUILD_DIR=dist-newstyle+  if test "$USE_GIT_CABAL" -eq 1+  then+    if which git-cabal 2>/dev/null+    then+        echo "Using git-cabal for branch specific builds"+        CABAL_EXECUTABLE=git-cabal+        BUILD_DIR=$(git-cabal show-builddir)+      fi+  fi+}++# To be called after parsing CLI arguments+set_derived_vars () {+  if test -n "$CABAL_WITH_COMPILER"+  then+    CABAL_BUILD_OPTIONS+=" --with-compiler $CABAL_WITH_COMPILER"+  else+    CABAL_WITH_COMPILER=ghc+  fi++  GHC_VERSION=$($CABAL_WITH_COMPILER --numeric-version)+}++# XXX cabal issue "cabal v2-exec which" cannot find benchmark/test executables++# $1: builddir+# $2: package name+# $3: component ("" (lib), t (test), b (benchmark), x (executable))+# $4: command to find+cabal_which_builddir() {+  local path=$(echo $1/build/*/ghc-${GHC_VERSION}/${2}-0.0.0/$3/$4/build/$4/$4)+  test -f "$path" && echo $path+}++# $1: package name+# $2: component+# $3: command to find+cabal_which() {+  cabal_which_builddir $BUILD_DIR $1 $2 $3+}++# $1: build program+# $2: package name+# $3: component prefix+# $4: targets+run_build () {+  local build_prog=$1+  local package=$2+  local component_prefix=$3+  local COMPONENTS+  local c++  for c in $4+  do+    COMPONENTS+="$package:$component_prefix:$c "+  done+  run_verbose $build_prog $COMPONENTS || die "build failed"+}++# $1: target name+get_tix_file () {+  echo $BUILD_DIR/build/$SYSTEM/ghc-${GHC_VERSION}/$PACKAGE_FULL_NAME/hpc/vanilla/tix/$1/$1.tix+}++# $1: package name+# $2: component+# $3: target+# $4: args generator func+run_target () {+  local package_name=$1+  local component=$2+  local target_name=$3+  local extra_args=$4++  local target_prog+  target_prog=$(cabal_target_prog $package_name $component $target_name) || \+    die "Cannot find executable for target $target_name"++  echo "Running executable $target_name ..."++  # Needed by bench-exec-one.sh+  export BENCH_EXEC_PATH=$target_prog+  mkdir -p $(dirname $(get_tix_file $target_name))+  export HPCTIXFILE=$(get_tix_file $target_name)++  run_verbose $target_prog $($extra_args $target_name $target_prog) \+    || die "Target exe failed"++  # hpc-coveralls fails if there is an empty dir and no .tix file generated+  rmdir $(dirname $(get_tix_file $target_name)) 2>/dev/null || true+}++# $1: package name+# $2: component+# $3: targets+# $4: args generator func+run_targets() {+    for i in $3+    do+      run_target $1 $2 $i $4+    done+}
+ bin/ghc.sh view
@@ -0,0 +1,45 @@+#!/bin/bash++ghc -Wall                            \+    -Wcompat                         \+    -Wunrecognised-warning-flags     \+    -Widentities                     \+    -Wincomplete-record-updates      \+    -Wincomplete-uni-patterns        \+    -Wredundant-constraints          \+    -Wnoncanonical-monad-instances   \+    -Rghc-timing                     \+    -XBangPatterns                   \+    -XCApiFFI                        \+    -XCPP                            \+    -XConstraintKinds                \+    -XDeriveDataTypeable             \+    -XDeriveGeneric                  \+    -XDeriveTraversable              \+    -XExistentialQuantification      \+    -XFlexibleContexts               \+    -XFlexibleInstances              \+    -XGeneralizedNewtypeDeriving     \+    -XInstanceSigs                   \+    -XKindSignatures                 \+    -XLambdaCase                     \+    -XMagicHash                      \+    -XMultiParamTypeClasses          \+    -XPatternSynonyms                \+    -XRankNTypes                     \+    -XRecordWildCards                \+    -XScopedTypeVariables            \+    -XTupleSections                  \+    -XTypeFamilies                   \+    -XViewPatterns                   \+    -XNoMonoLocalBinds               \+    -XTypeApplications               \+    -XQuantifiedConstraints          \+    -O2                              \+    -fdicts-strict                   \+    -fspec-constr-recursive=16       \+    -fmax-worker-args=16             \+    -fplugin Fusion.Plugin           \+    -ddump-to-file                   \+    -ddump-simpl                     \+    $*
+ bin/mk-hscope.sh view
@@ -0,0 +1,46 @@+#!/usr/bin/env bash++GHC_VERSION=8.10.4+STREAMLY_VERSION=0.8.0++case `uname` in+  Darwin) SYSTEM=x86_64-osx;;+  Linux) SYSTEM=x86_64-linux;;+  *) echo "Unsupported system"; exit 1 ;;+esac++pushd $(git rev-parse --show-toplevel)+git ls-files \+  | grep '\.l\?hs$' \+  | xargs hscope -b \+    -I src/ \+    -I test \+    -I dist-newstyle/build/$SYSTEM/ghc-$GHC_VERSION/streamly-$STREAMLY_VERSION/build/src/ \+    -X BangPatterns \+    -X CApiFFI \+    -X CPP \+    -X ConstraintKinds \+    -X DeriveDataTypeable \+    -X DeriveGeneric \+    -X DeriveTraversable \+    -X ExistentialQuantification \+    -X FlexibleContexts \+    -X FlexibleInstances \+    -X GeneralizedNewtypeDeriving \+    -X InstanceSigs \+    -X KindSignatures \+    -X LambdaCase \+    -X MagicHash \+    -X MultiParamTypeClasses \+    -X PatternSynonyms \+    -X RankNTypes \+    -X RecordWildCards \+    -X ScopedTypeVariables \+    -X TupleSections \+    -X TypeFamilies \+    -X ViewPatterns \+    -X NoMonoLocalBinds \+    -X TemplateHaskell \+    -X UnboxedTuples \+    -X UndecidableInstances+popd
+ bin/mk-tags.sh view
@@ -0,0 +1,25 @@+#!/bin/sh++HSCOPE_DIR=$HOME/.hscope+CODEX_CONFIG=$HOME/.codex++if test -e $CODEX_CONFIG+then+  echo "Please move or remove $CODEX_CONFIG and then run again"+  exit 1+fi++# XXX it does not seem to include the current project anyway+cat << EOF > $CODEX_CONFIG+currentProjectIncluded: true+hackagePath: $HSCOPE_DIR/packages/hackage.haskell.org/+tagsFileHeader: true+tagsFileName: tags+tagsFileSorted: true+tagsCmd: hasktags --ctags --follow-symlinks --output="\$TAGS" "\$SOURCES"+EOF++# XXX depends on cabal configure, does not seem to be supporting new cabal+# XXX it depends in the hackage index tar file in ~/.cabal+codex update --force+rm -f $CODEX_CONFIG
+ bin/run-ci.sh view
@@ -0,0 +1,250 @@+#!/usr/bin/env bash++# See dev/ci-tests.md++# TODO: (1) Detect if nix is available otherwise run with plain cabal,+# (2) Detect the platform and run tests applicable to the platform, (3)+# add a test for windows/msys++SCRIPT_DIR=$(cd `dirname $0`; pwd)+source $SCRIPT_DIR/build-lib.sh++#------------------------------------------------------------------------------+# Prime version (GHC 8.10)+#------------------------------------------------------------------------------++GHC_PRIME=ghc8104+GHC_PRIME_VER="8.10"++ghc_prime_dist () {+  nix-shell \+    --argstr compiler "$GHC_PRIME" \+    --run "\+      packcheck.sh cabal-v2 \+      GHCVER=$GHC_PRIME_VER \+      CABAL_DISABLE_DEPS=y \+      CABAL_CHECK_RELAX=y"+}++# build-all, Werror, test, inspection, fusion-plugin. Note, inspection+# requires fusion-plugin.++PERF_FLAGS="--flag inspection --flag fusion-plugin"++ghc_prime_perf () {+  nix-shell \+    --argstr compiler "$GHC_PRIME" \+    --argstr c2nix "--flag inspection" \+    --run "\+      bin/bench.sh --cabal-build-options \+        \"--project-file cabal.project.Werror $PERF_FLAGS\" --quick --raw;\+      bin/test.sh --cabal-build-options \+        \"--project-file cabal.project.Werror $PERF_FLAGS\";"+}++ghc_prime_O0 () {+  nix-shell \+    --argstr compiler "$GHC_PRIME" \+    --run "\+      bin/test.sh --cabal-build-options \+        \"--project-file cabal.project.O0\""+}++#------------------------------------------------------------------------------+# Check warnings, docs+#------------------------------------------------------------------------------++# XXX avoid rebuilding if nothing has changed in the source+# XXX run hlint only on changed files+lint () {+  packcheck cabal \+    HLINT_OPTIONS="lint --cpp-include=src --cpp-include=test"  \+    HLINT_TARGETS="src test benchmark"+}++Werror () {+  nix-shell \+    --argstr compiler "$GHC_PRIME" \+    --run "cabal build --project-file cabal.project.Werror-nocode all"+}++ghc_prime_werror () {+  nix-shell \+    --argstr compiler "$GHC_PRIME" \+    --run "cabal build --project-file cabal.project.Werror all"+}++ghc_prime_doctests () {+  nix-shell \+    --argstr compiler "$GHC_PRIME" \+    --run "cabal build --project-file cabal.project.doctest all"+  cabal-docspec --timeout 60+}++#------------------------------------------------------------------------------+# coverage+#------------------------------------------------------------------------------++# To upload the results to coveralls.io using hpc-coveralls+# hpc-coveralls --repo-token="$REPO_TOKEN" --coverage-mode=StrictlyFullLines++ghc_prime_coverage () {+  nix-shell \+    --argstr compiler "$GHC_PRIME" \+    --run "bin/test.sh --coverage"+}++#------------------------------------------------------------------------------+# Flags+#------------------------------------------------------------------------------++ghc_prime_dev () {+  nix-shell \+    --argstr compiler "$GHC_PRIME" \+    --run "bin/test.sh --cabal-build-options \"--flag dev\""+}++ghc_prime_c_malloc () {+  nix-shell \+    --argstr compiler "$GHC_PRIME" \+    --run "bin/test.sh --cabal-build-options \"--flag use-c-malloc\""+}++ghc_prime_debug () {+  nix-shell \+    --argstr compiler "$GHC_PRIME" \+    --run "bin/test.sh --cabal-build-options \"--flag debug\""+}++ghc_prime_streamk () {+  nix-shell \+    --argstr compiler "$GHC_PRIME" \+    --run "bin/test.sh --cabal-build-options \"--flag streamk\""+}++#------------------------------------------------------------------------------+# Other GHC versions+#------------------------------------------------------------------------------++# build-all only+# $1 883+# $2 8.8.3+ghc () {+  nix-shell \+    --argstr compiler "ghc$1" \+    --run "\+      packcheck.sh cabal-v2 \+      GHCVER=$2 \+      CABAL_DISABLE_DEPS=y \+      CABAL_CHECK_RELAX=y \+      DISABLE_SDIST_BUILD=y \+      DISABLE_TEST=y \+      DISABLE_DOCS=y"+}++ghc901 () { ghc 901 9.0.1; }+ghc884 () { ghc 884 8.8.4; }++#------------------------------------------------------------------------------+# GHC Head+#------------------------------------------------------------------------------++ghcHEAD () {+  nix-shell \+    --argstr compiler "ghcHEAD" \+    --run "\+      packcheck.sh cabal-v2 \+      GHCVER=9.3 \+      CABAL_CHECK_RELAX=y \+      DISABLE_SDIST_BUILD=y \+      CABAL_BUILD_OPTIONS=\"--allow-newer --project-file cabal.project.ghc-head"+}++#------------------------------------------------------------------------------+# ghcjs+#------------------------------------------------------------------------------++ghcjs () {+      export PATH=~/.local/bin:/opt/ghc/bin:/opt/ghcjs/bin:/usr/local/bin:/usr/bin:/bin:/usr/sbin:/sbin:$PATH+      packcheck.sh cabal-v2 \+        GHCVER=8.4.0 \+        CABAL_CHECK_RELAX=y \+        DISABLE_SDIST_BUILD=y \+        DISABLE_TEST=y \+        DISABLE_DOCS=y \+        ENABLE_GHCJS=y+}++#-----------------------------------------------------------------------------+# Read command line+#-----------------------------------------------------------------------------++ALL_TARGETS="\+ghc_prime_dist \+ghc_prime_perf \+ghc_prime_O0 \+ghc_prime_Werror \+ghc_prime_doctests \+ghc_prime_coverage \+ghc_prime_dev \+ghc_prime_c_malloc \+ghc_prime_debug \+ghc_prime_streamk \+ghc901 \+ghc884 \+ghcHEAD \+ghcjs \+lint \+Werror"++print_targets () {+  echo "Available targets: all $ALL_TARGETS"+}++print_help () {+  echo "Usage: $0 --targets <space separated target names>"+  print_targets+  exit+}++while test -n "$1"+do+  case $1 in+    -h|--help|help) print_help ;;+    # options with arguments+    --targets) shift; TARGETS=$1; shift ;;+    --) shift; break ;;+    -*|--*) echo "Unknown flags: $*"; echo; print_help ;;+    *) break ;;+  esac+done++if test -z "$TARGETS"+then+  print_help+fi++for i in "$TARGETS"+do+  if test "$(has_item "$ALL_TARGETS" $i)" != "$i"+  then+    echo "Unrecognized target: $i"+    print_help+  fi+done++if test "$(has_item "$TARGETS" help)" = "help"+then+  print_targets+  exit+fi++if test "$(has_item "$TARGETS" all)" = "all"+then+  TARGETS="$ALL_TARGETS"+fi++for i in $TARGETS+do+    $i || { echo "$i failed."; exit 1; }+done
+ bin/targets.sh view
@@ -0,0 +1,112 @@+#------------------------------------------------------------------------------+# test and benchmark groups+#------------------------------------------------------------------------------++# IMPORTANT NOTE: the names "_grp" and "_cmp" suffixes are special, do+# not rename them to something else.++base_stream_grp="\+  `bench_only Data.Stream.StreamD` \+  `bench_only Data.Stream.StreamK` \+  `bench_only Data.Stream.StreamDK`"++prelude_serial_grp="\+  Prelude.Serial \+  Prelude.WSerial \+  Prelude.ZipSerial"++prelude_concurrent_grp="\+  Prelude.Async \+  Prelude.WAsync \+  Prelude.Ahead \+  Prelude.Parallel \+  Prelude.ZipAsync"+++prelude_other_grp="\+  `test_only Prelude` \+  $(test_only $(dev_build Prelude.Rate)) \+  `bench_only Prelude.Rate` \+  `test_only Prelude.Fold` \+  `test_only Prelude.Concurrent` \+  $(bench_only $(dev_build Prelude.Concurrent)) \+  `bench_only Prelude.Adaptive`"++array_grp="\+  Data.Array \+  Data.Array.Foreign \+  Data.Array.Prim \+  Data.SmallArray \+  Data.Array.Prim.Pinned"++base_parser_grp="\+  Data.Parser.ParserD \+  `bench_only Data.Parser.ParserK`"++parser_grp="\+  Data.Fold \+  Data.Parser"++list_grp="\+  `test_only Data.List.Base` \+  `test_only Data.List`"++#------------------------------------------------------------------------------+# Streaming vs non-streaming+#------------------------------------------------------------------------------+# The "o-1-space" groups of these benchmarks are run with long stream+# sizes when --long option is used.++infinite_grp="\+  $prelude_serial_grp \+  $prelude_concurrent_grp \+  `bench_only Prelude.Rate`"++#------------------------------------------------------------------------------+# Benchmark comparison groups+#------------------------------------------------------------------------------++# *_cmp denotes a comparison benchmark, the benchmarks provided in *_cmp+# variables are compared with each other+base_stream_cmp="Data.Stream.StreamD Data.Stream.StreamK"+serial_wserial_cmp="Prelude.Serial Prelude.WSerial"+serial_async_cmp="Prelude.Serial Prelude.Async"+concurrent_cmp="Prelude.Async Prelude.WAsync Prelude.Ahead Prelude.Parallel"+array_cmp="Memory.Array Data.Array.Prim Data.Array Data.Array.Prim.Pinned"+pinned_array_cmp="Memory.Array Data.Array.Prim.Pinned"+base_parser_cmp=$base_parser_grp++COMPARISONS="\+  base_stream_cmp \+  serial_wserial_cmp \+  serial_async_cmp \+  concurrent_cmp \+  array_cmp \+  pinned_array_cmp \+  base_parser_cmp"++#------------------------------------------------------------------------------+# All test/benchmark modules must be in at least one of these+#------------------------------------------------------------------------------++# All groups+GROUP_TARGETS="\+    base_stream_grp \+    prelude_serial_grp \+    prelude_concurrent_grp \+    prelude_other_grp \+    array_grp \+    base_parser_grp \+    parser_grp \+    list_grp  \+    infinite_grp"++# Not in any groups+INDIVIDUAL_TARGETS="\+    Data.Unfold \+    Unicode.Stream \+    FileSystem.Handle \+    `test_only FileSystem.Event` \+    `test_only Network.Socket` \+    `test_only Network.Inet.TCP` \+    `test_only version-bounds`"
+ bin/test.sh view
@@ -0,0 +1,185 @@+#!/usr/bin/env bash++STREAMLY_VERSION=0.8.0++#------------------------------------------------------------------------------+# Script+#------------------------------------------------------------------------------++SCRIPT_DIR=$(dirname $0)++print_help () {+  echo "Usage: $0 "+  echo "       [--targets <"target1 target2 ..." | help>]"+  echo "       [--with-compiler <compiler exe name>]"+  echo "       [--cabal-build-options <option>]"+  echo "       [--dev-build]"+  echo "       [--coverage]"+  echo "       [--hpc-report-options <option>]"+  echo "       [--no-measure]"+  echo "       [--raw]"+  echo "       [--rtsopts <option>]"+  echo "       -- <hspec options or test names>"+  echo+  echo "--targets: targets to run, use 'help' for list of targets"+  echo "--cabal-build-options: Pass any cabal build options to be used for build"+  echo "--dev-build: runs some additional tests"+  echo "--coverage: enable coverage and report coverage info"+  echo "--hpc-report-options: option for 'hpc report'"+  echo "--no-measure: with --coverage, do not run tests, only show coverage info"+  echo "--raw: with --coverage, do not run hpc"+  echo "--rtsopts: pass GHC RTS options to the test executable"+  echo+  echo "Any arguments after a '--' are passed directly to hspec"+  exit+}++#-----------------------------------------------------------------------------+# Read command line+#-----------------------------------------------------------------------------++RUNNING_TESTS=y+source $SCRIPT_DIR/build-lib.sh++USE_GIT_CABAL=1+set_common_vars+COVERAGE=0+MEASURE=1+HPC_REPORT_OPTIONS=+RAW=0++# XXX add a bisect option+while test -n "$1"+do+  case $1 in+    -h|--help|help) print_help ;;+    # options with arguments+    --targets) shift; TARGETS=$1; shift ;;+    --with-compiler) shift; CABAL_WITH_COMPILER=$1; shift ;;+    --cabal-build-options) shift; CABAL_BUILD_OPTIONS=$1; shift ;;+    --hpc-report-options) shift; HPC_REPORT_OPTIONS=$1; shift ;;+    --rtsopts) shift; RTS_OPTIONS=$1; shift ;;+    # flags+    --raw) RAW=1; shift ;;+    #--slow) SLOW=1; shift ;; # not implemented+    #--quick) QUICK_MODE=1; shift ;; # not implemented+    --dev-build) RUNNING_DEVBUILD=1; shift ;;+    --coverage) COVERAGE=1; shift ;;+    --no-measure) MEASURE=0; shift ;;+    --) shift; break ;;+    -*|--*) echo "Unknown flags: $*"; echo; print_help ;;+    *) break ;;+  esac+done+TARGET_EXE_ARGS=$*++set_derived_vars++#-----------------------------------------------------------------------------+# Determine targets+#-----------------------------------------------------------------------------++# Requires RUNNING_DEVBUILD var+source $SCRIPT_DIR/targets.sh++if test "$(has_item "$TARGETS" help)" = "help"+then+  list_target_groups+  list_targets+  exit+fi++DEFAULT_TARGETS="$(all_grp)"+TARGETS=$(set_targets)++echo "Using targets [$TARGETS]"++#-----------------------------------------------------------------------------+# Build targets+#-----------------------------------------------------------------------------++test_exe_rts_opts () {+  case "$1" in+    # XXX Data.Array.* heap requirement increased for GHC-8.10+    Data.Array.Foreign) echo -n "-M128M" ;;+    Data.Array.Prim) echo -n "-M128M" ;;+    Data.Array.Prim.Pinned) echo -n "-M128M" ;;+    # For -O0 case writeChunks test fails, maybe we should have a separate flag+    # for O0 case?+    FileSystem.Handle) echo -n "-K16M" ;;+    *) if test "$COVERAGE" -eq "1"+       then+          echo -n "-K8M -M1024M"+        else+          echo -n "-K8M -M64M"+       fi ;;+  esac+}++# $1: bench name+# $2: bench executable+target_exe_extra_args () {+  local bench_name=$1+  local bench_prog=$2++  echo "+RTS \+    $(test_exe_rts_opts $(basename $bench_prog)) \+    $RTS_OPTIONS \+    -RTS"+}++if test "$COVERAGE" -eq "1"+then+  # Used to determine the hpc tix dir+  PACKAGE_FULL_NAME=streamly-$STREAMLY_VERSION+  case `uname` in+    Linux) SYSTEM=x86_64-linux ;;+    *) echo "Unsupported system"; exit 1 ;;+  esac++  # With the --enable-coverage option the tests as well as the library get+  # compiled with -fhpc, and we get coverage for tests as well. But we want to+  # exclude that, so a project file is needed.+  CABAL_BUILD_OPTIONS+=" --project-file cabal.project.coverage"+  mkdir -p $BUILD_DIR/hpc+fi+BUILD_TEST="$CABAL_EXECUTABLE v2-build $CABAL_BUILD_OPTIONS --enable-tests"++if test "$MEASURE" -eq "1"+then+run_build "$BUILD_TEST" streamly-tests test "$TARGETS"+fi++#-----------------------------------------------------------------------------+# Run targets+#-----------------------------------------------------------------------------++if test "$MEASURE" -eq "1"+then+run_targets streamly-tests t "$TARGETS" target_exe_extra_args+fi++#-----------------------------------------------------------------------------+# Run coverage reports+#-----------------------------------------------------------------------------++PACKAGE_NAME=streamly-$STREAMLY_VERSION+MIX_DIR=$BUILD_DIR/build/$SYSTEM/ghc-${GHC_VERSION}/$PACKAGE_NAME/hpc/vanilla/mix/$PACKAGE_NAME/+ALLTIX=$BUILD_DIR/hpc/all.tix++if test "$COVERAGE" -eq "1" -a "$RAW" -eq 0+then+  TIXFILES=+  for i in $TARGETS+  do+    tixfile="$(get_tix_file ${i})"+    if test -f "$tixfile"+    then+      TIXFILES+="$tixfile "+    fi+  done++  hpc sum --output=$ALLTIX $TIXFILES+  run_verbose hpc markup $ALLTIX --hpcdir $MIX_DIR+  run_verbose hpc report $ALLTIX $HPC_REPORT_OPTIONS --hpcdir $MIX_DIR+fi
configure view
@@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles.-# Generated by GNU Autoconf 2.71 for streamly 0.7.3.2.+# Generated by GNU Autoconf 2.71 for streamly 0.8.0. # # Report bugs to <streamly@composewell.com>. #@@ -610,10 +610,10 @@ # Identity of this package. PACKAGE_NAME='streamly' PACKAGE_TARNAME='streamly'-PACKAGE_VERSION='0.7.3.2'-PACKAGE_STRING='streamly 0.7.3.2'+PACKAGE_VERSION='0.8.0'+PACKAGE_STRING='streamly 0.8.0' PACKAGE_BUGREPORT='streamly@composewell.com'-PACKAGE_URL=''+PACKAGE_URL='https://streamly.composewell.com'  # Factoring default headers for most tests. ac_includes_default="\@@ -1256,7 +1256,7 @@   # Omit some internal or obsolete options to make the list less imposing.   # This message is too long to be a string in the A/UX 3.1 sh.   cat <<_ACEOF-\`configure' configures streamly 0.7.3.2 to adapt to many kinds of systems.+\`configure' configures streamly 0.8.0 to adapt to many kinds of systems.  Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1318,7 +1318,7 @@  if test -n "$ac_init_help"; then   case $ac_init_help in-     short | recursive ) echo "Configuration of streamly 0.7.3.2:";;+     short | recursive ) echo "Configuration of streamly 0.8.0:";;    esac   cat <<\_ACEOF @@ -1340,6 +1340,7 @@ it to find libraries and programs with nonstandard names/locations.  Report bugs to <streamly@composewell.com>.+streamly home page: <https://streamly.composewell.com>. _ACEOF ac_status=$? fi@@ -1403,7 +1404,7 @@ test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then   cat <<\_ACEOF-streamly configure 0.7.3.2+streamly configure 0.8.0 generated by GNU Autoconf 2.71  Copyright (C) 2021 Free Software Foundation, Inc.@@ -1456,6 +1457,58 @@  } # ac_fn_c_try_compile +# ac_fn_check_decl LINENO SYMBOL VAR INCLUDES EXTRA-OPTIONS FLAG-VAR+# ------------------------------------------------------------------+# Tests whether SYMBOL is declared in INCLUDES, setting cache variable VAR+# accordingly. Pass EXTRA-OPTIONS to the compiler, using FLAG-VAR.+ac_fn_check_decl ()+{+  as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack+  as_decl_name=`echo $2|sed 's/ *(.*//'`+  { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether $as_decl_name is declared" >&5+printf %s "checking whether $as_decl_name is declared... " >&6; }+if eval test \${$3+y}+then :+  printf %s "(cached) " >&6+else $as_nop+  as_decl_use=`echo $2|sed -e 's/(/((/' -e 's/)/) 0&/' -e 's/,/) 0& (/g'`+  eval ac_save_FLAGS=\$$6+  as_fn_append $6 " $5"+  cat confdefs.h - <<_ACEOF >conftest.$ac_ext+/* end confdefs.h.  */+$4+int+main (void)+{+#ifndef $as_decl_name+#ifdef __cplusplus+  (void) $as_decl_use;+#else+  (void) $as_decl_name;+#endif+#endif++  ;+  return 0;+}+_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+  eval $6=\$ac_save_FLAGS++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_check_decl+ # ac_fn_c_check_header_compile LINENO HEADER VAR INCLUDES # ------------------------------------------------------- # Tests whether HEADER exists and can be compiled using the include files in@@ -1621,7 +1674,7 @@ This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by streamly $as_me 0.7.3.2, which was+It was created by streamly $as_me 0.8.0, which was generated by GNU Autoconf 2.71.  Invocation command line was    $ $0$ac_configure_args_raw@@ -2288,7 +2341,7 @@ fi  -# Check headers and functions required+# XXX Do this only for linux   @@ -3285,6 +3338,150 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu  +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC options needed to detect all undeclared functions" >&5+printf %s "checking for $CC options needed to detect all undeclared functions... " >&6; }+if test ${ac_cv_c_undeclared_builtin_options+y}+then :+  printf %s "(cached) " >&6+else $as_nop+  ac_save_CFLAGS=$CFLAGS+   ac_cv_c_undeclared_builtin_options='cannot detect'+   for ac_arg in '' -fno-builtin; do+     CFLAGS="$ac_save_CFLAGS $ac_arg"+     # This test program should *not* compile successfully.+     cat confdefs.h - <<_ACEOF >conftest.$ac_ext+/* end confdefs.h.  */++int+main (void)+{+(void) strchr;+  ;+  return 0;+}+_ACEOF+if ac_fn_c_try_compile "$LINENO"+then :++else $as_nop+  # This test program should compile successfully.+        # No library function is consistently available on+        # freestanding implementations, so test against a dummy+        # declaration.  Include always-available headers on the+        # off chance that they somehow elicit warnings.+        cat confdefs.h - <<_ACEOF >conftest.$ac_ext+/* end confdefs.h.  */+#include <float.h>+#include <limits.h>+#include <stdarg.h>+#include <stddef.h>+extern void ac_decl (int, char *);++int+main (void)+{+(void) ac_decl (0, (char *) 0);+  (void) ac_decl;++  ;+  return 0;+}+_ACEOF+if ac_fn_c_try_compile "$LINENO"+then :+  if test x"$ac_arg" = x+then :+  ac_cv_c_undeclared_builtin_options='none needed'+else $as_nop+  ac_cv_c_undeclared_builtin_options=$ac_arg+fi+          break+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+    done+    CFLAGS=$ac_save_CFLAGS++fi+{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_undeclared_builtin_options" >&5+printf "%s\n" "$ac_cv_c_undeclared_builtin_options" >&6; }+  case $ac_cv_c_undeclared_builtin_options in #(+  'cannot detect') :+    { { 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 make $CC report undeclared builtins+See \`config.log' for more details" "$LINENO" 5; } ;; #(+  'none needed') :+    ac_c_undeclared_builtin_options='' ;; #(+  *) :+    ac_c_undeclared_builtin_options=$ac_cv_c_undeclared_builtin_options ;;+esac++ac_fn_check_decl "$LINENO" "IN_MASK_CREATE" "ac_cv_have_decl_IN_MASK_CREATE" "#include <sys/inotify.h>+" "$ac_c_undeclared_builtin_options" "CFLAGS"+if test "x$ac_cv_have_decl_IN_MASK_CREATE" = xyes+then :+  ac_have_decl=1+else $as_nop+  ac_have_decl=0+fi+printf "%s\n" "#define HAVE_DECL_IN_MASK_CREATE $ac_have_decl" >>confdefs.h++ac_fn_check_decl "$LINENO" "IN_EXCL_UNLINK" "ac_cv_have_decl_IN_EXCL_UNLINK" "#include <sys/inotify.h>+" "$ac_c_undeclared_builtin_options" "CFLAGS"+if test "x$ac_cv_have_decl_IN_EXCL_UNLINK" = xyes+then :+  ac_have_decl=1+else $as_nop+  ac_have_decl=0+fi+printf "%s\n" "#define HAVE_DECL_IN_EXCL_UNLINK $ac_have_decl" >>confdefs.h+++# XXX Do this only for macOS+ac_fn_check_decl "$LINENO" "kFSEventStreamCreateFlagFileEvents" "ac_cv_have_decl_kFSEventStreamCreateFlagFileEvents" "#include <CoreServices/CoreServices.h>+" "$ac_c_undeclared_builtin_options" "CFLAGS"+if test "x$ac_cv_have_decl_kFSEventStreamCreateFlagFileEvents" = xyes+then :+  ac_have_decl=1+else $as_nop+  ac_have_decl=0+fi+printf "%s\n" "#define HAVE_DECL_KFSEVENTSTREAMCREATEFLAGFILEEVENTS $ac_have_decl" >>confdefs.h++ac_fn_check_decl "$LINENO" "kFSEventStreamCreateFlagFullHistory" "ac_cv_have_decl_kFSEventStreamCreateFlagFullHistory" "#include <CoreServices/CoreServices.h>+" "$ac_c_undeclared_builtin_options" "CFLAGS"+if test "x$ac_cv_have_decl_kFSEventStreamCreateFlagFullHistory" = xyes+then :+  ac_have_decl=1+else $as_nop+  ac_have_decl=0+fi+printf "%s\n" "#define HAVE_DECL_KFSEVENTSTREAMCREATEFLAGFULLHISTORY $ac_have_decl" >>confdefs.h++ac_fn_check_decl "$LINENO" "kFSEventStreamEventFlagItemCloned" "ac_cv_have_decl_kFSEventStreamEventFlagItemCloned" "#include <CoreServices/CoreServices.h>+" "$ac_c_undeclared_builtin_options" "CFLAGS"+if test "x$ac_cv_have_decl_kFSEventStreamEventFlagItemCloned" = xyes+then :+  ac_have_decl=1+else $as_nop+  ac_have_decl=0+fi+printf "%s\n" "#define HAVE_DECL_KFSEVENTSTREAMEVENTFLAGITEMCLONED $ac_have_decl" >>confdefs.h++ac_fn_check_decl "$LINENO" "kFSEventStreamEventFlagItemIsHardlink" "ac_cv_have_decl_kFSEventStreamEventFlagItemIsHardlink" "#include <CoreServices/CoreServices.h>+" "$ac_c_undeclared_builtin_options" "CFLAGS"+if test "x$ac_cv_have_decl_kFSEventStreamEventFlagItemIsHardlink" = xyes+then :+  ac_have_decl=1+else $as_nop+  ac_have_decl=0+fi+printf "%s\n" "#define HAVE_DECL_KFSEVENTSTREAMEVENTFLAGITEMISHARDLINK $ac_have_decl" >>confdefs.h+++# Check headers and functions required ac_header= ac_cache= for ac_item in $ac_header_c_list do@@ -3330,7 +3527,7 @@   # Output-ac_config_headers="$ac_config_headers src/Streamly/Internal/Data/Time/config.h"+ac_config_headers="$ac_config_headers src/config.h"  cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure@@ -3831,7 +4028,7 @@ # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log="-This file was extended by streamly $as_me 0.7.3.2, which was+This file was extended by streamly $as_me 0.8.0, which was generated by GNU Autoconf 2.71.  Invocation command line was    CONFIG_FILES    = $CONFIG_FILES@@ -3878,7 +4075,8 @@ Configuration headers: $config_headers -Report bugs to <streamly@composewell.com>."+Report bugs to <streamly@composewell.com>.+streamly home page: <https://streamly.composewell.com>."  _ACEOF ac_cs_config=`printf "%s\n" "$ac_configure_args" | sed "$ac_safe_unquote"`@@ -3886,7 +4084,7 @@ cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config='$ac_cs_config_escaped' ac_cs_version="\\-streamly config.status 0.7.3.2+streamly config.status 0.8.0 configured by $0, generated by GNU Autoconf 2.71,   with options \\"\$ac_cs_config\\" @@ -3999,7 +4197,7 @@ for ac_config_target in $ac_config_targets do   case $ac_config_target in-    "src/Streamly/Internal/Data/Time/config.h") CONFIG_HEADERS="$CONFIG_HEADERS src/Streamly/Internal/Data/Time/config.h" ;;+    "src/config.h") CONFIG_HEADERS="$CONFIG_HEADERS src/config.h" ;;    *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;;   esac
configure.ac view
@@ -3,15 +3,25 @@ # See https://www.gnu.org/software/autoconf/manual/autoconf.html for help on # the macros used in this file. -AC_INIT([streamly], [0.7.3.2], [streamly@composewell.com], [streamly])+AC_INIT([streamly], [0.8.0], [streamly@composewell.com], [streamly], [https://streamly.composewell.com])  # To suppress "WARNING: unrecognized options: --with-compiler" AC_ARG_WITH([compiler], [GHC]) +# XXX Do this only for linux+AC_CHECK_DECLS([IN_MASK_CREATE],[],[],[#include <sys/inotify.h>])+AC_CHECK_DECLS([IN_EXCL_UNLINK],[],[],[#include <sys/inotify.h>])++# XXX Do this only for macOS+AC_CHECK_DECLS([kFSEventStreamCreateFlagFileEvents],[],[],[#include <CoreServices/CoreServices.h>])+AC_CHECK_DECLS([kFSEventStreamCreateFlagFullHistory],[],[],[#include <CoreServices/CoreServices.h>])+AC_CHECK_DECLS([kFSEventStreamEventFlagItemCloned],[],[],[#include <CoreServices/CoreServices.h>])+AC_CHECK_DECLS([kFSEventStreamEventFlagItemIsHardlink],[],[],[#include <CoreServices/CoreServices.h>])+ # Check headers and functions required AC_CHECK_HEADERS([time.h]) AC_CHECK_FUNCS([clock_gettime])  # Output-AC_CONFIG_HEADERS([src/Streamly/Internal/Data/Time/config.h])+AC_CONFIG_HEADERS([src/config.h]) AC_OUTPUT
credits/CONTRIBUTORS.md view
@@ -4,9 +4,28 @@ Use `git shortlog -sn tag1...tag2` on the git repository to get a list of contributors between two repository tags. -## 0.7.3.1+## 0.8.0 -* Phil de Joux+* Harendra Kumar+* Adithya Kumar+* Pranay Sashank+* Ranjeet Kumar Ranjan+* Anurag Hooda+* Ahmed Zaheer Dadarkar+* Shruti Umat+* Joseph Koshy (Google LLC.)+* Sanchayan Maity+* Kirill Elagin+* Shlok Datye+* Julian Ospald+* George Thomas+* endgame++## 0.7.3++* Pranay Sashank+* Adithya Kumar+* Julian Ospald  ## 0.7.2
credits/COPYRIGHTS.md view
@@ -3,6 +3,19 @@ original or modified code has been included please search for the copyright notices in the individual files. +## 0.8.0++* macOS FS Event handling C code adapted from hfsevents package:+  * Copyright (c) 2012, Luite Stegeman+  * http://hackage.haskell.org/package/hfsevents-0.1.6+  * See hfsevents-0.1.6.txt for the original license++* Some code snippets in Windows FS event handling module are taken from the+  fsnotify package.+  * Copyright (c) 2012, Mark Dittmer+  * http://hackage.haskell.org/package/fsnotify-0.3.0.1/+  * See fsnotify-0.3.0.1.txt for the original license+ ## 0.7.1  * For compatibility with older GHC versions portions of PrimArray and
credits/README.md view
@@ -1,3 +1,5 @@+# Credits and Contributions+ This library builds upon many good ideas from the existing body of Haskell work.  We would like to thank all the Haskellers whose work might have influenced this library. It is not possible to quantify that contribution and
+ credits/fsnotify-0.3.0.1.txt view
@@ -0,0 +1,30 @@+Copyright (c) 2012, Mark Dittmer++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 Mark Dittmer 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.
+ credits/hfsevents-0.1.6.txt view
@@ -0,0 +1,30 @@+Copyright (c) 2012, Luite Stegeman++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 Luite Stegeman 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.
+ default.nix view
@@ -0,0 +1,138 @@+# CAUTION! a spelling mistake in arg string is ignored silently.+#+# To build the chart executable for running bench.sh use:+# nix-shell --argstr c2nix "--flag dev" --run "cabal build chart --flag dev"+#+# You can permanently copy the "chart" executable to "./bin" to pick+# it up irrespective of the compiler/build. Its path is printed by the+# above build command. You can also print its path using the following+# command and then use "cp <path> ./bin" to copy it to "./bin", the bench.sh+# script will pick it up from there:+# nix-shell --argstr c2nix "--flag dev" --run "cabal exec --flag dev -- which chart"+#+# To use ghc-8.6.5+# nix-shell --argstr compiler "ghc865"++{+  nixpkgs ?+    import (builtins.fetchTarball https://github.com/NixOS/nixpkgs/archive/refs/tags/21.05.tar.gz)+        {}+, compiler ? "default"+, c2nix ? "" # cabal2nix CLI options+# TODO+#, sources ? [] # e.g. [./. ./benchmark]+#, hdeps ? [] # e.g. [time, mtl]+#, deps ? [] # e.g. [SDL2]+}:+let haskellPackages =+        if compiler == "default"+        then nixpkgs.haskellPackages+        else nixpkgs.haskell.packages.${compiler};++    # we can possibly avoid adding our package to HaskellPackages like+    # in the case of nix-shell for a single package?+    mkPackage = super: pkg: path: opts: inShell:+                let orig = super.callCabal2nixWithOptions pkg path opts {};+                 in if inShell+                    # Avoid copying the source directory to nix store by using+                    # src = null.+                    then orig.overrideAttrs (oldAttrs: { src = null; })+                    else orig;++    flags = "--benchmark --flag fusion-plugin --flag doctests" + " " + c2nix;++    mkHaskellPackages = inShell:+        haskellPackages.override {+            # We could disbale doCheck on all like this, but it would make the+            # whole world rebuild, we can't use the binary cache+            #packageSetConfig = self: super: {+            #    mkDerivation = drv: super.mkDerivation (drv // {+            #        doCheck = false;+            #    });+            #};+            overrides = self: super:+                with nixpkgs.haskell.lib;+                {+                    streamly = mkPackage super "streamly" ./. flags inShell;+                    streamly-benchmarks =+                        mkPackage super "streamly-benchmarks"+                            ./benchmark flags inShell;+                    streamly-tests =+                        mkPackage super "streamly-tests"+                            ./test flags inShell;+                    streamly-docs =+                        mkPackage super "streamly-docs"+                            ./docs flags inShell;++                    fusion-plugin =+                      super.callHackageDirect+                        { pkg = "fusion-plugin";+                          ver = "0.2.3";+                          sha256 = "073wbhdxj1sh5160blaihbzkkhabs8s71pqhag16lvmgbb7a3hla";+                        } {};++                    #tasty-bench =+                    #  super.callHackageDirect+                    #    { pkg = "tasty-bench";+                    #      ver = "0.2.5";+                    #      sha256 = "052vd87dcik77x6nfbivdibyxyd3byqy4akchr1mrz0hd5ll8apg";+                    #    } {};++                    #tasty =+                    #  super.callHackageDirect+                    #    { pkg = "tasty";+                    #      ver = "1.4.1";+                    #      sha256 = "0g1280gcpcvjbmyk83jv3y9gs2z7fvmcagi9rfs8c9x036nvjq6c";+                    #    } {};++                    # Example to Use a different version of a package+                    #QuickCheck = self.QuickCheck_2_14;++                    # Example to disable tests if tests fail or take too long+                    # or to use different configure flags if needed+                    #+                    # XXX We need the ability to disable doCheck on all+                    # those packages that are being built locally and+                    # not fetched from the cache. Running tests could do+                    # nasty things to the machine e.g. some tests even+                    # listen for incoming connections on the network.+                    #selective =+                    #    super.selective.overrideAttrs (oldAttrs:+                    #      { doCheck = false;+                    #        configureFlags =+                    #          oldAttrs.configureFlags ++ ["--disable-tests"];+                    #      });+                };+        };++    drv = mkHaskellPackages true;++    shell = drv.shellFor {+        packages = p:+          [ p.streamly+            p.streamly-benchmarks+            p.streamly-tests+            p.streamly-docs+          ];+        # some dependencies of hoogle fail to build with quickcheck-2.14+        # We should use hoogle as external tool instead of building it here+        # withHoogle = true;+        doBenchmark = true;+        # XXX On macOS cabal2nix does not seem to generate a dependency on+        # Cocoa framework.+        buildInputs =+            if builtins.currentSystem == "x86_64-darwin"+            then [nixpkgs.darwin.apple_sdk.frameworks.Cocoa]+            else [];+        # Use a better prompt+        shellHook = ''+          export CABAL_DIR="$(pwd)/.cabal.nix"+          if test -n "$PS_SHELL"+          then+            export PS1="$PS_SHELL\[$bldred\](nix)\[$txtrst\] "+          fi+        '';+    };+in if nixpkgs.lib.inNixShell+   then shell+   else (mkHaskellPackages false).streamly
− design/dfa-bytes.png

binary file changed (18288 → absent bytes)

− design/dfa-classes.png

binary file changed (15413 → absent bytes)

− design/dfa-rearr.png

binary file changed (16619 → absent bytes)

− design/inlining.md 
@@ -1,123 +0,0 @@-## INLINE Phases--A missing inline or inline in an incorrect GHC simplifier phase can adversely-impact performance.  We use three builtin phases of GHC simplifier for inlining-i.e. phase 0, 1 and 2. We have defined them as follows in `inline.h`:--```-#define INLINE_EARLY  INLINE [2]-#define INLINE_NORMAL INLINE [1]-#define INLINE_LATE   INLINE [0]-```--## Low Level `fromStreamD/toStreamD` Fusion--The combinators in `Streamly.Prelude` are defined in terms of combinators in-`Streamly.Internal.Data.Stream.StreamD` (Direct style streams) or `Streamly.Internal.Data.Stream.StreamK`-(CPS style streams). We convert the stream from `StreamD` to `StreamK`-representation or vice versa in some cases. --In the first inlining phase (INLINE_EARLY or INLINE) we expand-the combinators in `Streamly.Prelude` into-fromStreamD/fromStreamK/toStreamD/toStreamK and combinators defined in StreamD-or StreamK modules. Once we do that fromStreamD/toStreamD get exposed and we-can apply rewrite rules to rewrite transformations like `fromStreamK .-toStreamK` to `id`. A plain `INLINE` pragma is usually enough on combinators in-`Streamly.Prelude`.--```-{-# RULES "fromStreamK/toStreamK fusion"-  forall s. toStreamK (fromStreamK s) = s #-}-```--Also, we have to prevent fromStreamK and toStreamK themselves from inlining in-this phase so that rewrite rules can be applied on them, therefore, we annotate-these functions with `INLINE_LATE`.--## Fallback Rules--In some cases, if the operation could not fuse we want to use a fallback-rewrite rule in the next phase. For such cases we use the INLINE_EARLY phase-for the first rewrite and the INLINE_NORMAL phase for the fallback rules.--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.--```-{-# INLINE_EARLY unfoldr #-}-unfoldr :: (Monad m, IsStream t) => (b -> Maybe (a, b)) -> b -> t m a-unfoldr step seed = fromStreamS (S.unfoldr step seed)-{-# RULES "unfoldr fallback to StreamK" [1]-     forall a b. S.toStreamK (S.unfoldr a b) = K.unfoldr a b #-}-```--## High Level Operation Fusion--Since each high level combinator in `Streamly.Prelude` is wrapped in-`fromStreamD/toStreamD` etc. the combinator fusion cannot work unless we have-removed those and exposed consecutive operations e.g. a `map` followed by-another `map`.  Assuming that redundant `fromStreamK/toStreamK` have been-removed in the `INLINE_EARLY` phase, we can then apply the combinator fusion-rules in the `INLINE_NORMAL` phase.  For example, we can fuse two `map`-operations into a single `map` operation.  Note that now we have exposed the-`StreamD/StreamK` implementations of combinators and the rules would apply on-those.--## Inlining Higher Order Functions--Note that partially applied functions cannot be inlined. So if we have a code-like this:--```-concatMap1 src = runStream $ S.concatMap (S.replicate 3) src-```--We want to ensure that `concatMap` gets inlined before `replicate` so that-`replicate` becomes fully applied before it gets inlined. Currently ensuring-that both of them are inlined in the same phase (`INLINE_NORMAL`) seems to be-enough to achieve that. In general, we should try to ensure that higher order-functions are inlined before or in the same phase as the functions they can-consume as arguments. This means `StreamD` combinators should not be marked-as `INLINE` or `INLINE_EARLY`, instead they should all be marked as-`INLINE_NORMAL` because higher order funcitons like `concatMap`/`map`/`mapM`-etc are marked as `INLINE_NORMAL`. `StreamD` functions in other modules like-`Streamly.Memory.Array` should also follow the same rules.--## Stream Fusion--In StreamD combinators, inlining the inner step or loop functions too early-i.e. in the same pahse or before the outer function is inlined may block stream-fusion opportunities. Therefore, the inner step functions and folding loops are-marked as INLINE_LATE.--## Specialization--In some cases, the `step` function in `StreamD` does not get specialized when-inlined unless it is provided with an explicit signature or made a lambda, for-example, in the `replicate/replicateM` combinator we need the type annotation-on `i` to get it specialized:--```-    {-# INLINE_LATE step #-}-    step _ (i :: Int) =-        if i <= 0-        then return Stop-        else do-                x <- action-                return $ Yield x (i - 1)-```--`-flate-specialise` also helps in this case.--## Stream and Fold State Data Structures--Since state is an internal data structure threaded around in the loop, it is a-good practice to use strict unboxed fields for state data structures where-possible. In most cases it is not necessary, but in some cases it may affect-fusion and make a difference of 10x performance or more.  For example, using-non-strict fields can increase the code size for internal join points and-functions created during transformations, which can affect the inlining of-these code blocks which in turn can affect stream fusion. --See https://gitlab.haskell.org/ghc/ghc/issues/17075 .
− design/linked-lists.md 
@@ -1,32 +0,0 @@-# Linked Lists--The immutable Haskell lists or streams are great for stream processing.-However, they may not be suitable for purposes where we need to store data for-a longer while. In such cases we need mutable linked lists in pinned memory for-high performance applications i.e. we need the C like linked lists. Here are-some cases where linked-lists may be warranted instead of immutable lists:--* Let's say we want to buffer incoming data in a list. The buffered data may be-  millions of elements. When we are buffering we may allocate cells from-  different areas of the GC heap. When there are other activities going on we-  may have to keep copying this buffered data during GCs. When we consume this-  buffer, again it creates a fragmented heap and we may have to copy some other-  long-lived data to defragment the heap. The point is that we should not have-  long-lived data in the GC heap.--* When we delete a node in the list, Haskell lists have to be recreated-  generating a lot of garbage. We cannot take a reference to the unmodified-  segments and reuse them in the new list. On the other hand with mutable-  linked-lists we can delete a node cheaply. This could be a common case in a-  hash table collision chain which requires deletion of elements.--* Similar to deletion, if we need to insert an element in the middle of the-  list, an immutable list has to be re-created.--* To implement a queue, two lists in the immutable model can be used-  efficiently if we are strictly adding at the end and deleting from the front-  and if there is sufficient batching so that swapping of the lists is not a-  common operation. If we have to insert elements in the middle or if we have-  to swap too many times again we will have the same GC issues as stated above.-  For example, in implementations of priority search queues or timer wheels we-  have to mutate the lists.
− design/module-organization.md 
@@ -1,134 +0,0 @@-# Internal vs External Modules--We keep all modules exposed to facilitate convenient exposure of experimental-APIs and constructors to users. It allows users of the library to experiment-much more easily and carry a caveat that these APIs can change in future-without notice.  Since everything is exposed, maintainers do not have to think-about what to expose as experimental and what remains completely hidden every-time something is added to the library.--We expose the internal modules via `Streamly.Internal` namespace to keep all-the internal modules together under one module tree and to have their-documentation also separated under one head in haddock docs.--Another decision point is about two choices:--1) Keep the implementation of all the APIs in an internal module and just-reexport selected APIs through the external module. The disadvantages of this-are:-a) users may not be able to easily figure out what unexposed APIs are available-other than the ones exposed through the external module. To avoid this problem-we can mark the unexposed APIs in the docs with a special comment.-b) In tests and benchmarks we will be using internal modules to test internal-and unexposed APIs. Since exposed APIs are exported via both internal and-external modules we will have to be careful in not using the internal module-for testing accidentally, instead we should always be using the exposed module-so that we are always testing exactly the way users will be using the APIs.--2) Keep the implementations of unexposed modules in the internal module file-and exposed module in the external module file. In this approach, users can-easily figure out the unexposed vs exposed APIs. But maintaining this would-require us to move the APIs from internal to external module file whenever we-expose an API.--We choose the first approach.--# Module Name Spaces--We use the "Streamly" prefix to all the module names so that they do not-conflict with any other module on Hackage.--We have the following module hierarchy under Streamly:--* Data: All the data structures that make use of the unpinned GC memory to-  store data.  These data structures are suitable for stream processing but-  may not be suitable for storing large amounts of data in memory for longer-  durations. These are suitable for short lived and smaller structures-  because they can be moved by the GC to defragment the heap.--* Memory: This name space is for data structures that make use of the memory as-  a persistent storage device. The memory may be allocated by foreign-  allocators or pinned memory allocated by GHC. Because the memory is pinned it-  can be used for interfacing with the system/kernel. These structures are-  efficient for storing large amounts of data for longer durations because it-  does not have to be copied by the GC. These structures may not be suitable-  for small, short lived data because that is likely to fragment the heap.--* FileSystem: This name space is for data structures that reside in files-  provided by a file system interface on top of storage devices.--* Network: This name space is for APIs that access data from remote computers-  over the network.--## Data and Memory--As explained above, we distinguish two types of data structures under "Data"-and "Memory".  Alternatively, we could have used a "Memory" namespace under-each data structure e.g.  "Streamly.Data.Array.Memory" instead of using a top-level "Streamly.Memory", however, we chose to distinguish such data structures-using a top level "Memory" name space because it enforces consistent naming by-fitting all such data structures under this top level hierarchy. It also makes-it easier to find out what all data structures fall in this category.--# Module Types and Naming--## Abstract modules--Abstract modules are meant to represent an abstract interface (e.g. a type-class).  Concrete modules can make use of this interface and possibly-extend it to provide concrete functionality.--The general convention in the Haskell ecosystem for naming an abstract-interface module is to name it as "Module.Class" (e.g. Control.Monad.IO.Class).-An alternative name could be "Module.Interface".--In some other cases such modules are named after the class name (e.g. see the-array package for an example). This is more appropriate when there is no single-hierarchy where we can place the ".Class" module. For example, we have arrays-in Data.Array, Memory.Array, we have to choose one over the other to place the-".Class" module for an array abstraction. Alternatively, we can choose-"Data.IsArray" instead.--Yet another way could be to use the parent module as an interface module and-the child modules as concrete modules. For example, "Streamly.Data.Stream"-module could provide the common "Stream" type and the "IsStream" type class.-The submodule "Streamly.Data.Stream.Serial" can provide a concrete "Serial"-stream type importing the "Streamly.Data.Stream" abstract module.--## Common Modules--Some modules represent common types or utility functions that are shared across-multiple modules. The general convention is to name such modules as-"Module.Types", "Module.Common", or "Module.Core".--## Constrained Modules--Some modules represent operations on a type which constrain a type using a type-class or a specific instance of a general type.  For example, we may have a-module representing operations on a stream of any type and another module that-specifically deals with operations on a Char stream. There are two ways to deal-with this.--First is to use a submodule for the constrained type. For example,-`Streamly.Data.Stream` represents a general stream type whereas-`Streamly.Data.Stream.Char` represents operations on a stream of Char type.-This makes sense where the type we are constraining to is a specific type-rather than a type constrained using a type class.--Second is to use a separate hierarchy for the constrained type. For example, we-could use `Streamly.Data.Array` for a general array and `Streamly.Prim.Array`-for an array that works on `Prim` types. This makes sense when the type is-constrained by a type class, we may have more data structures for that-constrained type to be bundled under that hierarchy.--## Aggregate modules--In some cases we may want to aggregate the functionality of several small-modules in a combined aggregate module. In many cases, the aggregate module is-made a parent module of the constituent modules.  The parent module depends on-the child modules and exposes the functionality from the constituent modules.--## Placeholder Modules--In some cases a parent module is just a placeholder in the namespace and does-not export any functionality.
− design/utf8-decoder.md 
@@ -1,603 +0,0 @@-Flexible and Economical UTF-8 Decoder-=====================================--Systems with elaborate Unicode support usually confront programmers with-a multitude of different functions and macros to process UTF-8 encoded-strings, often with different ideas on handling buffer boundaries, state-between calls, error conditions, and performance characteristics, making-them difficult to use correctly and efficiently. Implementations also-tend to be very long and complicated; one popular library has over 500-lines of code just for one version of the decoder. This page presents-one that is very easy to use correctly, short, small, fast, and free.--Implementation in C (C99)----------------------------    // Copyright (c) 2008-2009 Bjoern Hoehrmann <bjoern@hoehrmann.de>-    // See http://bjoern.hoehrmann.de/utf-8/decoder/dfa/ for details.--    #define UTF8_ACCEPT 0-    #define UTF8_REJECT 1--    static const uint8_t utf8d[] = {-      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, // 00..1f-      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, // 20..3f-      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, // 40..5f-      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, // 60..7f-      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, // 80..9f-      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, // a0..bf-      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, // c0..df-      0xa,0x3,0x3,0x3,0x3,0x3,0x3,0x3,0x3,0x3,0x3,0x3,0x3,0x4,0x3,0x3, // e0..ef-      0xb,0x6,0x6,0x6,0x5,0x8,0x8,0x8,0x8,0x8,0x8,0x8,0x8,0x8,0x8,0x8, // f0..ff-      0x0,0x1,0x2,0x3,0x5,0x8,0x7,0x1,0x1,0x1,0x4,0x6,0x1,0x1,0x1,0x1, // s0..s0-      1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,1,1,1,1,1,0,1,0,1,1,1,1,1,1, // s1..s2-      1,2,1,1,1,1,1,2,1,2,1,1,1,1,1,1,1,1,1,1,1,1,1,2,1,1,1,1,1,1,1,1, // s3..s4-      1,2,1,1,1,1,1,1,1,2,1,1,1,1,1,1,1,1,1,1,1,1,1,3,1,3,1,1,1,1,1,1, // s5..s6-      1,3,1,1,1,1,1,3,1,3,1,1,1,1,1,1,1,3,1,1,1,1,1,1,1,1,1,1,1,1,1,1, // s7..s8-    };--    uint32_t inline-    decode(uint32_t* state, uint32_t* codep, uint32_t byte) {-      uint32_t type = utf8d[byte];--      *codep = (*state != UTF8_ACCEPT) ?-        (byte & 0x3fu) | (*codep << 6) :-        (0xff >> type) & (byte);--      *state = utf8d[256 + *state*16 + type];-      return *state;-    }--Usage--------UTF-8 is a variable length character encoding. To decode a character one-or more bytes have to be read from a string. The `decode` function-implements a single step in this process. It takes two parameters-maintaining state and a byte, and returns the state achieved after-processing the byte. Specifically, it returns the value `UTF8_ACCEPT`-(0) if enough bytes have been read for a character, `UTF8_REJECT` (1) if-the byte is not allowed to occur at its position, and some other-positive value if more bytes have to be read.--When decoding the first byte of a string, the caller must set the state-variable to `UTF8_ACCEPT`. If, after decoding one or more bytes the-state `UTF8_ACCEPT` is reached again, then the decoded Unicode character-value is available through the `codep` parameter. If the state-`UTF8_REJECT` is entered, that state will never be exited unless the-caller intervenes. See the examples below for more information on usage-and error handling, and the section on implementation details for how-the decoder is constructed.--Examples-----------### Validating and counting characters--This function checks if a null-terminated string is a well-formed UTF-8-sequence and counts how many code points are in the string.--    int-    countCodePoints(uint8_t* s, size_t* count) {-      uint32_t codepoint;-      uint32_t state = 0;--      for (*count = 0; *s; ++s)-        if (!decode(&state, &codepoint, *s))-          *count += 1;--      return state != UTF8_ACCEPT;-    }--It could be used like so:--    if (countCodePoints(s, &count)) {-      printf("The string is malformed\n");-    } else {-      printf("The string is %u characters long\n", count);-    }--### Printing code point values--This function prints out all code points in the string and an error-message if unexpected bytes are encountered, or if the string ends with-an incomplete sequence.--    void-    printCodePoints(uint8_t* s) {-      uint32_t codepoint;-      uint32_t state = 0;--      for (; *s; ++s)-        if (!decode(&state, &codepoint, *s))-          printf("U+%04X\n", codepoint);--      if (state != UTF8_ACCEPT)-        printf("The string is not well-formed\n");--    }--### Printing UTF-16 code units--This loop prints out UTF-16 code units for the characters in a-null-terminated UTF-8 encoded string.--    for (; *s; ++s) {--      if (decode(&state, &codepoint, *s))-        continue;--      if (codepoint <= 0xFFFF) {-        printf("0x%04X\n", codepoint);-        continue;-      }--      // Encode code points above U+FFFF as surrogate pair.-      printf("0x%04X\n", (0xD7C0 + (codepoint >> 10)));-      printf("0x%04X\n", (0xDC00 + (codepoint & 0x3FF)));-    }--### Error recovery--It is sometimes desirable to recover from errors when decoding strings-that are supposed to be UTF-8 encoded. Programmers should be aware that-this can negatively affect the security properties of their application.-A common recovery method is to replace malformed sequences with a-substitute character like `U+FFFD REPLACEMENT CHARACTER`.--Decoder implementations differ in which octets they replace and where-they restart. Consider for instance the sequence `0xED 0xA0 0x80`. It-encodes a surrogate code point which is prohibited in UTF-8. A-recovering decoder may replace the whole sequence and restart with the-next byte, or it may replace the first byte and restart with the second-byte, replace it, restart with the third, and replace the third byte-aswell.--The following code implements one such recovery strategy. When an-unexpected byte is encountered, the sequence up to that point will be-replaced and, if the error occurred in the middle of a sequence, will-retry the byte as if it occurred at the beginning of a string. Note that-the decode function detects errors as early as possible, so the sequence-`0xED 0xA0 0x80` would result in three replacement characters.--    for (prev = 0, current = 0; *s; prev = current, ++s) {--      switch (decode(&current, &codepoint, *s)) {-      case UTF8_ACCEPT:-        // A properly encoded character has been found.-        printf("U+%04X\n", codepoint);-        break;--      case UTF8_REJECT:-        // The byte is invalid, replace it and restart.-        printf("U+FFFD (Bad UTF-8 sequence)\n");-        current = UTF8_ACCEPT;-        if (prev != UTF8_ACCEPT)-          s--;-        break;-      ...--For some recovery strategies it may be useful to determine the number of-bytes expected. The states in the automaton are numbered such that,-assuming C\'s division operator, `state / 3 + 1` is that number. Of-course, this will only work for states other than `UTF8_ACCEPT` and-`UTF8_REJECT`. This number could then be used, for instance, to skip the-continuation octets in the illegal sequence `0xED 0xA0 0x80` so it will-be replaced by a single replacement character.--### Transcoding to UTF-16 buffer--This is a rough outline of a UTF-16 transcoder. Actual applications-would add code for error reporting, reporting of words written, required-buffer size in the case of a small buffer, and possibly other things.-Note that in order to avoid checking for free space in the inner loop,-we determine how many bytes can be read without running out of space.-This is one utf-8 byte per available utf-16 word, with one exception: if-the last byte read was the third byte in a four byte sequence we would-get two words for the next byte; so we read one byte less than we have-words available. This additional word is also needed for-null-termination, so it\'s never wrong to read one less.--    int-    toUtf16(uint8_t* src, size_t srcBytes, uint16_t* dst, size_t dstWords, ...) {--      uint8_t* src_actual_end = src + srcBytes;-      uint8_t* s = src;-      uint16_t* d = dst;-      uint32_t codepoint;-      uint32_t state = 0;--      while (s < src_actual_end) {--        size_t dst_words_free = dstWords - (d - dst);-        uint8_t* src_current_end = s + dst_words_free - 1;--        if (src_actual_end < src_current_end)-          src_current_end = src_actual_end;--        if (src_current_end <= s)-          goto toosmall;--        while (s < src_current_end) {--          if (decode(&state, &codepoint, *s++))-            continue;--          if (codepoint > 0xffff) {-            *d++ = (uint16_t)(0xD7C0 + (codepoint >> 10));-            *d++ = (uint16_t)(0xDC00 + (codepoint & 0x3FF));-          } else {-            *d++ = (uint16_t)codepoint;-          }-        }-      }--      if (state != UTF8_ACCEPT) {-        ...-      }--      if ((dstWords - (d - dst)) == 0)-        goto toosmall;--      *d++ = 0;-      ...--    toosmall:-      ...-    }--Implementation details-------------------------The `utf8d` table consists of two parts. The first part maps bytes to-character classes, the second part encodes a deterministic finite-automaton using these character classes as transitions. This section-details the composition of the table.--### Canonical UTF-8 automaton--UTF-8 is a variable length character encoding. That means state has to-be maintained while processing a string. The following transition graph-illustrates the process. We start in state zero, and whenever we come-back to it, we\'ve seen a whole Unicode character. Transitions not in-the graph are disallowed; they all lead to state one, which has been-omitted for readability.--![DFA with range transitions](/design/dfa-bytes.png)--### Automaton with character class transitions--The byte ranges in the transition graph above are not easily encoded in-the automaton in a manner that would allow fast lookup. Instead of-encoding the ranges directly, the ranges are split such that each byte-belongs to exactly one character class. Then the transitions go over-these character classes.--![DFA with class transitions](/design/dfa-classes.png)--### Mapping bytes to character classes--Primarily to save space in the transition table, bytes are mapped to-character classes. This is the mapping:--|||||-|-|-|-|-|-| 00..7f |  0 | 80..8f | 1 |-| 90..9f |  9 | a0..bf | 7 |-| c0..c1 |  8 | c2..df | 2 |-| e0..e0 | 10 | e1..ec | 3 |-| ed..ed |  4 | ee..ef | 3 |-| f0..f0 | 11 | f1..f3 | 6 |-| f4..f4 |  5 | f5..ff | 8 |---For bytes that may occur at the beginning of a multibyte sequence, the-character class number is also used to remove the most significant bits-from the byte, which do not contribute to the actual code point value.-Note that `0xc0`, `0xc1`, and `0xf5` .. `0xff` have all their bits-removed. These bytes cannot occur in well-formed sequences, so it does-not matter which bits, if any, are retained.--|||||||||||||-|-|-|-|-|-|-|-|-|-|-|-|-|-| c0 | 8 | **11000000** | d0 | 2 | **11**010000 | e0 | 10 | **11100000** | f0 | 11 | **11110000** |-| c1 | 8 | **11000001** | d1 | 2 | **11**010001 | e1 |  3 | **111**00001 | f1 |  6 | **111100**01 |-| c2 | 2 | **11**000010 | d2 | 2 | **11**010010 | e2 |  3 | **111**00010 | f2 |  6 | **111100**10 |-| c3 | 2 | **11**000011 | d3 | 2 | **11**010011 | e3 |  3 | **111**00011 | f3 |  6 | **111100**11 |-| c4 | 2 | **11**000100 | d4 | 2 | **11**010100 | e4 |  3 | **111**00100 | f4 |  5 | **11110**100 |-| c5 | 2 | **11**000101 | d5 | 2 | **11**010101 | e5 |  3 | **111**00101 | f5 |  8 | **11110101** |-| c6 | 2 | **11**000110 | d6 | 2 | **11**010110 | e6 |  3 | **111**00110 | f6 |  8 | **11110110** |-| c7 | 2 | **11**000111 | d7 | 2 | **11**010111 | e7 |  3 | **111**00111 | f7 |  8 | **11110111** |-| c8 | 2 | **11**001000 | d8 | 2 | **11**011000 | e8 |  3 | **111**01000 | f8 |  8 | **11111000** |-| c9 | 2 | **11**001001 | d9 | 2 | **11**011001 | e9 |  3 | **111**01001 | f9 |  8 | **11111001** |-| ca | 2 | **11**001010 | da | 2 | **11**011010 | ea |  3 | **111**01010 | fa |  8 | **11111010** |-| cb | 2 | **11**001011 | db | 2 | **11**011011 | eb |  3 | **111**01011 | fb |  8 | **11111011** |-| cc | 2 | **11**001100 | dc | 2 | **11**011100 | ec |  3 | **111**01100 | fc |  8 | **11111100** |-| cd | 2 | **11**001101 | dd | 2 | **11**011101 | ed |  4 | **1110**1101 | fd |  8 | **11111101** |-| ce | 2 | **11**001110 | de | 2 | **11**011110 | ee |  3 | **111**01110 | fe |  8 | **11111110** |-| cf | 2 | **11**001111 | df | 2 | **11**011111 | ef |  3 | **111**01111 | ff |  8 | **11111111** |---Notes on Variations----------------------There are several ways to change the implementation of this decoder. For-example, the size of the data table can be reduced, at the cost of a-couple more instructions, so it omits the mapping of bytes in the-US-ASCII range, and since all entries in the table are 4 bit values, two-values could be stored in a single byte.--In some situations it may be beneficial to have a separate start state.-This is easily achieved by copying the s0 state in the array to the end,-and using the new state 9 as start state as needed.--Where callers require the code point values, compilers tend to generate-slightly better code if the state calculation is moved into the-branches, for example--    if (*state != UTF8_ACCEPT) {-      *state = utf8d[256 + *state*16 + type];-      *codep = (*codep << 6) | (byte & 63);-    } else {-      *state = utf8d[256 + *state*16 + type];-      *codep = (byte) & (255 >> type);-    }--As the state will be zero in the else branch, this saves a shift and an-addition for each starter. Unfortunately, compilers will then typically-generate worse code if the codepoint value is not needed. Naturally,-then, two functions could be used, one that only calculates the states-for validation, counting, and similar applications, and one for full-decoding. For the sample UTF-16 transcoder a more substantial increase-in performance can be achieved by manually including the decode code in-the inner loop; then it is also worthwhile to make code points in the-US-ASCII range a special case:--    while (s < src_current_end) {--      uint32_t byte = *s++;-      uint32_t type = utf8d[byte];--      if (state != UTF8_ACCEPT) {-        codep = (codep << 6) | (byte & 63);-        state = utf8d[256 + state*16 + type];--        if (state)-          continue;--      } else if (byte > 0x7f) {-        codep = (byte) & (255 >> type);-        state = utf8d[256 + type];-        continue;--      } else {-        *d++ = (uint16_t)byte;-        continue;-      }-      ...--Another variation worth of note is changing the comparison when setting-the code point value to this:--    *codep = (*state >  UTF8_REJECT) ?-      (byte & 0x3fu) | (*codep << 6) :-      (0xff >> type) & (byte);--This ensures that the code point value does not exceed the value `0xff`-after some malformed sequence is encountered.--As written, the decoder disallows encoding of surrogate code points,-overlong 2, 3, and 4 byte sequences, and 4 byte sequences outside the-Unicode range. Allowing them can have serious security implications, but-can easily be achieved by changing the character class assignments in-the table.--The code samples have generally been written to perform well on my-system when compiled with Visual C++ 7.1 and GCC 3.4.5. Slight changes-may improve performance, for example, Visual C++ 7.1 will produce-slightly faster code when, in the manually inlined version of the-transcoder discussed above, the type assignment is moved into the-branches where it is needed, and the state and codepoint assignments in-the non-ASCII starter is swapped (approximately a 5% increase), but GCC-3.4.5 will produce considerably slower code (approximately 10%).--I have experimented with various rearrangements of states and character-classes. A seemingly promising one is the following:--![Re-arranged DFA with class transitions](/design/dfa-rearr.png)--One of the continuation ranges has been split into two, the other-changes are just renamings. This arrangement allows, when a continuation-octet is expected, to compute the character class with a shift instead-of a table lookup, and when looking at a non-ASCII starter, the next-state is simply the character class. On my system the change in-performance is in the area of +/- 1%. This encoding would have a number-of downsides: more rejecting states are required to account for-continuation octets where starters are expected, the table formatting-would use more hex notation making it longer, and calculating the number-of expected continuation octets from a given state is more difficult.-One thing I\'d still like to try out is if, perhaps by adding a couple-of additional states, for continuation states the next state can be-computed without any table lookup with a few easily paired instructions.--On 24th June 2010 Rich Felker pointed out that the state values in the-transition table can be pre-multiplied with 16 which would save a shift-instruction for every byte. D\'oh! We actually just need 12 and can-throw away the filler values previously in the table making the table 36-bytes shorter and save the shift in the code.--    // Copyright (c) 2008-2010 Bjoern Hoehrmann <bjoern@hoehrmann.de>-    // See http://bjoern.hoehrmann.de/utf-8/decoder/dfa/ for details.--    #define UTF8_ACCEPT 0-    #define UTF8_REJECT 12--    static const uint8_t utf8d[] = {-      // 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,-    };--    uint32_t inline-    decode(uint32_t* state, uint32_t* codep, uint32_t byte) {-      uint32_t type = utf8d[byte];--      *codep = (*state != UTF8_ACCEPT) ?-        (byte & 0x3fu) | (*codep << 6) :-        (0xff >> type) & (byte);--      *state = utf8d[256 + *state + type];-      return *state;-    }--Notes on performance-----------------------To conduct some ad-hoc performance testing I\'ve used three different-UTF-8 encoded buffers and passed them through a couple of UTF-8 to-UTF-16 transcoders. The large buffer is a April 2009 Hindi Wikipedia-article XML dump, the medium buffer Markus Kuhn\'s UTF-8-demo.txt, and-the tiny buffer my name, each about the number of times required for-about 1GB of data. All tests ran on a [Intel Prescott-Celeron](http://en.wikipedia.org/wiki/Celeron#Prescott-256) at 2666 MHz.-See [Changes](#changes) for some additional details.--  |                                                                           |  Large  |   Medium |   Tiny   |-  |---------------------------------------------------------------------------|---------| ---------|----------|-  |`NS_CStringToUTF16()` Mozilla 1.9 (*includes malloc/free time*)            |  36924ms|   39773ms|  107958ms|-  |`iconv()` 1.9 compiled with Visual C++ (Cygwin iconv 1.11 similar)         |  22740ms|   21765ms|   32595ms|-  |`g_utf8_to_utf16()` Cygwin Glib 2.0 (*includes malloc/free time*)          |  21599ms|   20345ms|   98782ms|-  |`ConvertUTF8toUTF16()` Unicode Inc., Visual C++ 7.1 -Ox -Ot -G7            |  11183ms|   11251ms|   19453ms|-  |`MultiByteToWideChar()` Windows API (Server 2003 SP2)                      |   9857ms|   10779ms|   12771ms|-  |`u_strFromUTF8` from ICU 4.0.1 (Visual Studio 2008, web site distribution) |   8778ms|    5223ms|    5419ms|-  |`PyUnicode_DecodeUTF8Stateful` (3.1a2), Visual C++ 7.1 -Ox -Ot -G7         |   4523ms|    5686ms|    3138ms|-  |Example section transcoder, Visual C++ 7.1 -Ox -Ot -G7                     |   5397ms|    5789ms|    6250ms|-  |Manually inlined transcoder (see above), Visual C++ 7.1 -Ox -Ot -G7        |   4277ms|    4998ms|    4640ms|-  |Same, Cygwin GCC 3.4.5 -march=prescott -fomit-frame-pointer -O3            |   4492ms|    5154ms|    4432ms|-  |Same, Cygwin GCC 4.3.2 -march=prescott -fomit-frame-pointer -O3            |   5439ms|    6322ms|    5567ms|-  |Same, Visual C++ 6.0 -TP -O2                                               |   5398ms|    6259ms|    6446ms|-  |Same, Visual C++ 7.1 -Ox -Ot -G7 (*includes malloc/free time*)             |   5498ms|    5086ms|   25852ms|--I have also timed functions that `xor` all code points in the large-buffer. In Visual Studio 2008 ICU\'s `U8_NEXT` macro comes out at-\~8000ms, the `U8_NEXT_UNSAFE` macro, which requires complete and-well-formed input, at \~4000ms, and the `decode` function is at-\~5900ms. Using the same manual inlining as for the transcode function,-Cygwin GCC 3.4.5 -march=prescott -O3 -fomit-frame-pointer brings it down-to roughly the same times as the transcode function for all three-buffers.--While these results do not model real-world applications well, it seems-reasonable to suggest that the reduced complexity does not come at the-price of reduced performance. Note that instructions that compute the-code point values will generally be optimized away when not needed. For-example, checking if a null-terminated string is properly UTF-8 encoded-\...--    int-    IsUTF8(uint8_t* s) {-      uint32_t codepoint, state = 0;--      while (*s)-        decode(&state, &codepoint, *s++);--      return state == UTF8_ACCEPT;-    }--\... does not require the individual code point values, and so the loop-becomes something like this:--    l1: movzx  eax,al-        shl    edx,4-        add    ecx,1-        movzx  eax,byte ptr [eax+404000h]-        movzx  edx,byte ptr [eax+edx+256+404000h]-        movzx  eax,byte ptr [ecx]-        test   al,al-        jne    l1--For comparison, this is a typical `strlen` loop:--    l1: mov    cl,byte ptr [eax]-        add    eax,1-        test   cl,cl-        jne    l1--With the large buffer and the same number of times as above, `strlen`-takes 1507ms while `IsUTF8` takes 2514ms.--License----------Copyright (c) 2008-2009 [Bjoern Hoehrmann](http://bjoern.hoehrmann.de/)-\<<bjoern@hoehrmann.de>\>--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.-:::--Changes----------25 Jun 2010-:   Added an improved variation based on an observation from Rich-    Felker.--30 April 2009-:   Added some more items to the performance table: the manually inlined-    transcoder allocating worst case memory for each run and freeing it-    before the next run; and results for Mozilla\'s NS\_CStringToUTF16-    (a new nsAutoString is created for each run, and truncated before-    the next). This used the XULRunner SDK 1.9.0.7 binary distribution-    from the Mozilla website.--18 April 2009-:   Added notes to the Variations section on handling malformed-    sequences and failed optimization attempts.--14 April 2009-:   Added PyUnicode\_DecodeUTF8Stateful times; the function has been-    modified slightly so it works outside Python and so it uses a-    pre-allocated buffer. Normally does not check output buffer-    boundaries but rather allocates a worst case buffer, then resizes-    it. Apparently the decoder [allows encodings of surrogate code-    points](http://bugs.python.org/issue3672).--Author---------[Björn Höhrmann](http://bjoern.hoehrmann.de) <bjoern@hoehrmann.de>-([Donate via-SourceForge](http://sourceforge.net/developer/user_donations.php?user_id=188003),-[PayPal](https://www.paypal.com/cgi-bin/webscr?cmd=_xclick&business=bjoern@hoehrmann.de&item_name=Support+Bjoern+Hoehrmann))
+ dev/MAINTAINING.md view
@@ -0,0 +1,308 @@+# Maintainers' Guide++## PR Merge Checklist++* All the CI tests pass+* New tests are added where applicable+* Benchmarks are added where applicable+* Run benchmarks locally if you suspect any regressions+* Documentation is added for any new combinators+  * New combinators have time and space complexity annotations+  * New combinators have `since` annotation+* Changelog entry is added for exposed combinators.+* Identify breaking changes, or changes that may require depndency+  version bound changes. See https://pvp.haskell.org/. Also see the+  "Breaking changes section below".+* Optionally, look at hlint output if anything in that is worth fixing.+* Merge the PR by rebasing. Note that github always creates new commits when+  merged with rebase, it records the committer as well as the author in the+  commit. This makes the local branch diverge from master. You can rebase and+  merge the commit manually in your local git tree and push the resulting+  master branch to avoid new commits and divergence from the original tree.++## Release Checklist++* Check if any critical pending bugs or issues are to be included+* If this is a major release check if any previously deprecated features are to+  be removed in this release.+* Check pre-release APIs to be exposed, especially from streamly-examples+* PVP is adhered to, additionally do not change pre-release APIs in a+  minor release++* _Documentation_:++    * README is updated, links in README are stable. Run `rg '/blob/'`+      and `rg '/tree/'` to search for github links, replace `master` ref+      with release tag where possible (e.g. streamly-examples). Ideally,+      the distribution process should automatically replace these with+      current stable references.+    * Haddock docs are consistent with the changes in the release+    * Tutorial has been updated for new changes+    * Documents in the `docs` directory are consistent with new changes+    * All combinators have time and space complexity annotations+    * All combinators have `since` annotation+    * Modules that were renamed or APIs that moved to other modules should be+      marked as "since" the current release.+    * Check all released modules to ensure that they do not have any leftover+      `Internal` or `Pre-release` annotations.+    * Unreleased combinators should be marked with `Pre-release` or+      `Internal` annotations+    * Streamly homepage is updated with the release docs+      * FileSystem.Event.Windows/Darwin modules require special handling++* _Build and Test_:++    * All CIs are green+    * Run tests using bin/test.sh to test with memory restrictions+    * Manually build and test for all flags (esp. `dev` flag) not covered by CIs+    * Test prime GHC version with -O0 and -O1++* _Benchmarks_:++    * Check regressions from previous release+    * Run benchmarks with large stream size (`bench.sh --long`) to+      check for space leaks and to ensure constant memory usage for streaming+      operations.+    * Run benchmarks with `dev` flag on. Some `fileio` benchmarks are disabled+      in regular runs.+    * Check comparative benchmarks using streaming-benchmarks++* _Dependencies_:++    * Make sure all dependency bounds can use latest versions+    * Update `stack.yaml` to latest stable resolver, cleanup extra-deps+    * Make sure fusion-plugin is up to date and uploaded+    * Check the dependency footprint of the library. See+      [Generating Dependency Graph](#generating-dependency-graph) section.++* _Dependent Packages_:++    * Update+      [streamly-examples](https://github.com/composewell/streamly-examples)+      to make sure it runs with the latest release.+    * Check the performance of examples where applicable+    * Update streamly-bytestring+    * Consider updating other packages e.g. streamly-process, streamly-lz4++* _Update Package Metadata:_++    * Make sure the description in cabal file is in sync with README and other docs+    * Make sure CI configs include last three major releases of GHC in CI testing.+    * Update GHC `tested-with` field+    * Update `docs/building.md` with the distributions tested with+    * Make sure any additional files are added to `extra-source-files` in cabal+      file. Artifacts required for build, test, benchmarks, docs, licenses+      should be packaged. Build environment customization may or may not be+      packaged.++* _Copyrights and Contibutors_++    * Make sure contributors to the release are listed in+      `credits/CONTRIBUTORS.md`.+    * Bump the release version in `credits/CONTRIBUTORS.md`.+    * Make sure any third party code included in the release has been listed in+      `credits/COPYRIGHTS.md` and the license is added to the repo.+    * Bump the release version in `credits/COPYRIGHTS.md`.++* _Update changelog & Version_:++    * Find API changes using `cabal-diff streamly 0.8.0 .` and record+      them in docs/API-changelog.txt.+    * Make sure all the bug fixes being included in this release are marked+      with a target release on github. So that users can search by release if+      they want.+    * Bump the package version in configure.ac and run autoreconf+    * Change the `Unreleased` section at the top of changelog file to the new+      release version number.+    * Bump the package version in cabal file or package.yaml+    * Bump the package version in any docs/links, use something like+      `rg '0\.7\.'|grep -v -i since` to find any remaining occurrences of the+      old release.  Check `rg -i unreleased` for any remaining todos.++* _Upload_:++    * Wait for final CI tests to pass:++        * Create a git tag corresponding to the release where X.Y.Z is the new+          package version (`git tag vX.Y.Z && git push -f origin vX.Y.Z`).+        * Mask out the build status lines from the README+        * Upload to hackage+          * Use a clean workspace to create source distribution+          by freshly cloning the git repository. The reason for+          doing this is that we use wild-cards in cabal file for+          `extra-source-files`, these wild-cards may match additional+          files lying around in the workspace and unintentionally ship+          them as well.+          * `cabal v2-sdist`; `cabal upload --publish <tarpath>`+          * `stack upload .`+        * Add to stackage (`build-constraints.yaml` in Stackage repo) if needed+        * Optionally upload `package-X.Y.Z-sdist.tar.gz` to github release page+            * Update release contributors on github release page+              (`git shortlog -s prev_tag..new_tag | sed $'s/^[0-9 \t]*/* /' | sort -f`)+        * Update and if needed release streaming-benchmarks package+        * Check https://matrix.hackage.haskell.org/package/streamly+        * Check haddocks on Hackage, upload if not built+        * Announce to haskell-cafe@haskell.org++## Breaking Changes++This section lists what constitutes breaking changes.  See+https://pvp.haskell.org/ breaking changes that can be determined by the+API alone. We specify some additional recommendations here:++Behavior changes, this kind of changes are nasty and should be avoided. If such+changes are made they should be emphasized adequately in the changelog:++* Silent changes in the behavior of an API without any changes to the+  signature.+* Even fixing a bug could break things as users may have employed workarounds+  for the bug.+* Changes in the behavior of a dependency may also cause a change in behavior.++Be cautious about the following:++* Change in version bounds of dependencies may cause compilation failure for+  some programs because they may not be able to find a build plan.+* Ideally, new warnings should not be considered breaking, dependencies+  should never be compiled with -Werror. But packages may not be following+  it perfectly.+* Deprecating an API may issue new warnings, however the code can still be+  compiled if warnings are not treated as errors.++Internal APIs:++* Internal APIs can change without having to change the major version. However,+  we should try to align the Internal API changes with a major release as long+  as possible.++## Managing Issues++We label the issues in different dimensions based on the lifecyle and different+management aspects of the issue. The folowing sections discuss the labels used+to manage the issues. If a new label is required, it should be discussed before+creating it.++### Disposition++The level-1 triaging of the issue determines the current disposition+of the issue. If no change is required the issue must have one of the+following labels:++* invalid+* question+* discussion+* duplicate+* wontfix++If a change is required we need to do level-2 triage of the issue, see the+sections below.++### Change type++When a change is required we need to put one of the __change type__+labels as part of level-2 triaging:++* performance: User visible impact on performance.+* usability: It is not convenient to use the library.+* documentation: documentation is not correct or sufficient.+* bug: A functionality issue, not working as expected.+* enhancement: A new feature or enhancement of the product.+* maintenance: A refactor or any other change with no user visible impact.++### Aspect++In addition we can put a __product aspect__ label describing a feature name or+any other product specific classification bucket.++* aspect:<aspect name>++### Severity++Optionally we can add a severity label to indicate how severe is the+impact of the bug/issue, which may determine how important it is to fix it. By+default the severity is normal, if it is high we put a label:++* severity:high++### Change impact++For a user visible issue whether it has a release/changelog impact:++* enhancement: includes a new feature or enhancement+* breaking: has a breaking impact on existing deployments+* deprecating: deprecates an existing functionality++__RULE__: Any commit that may affect the end user in some way MUST have+either a changelog entry OR MUST have an issue marked with one of the+above labels OR both.++### Priority++By default the issues are normal priority. We use a label for high priority+issues:++* priority:high++### Scheduling++If the issue is assigned to someone then it is considered scheduled. Otherwise+it is unscheduled.  Unassigned issues may have the following labels:++* deferred: blocked on any other fix or a decision to be made, or deliberately+  deferred for some reason.+* help-wanted: anyone can take the issue and contribute++## Correlating Changes, Issues and Releases++For planning purposes, open issues may be marked with milestones or target+releases.  However, it may not always be known which release a fix will finally+land in.  For example, we may decide to make a minor release instead of a major+one if there are no breaking changes yet, so we may not always know what would+be the next release version.++Trackability means that we should be able to find which issues got fixed in+which release. Or what all issues got fixed in a particular release. We track+significant changes using the changelog. However, there may be more changes+that can only be tracked via issues, PRs or commits.  When we make a release we+can mark all the issues fixed in that release with a correct release target for+future trackability.++For better trackability of which issue got fixed in which release we need the+following:++* Before you close an issue make sure a commit or a PR fixing the issue is+  attached with it. In the commit message you can reference an issue like+  "fixes #50", you can do the same in a PR as well.+* Before we make a new release EVERY issue with a commit included in that+  release that affects the end user, especially bugs and breaking changes MUST+  have the target release correctly set.++## Changelog Management++Keep the unreleased changes in the `Unreleased` section at the top of changelog+file.  Using `Unreleased` instead of the next release number for unreleased+changes is important. First, we do not know the next release number in advance,+it could be a major or minor release.  Second, if we use the next release+number instead, then when adding a new change to the changelog, at one look we+cannot know whether the release number on top is unreleased or released.++## TODO++* GPG signed releases and tags++## Generating Dependency Graph++Ways to get the dependencies. In the streamly package top dir:++```+# Keep only streamly in the packages section of stack.yaml+$ stack --system-ghc dot . --external|dot -Tpdf > streamly.pdf+```++Using nix, remove the test and benchmark components from+`shellFor/packages` in `default.nix` to get library only+dependencies. May show additional ghc boot libraries.++```+$ nix-shell --run "ghc-pkg dot | dot -Tpdf > streamly.pdf"+```
+ dev/ci-tests.md view
@@ -0,0 +1,54 @@+# Continuous integration tests++This file documents the required CI test matrix so that we do not accidentally+remove or miss any tests when making changes to CI configs:++## For prime GHC version:++Distribution:+  * build from source distribution WITHOUT a cabal.project file++Performance:+  * `--flag inspection` + `--flag fusion-plugin`+  * Run `bin/bench.sh --quick --raw`+  * Run `bin/test.sh`+  * -Werror (for lib, test, bench)++Lint:+  * -Werror (for lib, test, bench) (Need a Werror with default flags)+  * hlint++Doctests:+  * Run cabal-docspec++Coverage:+  * `coverage` build++Debug:+  * --flag debug++StreamK:+  * --flag streamk++Windows:+  * Windows + stack++MacOS:+  * MacOS + stack++## Other GHC versions++GHC head:+  * `--flag inspection` + `--flag fusion-plugin` tests to catch any+    issues early.+  * Ideally we should also be running perf tests and compare+    against the prime version.++Other GHC versions:+* build lib, test, bench, docs, run tests, on Linux platform, using+  cabal build++## GHCJS++GHCJS:+* Latest version ghcjs build (lib, test, bench), run tests
+ dev/container-api.md view
@@ -0,0 +1,65 @@+# Data Containers++Containers are persistent containers of data e.g. files, arrays, maps. For+consistency we use similar API for all such containers where possible. Usually+the API names are relative to the current module e.g. toBytes in an array+module means converting the array to bytes, it sounds intuitive if read+qualified with the module name e.g. Array.toBytes. This doc lists some+conventions and guidelines to be followed.++## Unfolds and Folds++* Unfolds are named as "read" or with a "read" prefix (e.g. readChunks).+* Folds are named as "write" or with a "write" prefix (e.g. writeChunks).++## From and Put++* Immutable construction from some external source is named with a "from"+  prefix (e.g.  fromList).+* Mutation of an existing container uses a "put" prefix instead of "from". When+  an API uses an existing container to write to and does not return a newly+  constructed container then use "put".+* "from" vs "put": "from" assumes creation of a new object, it may fail if the+  object being created already exists (e.g. the file exists), it may not take a+  lock as it assumes immutability. "put" may create a new object or overwrite+  an existing one, it may take a lock for writing as it assumes mutability.++## To and Get++* Converting the complete object to an external representation is prefixed with+  "to" (e.g. toBytes).+* For mutable objects "get" APIs may be used instead of "to" APIs.+* "to" vs "get": "to" assumes immutable object so does not have to take a lock.+  "get" assumes mutable object so may take a lock.++## Append++* Use "append" prefix for appending data at the end of a mutable container++## Random Access (Arrays)++* getIndex (for arrays)+* getSlice/getRange/getIndices+* putIndex (for mutable arrays)+* append (for mutable arrays)++## Key Access (Maps)++* getKey+* findKey (test existence)+* createKey (insert new key for mutable maps)+* putKey (insert or update for mutable maps)+* updateKey (update existing or fail)+* deleteKey  (delete existing or fail)+* destroyKey (delete existing or not)++## Points to Consider++The fold and unfold APIs can be used to express the to/from stream APIs. So we+may not need both, it may just add to more APIs being proliferated.++We may need an "append" style fold as well? What would "stream" append+operations be called then?++We may need locked version of "write" folds for mutable containers for+concurrent access.
+ dev/cps-vs-direct.rst view
@@ -0,0 +1,328 @@+Structured Loops (Direct Style)+===============================++::++  -- | Result of taking a single step in a stream+  data Step s a where+    Yield :: a -> s -> Step s a+    Stop  :: Step s a++  -- | Representation of a loop, step and state. Step returns the next value and+  -- the next state. We iterate on the state to keep producing more values.+  data Stream m a = forall s. Stream (s -> m (Step s a)) s++Generating+----------++::++  nil :: Monad m => Stream m a+  nil = Stream (const (return Stop)) ()++  -- | A single value+  fromPure :: Applicative m => a -> Stream m a+  fromPure x = Stream step True++      where++      step True  = return $ Yield x False+      step False = return $ Stop++  fromList :: Applicative m => [a] -> Stream m a+  fromList = Stream step++      where++      step _ (x:xs) = pure $ Yield x xs+      step _ []     = pure Stop++Eliminating+-----------++::++  foldrM :: Monad m => (a -> m b -> m b) -> m b -> Stream m a -> m b+  foldrM f z (Stream step state) = go state++      where++      go st = do+            r <- step st+            case r of+              Yield x s -> f x (go s)+              Stop      -> z++In the above code the state is explicit and being threaded around in a+recursive loop. The state from the previous iteration is to be consumed+by the next iteration to generate the next value.  This mandates a+closed recursive loop. This is straightforward translation of imperative+loops to functional paradigm.++Transforming Loops+------------------++::++  mapM :: Monad m => (a -> m b) -> Stream m a -> Stream m b+  mapM f (Stream step state) = Stream step' state++      where++      step' st = do+          r <- step st+          case r of+              Yield x s -> f x >>= \a -> return $ Yield a s+              Stop      -> return Stop++State wrapping+--------------++Some operations like "drop" (uniq, intersperse, deleteBy, insertBy) may+have to introduce a branch in the code by wrapping the state in another+layer::++  drop :: Monad m => Int -> Stream m a -> Stream m a+  drop n (Stream step state) = Stream step' (state, Just n)++      where++      step' (st, Just i)+        | i > 0 = do+            r <- step st+            return $+              case r of+                Yield _ s -> step' (s, Just (i - 1))+                Stop      -> Stop+        | otherwise = step' (st, Nothing)++      step' (st, Nothing) = do+        r <- step st+        return $+          case r of+            Yield x s -> Yield x (s, Nothing)+            Stop      -> Stop++Note that the branch is always checked for every element in the stream.+It is still quite efficient because the code fuses.++We should use rewrite rules to fuse such consecutive operations together as+they introduce branching which could be costly.++Composing Loops+---------------++Composing two independent loops together is not scalable, we need+to create a wrapper state, wrapping the state of the old stream:++::++  cons :: Monad m => m a -> Stream m a -> Stream m a+  cons m (Stream step state) = Stream step1 Nothing++      where++      step1 Nothing   = m >>= \x -> return $ Yield x (Just state)+      step1 (Just st) = do+          r <- step st+          return $+            case r of+              Yield a s -> Yield a (Just s)+              Stop      -> Stop++As we keep consing we keep creating more layers wrapping the state in+``Maybe``. These layers need to be traversed every time we run the step+function of the composed stream. In the above example ``step1`` needs+to always branch on ``Nothing/Just`` to reach to the wrapped stream. More+layers we add the more branching needs to occur to generate an element+of the stream. If we have ``n`` "cons" operations we need to go through:++* 1 branch at the top level to generate the first element+* 2 branches to generate the next element+* 3 branches to generate the third element+* n branches to generate the nth element++The total number of branches that we need to take is: ``1 + 2 + 3 ... n`` i.e.+``n * (n + 1)/2 = O(n^2)`` where ``n`` is the number of cons operations.++Conceptually, to avoid the introduction of a branch we could use a+mutable step function and state to modify step1/state after yielding+the first element. The next time we call it, it would be a different+function that i.e. "step" and its state "st". However, that would introduce+an indirection and mutability. There is a better way to do it with+immutability i.e. CPS.++CPS representation+==================++In the direct representation we represented a stream using a step and a+state. This model requires us to iterate the step on the state creating+an explicit loop. The state machine implemented by the step function is+incrementally modified by adding new layers in the state which introduce+branches to be traversed every time we go through the loop.++::++  newtype Stream m a = Stream+      { runStream :: forall r. (a -> Stream m a -> m r) -> m r -> m r }++Here we represent the stream as a single function.  Instead, the+function is provided with functions to be called next.++Notice, the function does not have to be called again and again to+iterate on a state for generating new values.  Therefore, there is no+closed recursion. There is no explicit loop.++We (the current ``runStream`` function) can choose which one of the supplied+functions (continuations) to call next.  If we decide to terminate+the stream execution we call the "stop" continuation. If we decide to+generate a value we call the "yield" continuation.++A stream execution is composed of a progression of such continuations+until one of those decides to call the stop continuation.  It is a+composition of functions, a tree of functions composed together.++Yield continuation+------------------++The yield continuation is provided with the generated value "a" and the+"Stream m a", the function representing the rest of the stream. Notice+that the stream function is done with one shot execution, there is no+closed loop or recursion, the future execution of the stream is the+responsibility of the continuation.++The continuation consumes the element "a" and then proceeds to call+"Stream m a" using a "yield" and "stop" continuation. By modifying the+"yield" and "stop" continuations that it passes to call "Stream m a", it+can control the execution of the stream.++Generating+----------++::++  nil :: Stream m a+  nil = Stream $ \_ stp -> stp++  fromPure :: a -> Stream m a+  fromPure a = Stream $ \yield _ -> yield a nil++  cons :: a -> Stream m a -> Stream m a+  cons a r = Stream $ \yld _ -> yld a r++  fromList :: [a] -> Stream m a+  fromList = Prelude.foldr cons nil++Eliminating+-----------++::++  foldrM :: (a -> m b -> m b) -> m b -> Stream m a -> m b+  foldrM step acc m = go m+      where+      go m1 =+          let stop = acc+              yieldk a r = step a (go r)+          in runStream yieldk stop m1++Note that unlike in direct style fold, there is no generator state being+threaded around here instead the function yielded by the continuation is+being executed.++Transforming+------------++::++  map :: (a -> b) -> Stream m a -> Stream m b+  map f = go++      where++      go m1 =+          Stream $ \yld stp ->+            let yieldk a r = yld (f a) (go r)+            in runStream yieldk stp m1++In direct style we had to examine the constructors to determine the+current state and execute code based on that. Here, we have to make+the next function call at each step. The former is much more efficient+because the compiler can optimize well to remove the constructors and+generate code with direct branches not involving the constructors. On+the other hand placing a function call is costlier. Though in some cases+it can be avoided by using foldr/build fusion but not always.++goto+----++::++  drop :: Int -> Stream m a -> Stream m a+  drop n = Stream $ go n++      where++      go n1 m1 =+        Stream $ \yld stp ->+          let yieldk _ r = runStream yld stp $ go (n1 - 1) r+          in if n1 <= 0+             then runStream yld stp m1+             else runStream yieldk stp m1++This shows a crucial difference between direct style and CPS. In direct+style we have to always check for the branch to determine if we are+dropping the elements or consuming. In this case we can see that once+we have taken the "then" path we never have to check the condition "n1+<= 0", it is out of the way.++Basically CPS provides us the ability to take an exit path and forget+about the past code forever. So if we have a million "drop" composed+together CPS would have no problem, after the final drop there won't be+any branches in the way whereas direct style would introduce a million+branches to be traversed forever.++Combining Streams+-----------------++::++  cons :: a -> Stream m a -> Stream m a+  cons a r = Stream $ \yld _ -> yld a r++Unlike in direct style representation, the performance of stream+generation is independent of the number of "cons" operations. There is+no quadratic complexity, we simply call the next continuation at each+step.++Similarly appending streams is independent of number of appends.++::++  serial :: Stream m a -> Stream m a -> Stream m a+  serial m1 m2 = go m1++      where++      go m =+        Stream $ \yld stp ->+           let stop       = runStream yld stp m2+               yieldk a r = yld a (go r)+           in runStream yieldk stop m++Interleaved production and consumption+--------------------------------------++In the direct style we have an explicit stream generator. A consumer+generates values using the generator and consumes them. In CPS the+consumer and generator are interleaved. The ``runStream`` function is a+generator and the "yield" continuation is a consumer. The consumer then+calls the generator again and so on.++Loop vs goto+------------++The direct style representation is like a structured loop with well+defined exit points. Whereas the CPS representation can exit from+anywhere. Therefore, exception handling and resource management in+direct style is much simpler to implement.
+ dev/dfa-bytes.png view

binary file changed (absent → 18288 bytes)

+ dev/dfa-classes.png view

binary file changed (absent → 15413 bytes)

+ dev/dfa-rearr.png view

binary file changed (absent → 16619 bytes)

+ dev/linked-lists.md view
@@ -0,0 +1,32 @@+# Linked Lists++The immutable Haskell lists or streams are great for stream processing.+However, they may not be suitable for purposes where we need to store data for+a longer while. In such cases we need mutable linked lists in pinned memory for+high performance applications i.e. we need the C like linked lists. Here are+some cases where linked-lists may be warranted instead of immutable lists:++* Let's say we want to buffer incoming data in a list. The buffered data may be+  millions of elements. When we are buffering we may allocate cells from+  different areas of the GC heap. When there are other activities going on we+  may have to keep copying this buffered data during GCs. When we consume this+  buffer, again it creates a fragmented heap and we may have to copy some other+  long-lived data to defragment the heap. The point is that we should not have+  long-lived data in the GC heap.++* When we delete a node in the list, Haskell lists have to be recreated+  generating a lot of garbage. We cannot take a reference to the unmodified+  segments and reuse them in the new list. On the other hand with mutable+  linked-lists we can delete a node cheaply. This could be a common case in a+  hash table collision chain which requires deletion of elements.++* Similar to deletion, if we need to insert an element in the middle of the+  list, an immutable list has to be re-created.++* To implement a queue, two lists in the immutable model can be used+  efficiently if we are strictly adding at the end and deleting from the front+  and if there is sufficient batching so that swapping of the lists is not a+  common operation. If we have to insert elements in the middle or if we have+  to swap too many times again we will have the same GC issues as stated above.+  For example, in implementations of priority search queues or timer wheels we+  have to mutate the lists.
+ dev/module-organization.md view
@@ -0,0 +1,250 @@+# Internal vs External Modules++## Exposing Internal Modules++We keep all modules exposed to facilitate convenient exposure of experimental+APIs and constructors to users. It allows users of the library to experiment+much more easily and carry a caveat that these APIs can change in future+without notice.  Since everything is exposed, maintainers do not have to think+about what to expose as experimental and what remains completely hidden every+time something is added to the library.++## Internal module Namespace++We expose the internal modules via `Streamly.Internal.*` namespace to keep all+the internal modules together under one module tree and to have their+documentation also separated under one head in haddock docs.++## Exposed Modules as Wrappers++Another decision point is about two choices:++* Keep the implementation of all the APIs in an internal module and just+reexport selected APIs through the external module. The disadvantages of this+are:++  1) users may not be able to easily figure out what unexposed APIs are available+  other than the ones exposed through the external module. To avoid this problem+  we can mark the unexposed APIs in the docs with a special comment.++  2) In tests and benchmarks we will be using internal modules to test internal+  and unexposed APIs. Since exposed APIs are exported via both internal and+  external modules we will have to be careful in not using the internal module+  for testing accidentally, instead we should always be using the exposed module+  so that we are always testing exactly the way users will be using the APIs.++* Keep the implementations of unexposed modules in the internal module file+and exposed module in the external module file. In this approach, users can+easily figure out the unexposed vs exposed APIs. But maintaining this would+require us to move the APIs from internal to external module file whenever we+expose an API.++We choose the first approach.++# Module Types and Naming++## Abstract modules++An abstract module represents an abstract interface using a type+class.  Multiple concrete modules can make use of this interface and possibly+extend it.++For example we have an `IsStream` type class that all stream types+implement.  The concrete stream types are `SerialT`, `AsyncT`+etc. Assuming `Streamly.Data.Stream` is the containing name space for+all stream modules, there are multiple ways to organize abstract and+concrete modules. The `IsStream` type class can be placed in:++* `Streamly.Data.Stream.Class` or `Streamly.Data.Stream.Interface`+* `Streamly.Data.Stream.IsStream`+* `Streamly.Data.Stream`++Using `Streamly.Data.Stream.IsStream` is preferred over `.Class` because it+conveys more information by the class name. We can place it in+`Streamly.Data.Stream` as well.++Concrete modules depend on the abstract module `IsStream` to implement+that interface.++Polymorphic operations utilizing the abstract interface can go in the+parent module `Streamly.Data.Stream`.++## Constrained Modules++Some modules represent operations on a type which constrain a type using a type+class or a specific instance of a general type. For example, we may have Arrays+that operate on a `Storable` or a `Prim` type.++One possible way to organize such module is to have a `Storable` or `Prim`+hierarchy and all data structures using that type constraint are bundled under+it. However, in general, a data structure may have multiple such+constraints or may have to be organized based on some other dimension+like an abstract interface it is implementing.++General purpose constraints like `Prim` can be defined in their own module+hierarchy and can be used everywhere. For example, we can have the following+Array types, here we have organized the types under the `Array` hierarchy+rather than putting the `PrimArray` under a `Prim` hierarchy.++```+Streamly.Internal.Data.Array.Boxed+Streamly.Internal.Data.Array.Prim+Streamly.Internal.Data.Array.Prim.Pinned+```++## Common Modules++Some modules represent common types or utility functions that are shared across+multiple higher level modules. Possible naming for such modules are:++* `Module.Types`+* `Module.Common`+* `Module.Core`+* `Module.Shared`++## Aggregate modules++In some cases we may want to aggregate the functionality of several small+modules in a combined aggregate module. In many cases, the aggregate module is+made a parent module of the constituent modules.  The parent module depends on+the child modules and exposes the functionality from the constituent modules.++## Placeholder Modules++In some cases a parent module is just a placeholder in the namespace and does+not export any functionality.++# Polymorphic vs Monomorphic Modules++In general we can just provide a polymorphic stream API and let the user use it+at the type he/she wants to use it. However, it has some disadvantages:++* Some constraints e.g. "MonadAsync" are unnecessarily imposed on all APIs even+  though they are needed by only concurrent types.+* type errors could be harder to resolve when using polymorphic types+* combinators like `fromAsync` can make all the combinators concurrent in one go+  which is usually problematic. If we use monorphic combinators it encourages+  to pick the required concurrent combinators one at a time which is+  usually better for performance.++Keeping this in mind our plan is to provide monomoprhic modules for each stream+type, keep the combinators that are specific to that stream type in the+monomorphic module and combinators that are exactly the same for all stream+types can be kept in the polymorphic module or in both the modules. Having+complete set of operations available in the monomorphic module has the+advantage that if we want we can just import a `Serial` module and get+everything if we just want to use the Serial stream.++# Streamly Modules++We use the "Streamly" prefix to all the module names so that they do not+conflict with any other module on Hackage.++We have the following module hierarchy under Streamly:++* Data: This is a generic bucket for basic data structures a la the `base`+  package's `Data` hierarchy.+    * Streamly.Data.Array++  Streams can be classified under `Data` or `Control`.  Though they are+  mostly used for processing, they can also be used to store data in+  memory.+    * Streamly.Data.Stream++  The following modules could in fact be classified under `Control`+  too as they are about processing of data rather than data itself:+    * Streamly.Data.Unfold+    * Streamly.Data.Fold+    * Streamly.Data.Parser++* Unicode: Unicode text processing:+    * Streamly.Unicode.Char       -- operations on individual chars+    * Streamly.Unicode.Stream     -- operations on streams of Char+    * Streamly.Unicode.Array.Char -- compact strings of UTF-32 chars+    * Streamly.Unicode.Array.Utf8 -- compact strings of UTF-8 encoded chars++* FileSystem: This name space is for data structures that reside in files+  provided by a file system interface on top of storage devices.++* Network: This name space is for APIs that access data from remote computers+  over the network.++## Stream modules++By default the streaming modules are effectful. The basic effectful+stream types are:++* `Streamly.Data.Stream`+* `Streamly.Data.Stream.Async`+* `Streamly.Data.Stream.Ahead`+* `Streamly.Data.Stream.Parallel`+* `Streamly.Data.Stream.IsStream` -- polymorphic operations+* `Streamly.Data.Stream.Using`    -- e.g. mapMUsing consMAsync++The above streams have an append-like multi-stream combining behavior+i.e. `concatMap` and `bind` would by default evaluate the streams one+after another. Alternative implementations of `concatMap` and `bind` are+possible. We can either use rebindable syntax to use a different bind or+define newtypes with a different bind behavior, all other operations for+these remain the same as the base type:++* `Streamly.Data.Stream.Zip`+* `Streamly.Data.Stream.Interleaved`+* `Streamly.Data.Stream.RoundRobin`+* `Streamly.Data.Stream.Async.Zip`+* `Streamly.Data.Stream.Async.Interleaved`+* `Streamly.Data.Stream.Async.RoundRobin`+* ...++Pure streams are a special case of effectful streams and have the same+interface as lists, so we put them under `Streamly.Data.List`:++* `Streamly.Data.List`+* `Streamly.Data.List.Zip`+* `Streamly.Data.List.Interleaved`+* `Streamly.Data.List.RoundRobin`+* ...++We could possibly use the same type named `Stream` for all stream+types, as the names of all stream operation are also the same and we+distinguish only by the module name.++## Array modules++Similarly, the immutable Array modules would go in:++* `Streamly.Data.Array`                  -- unpinned, native memory arrays+* `Streamly.Data.Array.Storable`         -- unpinned, unboxed, native memory arrays+* `Streamly.Data.Array.Storable.Pinned`  -- pinned, unboxed, native memory arrays+* `Streamly.Data.Array.Foreign` -- pinned, unboxed, foreign capable arrays++Unboxed arrays, based on `Prim` type class:++* `Streamly.Data.Array.Prim`+* `Streamly.Data.Array.Prim.Pinned`++Mutable arrays are a generalization of immutable arrays:++* `Streamly.Data.Array.Mut`+* `Streamly.Data.Array.Storable.Mut`+* `Streamly.Data.Array.Storable.Pinned.Mut`+* ...++## Stream and Fold Channels (SVar)++* `Streamly.Data.Stream.Channel`+* `Streamly.Data.Stream.Channel.Storable`+* `Streamly.Data.Fold.Channel`+* `Streamly.Data.Fold.Channel.Storable`++## Mutable variables++Unboxed IORef:++* `Streamly.Data.IORef.Prim`++## Strict Data++* `Streamly.Data.Tuple.Strict`+* `Streamly.Data.Maybe.Strict`+* `Streamly.Data.Either.Strict`
+ dev/optimization-guidelines.md view
@@ -0,0 +1,358 @@+# Guidelines for writing well optimized code++Stream operations are always part of a loop. Usually the loop consists of a+stream generation or an unfold operation followed by stream transformation+functions (e.g. map) and then a stream elimination operation or a fold+operation.++The default or most common stream representation used in streamly is+`StreamD` which is a direct style (compare with CPS representation+`StreamK`) stream representation.  All the direct style operations in+a loop "fuse" together to form a tight machine loop eliminating any+intermediate constructors, therefore, reducing allocations and cpu cost.+This elimination of intermediate constructors in a stream loop is known+as stream fusion.++## Writing high performance code using streamly++This section outlines guidelines for writing code using the available+combinators. The guidelines for writing new combinators are provided in+the following section.++Note that there is no absolute benchmark for performance, most of+the time even without following the guidelines you may get excellent+performance for the task at hand. Two important points to keep in mind+before you optimize:++* See if you actually need more performance+* See if the code you are optimizing is in fast path++### Stream Fusion++When your performance requirements are stringent you may want to care+about not breaking stream fusion unnecessarily.  Certain operations do+not fuse and act as a barrier to stream fusion. If these operations are+part of a loop, the loop won't fuse completely. In some cases these may+be necessary but in others it may be possible to replace these with+better fusing operations. These operations include:++* Avoid unnecessary use of stream append operations in code that should+  fuse.  Append operations in general force CPS style breaking stream+  fusion.  Some direct style append operations can fuse but they won't+  scale for more than a few appends.+* Avoid unnecessary use of the stream monad if fusion is important. You+  may use functor or applicative though.+* Concurrent stream operations cannot fuse+* Operations involving exception primitives like catch/throw/mask+  on elements of the stream cannot fuse.+* Stream loops involving FFI calls on the elements of the stream++The haddock documentation includes a note when an operation cannot fuse.++### Unfolds++* Use unfolds especially when higher order operations are involved. For+  example, `unfoldMany` can fuse completely whereas `concatMap` would+  not fuse.+* Use `outerProduct` in `Unfold` module instead of using the monad instance of+  streams to fuse nested loops where performance matters. See the unfold+  benchmarks for an example. `outerProduct` can give you C like nested loop+  performance.++### Inlining++To make sure fusion can occur INLINE any operations that are part of a+stream loop but factored out as separate functions.++### Strictness++Keep the fold and scan accumulators strict. You could also consider+using mutable state in a fold accumulator if the state is large. A+large immutable structure as an accumulator may cause optimization+issues. See the `WordCount` example for an example of this case.++## Writing streamly combinators++To enable stream fusion in a direct style stream all the operations that+are part of a loop must be inlined:++* Use an explicit INLINE pragma on any combinator that could be part of a loop+  to ensure they will be inlined.+* When a higher order function consumes another function then ensure that the+  higher order function is inlined in the same phase or before the function it+  is consuming. Use appropriate inline phases to ensure proper inline ordering+  when required.++### Streams and Unfolds++Stream and Unfold State.  Direct style stream and unfold combinators use a+state data type to represent the internal state of the stream/unfold generator.++* In some cases we may have to add a `FUSE` annotation on the state type to+  ensure that all the internal join points created by GHC are inlined with the+  help of the `fusion-plugin`.+* In rare cases we may need to use a strictness annotation on the state+  to allow fusion. `parseMany` and `splitOnSeq` are such examples.++Step function of a stream or unfold:++* Do not introduce unnecessary states. If there is only one entry point of a+  state then perhaps you want to collapse the state into the state from which+  it is called. More states means more jumps and may affect code locality, and+  efficiency of low level code (e.g. register allocation) because of+  independent placement of the code blocks in different states.++  In some cases we may have to go against the above guideline and introduce a+  separate state even though it is not necessary. See the GroupConsume state in+  foldMany for an example.+* Keep minimum possible data in state. More variables in state may lead+  to poor performance because the state may not fit into registers and the+  spill may cause allocations on each iteration of the loop. Mutable state+  may help in such cases.+* The step function must be annotated such that it gets inlined after the main+  combinator (`INLINE_LATE`).++Multiple yield points or single?:++* A single yield point is usually desirable, however, not always necessary.+  In some cases multiple yield points may in fact be needed for fusion,+  see `splitOnSeq` for an example. Or maybe its fusing because of a+  direct yield instead of going through an indirect common yielding+  state.++Recursion in step function:++* In general, we avoid making the step function recursive. Use the+  `Skip` constructor to remove recursion. Recursive step function can+  introduce optimization barriers that are harder to remove by the GHC+  simplifier.++  However, in some cases it may be better to have a local recursive+  loop. A recursive loop can help us avoid threading around some large+  state values every time. Values that do not change across a loop can+  be factored in the scope outside the loop (static argument transform),+  this way we can create a local loop which is more efficient than+  threading around the state in a larger loop.  See the `splitOnSeq`+  combinator as an example where we use a local recursive loop, it fuses+  and is significantly efficient compared to using `Skip`.++  In a local recursive loop use SPEC and annotate even the rest of the+  loop arguments as strict where needed. We have observed that when the+  arguments were not strict the loop does not fuse (splitOnSeq).++### Fold and Parser drivers++Recursive loop closing operations:++* When writing recursive looping combinators using StreamD (e.g. foldlM' in+  StreamD) use a strict SPEC argument in the recursive loops to ensure that+  "Spec Constructor" optimization removes boxed arguments and reduces+  allocations.++### Fold and Parser combinators++State of a Fold or Parser:++* The accumulator of a fold must be a strict data structure. Use the strict+  data structures provided in `Streamly.Internal.Data` for this purpose or use+  explicit bang annotation to make the data strict.+* In some cases you may need a `FUSE` annotation on the state type to ensure+  that any internal join points created by GHC are always inlined with the help+  of the fusion-plugin.++The step function of a Fold or Parser:++* Never make the fold step recursive, recursion creates an optimization barrier+  for the GHC simplifier. Use `Partial` or `Continue` constructors to avoid+  recursion.++* Sometimes you may need an explicit INLINE on the step function.++### NOINLINE, isolating the closed loop++We want the loop iterations to be optimized and the loop stages to be fused to+generate a tighter loop. However, it is not necessarily optimal to inline the+whole loop itself into a parent function. For example, consider the following+function in the `FileSystem.Handle` benchmarks:++```+{-# NOINLINE readWriteAfter_Stream #-}+readWriteAfter_Stream :: Handle -> Handle -> IO ()+readWriteAfter_Stream inh devNull =+    let readEx = IP.after_ (hClose inh) (S.unfold FH.read inh)+     in S.fold (FH.write devNull) readEx+```++If this is inlined into a parent benchmark group list, this leads to+many times performance degradation. That's because inlining the loop+into a bigger structure interferes with the optimization of the loop+body itself and it may not fuse. Whereas it is desirable to INLINE all+the stages of a loop, it is often not useful to inline the whole loop+itself, in fact we may have to occasionally use a `NOINLINE` so that the+compiler does not inline it.++### NoSpecConstr++It is not always useful to specialize function calls for all constructors, some+constructors may just add to code bloat or add overhead of passing unboxed+values in a loop. In such cases the `NoSpecConstr` annotation can be useful.+See the `parselMx'` function in `StreamD` module.++### StreamK operations++StreamK uses foldr/build fusion to a very limited degree. StreamK is not the+primary representation in streamly but is used for several operations that+cannot scale in StreamD representation. StreamK is relatively immune to compiler+optimizations. In some cases you may need an INLINE pragma to improve the+performance.++### How to debug non-fusing code?++Strip down the code to a minimal version until it starts fusing and then+start building it up from there adding more things incrementally. At+each stage keep checking if the code is fusing. At some point it+won't fuse. See what we added that made the code not fuse. Go through+the guidelines above to check if we did something that that is not+recommended. Or raise an issue for GHC to be fixed if possible.++# GHC Optimizations In Streamly++There are three important levels of optimizations used in streamly:++* CPS style stream representation (StreamK) to direct style (StreamD)+  conversion and vice-versa using rewrite rules+* Stream fusion using case-of-case optimization in StreamD+* foldr/build fusion using rewrite rules in StreamK++## INLINE Phases++Inlining of functions at the right time is crucial for all these optimization+to work.  A missing inline or inline in an incorrect GHC simplifier phase can+adversely impact performance.  We use three builtin phases of GHC simplifier+for inlining i.e. phase 0, 1 and 2. We have defined them as follows in+  `src/inline.hs`:++```+#define INLINE_EARLY  INLINE [2]+#define INLINE_NORMAL INLINE [1]+#define INLINE_LATE   INLINE [0]+```++We also use INLINE [3] in some cases.++## `fromStreamD/toStreamD` Fusion++The combinators in `Streamly.Prelude` are defined in terms of combinators in+`Streamly.Internal.Data.Stream.StreamD` (Direct style streams) or+`Streamly.Internal.Data.Stream.StreamK` (CPS style streams). We convert the+stream from `StreamD` to `StreamK` representation or vice versa in some cases.++Most operations use the StreamD representation, however, stream append+operations and monad instances use StreamK representation because StreamD would+not perform well in these cases. We use rewrite rules to convert from one+representation to another when required. For this reason the combinators in+Streamly.Prelude are written using fromStreamD/fromStreamK etc.++In the first inlining phase (INLINE_EARLY or INLINE) we expand the combinators+in `Streamly.Prelude` into fromStreamD/fromStreamK/toStreamD/toStreamK and+combinators defined in StreamD or StreamK modules. Once we do that+fromStreamD/toStreamD get exposed and we can apply rewrite rules to rewrite+transformations like `fromStreamK .  toStreamK` to `id`. A plain `INLINE`+pragma is usually enough on combinators in `Streamly.Prelude`.++```+{-# RULES "fromStreamK/toStreamK fusion"+  forall s. toStreamK (fromStreamK s) = s #-}+```++Also, we have to prevent fromStreamK and toStreamK themselves from inlining in+this phase so that rewrite rules can be applied on them, therefore, we annotate+these functions with `INLINE_LATE`.++## Fallback Rules++In some cases, if the operation could not fuse we want to use a fallback+rewrite rule in the next phase. For such cases we use the INLINE_EARLY phase+for the first rewrite and the INLINE_NORMAL phase for the fallback rules.++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.++```+{-# INLINE_EARLY unfoldr #-}+unfoldr :: (Monad m, IsStream t) => (b -> Maybe (a, b)) -> b -> t m a+unfoldr step seed = fromStreamS (S.unfoldr step seed)+{-# RULES "unfoldr fallback to StreamK" [1]+     forall a b. S.toStreamK (S.unfoldr a b) = K.unfoldr a b #-}+```++## High Level Operation Fusion++Since each high level combinator in `Streamly.Prelude` is wrapped in+`fromStreamD/toStreamD` etc. the combinator fusion cannot work unless we have+removed those and exposed consecutive operations e.g. a `map` followed by+another `map`.  Assuming that redundant `fromStreamK/toStreamK` have been+removed in the `INLINE_EARLY` phase, we can then apply the combinator fusion+rules in the `INLINE_NORMAL` phase.  For example, we can fuse two `map`+operations into a single `map` operation.  Note that now we have exposed the+`StreamD/StreamK` implementations of combinators and the rules would apply on+those.++## Inlining Higher Order Functions++Note that partially applied functions cannot be inlined. So if we have a code+like this:++```+concatMap1 src = runStream $ S.concatMap (S.replicate 3) src+```++We want to ensure that `concatMap` gets inlined before `replicate` so that+`replicate` becomes fully applied before it gets inlined. Currently ensuring+that both of them are inlined in the same phase (`INLINE_NORMAL`) seems to be+enough to achieve that. In general, we should try to ensure that higher order+functions are inlined before or in the same phase as the functions they can+consume as arguments. This means `StreamD` combinators should not be marked+as `INLINE` or `INLINE_EARLY`, instead they should all be marked as+`INLINE_NORMAL` because higher order functions like `concatMap`/`map`/`mapM`+etc are marked as `INLINE_NORMAL`. `StreamD` functions in other modules like+`Streamly.Data.Array.Foreign` should also follow the same rules.++## Stream Fusion++In StreamD combinators, inlining the inner step or loop functions too early+i.e. in the same phase or before the outer function is inlined may block stream+fusion opportunities. Therefore, the inner step functions and folding loops are+marked as INLINE_LATE.++## Specialization++In some cases, the `step` function in `StreamD` does not get specialized when+inlined unless it is provided with an explicit signature or made a lambda, for+example, in the `replicate/replicateM` combinator we need the type annotation+on `i` to get it specialized:++```+    {-# INLINE_LATE step #-}+    step _ (i :: Int) =+        if i <= 0+        then return Stop+        else do+                x <- action+                return $ Yield x (i - 1)+```++`-flate-specialise` also helps in this case.++## Stream and Fold State Data Structures++Since state is an internal data structure threaded around in the loop, it is a+good practice to use strict unboxed fields for state data structures where+possible. In most cases it is not necessary, but in some cases it may affect+fusion and make a difference of 10x performance or more.  For example, using+non-strict fields can increase the code size for internal join points and+functions created during transformations, which can affect the inlining of+these code blocks which in turn can affect stream fusion.++See https://gitlab.haskell.org/ghc/ghc/issues/17075 .
+ dev/paths.rst view
@@ -0,0 +1,230 @@+Introduction+------------++Paths are used by file systems as well as protocols to represent paths to files+and other resources. We need a generic type safe way to represent paths in+general and file system paths in particular.++Path limits+-----------++OS include files generally define PATH_MAX to 4K and NAME_MAX to 255,+however, it is possible to create paths bigger than these depending on+the file system.++Scalability+-----------++In general directory trees could be quite deep and a directory can contain+millions of entries. A good benchmark to measure the efficiency of path+representation would be to traverse a directory tree recursively and list all+the nodes under the tree. We could do this many times so that we do not need a+really big directory tree.++Compatibility+-------------++A file system starts with just the root directory and then files are+created in the file system by the user or by programs storing their data+on the file system. When a directory or file is created, or when a directory is+listed, the following operations are performed:++1. for lookups an existing directory name must be resolved based on the name+   supplied by the user.+2. for creation the file name to be created is supplied by the user++When the user asks the file system to lookup or create a file or+directory in the file system:++1) The operating system passes the name, as it is without any changes+   whatsoever, to the file system. or does it? Windows?+2) The file system may translate the name to its own conventions before a+   lookup or create, e.g. it may++   * change the name to upper case+   * translate the name to 8.3 chars+   * change the character encoding?+   * change the unicode normalization form of the name (Apple)++When resolving an existing directory name in the file system we need+to supply a path which consists of component names separated by a separator+byte. Separators are of no consequence to the file system, they are+resolved by the OS and the path components are used to lookup the paths+one components at a time. The path for lookup is acquired either by a+user input, device input or by the program which previously got the path+entries by traversing the file system itself.++1) When the path is acquired by a user input,  the user input could be:++   a) a literal string in the program+   b) a path entered via an input device+   c) a path coming from the network++2) If the path was previously acquired from the file system then the+   best thing to do is to never change anything in the path and store it+   as it is and supply exactly the same path when needed. That way we can+   guarantee that the path remains exactly what it was in the file system.++Handling String Literals+========================++The encoding of the source code file depends on the editor used and the+encoding chosen when saving it. The string literals would be parsed+by the GHC parser and then stored in the generated binaries as null+terminated C string literals encoded in UTF-8 (see GHC reference). There are+several possible points of failure here:++a) GHC parser needs to interpret the source code encoding correctly.+b) We assume that the editor does not perform any translation on the+   literal as entered by the user e.g. it does not perform unicode+   normalization on it. If it does then the string as entered by the user+   won't remain the same when it reaches the file system.+c) GHC parser stores the parsed string literal in UTF-8 encoding. We+   assume that GHC does not perform any unicode normalization or any+   other translation on the string.++The UTF-8 encoded string literal can be passed as a blob of bytes to the file+system or it can be converted to String type and re-encoded as UTF-8 both+should work equivalently in this case.++Handling Input From Devices+===========================++The path provided by the user would assume some encoding based on+the terminal settings or the encoding assumed by the sender over the+network. The correctness depends on the contract between the two parties+e.g. the locale setting. We assume that we get a sequence of raw bytes+from the input device. We need to use the sequence as raw bytes and send+it as it is to the file system without any translation.++Manipulating Paths+------------------++We need to parse the path components by the separator bytes.  We assume+that the separator can be identified and removed correctly irrespective+of the encoding. We also make sure that none of the bytes in the+components is a separator byte.++Also, we would join the path components by the separator byte+irrespective of the encoding of the components. If the OS treats the+path as a sequence of bytes and nothing else and the components do not+have the separator byte then we are good, we know that the OS would also be+parsing based on the separator as a raw byte.++We may perform some validations on the paths such as the file names are+not "." or "..". Such validations could be optional and we could also+provide a way to not perform any validations and just blindly use the+paths as provided by the user and let the file system/OS fail.++File System Translations+------------------------++As we noted earlier, the file system may translate the paths before+using them.  For example, it may store the path after converting it to+NFD unicode normalization. Translation may create some round tripping+issues for programs. For example, a program may use a string literal+which is stored in NFC and the file system converts it to NFD. Later,+when the same path is retrieved from the file system and compared with+the string literal that was to create it then it won't match. For such+cases the programs need to understand the file system and perform+comparisons by performing appropriate translations on the paths. To+perform matching and translations correctly the program needs to+correctly interpret the encoding specific to the file system.++Displaying Paths+----------------++When we display the paths to the user then we are forced to interpret+it according to some encoding, to display the path correctly we have to+know exactly how the file system stores the path. Otherwise if we display+it differently, the user may use the displayed result to find the file+and may not find it.++Type Safety Requirements+------------------------++* Safety against using an absolute path where a relative path is to be+  used and vice-versa.  +  +  * Validations for absolute or relative path when constructing a path.+  * We cannot append an absolute path to another path+* Safety against using a file name where a directory name is to be used and+  vice-versa.++  * Certain validations can be performed e.g. file names cannot be "." or "..".+  * We should not be appending more directory components to a file path++In don't care situations we should be easily able to use any type+conveniently or cast a type into another.  It is desirable that the+programmer can choose the safety level. For example, we should be able+to instantiate a path type where we only worry about the distinction+between Absolute and Relative paths but no distinction between files and+directories or vice versa.++Requirement Summary+-------------------++* minimal dependencies, specifically streamly does not depend on bytestring+* round-tripping safety wrt to file system returned paths+* type safety for different path types+* support Posix/Windows+* support URI paths and other ways to represent paths where the separator could+  be different.++Design Considerations+---------------------++* Should we store path as separate components or single string with+  separators?++* Should we validate the paths returned from the file system or trust+  those and use directly without any validations? Need to see if that makes+  any difference to path heavy benchmarks. If we want to use it directly+  then we have to store it as a single string.++* Parameterize the low level APIs with the separator so that we can+  support arbitrary separators when parsing or reconstructing paths.++* The low level API can support path handling in trees/DAGs/Graphs in general.+  For example, in trees we cannot have multiple parents of a child whereas in+  DAGs that is allowed, in graphs we can have cycles. We may also need ways to+  detect cycles.++* Do we need to support arbitrarily long paths i.e. streaming of path? We do+  not need that for file system paths and file system paths are limited size+  and operating system anyway requires them in strict buffers. In case of+  graphs if we have cycles paths can be infinite, we could generate a stream of+  path and the consumer could be traversing the graph according to the+  generated stream. If we want to support streaming then we have to store paths+  as a stream of chunks rather than a single string.++* In general, paths need not be strings, e.g. they can be references to+  locations in memory or they can be IP addresses of nodes. At an abstract+  level, paths are just a stream of tokens that represent a certain traversal.++* Relative paths are the most general representation. At a low level,+  all paths are relative, absolute paths are relative to a specified root+  whereas relative paths are relative to a dynamic root which is the+  current directory.++* Windows can have the root as different drive letters. So to represent paths+  with a root in general we can also store the specific root along with the+  path. In case of POSIX this will always be "/". In general, it could be a+  host name or IP address or dependent on the protocol whose path we are+  representing.++* We can parameterize the low level path type with the type of path e.g. POSIX,+  WINDOWS, HTTP etc. In general, programs may have to manipulate different+  types of paths at the same time. High level path types can be instantiated+  using the low level type therefore they can be much simpler as desired.++References+----------++Some related links found by web search:++* https://gitlab.haskell.org/ghc/ghc/issues/5218+* https://nodejs.org/fr/docs/guides/working-with-different-filesystems/+* https://unix.stackexchange.com/questions/2089/what-charset-encoding-is-used-for-filenames-and-paths-on-linux+* https://docs.microsoft.com/en-us/windows/win32/intl/character-sets-used-in-file-names+* https://beets.io/blog/paths.html
+ dev/related-packages.md view
@@ -0,0 +1,71 @@+# Related Haskell Libraries++This document lists some notable libraries in the areas covered by Streamly.++## Lists+* https://hackage.haskell.org/package/base+* http://hackage.haskell.org/package/dlist++## Non-determinism+* https://hackage.haskell.org/package/pipes+* https://hackage.haskell.org/package/list-t+* https://hackage.haskell.org/package/list-transformer+* https://hackage.haskell.org/package/logict+* https://hackage.haskell.org/package/transformers-0.5.4.0/docs/Control-Monad-Trans-Select.html+* http://hackage.haskell.org/package/freer-effects NonDet effects++## Streaming+* https://hackage.haskell.org/package/vector+* https://hackage.haskell.org/package/streams+* https://hackage.haskell.org/package/simple-conduit+* https://hackage.haskell.org/package/streaming+* http://hackage.haskell.org/package/streaming-concurrency+* https://hackage.haskell.org/package/streaming-eversion+* https://hackage.haskell.org/package/conduit+* https://hackage.haskell.org/package/stm-conduit+* https://hackage.haskell.org/package/pipes+* http://hackage.haskell.org/package/pipes-group+* https://hackage.haskell.org/package/pipes-async+* https://hackage.haskell.org/package/pipes-concurrency+* https://hackage.haskell.org/package/pipes-interleave+* https://hackage.haskell.org/package/machines+* https://hackage.haskell.org/package/concurrent-machines+* http://hackage.haskell.org/package/io-streams++## Concurrency+* http://hackage.haskell.org/package/parallel+* http://hackage.haskell.org/package/monad-par+* https://hackage.haskell.org/package/async+* https://hackage.haskell.org/package/haxl+* https://hackage.haskell.org/package/fraxl+* https://hackage.haskell.org/package/free-concurrent+* https://hackage.haskell.org/package/transient++## Distributed+* https://hackage.haskell.org/package/transient-universe+* https://hackage.haskell.org/package/cloud-haskell+* https://hackage.haskell.org/package/distributed-process++## FRP+* https://hackage.haskell.org/package/reactive-banana+* https://hackage.haskell.org/package/Yampa+* https://hackage.haskell.org/package/reflex+* https://hackage.haskell.org/package/frpnow+* https://hackage.haskell.org/package/dunai+* https://hackage.haskell.org/package/bearriver++## Web+* https://hackage.haskell.org/package/axiom+* https://hackage.haskell.org/package/reflex-dom++## Folds+* https://hackage.haskell.org/package/foldl+* https://hackage.haskell.org/package/folds++## Resource Handling+* http://hackage.haskell.org/package/resourcet+* http://hackage.haskell.org/package/pipes-safe+* http://hackage.haskell.org/package/streaming-with++## Events+* https://hackage.haskell.org/package/event-list
+ dev/resources.md view
@@ -0,0 +1,45 @@+# Resources++This document lists some resources, papers, documents that might be+related to the areas covered by Streamly and may help in designing and+implementing features in Streamly.++## Non-Determinism/Logic++* [Backtracking, Interleaving, and Terminating Monad Transformers](https://pdfs.semanticscholar.org/42eb/2d71af7e00356a41fae47c7752299dc6700d.pdf)+* [Monad Transformers for Backtracking Search](https://arxiv.org/pdf/1406.2058.pdf)+* [Continuations for Parallel Logic Programming](http://www.softlab.ntua.gr/~nickie/Papers/todoran-2000-cplp.pdf)+* [A Concurrent Extension of Functional Logic+Programming Languages](http://convecs.inria.fr/people/Wendelin.Serwe/Pubs/lopstr99.pdf)++## Arrows+* [Generalising Monads to Arrows](http://www.cse.chalmers.se/~rjmh/Papers/arrows.pdf)+* [Monads, Kleisli Arrows, Comonads and other Rambling Thoughts](http://blog.sigfpe.com/2006/06/monads-kleisli-arrows-comonads-and.html)++## Concurrency+* https://en.wikipedia.org/wiki/Fork-join_model+* https://en.wikipedia.org/wiki/Work_stealing+* https://en.wikipedia.org/wiki/Task_parallelism+* https://en.wikipedia.org/wiki/OpenMP+* https://en.wikipedia.org/wiki/Cilk See the "see also" section on this page+* https://en.wikipedia.org/wiki/Green_threads+* [Fraxl: Abstracting Async.Concurrently](http://elvishjerricco.github.io/2016/09/17/abstracting-async-concurrently.html)++## Streaming+* [Coroutines for streaming](https://www.schoolofhaskell.com/school/to-infinity-and-beyond/pick-of-the-week/coroutines-for-streaming)+* [Stackless purescript](http://blog.functorial.com/posts/2015-07-31-Stackless-PureScript.html)+* [Coroutine Pipelines](https://themonadreader.files.wordpress.com/2011/10/issue19.pdf)+* [Faster Coroutine Pipelines](https://dl.acm.org/ft_gateway.cfm?id=3110249&ftid=1902054&dwn=1&CFID=982135108&CFTOKEN=78426775)++## Distributed+* [Making reliable distributed systems in the presence of software errors](http://erlang.org/download/armstrong_thesis_2003.pdf)+* [Towards Haskell in the Cloud](https://www.microsoft.com/en-us/research/wp-content/uploads/2016/07/remote.pdf?from=http%3A%2F%2Fresearch.microsoft.com%2Fen-us%2Fum%2Fpeople%2Fsimonpj%2Fpapers%2Fparallel%2Fremote.pdf)+* https://github.com/transient-haskell/transient/wiki/Transient-tutorial+* http://haskell-distributed.github.io/wiki.html+* https://en.wikipedia.org/wiki/MapReduce++## FRP+* https://github.com/HeinrichApfelmus/frp-guides+* [Push-Pull Functional Reactive Programming](http://conal.net/papers/push-pull-frp/push-pull-frp.pdf)+* [Functional Reactive Programming, Refactored](http://www.cs.nott.ac.uk/~psxip1/papers/2016-HaskellSymposium-Perez-Barenz-Nilsson-FRPRefactored-short.pdf)+* [Back to the Future: Time Travel in FRP](http://www.cs.nott.ac.uk/~psxip1/papers/2017-HaskellSymposium-Perez-BackToTheFuture-TimeTravelInFRP-latest.pdf)
+ dev/roadmap.md view
@@ -0,0 +1,36 @@+# Roadmap++Some of these items may be present in the issues as well, but this file+lists larger areas, experimental areas and organizes items by areas. We can+also use the areas listed here as labels (aspect:topic) on issues.++## Scheduling++* Free applicative and Free Alternative, batched Alternative (push+  scheduling instead of pull scheduling)+* N-ary operations e.g. real balanced interleave+* Scheduling: Coalescing of tasks based on programmer defined criteria+    * Batching based on the target host+    * Batching/chunking for parallel/distributed execution+    * Batching iterations++## Concurerncy++* Controlled parallelism:+    * Control based on the level in the tree+    * Control based on the CPU/IO utilization based pacing+    * Utilize non-blocking IO+* Performance: Measure lock/CAS contention overhead, an option to+  dequeue work and run in batches instead of one at a time to reduce lock+  contention?+* Cross thread recursion++## Persistence++* Pause and resume using something like+  [monad-recorder](https://hackage.haskell.org/package/monad-recorder)+* Save internal buffered state during a pause?++## Testing++* improve coverage
+ dev/unicode.md view
@@ -0,0 +1,224 @@+## Overview++Unicode is a standard which consists of a `char set`, `encodings`, attributes+and properties of characters, processing of strings, paragraphs, processing of+text in `locale` specific manner.++### Char Set++Unicode `char set` represents characters from all languages in the world.  Each+character is assigned a, code point, a unique number identifying the character,+and written as `U+0076` where the four hex digits `0076` represent the unique+number assigned to the character.++### Encodings++A unicode character can be encoded as a:++* fixed length encoding with a 32-bit value directly representing the code+  point in little endian (UTF32LE) or big endian (UTF32BE) byte ordering.  See+  https://en.wikipedia.org/wiki/UTF-32.+* variable length encoding with one or two 16-bit values depending on the code+  point, UTF16LE and UTF16BE. See https://en.wikipedia.org/wiki/UTF-16.+* variable length encoding with one, two or three 8-bit values depending on the+  code point, UTF8. See https://en.wikipedia.org/wiki/UTF-8.++### i18n and L10n++Internationalization (i18n) is being able to represent and process all+languages in the world. Unicode performs i18n by representing all languages and+their common processing rules.++Localization (L10n) is being able to customize the common internationalized+processing to a country or region (`locale`). Unicode specifies various+standard locales which includes customization of the attributes and processing+rules for each locale. Custom locales can be created with custom text+processing rules.++* https://en.wikipedia.org/wiki/Internationalization_and_localization .+* http://userguide.icu-project.org/i18n++## POSIX Locales++On Debian Linux, the default system wide locale can be administered using+`localectl` or `sudo dpkg-reconfigure locales`.++In a shell, the `locale` command shows the current locale settings. When you+start a program from the shell it inherits these settings via the process+environment and the C library loads and uses the appropriate locale. Even some+GUI programs if started from the shell can use the values from the+environment. Other GUI programs may have there own locale settings that can be+configured from their menu.++The following environment variables can override the system wide locale and+determine how a process (handled by libc) performs unicode text processing for+different locale aspects:++```+LC_CTYPE     Defines character classification and case conversion.+LC_COLLATE   Defines collation rules.+LC_MONETARY  Defines the format and symbols used in formatting of monetary information.+LC_NUMERIC   Defines the decimal delimiter, grouping, and grouping symbol for non-monetary numeric editing.+LC_TIME      Defines the format and content of date and time information.+LC_MESSAGES  Defines the format and values of affirmative and negative responses.+```++Each environment variable above can be set to available `locale` settings. For+example `LC_CTYPE=en_US.UTF-8` (locale.charmap) specifies a locale `en_US` for+the language `en` (English) and the territory `US` (USA) to be used for+character classifications (e.g. `iswalpha`) and case conversions (e.g.+`toupper`). `UTF-8` is the charmap used by the locale.++`C` and `POSIX` locales are the same and are used by default. glibc also+provides a generic `i18n` locale.++Use `locale -a` command to see all available locales on a system and `locale+-m` for charmaps. See `man locale` as well. Also see+`/usr/share/i18n/SUPPORTED` on Linux (Debian).+https://www.gnu.org/software/libc/manual/html_node/Locale-Names.html for the+format in which these environment variables can be specified.++The environment variables are preferred in the following order:++```+LC_ALL       Overrides everything else+LC_*         Individual aspect customization+LANG         Used as a substitute for any unset LC_* variable+```++Normally only `LANG` should be used. If a particular aspect needs to be+cutsomized then `LC_*` variables can be used. `LC_ALL` overrides everything.+On GNU/Linux `LANGUAGE` can also be used as a list of preferred languages+separated by ":". LANGUAGE is effective only if LANG has been set to something+other than default and has higher priority than anything else.++* https://www.gnu.org/software/gettext/manual/gettext.html#Users has a good+  overview of locale settings.+* https://pubs.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap07.html+  POSIX Locales standard++### Localizing Messages++GNU https://www.gnu.org/software/gettext/manual/gettext.html can be used by+programs to translate/localize the user interfacing text to multiple languages.+Catalogs of localized program error, alert, notification messages are installed+at e.g.  `/usr/share/locale/en_US/LC_MESSAGES/`.++* https://www.gnu.org/software/gettext/manual/gettext.html++### Creating Locales++From the `debian` manpage of `localedef` POSIX command:++The  localedef  program  reads  the  indicated charmap and input files,+compiles them to a binary form quickly usable by the locale functions in the C+library (setlocale(3), localeconv(3), etc.), and places the output in+outputpath.++See `locale-gen` for a more high level program to generate locales.+/usr/lib/locale/locale-archive contains the generated binary files. On Debian+you can use `sudo dpkg-reconfigure locales` to select locales and set system+locale.++On Linux/glibc (Debian), installed `charmaps` can be found at+`/usr/share/i18n/charmaps/` and locale definition input files at+`/usr/share/i18n/locales/`. ++## ICU Locales++An ICU locale is frequently confused with a POSIX locale ID. An ICU locale ID+is not a POSIX locale ID. ICU locales do not specify the encoding and specify+variant locales differently.++* http://userguide.icu-project.org/locale++### Localizing Messages++* http://userguide.icu-project.org/locale/localizing++## Unicode Text processing++* http://userguide.icu-project.org/posix+* http://userguide.icu-project.org/strings/properties++### Locale Independent++1) Char Properties+2) Normalization+3) Regex matching++### Locale Specific++1) Case Mapping:+    * https://unicode.org/faq/casemap_charprop.html+    * http://www.unicode.org/versions/latest/ch05.pdf#G21180+    * ftp://ftp.unicode.org/Public/UCD/latest/ucd/SpecialCasing.txt+    * ftp://ftp.unicode.org/Public/UCD/latest/ucd/CaseFolding.txt+2) Breaking+3) Collation+4) Charset Conversion++## Haskell++### Haskell Unicode Text Processing++Related packages on hackage:++* [base](https://www.stackage.org/lts/package/base) Data.Char module, uses libc+* [text](https://www.stackage.org/lts/package/text)+* [text-icu](https://stackage.org/lts/package/text-icu) C bindings to icu+++* https://github.com/composewell/unicode-transforms+* https://github.com/llelf/prose+* [unicode-properties](https://hackage.haskell.org/package/unicode-properties) Unicode 3.2.0 character properties+* [hxt-charproperties](http://www.stackage.org/lts/package/hxt-charproperties) Character properties and classes for XML and Unicode+* [unicode-names](http://hackage.haskell.org/package/unicode-names) Unicode 3.2.0 character names+* [unicode](https://hackage.haskell.org/package/unicode) Construct and transform unicode characters+++* [charset](https://www.stackage.org/lts/package/charset) Fast unicode character sets++None of the existing Haskell packages provide comprehensive and fast access to+properties. `unicode-transforms` provides composition/decomposition data and+the script to extract data from unicode database.++### Haskell Localization++* http://wiki.haskell.org/Internationalization_of_Haskell_programs+* https://hackage.haskell.org/package/localize+* http://hackage.haskell.org/package/localization+* http://hackage.haskell.org/package/hgettext+* http://hackage.haskell.org/package/i18n+* https://hackage.haskell.org/package/setlocale+* http://hackage.haskell.org/package/system-locale+* https://github.com/llelf/numerals++## TODO++Factor out a `unicode-data` package from `unicode-transforms`.+`unicode-transforms` package will depend on unicode-data and can continue to be+used as is. Other packages can take advantage of the `unicode-data` to provide+unicode text processing services.++To begin with, this package will contain:++* char properties data+* case mapping data+* unicode normalization data++This package can be used in `Streamly.Internal.Data.Unicode.*` to provide:++* Fast access to char properties, we will no longer depend on libc for that and+  no FFI will be required to do iswspace, iswalpha etc.+* Correct case mappings from a single char to multi-char+* Stream based unicode normalization+* Breaking (locale independent for now)++## Later++* add locale data from CLDR to `unicode-data` to provide locale specific+  services as well.+* support locale specific breaking, regex, collation and charset conversion+* facility to add customized locale data+* Support providing application level resource data for localization
+ dev/utf8-decoder.md view
@@ -0,0 +1,603 @@+Flexible and Economical UTF-8 Decoder+=====================================++Systems with elaborate Unicode support usually confront programmers with+a multitude of different functions and macros to process UTF-8 encoded+strings, often with different ideas on handling buffer boundaries, state+between calls, error conditions, and performance characteristics, making+them difficult to use correctly and efficiently. Implementations also+tend to be very long and complicated; one popular library has over 500+lines of code just for one version of the decoder. This page presents+one that is very easy to use correctly, short, small, fast, and free.++Implementation in C (C99)+-------------------------++    // Copyright (c) 2008-2009 Bjoern Hoehrmann <bjoern@hoehrmann.de>+    // See http://bjoern.hoehrmann.de/utf-8/decoder/dfa/ for details.++    #define UTF8_ACCEPT 0+    #define UTF8_REJECT 1++    static const uint8_t utf8d[] = {+      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, // 00..1f+      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, // 20..3f+      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, // 40..5f+      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, // 60..7f+      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, // 80..9f+      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, // a0..bf+      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, // c0..df+      0xa,0x3,0x3,0x3,0x3,0x3,0x3,0x3,0x3,0x3,0x3,0x3,0x3,0x4,0x3,0x3, // e0..ef+      0xb,0x6,0x6,0x6,0x5,0x8,0x8,0x8,0x8,0x8,0x8,0x8,0x8,0x8,0x8,0x8, // f0..ff+      0x0,0x1,0x2,0x3,0x5,0x8,0x7,0x1,0x1,0x1,0x4,0x6,0x1,0x1,0x1,0x1, // s0..s0+      1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,1,1,1,1,1,0,1,0,1,1,1,1,1,1, // s1..s2+      1,2,1,1,1,1,1,2,1,2,1,1,1,1,1,1,1,1,1,1,1,1,1,2,1,1,1,1,1,1,1,1, // s3..s4+      1,2,1,1,1,1,1,1,1,2,1,1,1,1,1,1,1,1,1,1,1,1,1,3,1,3,1,1,1,1,1,1, // s5..s6+      1,3,1,1,1,1,1,3,1,3,1,1,1,1,1,1,1,3,1,1,1,1,1,1,1,1,1,1,1,1,1,1, // s7..s8+    };++    uint32_t inline+    decode(uint32_t* state, uint32_t* codep, uint32_t byte) {+      uint32_t type = utf8d[byte];++      *codep = (*state != UTF8_ACCEPT) ?+        (byte & 0x3fu) | (*codep << 6) :+        (0xff >> type) & (byte);++      *state = utf8d[256 + *state*16 + type];+      return *state;+    }++Usage+-----++UTF-8 is a variable length character encoding. To decode a character one+or more bytes have to be read from a string. The `decode` function+implements a single step in this process. It takes two parameters+maintaining state and a byte, and returns the state achieved after+processing the byte. Specifically, it returns the value `UTF8_ACCEPT`+(0) if enough bytes have been read for a character, `UTF8_REJECT` (1) if+the byte is not allowed to occur at its position, and some other+positive value if more bytes have to be read.++When decoding the first byte of a string, the caller must set the state+variable to `UTF8_ACCEPT`. If, after decoding one or more bytes the+state `UTF8_ACCEPT` is reached again, then the decoded Unicode character+value is available through the `codep` parameter. If the state+`UTF8_REJECT` is entered, that state will never be exited unless the+caller intervenes. See the examples below for more information on usage+and error handling, and the section on implementation details for how+the decoder is constructed.++Examples+--------++### Validating and counting characters++This function checks if a null-terminated string is a well-formed UTF-8+sequence and counts how many code points are in the string.++    int+    countCodePoints(uint8_t* s, size_t* count) {+      uint32_t codepoint;+      uint32_t state = 0;++      for (*count = 0; *s; ++s)+        if (!decode(&state, &codepoint, *s))+          *count += 1;++      return state != UTF8_ACCEPT;+    }++It could be used like so:++    if (countCodePoints(s, &count)) {+      printf("The string is malformed\n");+    } else {+      printf("The string is %u characters long\n", count);+    }++### Printing code point values++This function prints out all code points in the string and an error+message if unexpected bytes are encountered, or if the string ends with+an incomplete sequence.++    void+    printCodePoints(uint8_t* s) {+      uint32_t codepoint;+      uint32_t state = 0;++      for (; *s; ++s)+        if (!decode(&state, &codepoint, *s))+          printf("U+%04X\n", codepoint);++      if (state != UTF8_ACCEPT)+        printf("The string is not well-formed\n");++    }++### Printing UTF-16 code units++This loop prints out UTF-16 code units for the characters in a+null-terminated UTF-8 encoded string.++    for (; *s; ++s) {++      if (decode(&state, &codepoint, *s))+        continue;++      if (codepoint <= 0xFFFF) {+        printf("0x%04X\n", codepoint);+        continue;+      }++      // Encode code points above U+FFFF as surrogate pair.+      printf("0x%04X\n", (0xD7C0 + (codepoint >> 10)));+      printf("0x%04X\n", (0xDC00 + (codepoint & 0x3FF)));+    }++### Error recovery++It is sometimes desirable to recover from errors when decoding strings+that are supposed to be UTF-8 encoded. Programmers should be aware that+this can negatively affect the security properties of their application.+A common recovery method is to replace malformed sequences with a+substitute character like `U+FFFD REPLACEMENT CHARACTER`.++Decoder implementations differ in which octets they replace and where+they restart. Consider for instance the sequence `0xED 0xA0 0x80`. It+encodes a surrogate code point which is prohibited in UTF-8. A+recovering decoder may replace the whole sequence and restart with the+next byte, or it may replace the first byte and restart with the second+byte, replace it, restart with the third, and replace the third byte+aswell.++The following code implements one such recovery strategy. When an+unexpected byte is encountered, the sequence up to that point will be+replaced and, if the error occurred in the middle of a sequence, will+retry the byte as if it occurred at the beginning of a string. Note that+the decode function detects errors as early as possible, so the sequence+`0xED 0xA0 0x80` would result in three replacement characters.++    for (prev = 0, current = 0; *s; prev = current, ++s) {++      switch (decode(&current, &codepoint, *s)) {+      case UTF8_ACCEPT:+        // A properly encoded character has been found.+        printf("U+%04X\n", codepoint);+        break;++      case UTF8_REJECT:+        // The byte is invalid, replace it and restart.+        printf("U+FFFD (Bad UTF-8 sequence)\n");+        current = UTF8_ACCEPT;+        if (prev != UTF8_ACCEPT)+          s--;+        break;+      ...++For some recovery strategies it may be useful to determine the number of+bytes expected. The states in the automaton are numbered such that,+assuming C\'s division operator, `state / 3 + 1` is that number. Of+course, this will only work for states other than `UTF8_ACCEPT` and+`UTF8_REJECT`. This number could then be used, for instance, to skip the+continuation octets in the illegal sequence `0xED 0xA0 0x80` so it will+be replaced by a single replacement character.++### Transcoding to UTF-16 buffer++This is a rough outline of a UTF-16 transcoder. Actual applications+would add code for error reporting, reporting of words written, required+buffer size in the case of a small buffer, and possibly other things.+Note that in order to avoid checking for free space in the inner loop,+we determine how many bytes can be read without running out of space.+This is one utf-8 byte per available utf-16 word, with one exception: if+the last byte read was the third byte in a four byte sequence we would+get two words for the next byte; so we read one byte less than we have+words available. This additional word is also needed for+null-termination, so it\'s never wrong to read one less.++    int+    toUtf16(uint8_t* src, size_t srcBytes, uint16_t* dst, size_t dstWords, ...) {++      uint8_t* src_actual_end = src + srcBytes;+      uint8_t* s = src;+      uint16_t* d = dst;+      uint32_t codepoint;+      uint32_t state = 0;++      while (s < src_actual_end) {++        size_t dst_words_free = dstWords - (d - dst);+        uint8_t* src_current_end = s + dst_words_free - 1;++        if (src_actual_end < src_current_end)+          src_current_end = src_actual_end;++        if (src_current_end <= s)+          goto toosmall;++        while (s < src_current_end) {++          if (decode(&state, &codepoint, *s++))+            continue;++          if (codepoint > 0xffff) {+            *d++ = (uint16_t)(0xD7C0 + (codepoint >> 10));+            *d++ = (uint16_t)(0xDC00 + (codepoint & 0x3FF));+          } else {+            *d++ = (uint16_t)codepoint;+          }+        }+      }++      if (state != UTF8_ACCEPT) {+        ...+      }++      if ((dstWords - (d - dst)) == 0)+        goto toosmall;++      *d++ = 0;+      ...++    toosmall:+      ...+    }++Implementation details+----------------------++The `utf8d` table consists of two parts. The first part maps bytes to+character classes, the second part encodes a deterministic finite+automaton using these character classes as transitions. This section+details the composition of the table.++### Canonical UTF-8 automaton++UTF-8 is a variable length character encoding. That means state has to+be maintained while processing a string. The following transition graph+illustrates the process. We start in state zero, and whenever we come+back to it, we\'ve seen a whole Unicode character. Transitions not in+the graph are disallowed; they all lead to state one, which has been+omitted for readability.++![DFA with range transitions](/design/dfa-bytes.png)++### Automaton with character class transitions++The byte ranges in the transition graph above are not easily encoded in+the automaton in a manner that would allow fast lookup. Instead of+encoding the ranges directly, the ranges are split such that each byte+belongs to exactly one character class. Then the transitions go over+these character classes.++![DFA with class transitions](/design/dfa-classes.png)++### Mapping bytes to character classes++Primarily to save space in the transition table, bytes are mapped to+character classes. This is the mapping:++|||||+|-|-|-|-|+| 00..7f |  0 | 80..8f | 1 |+| 90..9f |  9 | a0..bf | 7 |+| c0..c1 |  8 | c2..df | 2 |+| e0..e0 | 10 | e1..ec | 3 |+| ed..ed |  4 | ee..ef | 3 |+| f0..f0 | 11 | f1..f3 | 6 |+| f4..f4 |  5 | f5..ff | 8 |+++For bytes that may occur at the beginning of a multibyte sequence, the+character class number is also used to remove the most significant bits+from the byte, which do not contribute to the actual code point value.+Note that `0xc0`, `0xc1`, and `0xf5` .. `0xff` have all their bits+removed. These bytes cannot occur in well-formed sequences, so it does+not matter which bits, if any, are retained.++|||||||||||||+|-|-|-|-|-|-|-|-|-|-|-|-|+| c0 | 8 | **11000000** | d0 | 2 | **11**010000 | e0 | 10 | **11100000** | f0 | 11 | **11110000** |+| c1 | 8 | **11000001** | d1 | 2 | **11**010001 | e1 |  3 | **111**00001 | f1 |  6 | **111100**01 |+| c2 | 2 | **11**000010 | d2 | 2 | **11**010010 | e2 |  3 | **111**00010 | f2 |  6 | **111100**10 |+| c3 | 2 | **11**000011 | d3 | 2 | **11**010011 | e3 |  3 | **111**00011 | f3 |  6 | **111100**11 |+| c4 | 2 | **11**000100 | d4 | 2 | **11**010100 | e4 |  3 | **111**00100 | f4 |  5 | **11110**100 |+| c5 | 2 | **11**000101 | d5 | 2 | **11**010101 | e5 |  3 | **111**00101 | f5 |  8 | **11110101** |+| c6 | 2 | **11**000110 | d6 | 2 | **11**010110 | e6 |  3 | **111**00110 | f6 |  8 | **11110110** |+| c7 | 2 | **11**000111 | d7 | 2 | **11**010111 | e7 |  3 | **111**00111 | f7 |  8 | **11110111** |+| c8 | 2 | **11**001000 | d8 | 2 | **11**011000 | e8 |  3 | **111**01000 | f8 |  8 | **11111000** |+| c9 | 2 | **11**001001 | d9 | 2 | **11**011001 | e9 |  3 | **111**01001 | f9 |  8 | **11111001** |+| ca | 2 | **11**001010 | da | 2 | **11**011010 | ea |  3 | **111**01010 | fa |  8 | **11111010** |+| cb | 2 | **11**001011 | db | 2 | **11**011011 | eb |  3 | **111**01011 | fb |  8 | **11111011** |+| cc | 2 | **11**001100 | dc | 2 | **11**011100 | ec |  3 | **111**01100 | fc |  8 | **11111100** |+| cd | 2 | **11**001101 | dd | 2 | **11**011101 | ed |  4 | **1110**1101 | fd |  8 | **11111101** |+| ce | 2 | **11**001110 | de | 2 | **11**011110 | ee |  3 | **111**01110 | fe |  8 | **11111110** |+| cf | 2 | **11**001111 | df | 2 | **11**011111 | ef |  3 | **111**01111 | ff |  8 | **11111111** |+++Notes on Variations+-------------------++There are several ways to change the implementation of this decoder. For+example, the size of the data table can be reduced, at the cost of a+couple more instructions, so it omits the mapping of bytes in the+US-ASCII range, and since all entries in the table are 4 bit values, two+values could be stored in a single byte.++In some situations it may be beneficial to have a separate start state.+This is easily achieved by copying the s0 state in the array to the end,+and using the new state 9 as start state as needed.++Where callers require the code point values, compilers tend to generate+slightly better code if the state calculation is moved into the+branches, for example++    if (*state != UTF8_ACCEPT) {+      *state = utf8d[256 + *state*16 + type];+      *codep = (*codep << 6) | (byte & 63);+    } else {+      *state = utf8d[256 + *state*16 + type];+      *codep = (byte) & (255 >> type);+    }++As the state will be zero in the else branch, this saves a shift and an+addition for each starter. Unfortunately, compilers will then typically+generate worse code if the codepoint value is not needed. Naturally,+then, two functions could be used, one that only calculates the states+for validation, counting, and similar applications, and one for full+decoding. For the sample UTF-16 transcoder a more substantial increase+in performance can be achieved by manually including the decode code in+the inner loop; then it is also worthwhile to make code points in the+US-ASCII range a special case:++    while (s < src_current_end) {++      uint32_t byte = *s++;+      uint32_t type = utf8d[byte];++      if (state != UTF8_ACCEPT) {+        codep = (codep << 6) | (byte & 63);+        state = utf8d[256 + state*16 + type];++        if (state)+          continue;++      } else if (byte > 0x7f) {+        codep = (byte) & (255 >> type);+        state = utf8d[256 + type];+        continue;++      } else {+        *d++ = (uint16_t)byte;+        continue;+      }+      ...++Another variation worth of note is changing the comparison when setting+the code point value to this:++    *codep = (*state >  UTF8_REJECT) ?+      (byte & 0x3fu) | (*codep << 6) :+      (0xff >> type) & (byte);++This ensures that the code point value does not exceed the value `0xff`+after some malformed sequence is encountered.++As written, the decoder disallows encoding of surrogate code points,+overlong 2, 3, and 4 byte sequences, and 4 byte sequences outside the+Unicode range. Allowing them can have serious security implications, but+can easily be achieved by changing the character class assignments in+the table.++The code samples have generally been written to perform well on my+system when compiled with Visual C++ 7.1 and GCC 3.4.5. Slight changes+may improve performance, for example, Visual C++ 7.1 will produce+slightly faster code when, in the manually inlined version of the+transcoder discussed above, the type assignment is moved into the+branches where it is needed, and the state and codepoint assignments in+the non-ASCII starter is swapped (approximately a 5% increase), but GCC+3.4.5 will produce considerably slower code (approximately 10%).++I have experimented with various rearrangements of states and character+classes. A seemingly promising one is the following:++![Re-arranged DFA with class transitions](/design/dfa-rearr.png)++One of the continuation ranges has been split into two, the other+changes are just renamings. This arrangement allows, when a continuation+octet is expected, to compute the character class with a shift instead+of a table lookup, and when looking at a non-ASCII starter, the next+state is simply the character class. On my system the change in+performance is in the area of +/- 1%. This encoding would have a number+of downsides: more rejecting states are required to account for+continuation octets where starters are expected, the table formatting+would use more hex notation making it longer, and calculating the number+of expected continuation octets from a given state is more difficult.+One thing I\'d still like to try out is if, perhaps by adding a couple+of additional states, for continuation states the next state can be+computed without any table lookup with a few easily paired instructions.++On 24th June 2010 Rich Felker pointed out that the state values in the+transition table can be pre-multiplied with 16 which would save a shift+instruction for every byte. D\'oh! We actually just need 12 and can+throw away the filler values previously in the table making the table 36+bytes shorter and save the shift in the code.++    // Copyright (c) 2008-2010 Bjoern Hoehrmann <bjoern@hoehrmann.de>+    // See http://bjoern.hoehrmann.de/utf-8/decoder/dfa/ for details.++    #define UTF8_ACCEPT 0+    #define UTF8_REJECT 12++    static const uint8_t utf8d[] = {+      // 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,+    };++    uint32_t inline+    decode(uint32_t* state, uint32_t* codep, uint32_t byte) {+      uint32_t type = utf8d[byte];++      *codep = (*state != UTF8_ACCEPT) ?+        (byte & 0x3fu) | (*codep << 6) :+        (0xff >> type) & (byte);++      *state = utf8d[256 + *state + type];+      return *state;+    }++Notes on performance+--------------------++To conduct some ad-hoc performance testing I\'ve used three different+UTF-8 encoded buffers and passed them through a couple of UTF-8 to+UTF-16 transcoders. The large buffer is a April 2009 Hindi Wikipedia+article XML dump, the medium buffer Markus Kuhn\'s UTF-8-demo.txt, and+the tiny buffer my name, each about the number of times required for+about 1GB of data. All tests ran on a [Intel Prescott+Celeron](http://en.wikipedia.org/wiki/Celeron#Prescott-256) at 2666 MHz.+See [Changes](#changes) for some additional details.++  |                                                                           |  Large  |   Medium |   Tiny   |+  |---------------------------------------------------------------------------|---------| ---------|----------|+  |`NS_CStringToUTF16()` Mozilla 1.9 (*includes malloc/free time*)            |  36924ms|   39773ms|  107958ms|+  |`iconv()` 1.9 compiled with Visual C++ (Cygwin iconv 1.11 similar)         |  22740ms|   21765ms|   32595ms|+  |`g_utf8_to_utf16()` Cygwin Glib 2.0 (*includes malloc/free time*)          |  21599ms|   20345ms|   98782ms|+  |`ConvertUTF8toUTF16()` Unicode Inc., Visual C++ 7.1 -Ox -Ot -G7            |  11183ms|   11251ms|   19453ms|+  |`MultiByteToWideChar()` Windows API (Server 2003 SP2)                      |   9857ms|   10779ms|   12771ms|+  |`u_strFromUTF8` from ICU 4.0.1 (Visual Studio 2008, web site distribution) |   8778ms|    5223ms|    5419ms|+  |`PyUnicode_DecodeUTF8Stateful` (3.1a2), Visual C++ 7.1 -Ox -Ot -G7         |   4523ms|    5686ms|    3138ms|+  |Example section transcoder, Visual C++ 7.1 -Ox -Ot -G7                     |   5397ms|    5789ms|    6250ms|+  |Manually inlined transcoder (see above), Visual C++ 7.1 -Ox -Ot -G7        |   4277ms|    4998ms|    4640ms|+  |Same, Cygwin GCC 3.4.5 -march=prescott -fomit-frame-pointer -O3            |   4492ms|    5154ms|    4432ms|+  |Same, Cygwin GCC 4.3.2 -march=prescott -fomit-frame-pointer -O3            |   5439ms|    6322ms|    5567ms|+  |Same, Visual C++ 6.0 -TP -O2                                               |   5398ms|    6259ms|    6446ms|+  |Same, Visual C++ 7.1 -Ox -Ot -G7 (*includes malloc/free time*)             |   5498ms|    5086ms|   25852ms|++I have also timed functions that `xor` all code points in the large+buffer. In Visual Studio 2008 ICU\'s `U8_NEXT` macro comes out at+\~8000ms, the `U8_NEXT_UNSAFE` macro, which requires complete and+well-formed input, at \~4000ms, and the `decode` function is at+\~5900ms. Using the same manual inlining as for the transcode function,+Cygwin GCC 3.4.5 -march=prescott -O3 -fomit-frame-pointer brings it down+to roughly the same times as the transcode function for all three+buffers.++While these results do not model real-world applications well, it seems+reasonable to suggest that the reduced complexity does not come at the+price of reduced performance. Note that instructions that compute the+code point values will generally be optimized away when not needed. For+example, checking if a null-terminated string is properly UTF-8 encoded+\...++    int+    IsUTF8(uint8_t* s) {+      uint32_t codepoint, state = 0;++      while (*s)+        decode(&state, &codepoint, *s++);++      return state == UTF8_ACCEPT;+    }++\... does not require the individual code point values, and so the loop+becomes something like this:++    l1: movzx  eax,al+        shl    edx,4+        add    ecx,1+        movzx  eax,byte ptr [eax+404000h]+        movzx  edx,byte ptr [eax+edx+256+404000h]+        movzx  eax,byte ptr [ecx]+        test   al,al+        jne    l1++For comparison, this is a typical `strlen` loop:++    l1: mov    cl,byte ptr [eax]+        add    eax,1+        test   cl,cl+        jne    l1++With the large buffer and the same number of times as above, `strlen`+takes 1507ms while `IsUTF8` takes 2514ms.++License+-------++Copyright (c) 2008-2009 [Bjoern Hoehrmann](http://bjoern.hoehrmann.de/)+\<<bjoern@hoehrmann.de>\>++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.+:::++Changes+-------++25 Jun 2010+:   Added an improved variation based on an observation from Rich+    Felker.++30 April 2009+:   Added some more items to the performance table: the manually inlined+    transcoder allocating worst case memory for each run and freeing it+    before the next run; and results for Mozilla\'s NS\_CStringToUTF16+    (a new nsAutoString is created for each run, and truncated before+    the next). This used the XULRunner SDK 1.9.0.7 binary distribution+    from the Mozilla website.++18 April 2009+:   Added notes to the Variations section on handling malformed+    sequences and failed optimization attempts.++14 April 2009+:   Added PyUnicode\_DecodeUTF8Stateful times; the function has been+    modified slightly so it works outside Python and so it uses a+    pre-allocated buffer. Normally does not check output buffer+    boundaries but rather allocates a worst case buffer, then resizes+    it. Apparently the decoder [allows encodings of surrogate code+    points](http://bugs.python.org/issue3672).++Author+------++[Björn Höhrmann](http://bjoern.hoehrmann.de) <bjoern@hoehrmann.de>+([Donate via+SourceForge](http://sourceforge.net/developer/user_donations.php?user_id=188003),+[PayPal](https://www.paypal.com/cgi-bin/webscr?cmd=_xclick&business=bjoern@hoehrmann.de&item_name=Support+Bjoern+Hoehrmann))
+ docs/API-changelog.txt view
@@ -0,0 +1,250 @@+# Release 0.8.0 vs release 0.7.3+# API diff generated by cabal-diff with some edits.+# ~~~ deprecated module+# ~~ deprecated symbol++# Deprecated, merged into Streamly.Prelude+~~~ Streamly+# Fixity changes+++ infixr 6 `ahead`+++ infixr 6 `async`+++ infixr 6 `parallel`+++ infixr 6 `serial`+++ infixr 6 `wAsync`+++ infixr 6 `wSerial`++# Added+@@@ Streamly.Console.Stdio++# Deprecated, renamed+~~~ Streamly.Memory.Array+@@@ Streamly.Data.Array.Foreign++# Moved from Streamly.Memory.Array+++ data Array a+++ fromList :: Storable a => [a] -> Array a+++ fromListN :: Storable a => Int -> [a] -> Array a+++ length :: forall a. Storable a => Array a -> Int+++ read :: forall m a. (Monad m, Storable a) => Unfold m (Array a) a+++ toList :: Storable a => Array a -> [a]+++ write :: forall m a. (MonadIO m, Storable a) => Fold m a (Array a)+++ writeN :: forall m a. (MonadIO m, Storable a) => Int -> Fold m a (Array a)++# Added+++ asBytes :: Array a -> Array Word8+++ cast :: forall a b. Storable b => Array a -> Maybe (Array b)+++ getIndex :: Storable a => Array a -> Int -> Maybe a+++ readRev :: forall m a. (Monad m, Storable a) => Unfold m (Array a) a+++ writeLastN :: (Storable a, MonadIO m) => Int -> Fold m a (Array a)++@@@ Streamly.Data.Fold+# Signature changed+ - product :: (Monad m, Num a) => Fold m a a+ + product :: (Monad m, Num a, Eq a) => Fold m a a++# Removed (Moved to the Streamly.Data.Fold.Tee module)+-- instance (Monad m, Floating b) => Floating (Fold m a b)+-- instance (Monad m, GHC.Num.Num b) => GHC.Num.Num (Fold m a b)+-- instance (Monad m, GHC.Real.Fractional b) => GHC.Real.Fractional (Fold m a b)+-- instance (Semigroup b, Monad m) => Semigroup (Fold m a b)+-- instance (Semigroup b, Monoid b, Monad m) => Monoid (Fold m a b)+-- instance Applicative m => Applicative (Fold m a)++# Renamed+~~ mapM :: Monad m => (b -> m c) -> Fold m a b -> Fold m a c+++ rmapM :: Monad m => (b -> m c) -> Fold m a b -> Fold m a c++# Deprecated+~~ sequence :: Monad m => Fold m a (m b) -> Fold m a b++# Added+++ catMaybes :: Monad m => Fold m a b -> Fold m (Maybe a) b+++ chunksOf :: Monad m => Int -> Fold m a b -> Fold m b c -> Fold m a c+++ concatMap :: Monad m => (b -> Fold m a c) -> Fold m a b -> Fold m a c+++ filter :: Monad m => (a -> Bool) -> Fold m a r -> Fold m a r+++ filterM :: Monad m => (a -> m Bool) -> Fold m a r -> Fold m a r+++ foldl' :: Monad m => (b -> a -> b) -> b -> Fold m a b+++ foldlM' :: Monad m => (b -> a -> m b) -> m b -> Fold m a b+++ foldr :: Monad m => (a -> b -> b) -> b -> Fold m a b+++ lmap :: (a -> b) -> Fold m b r -> Fold m a r+++ lmapM :: Monad m => (a -> m b) -> Fold m b r -> Fold m a r+++ many :: Monad m => Fold m a b -> Fold m b c -> Fold m a c+++ mapMaybe :: Monad m => (a -> Maybe b) -> Fold m b r -> Fold m a r+++ rollingHash :: (Monad m, Enum a) => Fold m a Int64+++ rollingHashWithSalt :: (Monad m, Enum a) => Int64 -> Fold m a Int64+++ sconcat :: (Monad m, Semigroup a) => a -> Fold m a a+++ serialWith :: Monad m => (a -> b -> c) -> Fold m x a -> Fold m x b -> Fold m x c+++ take :: Monad m => Int -> Fold m a b -> Fold m a b+++ takeEndBy :: Monad m => (a -> Bool) -> Fold m a b -> Fold m a b+++ takeEndBy_ :: Monad m => (a -> Bool) -> Fold m a b -> Fold m a b+++ teeWith :: Monad m => (a -> b -> c) -> Fold m x a -> Fold m x b -> Fold m x c+++ toListRev :: Monad m => Fold m a [a]++# Added+@@@ Streamly.Data.Fold.Tee++@@@ Streamly.Data.Unfold+# Added+++ crossWith :: Monad m => (b -> c -> d) -> Unfold m a b -> Unfold m a c -> Unfold m a d+++ drop :: Monad m => Int -> Unfold m a b -> Unfold m a b+++ dropWhile :: Monad m => (b -> Bool) -> Unfold m a b -> Unfold m a b+++ dropWhileM :: Monad m => (b -> m Bool) -> Unfold m a b -> Unfold m a b+++ filter :: Monad m => (b -> Bool) -> Unfold m a b -> Unfold m a b+++ filterM :: Monad m => (b -> m Bool) -> Unfold m a b -> Unfold m a b+++ fromList :: Monad m => Unfold m [a] a+++ fromListM :: Monad m => Unfold m [m a] a+++ fromStream :: (IsStream t, Monad m) => Unfold m (t m a) a+++ function :: Applicative m => (a -> b) -> Unfold m a b+++ functionM :: Applicative m => (a -> m b) -> Unfold m a b+++ iterateM :: Monad m => (a -> m a) -> Unfold m (m a) a+++ lmap :: (a -> c) -> Unfold m c b -> Unfold m a b+++ lmapM :: Monad m => (a -> m c) -> Unfold m c b -> Unfold m a b+++ many :: Monad m => Unfold m a b -> Unfold m b c -> Unfold m a c+++ mapM :: Monad m => (b -> m c) -> Unfold m a b -> Unfold m a c+++ repeatM :: Monad m => Unfold m (m a) a+++ replicateM :: Monad m => Int -> Unfold m (m a) a+++ take :: Monad m => Int -> Unfold m a b -> Unfold m a b+++ takeWhile :: Monad m => (b -> Bool) -> Unfold m a b -> Unfold m a b+++ takeWhileM :: Monad m => (b -> m Bool) -> Unfold m a b -> Unfold m a b+++ unfoldr :: Applicative m => (a -> Maybe (b, a)) -> Unfold m a b+++ unfoldrM :: Applicative m => (a -> m (Maybe (b, a))) -> Unfold m a b+++ zipWith :: Monad m => (b -> c -> d) -> Unfold m a b -> Unfold m a c -> Unfold m a d++# Deprecated, renamed to Streamly.Unicode.Stream+~~~ Streamly.Data.Unicode.Stream++@@@ Streamly.Network.Socket+# Added+++ forSocketM :: (MonadMask m, MonadIO m) => (Socket -> m ()) -> Socket -> m ()+++ readChunk :: Int -> Socket -> IO (Array Word8)+++ writeChunk :: Storable a => Socket -> Array a -> IO ()+++ writeChunksWithBufferOf :: (MonadIO m, Storable a) => Int -> Socket -> Fold m (Array a) ()++@@@ Streamly.Prelude+# Signature changed+ - after :: (IsStream t, Monad m) => m b -> t m a -> t m a+ + after :: (IsStream t, MonadIO m, MonadBaseControl IO m) => m b -> t m a -> t m a+ - bracket :: (IsStream t, MonadCatch m) => m b -> (b -> m c) -> (b -> t m a) -> t m a+ + bracket :: (IsStream t, MonadAsync m, MonadCatch m) => m b -> (b -> m c) -> (b -> t m a) -> t m a+ - concatMapWith :: IsStream t => (forall c. t m c -> t m c -> t m c) -> (a -> t m b) -> t m a -> t m b+ + concatMapWith :: IsStream t => (t m b -> t m b -> t m b) -> (a -> t m b) -> t m a -> t m b+ - finally :: (IsStream t, MonadCatch m) => m b -> t m a -> t m a+ + finally :: (IsStream t, MonadAsync m, MonadCatch m) => m b -> t m a -> t m a+ - foldlM' :: Monad m => (b -> a -> m b) -> b -> SerialT m a -> m b+ + foldlM' :: Monad m => (b -> a -> m b) -> m b -> SerialT m a -> m b+ - postscanlM' :: (IsStream t, Monad m) => (b -> a -> m b) -> b -> t m a -> t m b+ + postscanlM' :: (IsStream t, Monad m) => (b -> a -> m b) -> m b -> t m a -> t m b+ - scanlM' :: (IsStream t, Monad m) => (b -> a -> m b) -> b -> t m a -> t m b+ + scanlM' :: (IsStream t, Monad m) => (b -> a -> m b) -> m b -> t m a -> t m b++# Renamed+~~ yieldM :: (Monad m, IsStream t) => m a -> t m a+++ fromEffect :: (Monad m, IsStream t) => m a -> t m a+~~ yield :: IsStream t => a -> t m a+++ fromPure :: IsStream t => a -> t m a+~~ concatUnfold :: (IsStream t, Monad m) => Unfold m a b -> t m a -> t m b+++ unfoldMany :: (IsStream t, Monad m) => Unfold m a b -> t m a -> t m b++# Moved from "Streamly" module+## Fixity change+++ infixr 6 `ahead`+++ infixr 6 `async`+++ infixr 6 `parallel`+++ infixr 6 `serial`+++ infixr 6 `wAsync`+++ infixr 6 `wSerial`+## Renamed+~~ foldWith :: (IsStream t, Foldable f) => (t m a -> t m a -> t m a) -> f (t m a) -> t m a+++ concatFoldableWith :: (IsStream t, Foldable f) => (t m a -> t m a -> t m a) -> f (t m a) -> t m a+~~ forEachWith :: (IsStream t, Foldable f) => (t m b -> t m b -> t m b) -> f a -> (a -> t m b) -> t m b+++ concatForFoldableWith :: (IsStream t, Foldable f) => (t m b -> t m b -> t m b) -> f a -> (a -> t m b) -> t m b+~~ foldMapWith :: (IsStream t, Foldable f) => (t m b -> t m b -> t m b) -> (a -> t m b) -> f a -> t m b+++ concatMapFoldableWith :: (IsStream t, Foldable f) => (t m b -> t m b -> t m b) -> (a -> t m b) -> f a -> t m b+~~ aheadly :: IsStream t => AheadT m a -> t m a+++ fromAhead :: IsStream t => AheadT m a -> t m a+~~ asyncly :: IsStream t => AsyncT m a -> t m a+++ fromAsync :: IsStream t => AsyncT m a -> t m a+~~ parallely :: IsStream t => ParallelT m a -> t m a+++ fromParallel :: IsStream t => ParallelT m a -> t m a+~~ serially :: IsStream t => SerialT m a -> t m a+++ fromSerial :: IsStream t => SerialT m a -> t m a+~~ wAsyncly :: IsStream t => WAsyncT m a -> t m a+++ fromWAsync :: IsStream t => WAsyncT m a -> t m a+~~ wSerially :: IsStream t => WSerialT m a -> t m a+++ fromWSerial :: IsStream t => WSerialT m a -> t m a+~~ zipAsyncly :: IsStream t => ZipAsyncM m a -> t m a+++ fromZipAsync :: IsStream t => ZipAsyncM m a -> t m a+~~ zipSerially :: IsStream t => ZipSerialM m a -> t m a+++ fromZipSerial :: IsStream t => ZipSerialM m a -> t m a+## unchanged+++ class (forall m a. MonadAsync m => Semigroup (t m a), forall m a. MonadAsync m => Monoid (t m a), forall m. Monad m => Functor (t m), forall m. MonadAsync m => Applicative (t m)) => IsStream t+++ data AheadT m a+++ data AsyncT m a+++ data ParallelT m a+++ data Rate Rate :: Double -> Double -> Double -> Int -> Rate+++ data SerialT m a+++ data WAsyncT m a+++ data WSerialT m a+++ data ZipAsyncM m a+++ data ZipSerialM m a+++ type Ahead = AheadT IO+++ type Async = AsyncT IO+++ type MonadAsync m = (MonadIO m, MonadBaseControl IO m, MonadThrow m)+++ type Parallel = ParallelT IO+++ type Serial = SerialT IO+++ type WAsync = WAsyncT IO+++ type WSerial = WSerialT IO+++ type ZipAsync = ZipAsyncM IO+++ type ZipSerial = ZipSerialM IO+++ (|$) :: (IsStream t, MonadAsync m) => (t m a -> t m b) -> t m a -> t m b+++ (|$.) :: (IsStream t, MonadAsync m) => (t m a -> m b) -> t m a -> m b+++ (|&) :: (IsStream t, MonadAsync m) => t m a -> (t m a -> t m b) -> t m b+++ (|&.) :: (IsStream t, MonadAsync m) => t m a -> (t m a -> m b) -> m b+++ [rateBuffer] :: Rate -> Int+++ [rateGoal] :: Rate -> Double+++ [rateHigh] :: Rate -> Double+++ [rateLow] :: Rate -> Double+++ adapt :: (IsStream t1, IsStream t2) => t1 m a -> t2 m a+++ ahead :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a+++ async :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a+++ avgRate :: IsStream t => Double -> t m a -> t m a+++ constRate :: IsStream t => Double -> t m a -> t m a+++ maxBuffer :: IsStream t => Int -> t m a -> t m a+++ maxRate :: IsStream t => Double -> t m a -> t m a+++ maxThreads :: IsStream t => Int -> t m a -> t m a+++ minRate :: IsStream t => Double -> t m a -> t m a+++ mkAsync :: (IsStream t, MonadAsync m) => t m a -> t m a+++ parallel :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a+++ rate :: IsStream t => Maybe Rate -> t m a -> t m a+++ serial :: IsStream t => t m a -> t m a -> t m a+++ wAsync :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a+++ wSerial :: IsStream t => t m a -> t m a -> t m a++# Added+++ delay :: (IsStream t, MonadIO m) => Double -> t m a -> t m a+++ foldMany :: (IsStream t, Monad m) => Fold m a b -> t m a -> t m b+++ intercalate :: (IsStream t, Monad m) => Unfold m b c -> b -> t m b -> t m c+++ intercalateSuffix :: (IsStream t, Monad m) => Unfold m b c -> b -> t m b -> t m c+++ liftInner :: (Monad m, IsStream t, MonadTrans tr, Monad (tr m)) => t m a -> t (tr m) a+++ runReaderT :: (IsStream t, Monad m) => m s -> t (ReaderT s m) a -> t m a+++ runStateT :: Monad m => m s -> SerialT (StateT s m) a -> SerialT m (s, a)++# Removed: documentation moved to streamly-docs module in docs dir+@@@ Streamly.Tutorial++# Deprecated, renamed+~~~ Streamly.Data.Unicode.Stream+@@@ Streamly.Unicode.Stream+# Moved from Streamly.Data.Unicode.Stream+## Behavior changed+++ decodeUtf8 :: (Monad m, IsStream t) => t m Word8 -> t m Char+++ encodeLatin1 :: (IsStream t, Monad m) => t m Char -> t m Word8+++ encodeUtf8 :: (Monad m, IsStream t) => t m Char -> t m Word8+## Unchanged+++ decodeLatin1 :: (IsStream t, Monad m) => t m Word8 -> t m Char++# Added+++ decodeUtf8' :: (Monad m, IsStream t) => t m Word8 -> t m Char+++ encodeLatin1' :: (IsStream t, Monad m) => t m Char -> t m Word8+++ encodeStrings :: (MonadIO m, IsStream t) => (SerialT m Char -> SerialT m Word8) -> t m String -> t m (Array Word8)+++ encodeUtf8' :: (Monad m, IsStream t) => t m Char -> t m Word8
− docs/Build.md 
@@ -1,95 +0,0 @@-# Compilation Options--## Recommended Options--Benchmarks show that GHC 8.8 has significantly better performance than GHC 8.6-in many cases.--Use the following GHC options:--```-  -O2-  -fdicts-strict-  -fmax-worker-args=16-  -fspec-constr-recursive=16-```--Important Note: In certain cases it is possible that GHC takes too long to-compile with `-fspec-constr-recursive=16`, if that happens please reduce the-value or remove that option.--## Using Fusion Plugin--In many cases `fusion-plugin` can improve performance by better stream-fusion. However, in some cases performance may also regress. Please note-that the `fusion-plugin` package works only for GHC >= 8.6.--* Install the-[fusion-plugin](https://hackage.haskell.org/package/fusion-plugin)-package or add it to the `build-depends` section of your program in the-cabal file.--* Use the following GHC option in addition to the options listed in the-  previous section:--```-  -fplugin=Fusion.Plugin -```--## Minimal--At the very least `-O -fdicts-strict` compilation options are-required. If these options are not used, the program may exhibit memory-hog.  For example, the following program, if compiled without an-optimization option, is known to hog memory:--```-main = S.drain $ S.concatMap S.fromList $ S.repeat []-```--## Explanation--* `-fdicts-strict` is needed to avoid [a GHC-issue](https://gitlab.haskell.org/ghc/ghc/issues/17745) leading to-memory leak in some cases.--* `-fspec-constr-recursive` is needed for better stream fusion by enabling-the `SpecConstr` optimization in more cases.--* `-fmax-worker-args` is needed for better stream fusion by enabling the-`SpecConstr` optimization in some important cases.--* `-fplugin=Fusion.Plugin` enables predictable stream fusion-optimization in certain cases by helping the compiler inline internal-bindings and therefore enabling case-of-case optimization. In some-cases, especially in some fileio benchmarks, it can make a difference of-5-10x better performance.--# Multi-core Parallelism--Concurrency without a threaded runtime may be a bit more efficient. Do not use-threaded runtime unless you really need multi-core parallelism. To get-multi-core parallelism use the following GHC options:--  `-threaded -with-rtsopts "-N"`--# Compiler Versions--Use GHC 8.8 for best performance.--GHC 8.2.2 may hog memory and hang when building certain application using-streamly (particularly the benchmark programs in the streamly package).-Therefore we recommend avoiding using the GHC version 8.2.x.--# Performance Optimizations--If performance is below expectations:--* Look for inlining functions in the fast path-* Strictness annotations on data, specially the data used as accumulator in-  folds and scans, can help in improving performance.-* Strictness annotations on function arguments can help the compiler unbox-  constructors in certain cases, improving performance.-* Sometimes using `-XStrict` extension can help improve performance, if so you-  may be missing some strictness annotations.-* Use tail recursion for streaming data or for large loops
+ docs/ConcurrentStreams.hs view
@@ -0,0 +1,780 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+-- |+-- Module      : ConcurrentStreams+-- Copyright   : (c) 2017 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+--+-- In this tutorial we will show how streamly can be used for idiomatic and+-- declarative concurrent programming.  Before you go through this tutorial we+-- recommend that you take a look at the Streamly serial streams tutorial.++module ConcurrentStreams+    (+    -- * Concurrent Streams+    -- $concurrentStreams++    -- * Combining Streams+    -- $flavors++    -- * Imports and Supporting Code+    -- $imports++    -- * Generating Streams Concurrently+    -- $generatingConcurrently++    -- * Concurrent Pipeline Stages+    -- $concurrentApplication++    -- * Mapping Concurrently+    -- $concurrentTransformation++    -- * Merging Streams++    -- ** Semigroup Style++    -- *** Deep Speculative Composition ('Ahead')+    -- $ahead++    -- *** Deep Asynchronous Composition ('Async')+    -- $async++    -- *** Wide Asynchronous Composition ('WAsync')+    -- $wasync++    -- *** Parallel Asynchronous Composition ('Parallel')+    -- $parallel++    -- XXX we should deprecate and remove the mkAsync API+    -- Custom composition+    -- custom++    -- ** Monoid Style+    -- $monoid++    -- * Nesting Streams++    -- ** Monad+    -- *** Deep Speculative Nesting ('Ahead')+    -- $aheadNesting++    -- *** Deep Asynchronous Nesting ('Async')+    -- $concurrentNesting++    -- *** Wide Asynchronous Nesting ('WAsync')+    -- $wasyncNesting++    -- *** Parallel Asynchronous Nesting ('Parallel')+    -- $parallelNesting++    -- ** Applicative+    -- $applicative++    -- * Zipping Streams++    -- ** Parallel Zipping+    -- $parallelzip++    -- * Concurrent Programming+    -- $concurrent++    -- * Writing Concurrent Programs+    -- $programs++    -- * Where to go next?+    -- $furtherReading+    )+where++import Streamly.Prelude+import Data.Semigroup+import Control.Applicative+import Control.Monad+import Control.Monad.IO.Class      (MonadIO(..))+import Control.Monad.Trans.Class   (MonadTrans (lift))++-- CAUTION: please keep setup and imports sections in sync++-- $setup+-- >>> :m+-- >>> import Data.Function ((&))+-- >>> import Streamly.Prelude ((|:), (|&))+-- >>> import qualified Streamly.Prelude as Stream+-- >>> import qualified Streamly.Data.Fold as Fold+--+-- >>> import Control.Concurrent (threadDelay, myThreadId)+-- >>> :{+--   delay n = Stream.fromEffect $ do+--      threadDelay (n * 1000000)+--      tid <- myThreadId+--      putStrLn (show tid ++ ": Delay " ++ show n)+-- :}+--+-- >>> import System.IO (stdout, hSetBuffering, BufferMode(LineBuffering))+-- >>> hSetBuffering stdout LineBuffering+--++-- $imports+--+-- In most of example snippets we do not repeat the imports. Where imports are+-- not explicitly specified use the imports shown below.+--+-- >>> :m+-- >>> import Data.Function ((&))+-- >>> import Streamly.Prelude ((|:), (|&))+-- >>> import qualified Streamly.Prelude as Stream+-- >>> import qualified Streamly.Data.Fold as Fold+--+-- To illustrate concurrent vs serial composition aspects, we will use the+-- following @delay@ function to introduce a sleep or delay specified in+-- seconds. After the delay it prints the number of seconds it slept.+--+-- >>> import Control.Concurrent (threadDelay, myThreadId)+-- >>> :{+--   delay n = Stream.fromEffect $ do+--      threadDelay (n * 1000000)+--      tid <- myThreadId+--      putStrLn (show tid ++ ": Delay " ++ show n)+-- :}+--+-- For concurrent examples, use line buffering, otherwise output from different+-- threads may get mixed:+--+-- >>> import System.IO (stdout, hSetBuffering, BufferMode(LineBuffering))+-- >>> hSetBuffering stdout LineBuffering+--++-- $concurrentStreams+--+-- Many stream operations can be done concurrently:+--+-- * Streams can be generated concurrently.+--+-- * Streams can be merged concurrently.+--+-- * Multiple stages in a streaming pipeline can run concurrently.+--+-- * Streams can be mapped and zipped concurrently.+--+-- * In monadic composition they combine like a list transformer,+--   providing concurrent non-determinism.+--+-- There are three basic concurrent stream styles, 'Ahead', 'Async', and+-- 'Parallel'. The 'Ahead' style streams are similar to 'Serial' except that+-- they can speculatively execute multiple stream actions concurrently in+-- advance. 'Ahead' would return exactly the same stream as 'Serial' except+-- that it may execute the actions concurrently. The 'Async' style streams,+-- like 'Ahead', speculatively execute multiple stream actions in advance but+-- return the results in their finishing order rather than in the stream+-- traversal order.  'Parallel' is like 'Async' except that it provides+-- unbounded parallelism instead of controlled parallelism.+--+-- For easy reference, we can classify the stream types based on /execution order/,+-- /consumption order/, and /bounded or unbounded/ concurrency.+-- Execution could be serial (i.e. synchronous) or asynchronous. In serial+-- execution we execute the next action in the stream only after the previous+-- one has finished executing. In asynchronous execution multiple actions in+-- the stream can be executed asynchronously i.e. the next action can start+-- executing even before the first one has finished. Consumption order+-- determines the order in which the outputs generated by the composition are+-- consumed.  Consumption could be serial or asynchronous. In serial+-- consumption, the outputs are consumed in the traversal order, in+-- asynchronous consumption the outputs are consumed as they arrive i.e. first+-- come first serve order.+--+-- +------------+--------------+--------------+--------------++-- | Type       | Execution    | Consumption  | Concurrency  |+-- +============+==============+==============+==============++-- | 'Serial'   | Serial       | Serial       | None         |+-- +------------+--------------+--------------+--------------++-- | 'Ahead'    | Asynchronous | Serial       | bounded      |+-- +------------+--------------+--------------+--------------++-- | 'Async'    | Asynchronous | Asynchronous | bounded      |+-- +------------+--------------+--------------+--------------++-- | 'Parallel' | Asynchronous | Asynchronous | unbounded    |+-- +------------+--------------+--------------+--------------++--+-- All these types can be freely inter-converted using type conversion+-- combinators or type annotations, without any cost, to achieve the desired+-- composition style.  To force a particular type of composition, we coerce the+-- stream type using the corresponding type adapting combinator from+-- 'fromSerial', 'fromAhead', 'fromAsync', or 'fromParallel'.  The default stream type+-- is inferred as 'Serial' unless you change it by using one of the combinators+-- or by using a type annotation.++-- $flavors+--+-- Streams can be combined using '<>' or 'mappend' to form a+-- composite. Composite streams can be interpreted in a depth first or+-- breadth first manner using an appropriate type conversion before+-- consumption. Deep (e.g. 'Serial') stream type variants traverse a+-- composite stream in a depth first manner, such that each stream is+-- traversed fully before traversing the next stream. Wide+-- (e.g. 'WSerial') stream types traverse it in a breadth first+-- manner, such that one element from each stream is traversed before+-- coming back to the first stream again.+--+-- Each stream type has a wide traversal variant prefixed by 'W'. The wide+-- variant differs only in the Semigroup\/Monoid, Applicative\/Monad+-- compositions of the streams.+-- The following table summarizes the basic types and the corresponding wide+-- variants:+--+-- @+-- +------------+-----------++-- | Deep       | Wide      |+-- +============+===========++-- | 'Serial'     | 'WSerial'   |+-- +------------+-----------++-- | 'Ahead'      | 'WAhead'    |+-- +------------+-----------++-- | 'Async'      | 'WAsync'    |+-- +------------+-----------++-- @+--+-- Other than these types there are also 'ZipSerial' and 'ZipAsync' types that+-- zip streams serially or concurrently using 'Applicative' operation. These+-- types are not monads they are only applicatives and they do not differ in+-- 'Semigroup' composition.+--++-- $programs+--+-- When writing concurrent programs it is advised to not use the concurrent+-- style stream combinators blindly at the top level. That might create too+-- much concurrency where it is not even required, and can even degrade+-- performance in some cases. In some cases it can also lead to surprising+-- behavior because of some code that is supposed to be serial becoming+-- concurrent. Please be aware that all concurrency capable APIs that you may+-- have used under the scope of a concurrent stream combinator will become+-- concurrent. For example if you have a 'repeatM' somewhere in your program+-- and you use 'fromParallel' on top, the 'repeatM' becomes fully parallel,+-- resulting into an infinite parallel execution . Instead, use the+-- /Keep It Serial and Stupid/ principle, start with the default serial+-- composition and enable concurrent combinators only when and where necessary.+-- When you use a concurrent combinator you can use an explicit 'fromSerial'+-- combinator to suppress any unnecessary concurrency under the scope of that+-- combinator.++-- $generatingConcurrently+--+-- Monadic construction and generation functions like 'consM', 'unfoldrM',+-- 'replicateM', 'repeatM', 'iterateM' and 'fromFoldableM' work concurrently+-- when used with appropriate stream type combinator. The pure versions of+-- these APIs are not concurrent, however you can use the monadic versions even+-- for pure computations by wrapping the pure value in a monad to get the+-- concurrent generation capability where required.+--+-- The following code finishes in 3 seconds (6 seconds when serial):+--+-- >>> let p n = threadDelay (n * 1000000) >> return n+-- >>> Stream.toList $ Stream.fromParallel $ p 3 |: p 2 |: p 1 |: Stream.nil+-- [1,2,3]+--+-- >>> Stream.toList $ Stream.fromAhead $ p 3 |: p 2 |: p 1 |: Stream.nil+-- [3,2,1]+--+-- The following finishes in 10 seconds (100 seconds when serial):+--+-- >>> Stream.drain $ Stream.fromAsync $ Stream.replicateM 10 $ p 10+--++-- $concurrentTransformation+--+-- Monadic transformation functions 'mapM' and 'sequence' work concurrently+-- when used with appropriate stream type combinators. The pure versions do not+-- work concurrently, however you can use the monadic versions even for pure+-- computations to get the concurrent transformation capability where required.+--+-- This would print a value every second (2 seconds when serial):+--+-- >>> let p n = threadDelay (n * 1000000) >> return n+-- >>> :{+-- parMap =+--       Stream.repeatM (p 1)+--     & Stream.fromSerial   -- repeatM is serial+--     & Stream.mapM (\x -> p 1 >> print x)+--     & Stream.fromAhead    -- mapM is cocnurrent using Ahead style+--     & Stream.drain+-- :}+--++-- $concurrentApplication+--+-- The concurrent function application operators '|$' and '|&' apply a stream+-- argument to a stream function concurrently to compose a concurrent pipeline+-- of stream processing functions:+--+-- Because both the stages run concurrently, we would see a delay of only 1+-- second instead of 2 seconds in the following:+--+-- >>> let p n = threadDelay (n * 1000000) >> return n+-- >>> :{+-- parApp =+--        Stream.repeatM (p 1)+--     |& Stream.mapM (\x -> p 1 >> print x)+--      & Stream.drain+-- :}++-- $ahead+--+-- The 'Semigroup' operation '<>' of the 'Ahead' type combines two streams in a+-- /serial depth first/ manner with concurrent lookahead. We use the 'fromAhead'+-- type combinator to effect 'Ahead' style of composition. We can also use an+-- explicit 'Ahead' type annotation for the stream to achieve the same effect.+--+-- When two streams are combined in this manner, the streams are traversed in+-- depth first manner just like 'Serial', however it can execute the next+-- stream concurrently and keep the results ready when its turn arrives.+-- Concurrent execution of the next stream(s) is performed if the first stream+-- blocks or if it cannot produce output at the rate that is enough to meet the+-- consumer demand. Multiple streams can be executed concurrently to meet the+-- demand.  The following example would print the result in a second even+-- though each action in each stream takes one second:+--+-- >>> p n = threadDelay 1000000 >> return n+-- >>> stream1 = p 1 |: p 2 |: Stream.nil+-- >>> stream2 = p 3 |: p 4 |: Stream.nil+-- >>> Stream.toList $ Stream.fromAhead $ stream1 <> stream2+-- [1,2,3,4]+--+-- Each stream is constructed 'fromAhead' and then both the streams are merged+-- 'fromAhead', therefore, all the actions can run concurrently but the result is+-- presented in serial order.+--+-- You can also use the polymorphic combinator 'ahead' in place of '<>' to+-- compose any type of streams in this manner.++-- $async+--+-- The 'Semigroup' operation '<>' of the 'Async' type combines the two+-- streams in a depth first manner with parallel look ahead. We use the+-- 'fromAsync' type combinator to effect 'Async' style of composition. We+-- can also use the 'Async' type annotation for the stream type to achieve+-- the same effect.+--+-- When two streams with multiple elements are combined in this manner, the+-- streams are traversed in depth first manner just like 'Serial', however it+-- can execute the next stream concurrently and return the results from it+-- as they arrive i.e. the results from the next stream may be yielded even+-- before the results from the first stream. Concurrent execution of the next+-- stream(s) is performed if the first stream blocks or if it cannot produce+-- output at the rate that is enough to meet the consumer demand. Multiple+-- streams can be executed concurrently to meet the demand.+-- In the example below each element in the stream introduces a constant delay+-- of 1 second, however, it takes just one second to produce all the results.+-- The results are not guaranteed to be in any particular order:+--+-- >>> p n = threadDelay 1000000 >> return n+-- >>> stream1 = p 1 |: p 2 |: Stream.nil+-- >>> stream2 = p 3 |: p 4 |: Stream.nil+-- >>> Stream.toList $ Stream.fromAsync $ stream1 <> stream2+-- ...+--+-- The constituent streams are also composed in 'Async' manner and the+-- composition of streams too. We can compose the constituent streams to run+-- serially, in that case it would take 2 seconds to produce all the results.+-- The elements in the serial streams would be in serial order in the results:+--+-- >>> p n = threadDelay 1000000 >> return n+-- >>> stream = (Stream.fromSerial stream1) <> (Stream.fromSerial stream2)+-- >>> Stream.toList $ Stream.fromAsync stream+-- ...+--+-- In the following example we can see that new threads are started when a+-- computation blocks.  Notice that the output from the stream with the+-- shortest delay is printed first. The whole computation takes @maximum of+-- (3, 2, 1) = 3@ seconds:+--+-- >>> Stream.drain $ Stream.fromAsync $ delay 3 <> delay 2 <> delay 1+-- ThreadId ...: Delay 1+-- ThreadId ...: Delay 2+-- ThreadId ...: Delay 3+--+-- When we have a tree of computations composed using this style, the tree is+-- traversed in DFS style just like the 'Serial' style, the only difference is+-- that here we can move on to executing the next stream if a stream blocks.+-- However, we will not start new threads if we have sufficient output to+-- saturate the consumer.  This is why we call it left-biased demand driven or+-- adaptive concurrency style, the concurrency tends to stay on the left side+-- of the composition as long as possible. More threads are started based on+-- the pull rate of the consumer. The following example prints an output every+-- second as all of the actions are concurrent.+--+-- >>> Stream.drain $ Stream.fromAsync $ (delay 1 <> delay 2) <> (delay 3 <> delay 4)+-- ThreadId ...: Delay 1+-- ThreadId ...: Delay 2+-- ThreadId ...: Delay 3+-- ThreadId ...: Delay 4+--+-- All the computations may even run in a single thread when more threads are+-- not needed. As you can see, in the following example the computations are+-- run in a single thread one after another, because none of them blocks.+-- However, if the thread consuming the stream were faster than the producer+-- then it would have started parallel threads for each computation to keep up+-- even if none of them blocks:+--+-- >>> :{+-- traced m = Stream.fromEffect (myThreadId >>= print) >> return m+-- stream = traced (sqrt 9) <> traced (sqrt 16) <> traced (sqrt 25)+-- main = Stream.drain $ Stream.fromAsync stream+-- :}+--+-- Note that the order of printing in the above examples may change due to+-- variations in scheduling latencies for concurrent threads.+--+-- The polymorphic version of the 'Async' binary operation '<>' is called+-- 'async'. We can use 'async' to join streams in a left biased+-- adaptively concurrent manner irrespective of the type, notice that we have+-- not used the 'fromAsync' combinator in the following example:+--+-- >>> Stream.drain $ delay 3 `Stream.async` delay 2 `Stream.async` delay 1+-- ThreadId ...: Delay 1+-- ThreadId ...: Delay 2+-- ThreadId ...: Delay 3+--+-- Since the concurrency provided by this operator is demand driven it cannot+-- be used when the composed computations start timers that are relative to+-- each other because all computations may not be started at the same time and+-- therefore timers in all of them may not start at the same time.  When+-- relative timing among all computations is important or when we need to start+-- all computations at once for any reason 'Parallel' style must be used+-- instead.+--+-- 'Async' style utilizes resources optimally and should be preferred over+-- 'Parallel' or 'WAsync' unless you really need those. 'Async' should be used+-- when we know that the computations can run in parallel but we do not care if+-- they actually run in parallel or not, that decision can be left to the+-- scheduler based on demand. Also, note that 'async' operator can be used to fold+-- infinite number of streams in contrast to the 'Parallel' or 'WAsync' styles,+-- because it does not require us to run all of them at the same time in a fair+-- manner.++-- $wasync+--+-- The 'Semigroup' operation '<>' of the 'WAsync' type combines two streams in+-- a concurrent manner using /breadth first traversal/. We use the 'fromWAsync'+-- type combinator to effect 'WAsync' style of composition. We can also use the+-- 'WAsync' type annotation for the stream to achieve the same effect.+--+-- When streams with multiple elements are combined in this manner, we traverse+-- all the streams concurrently in a breadth first manner i.e. one action from+-- each stream is performed and yielded to the resulting stream before we come+-- back to the first stream again and so on. Even though we execute the actions+-- in a breadth first order the outputs are consumed on a first come first+-- serve basis.+--+-- In the following example we can see that outputs are produced in the breadth+-- first traversal order but this is not guaranteed.+--+-- >>> stream1 = print 1 |: print 2 |: Stream.nil+-- >>> stream2 = print 3 |: print 4 |: Stream.nil+-- >>> Stream.drain $ Stream.fromWAsync $ stream1 <> stream2+-- 1+-- 3+-- 2+-- 4+--+-- The polymorphic version of the binary operation '<>' of the 'WAsync' type is+-- 'wAsync'.  We can use 'wAsync' to join streams using a breadth first+-- concurrent traversal irrespective of the type, notice that we have not used+-- the 'fromWAsync' combinator in the following example:+--+-- >>> Stream.drain $ delay 3 `Stream.wAsync` delay 2 `Stream.wAsync` delay 1+-- ThreadId ...: Delay 1+-- ThreadId ...: Delay 2+-- ThreadId ...: Delay 3+--+-- Since the concurrency provided by this style is demand driven it may not+-- be used when the composed computations start timers that are relative to+-- each other because all computations may not be started at the same time and+-- therefore timers in all of them may not start at the same time.  When+-- relative timing among all computations is important or when we need to start+-- all computations at once for any reason 'Parallel' style must be used+-- instead.+--++-- $parallel+--+-- The 'Semigroup' operation '<>' of the 'Parallel' type combines the two+-- streams in a fairly concurrent manner with round robin scheduling. We use+-- the 'fromParallel' type combinator to effect 'Parallel' style of composition.+-- We can also use the 'Parallel' type annotation for the stream type to+-- achieve the same effect.+--+-- When two streams with multiple elements are combined in this manner, the+-- monadic actions in both the streams are performed concurrently with a fair+-- round robin scheduling.  The outputs are yielded in the order in which the+-- actions complete. This is pretty similar to the 'WAsync' type, the+-- difference is that 'WAsync' is adaptive to the consumer demand and may or+-- may not execute all actions in parallel depending on the demand, whereas+-- 'Parallel' runs all the streams in parallel irrespective of the demand.+--+-- The polymorphic version of the binary operation '<>' of the 'Parallel' type+-- is 'parallel'. We can use 'parallel' to join streams in a fairly concurrent+-- manner irrespective of the type, notice that we have not used the+-- 'fromParallel' combinator in the following example:+--+-- >>> Stream.drain $ delay 3 `Stream.parallel` delay 2 `Stream.wAsync` delay 1+-- ThreadId ...: Delay 1+-- ThreadId ...: Delay 2+-- ThreadId ...: Delay 3+--+-- Note that this style of composition cannot be used to combine infinite+-- number of streams, as it will lead to an infinite sized scheduling queue.+--++-- XXX to be removed+-- $custom+--+-- The 'mkAsync' API can be used to create references to asynchronously running+-- stream computations. We can then use 'uncons' to explore the streams+-- arbitrarily and then recompose individual elements to create a new stream.+-- This way we can dynamically decide which stream to explore at any given+-- time.  Take an example of a merge sort of two sorted streams. We need to+-- keep consuming items from the stream which has the lowest item in the sort+-- order.  This can be achieved using async references to streams. See+-- "MergeSort.hs" in <https://github.com/composewell/streamly-examples Streamly Examples>.++-- $monoid+--+-- All of the following are equivalent and start ten concurrent tasks each with+-- a delay from 1 to 10 seconds, resulting in the printing of each number every+-- second:+--+-- >>> :{+-- main = do+--  Stream.drain $ Stream.fromAsync $ foldMap delay [1..10]+--  Stream.drain $ Stream.concatFoldableWith Stream.async (map delay [1..10])+--  Stream.drain $ Stream.concatMapFoldableWith Stream.async delay [1..10]+--  Stream.drain $ Stream.concatForFoldableWith Stream.async [1..10] delay+-- :}+--++-- $aheadNesting+--+-- The 'Monad' composition of 'Ahead' type behaves just like 'Serial' except+-- that it can speculatively perform a bounded number of next iterations of a+-- loop concurrently.+--+-- >>> :{+-- Stream.toList $ Stream.fromAhead $ do+--     x <- Stream.fromFoldable [3,2,1]+--     delay x+--     return x+-- :}+-- ThreadId ...: Delay 1+-- ThreadId ...: Delay 2+-- ThreadId ...: Delay 3+-- [3,2,1]+--+-- This code finishes in 3 seconds, 'Serial' would take 6 seconds.  As we can+-- see all the three iterations are concurrent and run in different threads,+-- however, the results are returned in the serial order.+--+-- Concurrency is demand driven, when multiple streams are composed using this+-- style, the iterations are executed in a depth first manner just like+-- 'Serial' i.e. nested iterations are executed before we proceed to the next+-- outer iteration. The only difference is that we may execute multiple future+-- iterations concurrently and keep the results ready.+--+-- The 'fromAhead' type combinator can be used to switch to this style of+-- composition. Alternatively, a type annotation can be used to specify the+-- type of the stream as 'Ahead'.+--++-- $concurrentNesting+--+-- The 'Monad' composition of 'Async' type can perform the iterations of a+-- loop concurrently.+--+-- >>> :{+-- Stream.drain $ Stream.fromAsync $ do+--      x <- Stream.fromFoldable [3,2,1]+--      delay x+-- :}+-- ThreadId ...: Delay 1+-- ThreadId ...: Delay 2+-- ThreadId ...: Delay 3+--+-- As we can see the code after the @fromFoldable@ statement is run three+-- times, once for each value of @x@. All the three iterations are concurrent+-- and run in different threads. The iteration with least delay finishes first.+-- When compared to imperative programming, this can be viewed as a @for@ loop+-- with three concurrent iterations.+--+-- Concurrency is demand driven i.e. more concurrent iterations are started+-- only if the previous iterations are not able to saturate the consumer of the+-- output stream.  This works exactly the same way as the merging of two+-- streams using 'async' works.+--+-- The 'fromAsync' type combinator can be used to switch to this style of+-- composition. Alternatively, a type annotation can be used to specify the+-- type of the stream as 'Async'.+--+-- When multiple streams are nested using this style, the iterations are+-- concurrently evaluated in a depth first manner:+--+--+-- >>> :{+-- Stream.drain $ Stream.fromAsync $ do+--     x <- Stream.fromFoldable [1,2]+--     y <- Stream.fromFoldable [3,4]+--     Stream.fromEffect $ putStrLn $ show (x, y)+-- :}+-- (1,3)+-- (1,4)+-- (2,3)+-- (2,4)+--+-- Nested iterations are given preference for concurrent evaluation i.e.+-- (1,4) will be scheduled in preference to (2,3).++-- $wasyncNesting+--+-- Like 'Async', the 'Monad' composition of 'WAsync' runs the iterations of a+-- loop concurrently. It differs from 'Async' in the nested loop behavior. Like+-- 'WSerial', the nested loops in this type are traversed and executed in a+-- breadth first manner rather than the depth first manner of 'Async' style.+--+-- >>> :{+-- Stream.drain $ Stream.fromWAsync $ do+--     x <- Stream.fromSerial $ Stream.fromFoldable [1,2]+--     y <- Stream.fromSerial $ Stream.fromFoldable [3,4]+--     Stream.fromEffect $ putStrLn $ show (x, y)+-- :}+-- (1,3)+-- (1,4)+-- (2,3)+-- (2,4)+--+-- Note that (2,3) is preferred to (1,4) when evaluating the iterations+-- concurrently.  This works exactly the same way as the merging of two streams+-- using 'wAsync' works.+--+-- The 'fromWAsync' type combinator can be used to switch to this style of+-- composition. Alternatively, a type annotation can be used to specify the+-- type of the stream as 'WAsync'.+--++-- $parallelNesting+--+-- Just like 'Async' or 'WAsync' the 'Monad' composition of 'Parallel' runs the+-- iterations of a loop concurrently.+--+-- >>> :{+-- Stream.drain $ Stream.fromParallel $ do+--    x <- Stream.fromFoldable [3,2,1]+--    delay x+-- :}+-- ThreadId ...: Delay 1+-- ThreadId ...: Delay 2+-- ThreadId ...: Delay 3+--+-- It differs from 'Async' and 'WAsync' in the nested loop behavior. All+-- iterations of the loop are run fully concurrently irrespective of the+-- demand.  This works exactly the same way as the merging of streams using+-- 'parallel' works.+--+-- The 'fromParallel' type combinator can be used to switch to this style of+-- composition. Alternatively, a type annotation can be used to specify the+-- type of the stream as 'Parallel'.+--++-- $applicative+--+-- 'Async' can run the iterations concurrently, therefore, it takes a total+-- of 6 seconds which is max (1, 2) + max (3, 4):+--+-- >>> (Stream.toList $ Stream.fromAsync $ (,) <$> s1 <*> s2) >>= print+-- ...+--+-- @+-- ThreadId 34: Delay 1+-- ThreadId 36: Delay 2+-- ThreadId 35: Delay 3+-- ThreadId 36: Delay 3+-- ThreadId 35: Delay 4+-- ThreadId 36: Delay 4+-- [(1,3),(2,3),(1,4),(2,4)]+-- @+--+-- Similarly, 'WAsync' as well can run the iterations concurrently, but with a+-- different style of scheduling than 'Async' as explained in the Monad+-- section, therefore, it too takes a total of 6 seconds (2 + 4):+--+-- >>> (Stream.toList $ Stream.fromWAsync $ (,) <$> s1 <*> s2) >>= print+-- ...+--+-- @+-- ThreadId 34: Delay 1+-- ThreadId 36: Delay 2+-- ThreadId 35: Delay 3+-- ThreadId 36: Delay 3+-- ThreadId 35: Delay 4+-- ThreadId 36: Delay 4+-- [(1,3),(2,3),(1,4),(2,4)]+-- @++-- $parallelzip+--+-- The applicative instance of 'ZipAsync' type zips streams concurrently.+-- 'fromZipAsync' type combinator can be used to switch to parallel applicative+-- zip composition:+--+-- This takes 7 seconds to zip, which is max (1,3) + max (2,4) because 1 and 3+-- are produced concurrently, and 2 and 4 are produced concurrently:+--+-- >>> d n = delay n >> return n+-- >>> s1 = Stream.fromSerial $ d 1 <> d 2+-- >>> s2 = Stream.fromSerial $ d 3 <> d 4+-- >>> (Stream.toList $ Stream.fromZipAsync $ (,) <$> s1 <*> s2) >>= print+-- ThreadId ...: Delay 1+-- ThreadId ...: Delay 2+-- ThreadId ...: Delay 3+-- ThreadId ...: Delay 4+-- [(1,3),(2,4)]+--++-- $concurrent+--+-- When writing concurrent programs there are two distinct places where the+-- programmer can control the concurrency. First, when /composing/ a stream by+-- merging multiple streams we can choose an appropriate sum style operators to+-- combine them concurrently or serially. Second, when /processing/ a stream in+-- a monadic composition we can choose one of the monad composition types to+-- choose the desired type of concurrency.+--+-- In the following example the squares of @x@ and @y@ are computed+-- concurrently using the 'async' operation and the square roots of their+-- sum are computed serially because of the 'fromSerial' combinator. We can+-- choose different combinators for the monadic processing and the stream+-- generation, to control the concurrency.  We can also use the 'fromAsync'+-- combinator instead of explicitly folding with 'async'.+--+-- >>> import Data.List (sum)+-- >>> :{+-- main = do+--     z <-   Stream.toList+--          $ Stream.fromSerial     -- Serial monadic processing (sqrt below)+--          $ do+--              x2 <- Stream.concatForFoldableWith Stream.async [1..100] $ -- Concurrent @"for"@ loop+--                          \x -> return $ x * x  -- body of the loop+--              y2 <- Stream.concatForFoldableWith Stream.async [1..100] $+--                          \y -> return $ y * y+--              return $ sqrt (x2 + y2)+--     print $ sum z+-- :}+--+-- We can see how this directly maps to the imperative style+-- <https://en.wikipedia.org/wiki/OpenMP OpenMP> model, we use combinators+-- and operators instead of the ugly pragmas.+--+-- For more concurrent programming examples see,+-- <https://github.com/composewell/streamly-examples>.++-- $furtherReading+--+-- * Read the reactive programming tutorial+-- * See the examples in <https://github.com/composewell/streamly-examples streamly-examples> repo.
+ docs/Overview.md view
@@ -0,0 +1,468 @@+# Streaming++These are some notes from an old version of README that may be+useful. For a quick introduction please read the README.md at the repo+root first.++## Streamly++Streamly is a general computing framework based on data flow programming also+known as streaming. Moreover streamly supports concurrent dataflow programming.++Streaming in general enables writing modular, composable and scalable+applications with ease, and concurrency allows you to make them scale and+perform well.  Streamly enables writing scalable concurrent applications+without being aware of threads or synchronization. No explicit thread+control is needed. Where applicable, concurrency rate is automatically+controlled based on the demand by the consumer. However, combinators can be+used to fine tune the concurrency control.++Streaming and concurrency together enable expressing reactive applications+conveniently. See the @CirclingSquare@ example in+<https://github.com/composewell/streamly-examples Streamly Examples> for+a simple SDL based FRP example. To summarize, streamly provides a unified+computing framework for streaming, non-determinism and functional reactive+programming in an elegant and simple API that is a natural extension of pure+lists to monadic streams.++## What are streams?++In simple terms, streams are the functional equivalent of loops in+imperative programming.++A stream is a representation of potentially infinite data sequence.  You+can compose a pipeline of functions or stream processors to process+an input stream of data to produce an output stream. We call it a+form of dataflow programming as data flows through the processing+logic. In imperative programming there is no clear separation of data+and logic. The logic can arbitrarily examine and mutate data which+creates a problem due to complex interleaving of state and logic in the+program.++In streamly there are two fundamental data structures, streams and arrays.+Streams are for dataflow style processing while arrays are for storing data.+Both taken together are powerful tools for general purpose programming in a+functional or dataflow style.++## Loops vs Streams++In imperative programming when we have to process a sequence of items+or an array of data we run a loop over it, each iteration of the loop+examines the data to do something with it and produce an output.++Loops are a low level, monolithic and general concept. Whereas streams+are high level, structured and modular way of expressing what you usualy+do with loops. Streams allow you to write different parts of the loop+as separate modular combinators and then compose them to create bigger+loops.++## Streaming Concurrently++Haskell lists express pure computations using composable stream operations like+`:`, `unfold`, `map`, `filter`, `zip` and `fold`.  Streamly is exactly like+lists except that it can express sequences of pure as well as monadic+computations aka streams. More importantly, it can express monadic sequences+with concurrent execution semantics without introducing any additional APIs.++Streamly expresses concurrency using standard, well known abstractions.+Concurrency semantics are defined for list operations, semigroup, applicative+and monadic compositions. Programmer does not need to know any low level+notions of concurrency like threads, locking or synchronization.  Concurrent+and non-concurrent programs are fundamentally the same.  A chosen segment of+the program can be made concurrent by annotating it with an appropriate+combinator.  We can choose a combinator for lookahead style or asynchronous+concurrency.  Concurrency is automatically scaled up or down based on the+demand from the consumer application, we can finally say goodbye to managing+thread pools and associated sizing issues.  The result is truly fearless+and declarative monadic concurrency.++## Where to use streamly?++Streamly is a general purpose programming framework.  It can be used equally+efficiently from a simple `Hello World!` program to a massively concurrent+application. The answer to the question, "where to use streamly?" - would be+similar to the answer to - "Where to use Haskell lists or the IO monad?".++Streamly simplifies streaming and makes it as intuitive as plain lists. Unlike+other streaming libraries, no fancy types are required.  Streamly is simply a+generalization of Haskell lists to monadic streaming optionally with concurrent+composition. The basic stream type in streamly `SerialT m a` can be considered+as a list type `[a]` parameterized by the monad `m`. For example, `SerialT IO+a` is a moral equivalent of `[a]` in the IO monad. `SerialT Identity a`, is+equivalent to pure lists.  Streams are constructed very much like lists, except+that they use `nil` and `cons` instead of `[]` and `:`.  Unlike lists, streams+can be constructed from monadic effects, not just pure elements.  Streams are+processed just like lists, with list like combinators, except that they are+monadic and work in a streaming fashion. In other words streamly just completes+what lists lack, you do not need to learn anything new. Please see [streamly vs+lists](docs/streamly-vs-lists.md) for a detailed comparison.++Not surprisingly, the monad instance of streamly is a list transformer, with+concurrency capability.++## Why data flow programming?++If you need some convincing for using streaming or data flow programming+paradigm itself then try to answer this question - why do we use lists in+Haskell? It boils down to why we use functional programming in the first place.+Haskell is successful in enforcing the functional data flow paradigm for pure+computations using lists, but not for monadic computations. In the absence of a+standard and easy to use data flow programming paradigm for monadic+computations, and the IO monad providing an escape hatch to an imperative+model, we just love to fall into the imperative trap, and start asking the same+fundamental question again - why do we have to use the streaming data model?++## Streaming Pipelines++The following snippet provides a simple stream composition example that reads+numbers from stdin, prints the squares of even numbers and exits if an even+number more than 9 is entered.++``` haskell+import qualified Streamly.Prelude as S+import Data.Function ((&))++main = S.drain $+       S.repeatM getLine+     & fmap read+     & S.filter even+     & S.takeWhile (<= 9)+     & fmap (\x -> x * x)+     & S.mapM print+```++Unlike `pipes` or `conduit` and like `vector` and `streaming`, `streamly`+composes stream data instead of stream processors (functions).  A stream is+just like a list and is explicitly passed around to functions that process the+stream.  Therefore, no special operator is needed to join stages in a streaming+pipeline, just the standard function application (`$`) or reverse function+application (`&`) operator is enough.++## Concurrent Stream Generation++`consM` or its operator form `|:` can be used to construct a stream from+monadic actions. A stream constructed with `consM` can run the monadic actions+in the stream concurrently when used with appropriate stream type combinator+(e.g. `fromAsync`, `fromAhead` or `fromParallel`).++The following code finishes in 3 seconds (6 seconds when serial), note the+order of elements in the resulting output, the outputs are consumed as soon as+each action is finished (asyncly):++``` haskell+> let p n = threadDelay (n * 1000000) >> return n+> S.toList $ S.fromAsync $ p 3 |: p 2 |: p 1 |: S.nil+[1,2,3]+```++Use `fromAhead` if you want speculative concurrency i.e. execute the actions in+the stream concurrently but consume the results in the specified order:++``` haskell+> S.toList $ S.fromAhead $ p 3 |: p 2 |: p 1 |: S.nil+[3,2,1]+```++Monadic stream generation functions e.g. `unfoldrM`, `replicateM`, `repeatM`,+`iterateM` and `fromFoldableM` etc. can work concurrently.++The following finishes in 10 seconds (100 seconds when serial):++``` haskell+S.drain $ S.fromAsync $ S.replicateM 10 $ p 10+```++## Concurrent Streaming Pipelines++Use `|&` or `|$` to apply stream processing functions concurrently. The+following example prints a "hello" every second; if you use `&` instead of+`|&` you will see that the delay doubles to 2 seconds instead because of serial+application.++``` haskell+main = S.drain $+      S.repeatM (threadDelay 1000000 >> return "hello")+   |& S.mapM (\x -> threadDelay 1000000 >> putStrLn x)+```++## Mapping Concurrently++We can use `mapM` or `sequence` functions concurrently on a stream.++``` haskell+> let p n = threadDelay (n * 1000000) >> return n+> S.drain $ S.fromAhead $ S.mapM (\x -> p 1 >> print x) (S.fromSerial $ S.repeatM (p 1))+```++## Serial and Concurrent Merging++Semigroup and Monoid instances can be used to fold streams serially or+concurrently. In the following example we compose ten actions in the+stream, each with a delay of 1 to 10 seconds, respectively. Since all the+actions are concurrent we see one output printed every second:++``` haskell+import qualified Streamly.Prelude as S+import Control.Concurrent (threadDelay)++main = S.toList $ S.fromParallel $ foldMap delay [1..10]+ where delay n = S.fromEffect $ threadDelay (n * 1000000) >> print n+```++Streams can be combined together in many ways. We provide some examples+below, see the tutorial for more ways. We use the following `delay`+function in the examples to demonstrate the concurrency aspects:++``` haskell+import qualified Streamly.Prelude as S+import Control.Concurrent++delay n = S.fromEffect $ do+    threadDelay (n * 1000000)+    tid <- myThreadId+    putStrLn (show tid ++ ": Delay " ++ show n)+```+### Serial++``` haskell+main = S.drain $ delay 3 <> delay 2 <> delay 1+```+```+ThreadId 36: Delay 3+ThreadId 36: Delay 2+ThreadId 36: Delay 1+```++### Parallel++``` haskell+main = S.drain . S.fromParallel $ delay 3 <> delay 2 <> delay 1+```+```+ThreadId 42: Delay 1+ThreadId 41: Delay 2+ThreadId 40: Delay 3+```++## Nested Loops (aka List Transformer)++The monad instance composes like a list monad.++``` haskell+import qualified Streamly.Prelude as S++loops = do+    x <- S.fromFoldable [1,2]+    y <- S.fromFoldable [3,4]+    S.fromEffect $ putStrLn $ show (x, y)++main = S.drain loops+```+```+(1,3)+(1,4)+(2,3)+(2,4)+```++## Concurrent Nested Loops++To run the above code with speculative concurrency i.e. each iteration in the+loop can run concurrently but the results are presented to the consumer of the+output in the same order as serial execution:++``` haskell+main = S.drain $ S.fromAhead $ loops+```++Different stream types execute the loop iterations in different ways. For+example, `fromWSerial` interleaves the loop iterations. There are several+concurrent stream styles to execute the loop iterations concurrently in+different ways, see the `Streamly.Tutorial` module for a detailed treatment.++## Magical Concurrency++Streams can perform semigroup (<>) and monadic bind (>>=) operations+concurrently using combinators like `fromAsync`, `parallelly`. For example,+to concurrently generate squares of a stream of numbers and then concurrently+sum the square roots of all combinations of two streams:++``` haskell+import qualified Streamly.Prelude as S++main = do+    s <- S.sum $ S.fromAsync $ do+        -- Each square is performed concurrently, (<>) is concurrent+        x2 <- foldMap (\x -> return $ x * x) [1..100]+        y2 <- foldMap (\y -> return $ y * y) [1..100]+        -- Each addition is performed concurrently, monadic bind is concurrent+        return $ sqrt (x2 + y2)+    print s+```++## Rate Limiting++For bounded concurrent streams, stream yield rate can be specified. For+example, to print hello once every second you can simply write this:++``` haskell+import Streamly.Prelude as S++main = S.drain $ S.fromAsync $ S.avgRate 1 $ S.repeatM $ putStrLn "hello"+```++For some practical uses of rate control, see+[AcidRain.hs](https://github.com/composewell/streamly-examples/tree/master/examples/AcidRain.hs)+and+[CirclingSquare.hs](https://github.com/composewell/streamly-examples/tree/master/examples/CirclingSquare.hs)+.+Concurrency of the stream is automatically controlled to match the specified+rate. Rate control works precisely even at throughputs as high as millions of+yields per second. For more sophisticated rate control see the haddock+documentation.++## Arrays++The `Streamly.Data.Array.Foreign` module provides immutable arrays.  Arrays are the+computing duals of streams. Streams are good at sequential access and immutable+transformations of in-transit data whereas arrays are good at random access and+in-place transformations of buffered data. Unlike streams which are potentially+infinite, arrays are necessarily finite. Arrays can be used as an efficient+interface between streams and external storage systems like memory, files and+network. Streams and arrays complete each other to provide a general purpose+computing system. The design of streamly as a general purpose computing+framework is centered around these two fundamental aspects of computing and+storage.++`Streamly.Data.Array.Foreign` uses pinned memory outside GC and therefore avoid any+GC overhead for the storage in arrays. Streamly allows efficient+transformations over arrays using streams. It uses arrays to transfer data to+and from the operating system and to store data in memory.++## Folds++Folds are consumers of streams.  `Streamly.Data.Fold` module provides a `Fold`+type that represents a `foldl'`.  Such folds can be efficiently composed+allowing the compiler to perform stream fusion and therefore implement high+performance combinators for consuming streams. A stream can be distributed to+multiple folds, or it can be partitioned across multiple folds, or+demultiplexed over multiple folds, or unzipped to two folds. We can also use+folds to fold segments of stream generating a stream of the folded results.++If you are familiar with the `foldl` library, these are the same composable+left folds but simpler and better integrated with streamly, and with many more+powerful ways of composing and applying them.++## Unfolds++Unfolds are duals of folds. Folds help us compose consumers of streams+efficiently and unfolds help us compose producers of streams efficiently.+`Streamly.Data.Unfold` provides an `Unfold` type that represents an `unfoldr`+or a stream generator. Such generators can be combined together efficiently+allowing the compiler to perform stream fusion and implement high performance+stream merging combinators.++## File IO++The following code snippets implement some common Unix command line utilities+using streamly.  You can compile these with `ghc -O2 -fspec-constr-recursive=16+-fmax-worker-args=16` and compare the performance with regular GNU coreutils+available on your system.  Though many of these are not most optimal solutions+to keep them short and elegant. Source file+[HandleIO.hs](https://github.com/composewell/streamly-examples/tree/master/examples/HandleIO.hs)+in the examples directory includes these examples.++``` haskell+module Main where++import qualified Streamly.Prelude as S+import qualified Streamly.Data.Fold as FL+import qualified Streamly.Data.Array.Foreign as A+import qualified Streamly.FileSystem.Handle as FH+import qualified System.IO as FH++import Data.Char (ord)+import System.Environment (getArgs)+import System.IO (openFile, IOMode(..), stdout)++withArg f = do+    (name : _) <- getArgs+    src <- openFile name ReadMode+    f src++withArg2 f = do+    (sname : dname : _) <- getArgs+    src <- openFile sname ReadMode+    dst <- openFile dname WriteMode+    f src dst+```++### cat++``` haskell+cat = S.fold (FH.writeChunks stdout) . S.unfold FH.readChunks+main = withArg cat+```++### cp++``` haskell+cp src dst = S.fold (FH.writeChunks dst) $ S.unfold FH.readChunks src+main = withArg2 cp+```++### wc -l++``` haskell+wcl = S.length . S.splitOn (== 10) FL.drain . S.unfold FH.read+main = withArg wcl >>= print+```++### Average Line Length++``` haskell+avgll =+      S.fold avg+    . S.splitOn (== 10) FL.length+    . S.unfold FH.read++    where avg      = (/) <$> toDouble FL.sum <*> toDouble FL.length+          toDouble = fmap (fromIntegral :: Int -> Double)++main = withArg avgll >>= print+```++### Line Length Histogram++`classify` is not released yet, and is available in+`Streamly.Internal.Data.Fold`++``` haskell+llhisto =+      S.fold (FL.classify FL.length)+    . S.map bucket+    . S.splitOn (== 10) FL.length+    . S.unfold FH.read++    where+    bucket n = let i = n `mod` 10 in if i > 9 then (9,n) else (i,n)++main = withArg llhisto >>= print+```++## Exceptions++Exceptions can be thrown at any point using the `MonadThrow` instance. Standard+exception handling combinators like `bracket`, `finally`, `handle`,+`onException` are provided in `Streamly.Prelude` module.++In presence of concurrency, synchronous exceptions work just the way they are+supposed to work in non-concurrent code. When concurrent streams+are combined together, exceptions from the constituent streams are propagated+to the consumer stream. When an exception occurs in any of the constituent+streams other concurrent streams are promptly terminated.++There is no notion of explicit threads in streamly, therefore, no+asynchronous exceptions to deal with. You can just ignore the zillions of+blogs, talks, caveats about async exceptions. Async exceptions just don't+exist.  Please don't use things like `myThreadId` and `throwTo` just for fun!
+ docs/ReactiveProgramming.hs view
@@ -0,0 +1,124 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+-- |+-- Module      : ReactiveProgramming+-- Copyright   : (c) 2017 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+--+-- In this tutorial we will show how Streamly can be used for reactive+-- programming.  Before you go through this tutorial we recommend that you take+-- a look at the Streamly concurrent programming tutorial.++module ReactiveProgramming+    (+    -- * Reactive Programming+    -- $reactive++    -- * Where to go next?+    -- $furtherReading+    )+where++import Streamly.Prelude+import Data.Semigroup+import Control.Applicative+import Control.Monad+import Control.Monad.IO.Class      (MonadIO(..))+import Control.Monad.Trans.Class   (MonadTrans (lift))++-- $reactive+--+-- Reactive programming is nothing but concurrent streaming which is what+-- streamly is all about. With streamly we can generate streams of events,+-- merge streams that are generated concurrently and process events+-- concurrently. We can do all this without any knowledge about the specifics+-- of the implementation of concurrency. In the following example you will see+-- that the code is just regular Haskell code without much streamly APIs used+-- (active hyperlinks are the streamly APIs) and yet it is a reactive+-- application.+--+-- This application has two independent and concurrent sources of event+-- streams, @acidRain@ and @userAction@. @acidRain@ continuously generates+-- events that deteriorate the health of the character in the game.+-- @userAction@ can be "potion" or "quit". When the user types "potion" the+-- health improves and the game continues.+--+-- @+-- {-\# LANGUAGE FlexibleContexts \#-}+--+-- import "Streamly.Prelude" (MonadAsync, SerialT)+-- import "Streamly.Prelude" as Stream+-- import Control.Monad (void)+-- import Control.Monad.IO.Class (MonadIO(liftIO))+-- import Control.Monad.State (MonadState, get, modify, runStateT)+--+-- data Event = Quit | Harm Int | Heal Int deriving (Show)+--+-- userAction :: MonadAsync m => 'SerialT' m Event+-- userAction = Stream.'repeatM' $ liftIO askUser+--     where+--     askUser = do+--         command <- getLine+--         case command of+--             "potion" -> return (Heal 10)+--             "harm"   -> return (Harm 10)+--             "quit"   -> return Quit+--             _        -> putStrLn "Type potion or harm or quit" >> askUser+--+-- acidRain :: MonadAsync m => 'SerialT' m Event+-- acidRain = Stream.'fromAsync' $ Stream.'constRate' 1 $ Stream.'repeatM' $ liftIO $ return $ Harm 1+--+-- data Result = Check | Done+--+-- runEvents :: (MonadAsync m, MonadState Int m) => 'SerialT' m Result+-- runEvents = do+--     event \<- userAction \`Stream.'parallel'` acidRain+--     case event of+--         Harm n -> modify (\\h -> h - n) >> return Check+--         Heal n -> modify (\\h -> h + n) >> return Check+--         Quit -> return Done+--+-- data Status = Alive | GameOver deriving Eq+--+-- getStatus :: (MonadAsync m, MonadState Int m) => Result -> m Status+-- getStatus result =+--     case result of+--         Done  -> liftIO $ putStrLn "You quit!" >> return GameOver+--         Check -> do+--             h <- get+--             liftIO $ if (h <= 0)+--                      then putStrLn "You die!" >> return GameOver+--                      else putStrLn ("Health = " <> show h) >> return Alive+--+-- main :: IO ()+-- main = do+--     putStrLn "Your health is deteriorating due to acid rain, type \\\"potion\\\" or \\\"quit\\\""+--     let runGame = Stream.'drainWhile' (== Alive) $ Stream.'mapM' getStatus runEvents+--     void $ runStateT runGame 60+-- @+--+-- You can also find the source of this example in the streamly-examples repo+-- as <https://github.com/composewell/streamly-examples/tree/master/AcidRain.hs AcidRain.hs>.+-- It has been adapted from Gabriel's+-- <https://hackage.haskell.org/package/pipes-concurrency-2.0.8/docs/Pipes-Concurrent-Tutorial.html pipes-concurrency>+-- package.+-- This is much simpler compared to the pipes version because of the builtin+-- concurrency in streamly. You can also find a SDL based reactive programming+-- example adapted from Yampa in+-- <https://github.com/composewell/streamly-examples/tree/master/CirclingSquare.hs CirclingSquare.hs>.++-- $performance+--+-- Streamly is highly optimized for performance, it is designed for serious+-- high performing, concurrent and scalable applications. We have created the+-- <https://hackage.haskell.org/package/streaming-benchmarks streaming-benchmarks>+-- package which is specifically and carefully designed to measure the+-- performance of Haskell streaming libraries fairly and squarely in the right+-- way. Streamly performs at par or even better than most streaming libraries+-- for serial operations even though it needs to deal with the concurrency+-- capability.++-- $furtherReading+--+-- * See the examples in <https://github.com/composewell/streamly-examples streamly-examples> repo.
+ docs/Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ docs/Tutorial.hs view
@@ -0,0 +1,553 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+-- |+-- Module      : Tutorial+-- Copyright   : (c) 2017 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+--+-- In this tutorial we will show how Streamly can be used for idiomatic+-- dataflow programming.  Before you go through this tutorial we recommend that+-- you take a look at the Streamly Getting Started guide so that you are ready+-- to try out the examples.++module Tutorial+    (+    -- * Stream Types+    -- $streams++    -- * Imports and Supporting Code+    -- $imports++    -- * Generating Streams+    -- $generating++    -- * Eliminating Streams+    -- $eliminating++    -- * Transforming Streams+    -- $transformation++    -- * Merging Streams++    -- ** Semigroup Style+    -- $semigroup++    -- *** Deep Serial Composition ('Serial')+    -- $serial++    -- *** Wide Serial Composition ('WSerial')+    -- $interleaved++    -- ** Monoid Style+    -- $monoid++    -- * Nesting Streams+    -- $nesting++    -- ** Monad+    -- $monad++    -- *** Deep Serial Nesting ('Serial')+    -- $regularSerial++    -- *** Wide Serial Nesting ('WSerial')+    -- $interleavedNesting++    -- *** Exercise+    -- $monadExercise++    -- ** Applicative+    -- $applicative++    -- ** Functor+    -- $functor++    -- * Zipping Streams+    -- $zipping++    -- ** Serial Zipping+    -- $serialzip++    -- * Where to go next?+    -- $furtherReading+    )+where++import Streamly.Prelude+import Data.Semigroup+import Control.Applicative+import Control.Monad+import Control.Monad.IO.Class      (MonadIO(..))+import Control.Monad.Trans.Class   (MonadTrans (lift))++-- CAUTION: please keep setup and imports sections in sync++-- $setup+-- >>> :m+-- >>> import Data.Function ((&))+-- >>> import Streamly.Prelude ((|:), (|&))+-- >>> import qualified Streamly.Prelude as Stream+-- >>> import qualified Streamly.Data.Fold as Fold+--++-- $imports+--+-- In most of example snippets we do not repeat the imports. Where imports are+-- not explicitly specified use the imports shown below.+--+-- >>> :m+-- >>> import Data.Function ((&))+-- >>> import Streamly.Prelude ((|:), (|&))+-- >>> import qualified Streamly.Prelude as Stream+-- >>> import qualified Streamly.Data.Fold as Fold+--++-- $streams+--+-- The monadic stream API offered by Streamly is very close to the Haskell+-- "Prelude" pure lists' API, it can be considered as a natural extension of+-- lists to monadic actions. Streamly streams provide concurrent composition+-- and merging of streams. It can be considered as a concurrent list+-- transformer.+--+-- The basic stream type is 'Serial', it represents a sequence of IO actions,+-- and is a 'Monad'.  The 'Serial' monad is almost a drop in replacement for+-- the 'IO' monad, IO monad is a special case of the 'Serial' monad; IO monad+-- represents a single IO action whereas the 'Serial' monad represents a series+-- of IO actions.  The only change you need to make to go from 'IO' to 'Serial'+-- is to use 'drain' to run the monad and to prefix the IO actions with+-- either 'fromEffect' or 'liftIO'.  If you use liftIO you can switch from 'Serial'+-- to IO monad by simply removing the 'drain' function; no other changes+-- are needed unless you have used some stream specific composition or+-- combinators.+--+-- Similarly, the 'Serial' type is almost a drop in replacement for pure lists,+-- pure lists are a special case of monadic streams. If you use 'nil' in place+-- of '[]' and '|:' in place ':' you can replace a list with a 'Serial' stream.+-- The only difference is that the elements must be monadic type and to operate+-- on the streams we must use the corresponding functions from+-- "Streamly.Prelude" instead of using the base "Prelude".++-- $generating+--+-- 'nil' represents an empty stream and 'consM' or its operator form '|:' adds+-- a monadic action at the head of the stream.+--+-- >>> Stream.toList Stream.nil+-- []+--+-- Stream.toList $ getLine |: getLine |: Stream.nil+-- hello+-- world+-- ["hello","world"]+--+-- To create a singleton stream from a pure value use 'fromPure' or 'pure' and to+-- create a singleton stream from a monadic action use 'fromEffect'. Note that in+-- case of Zip applicative streams "pure" repeats the value to generate an+-- infinite stream.+--+-- >>> Stream.toList $ pure 1+-- [1]+--+-- >>> Stream.toList $ Stream.fromPure 1+-- [1]+--+-- Stream.toList $ Stream.fromEffect getLine+-- hello+-- ["hello"]+--+-- To create a stream from pure values in a 'Foldable' container use+-- 'fromFoldable' which is equivalent to a fold using 'cons' and 'nil':+--+-- >>> Stream.toList $ Stream.fromFoldable [1..3]+-- [1,2,3]+--+-- >>> Stream.toList $ Prelude.foldr Stream.cons Stream.nil [1..3]+-- [1,2,3]+--+-- To create a stream from monadic actions in a 'Foldable' container just use a+-- right fold using 'consM' and 'nil':+--+-- >>> Stream.drain $ Prelude.foldr (|:) Stream.nil [putStr "Hello ", putStrLn "world!"]+-- Hello world!+--+-- For more ways to construct a stream see the module "Streamly.Prelude".++-- $eliminating+--+-- We have already seen 'drain' and toList to eliminate a stream in the+-- examples above.  'drain' runs a stream discarding the results i.e. only+-- for effects.  'toList' runs the stream and collects the results in a list.+--+-- For other ways to eliminate a stream see the @Folding@ section in+-- "Streamly.Prelude" module.++-- $transformation+--+-- Transformation over a stream is the equivalent of a @for@ loop construct in+-- imperative paradigm. We iterate over every element in the stream and perform+-- certain transformations for each element.  Transformations may involve+-- mapping functions over the elements, filtering elements from the stream or+-- folding all the elements in the stream into a single value. Streamly streams+-- are exactly like lists and you can perform all the transformations in the+-- same way as you would on lists.+--+-- Here is a simple console echo program that just echoes every input line,+-- forever:+--+-- >>> :{+-- echo =+--       Stream.repeatM getLine+--     & Stream.mapM putStrLn+--     & Stream.drain+-- :}+--+-- The following code snippet reads lines from standard input, filters blank+-- lines, drops the first non-blank line, takes the next two, up cases them,+-- numbers them and prints them:+--+-- >>> import Data.Char (toUpper)+-- >>> :{+-- main =+--       Stream.repeatM getLine+--     & Stream.filter (not . null)+--     & Stream.drop 1+--     & Stream.take 2+--     & fmap (map toUpper)+--     & Stream.zipWith (\n s -> show n ++ " " ++ s) (Stream.fromFoldable [1..])+--     & Stream.mapM putStrLn+--     & Stream.drain+-- :}+--++-- $semigroup+--+-- We can combine two streams into a single stream using semigroup composition+-- operation '<>'.  Streams can be combined in many different ways as described+-- in the following sections, the '<>' operation behaves differently depending+-- on the stream type in effect. The stream type and therefore the composition+-- style can be changed at any point using one of the type combinators as+-- discussed earlier.++-- $serial+--+-- The 'Semigroup' operation '<>' of the 'Serial' type combines the two streams+-- in a /serial depth first/ manner. We use the 'fromSerial' type combinator to+-- effect 'Serial' style of composition. We can also use an explicit 'Serial'+-- type annotation for the stream to achieve the same effect.  However, since+-- 'Serial' is the default type unless explicitly specified by using a+-- combinator, we can omit using an explicit combinator or type annotation for+-- this style of composition.+--+-- When two streams with multiple elements are combined in this manner, the+-- monadic actions in the two streams are performed sequentially i.e. first all+-- actions in the first stream are performed sequentially and then all actions+-- in the second stream are performed sequentially. We call it+-- /serial depth first/ as the full depth of one stream is fully traversed+-- before we move to the next. The following example prints the sequence 1, 2,+-- 3, 4:+--+-- >>> stream1 = print 1 |: print 2 |: Stream.nil+-- >>> stream2 = print 3 |: print 4 |: Stream.nil+-- >>> Stream.drain $ stream1 <> stream2+-- 1+-- 2+-- 3+-- 4+--+-- All actions in both the streams are performed serially in the same thread.+--+-- The polymorphic version of the binary operation '<>' of the 'Serial' type is+-- 'serial'. We can use 'serial' to join streams in a sequential manner+-- irrespective of the type of stream:+--+-- >>> Stream.drain $ stream1 `Stream.serial` stream2+-- 1+-- 2+-- 3+-- 4+--++-- $interleaved+--+-- The 'Semigroup' operation '<>' of the 'WSerial' type combines the two+-- streams in a /serial breadth first/ manner. We use the fromWSerial type+-- combinator to effect 'WSerial' style of composition. We can also use the+-- 'WSerial' type annotation for the stream to achieve the same effect.+--+-- When two streams with multiple elements are combined in this manner, we+-- traverse all the streams in a breadth first manner i.e. one action from each+-- stream is performed and yielded to the resulting stream before we come back+-- to the first stream again and so on.+-- The following example prints the sequence 1, 3, 2, 4+--+-- >>> stream1 = print 1 |: print 2 |: Stream.nil+-- >>> stream2 = print 3 |: print 4 |: Stream.nil+-- >>> Stream.drain $ Stream.fromWSerial $ stream1 <> stream2+-- 1+-- 3+-- 2+-- 4+--+-- Even though the monadic actions of the two streams are performed in an+-- interleaved manner they are all performed serially in the same thread.+--+-- The polymorphic version of the 'WSerial' binary operation '<>' is called+-- 'wSerial'. We can use 'wSerial' to join streams in an interleaved manner+-- irrespective of the type, notice that we have not used the fromWSerial+-- combinator in the following example:+--+-- >>> Stream.drain $ stream1 `Stream.wSerial` stream2+-- 1+-- 3+-- 2+-- 4+--+-- Note that this composition cannot be used to fold infinite number of streams+-- since it requires preserving the state until a stream is finished.++-- $monoid+--+-- We can use 'Monoid' instances to fold a container of streams in the desired+-- style using 'fold' or 'foldMap'.  We have also provided some fold utilities+-- to fold streams using the polymorphic combine operations:+--+-- * 'concatFoldableWith' is like 'fold', it folds a 'Foldable' container of+-- streams using the given composition operator.+-- * 'concatMapFoldableWith' is like 'foldMap', it folds like+-- @concatFoldableWith@ but also maps a function before folding.+-- * 'concatForFoldableWith' is like @concatMapFoldableWith@ but the container+-- argument comes before the function argument.+--+-- All of the following are equivalent:+--+-- >>> :{+-- traced = Stream.fromEffect . print+-- main = do+--  Stream.drain $ foldMap traced [1..10]+--  Stream.drain $ Stream.concatFoldableWith Stream.serial (map traced [1..10])+--  Stream.drain $ Stream.concatMapFoldableWith Stream.serial traced [1..10]+--  Stream.drain $ Stream.concatForFoldableWith Stream.serial [1..10] traced+-- :}+--++-- $nesting+--+-- Till now we discussed ways to apply transformations on a stream or to merge+-- streams together to create another stream. We mentioned earlier that+-- transforming a stream is similar to a @for@ loop in the imperative paradigm.+-- We will now discuss the concept of a nested composition of streams which is+-- analogous to nested @for@ loops in the imperative paradigm. Functional+-- programmers call this style of composition a list transformer or @ListT@.+-- Logic programmers call it a logic monad or non-deterministic composition,+-- but for ordinary imperative minded people like me it is easier to think in+-- terms of good old nested @for@ loops.+--+-- $monad+--+-- In functional programmer's parlance the 'Monad' instances of different+-- 'IsStream' types implement non-determinism, exploring all possible+-- combination of choices from both the streams. From an imperative+-- programmer's point of view it behaves like nested loops i.e.  for each+-- element in the first stream and for each element in the second stream+-- execute the body of the loop.+--+-- The 'Monad' instances of 'Serial', 'WSerial', 'Async' and 'WAsync'+-- stream types support different flavors of nested looping.  In other words,+-- they are all variants of list transformer.  The nesting behavior of these+-- types correspond exactly to the way they merge streams as we discussed in+-- the previous section.+--++-- $regularSerial+--+-- The 'Monad' composition of the 'Serial' type behaves like a standard list+-- transformer. This is the default when we do not use an explicit type+-- combinator. However, the 'fromSerial' type combinator can be used to switch to+-- this style of composition. We will see how this style of composition works+-- in the following examples.+--+-- Let's start with an example with a simple @for@ loop without any nesting.+-- For simplicity of illustration we are using streams of pure values in all+-- the examples.  However, the streams could also be made of monadic actions+-- instead.+--+-- >>> :{+-- Stream.drain $ do+--     x <- Stream.fromFoldable [3,2,1]+--     Stream.fromEffect $ print x+-- :}+-- 3+-- 2+-- 1+--+-- As we can see, the code after the @fromFoldable@ statement is run three+-- times, once for each value of @x@ drawn from the stream. All the three+-- iterations are serial and run in the same thread one after another. In+-- imperative terms this is equivalent to a @for@ loop with three iterations.+--+-- We can write the console echo program that we wrote earlier using the monad+-- instance:+--+-- >>> :{+-- main =+--     Stream.drain $ do+--         x <- Stream.repeatM getLine+--         Stream.fromEffect $ putStrLn x+-- :}+--+-- When multiple streams are composed using this style they nest in a DFS+-- manner:+--+-- >>> :{+-- Stream.drain $ do+--   x <- Stream.fromFoldable [1,2]+--   y <- Stream.fromFoldable [3,4]+--   Stream.fromEffect $ print (x, y)+-- :}+-- (1,3)+-- (1,4)+-- (2,3)+-- (2,4)+--+-- i.e. inner loop iterations ((1,3), (1,4)) are executed before we proceed to+-- the next iteration of the outer loop ((2,3), (2,4)). This behaves just like+-- nested @for@ loops in imperative programming.+--+-- Notice that this is analogous to merging streams of type 'Serial' or merging+-- streams using 'serial'.++-- $interleavedNesting+--+-- The 'Monad' composition of 'WSerial' type interleaves the iterations of+-- outer and inner loops in a nested loop composition.+--+-- >>> :{+-- Stream.drain $ Stream.fromWSerial $ do+--      x <- Stream.fromFoldable [1,2]+--      y <- Stream.fromFoldable [3,4]+--      Stream.fromEffect $ print (x, y)+-- :}+-- (1,3)+-- (2,3)+-- (1,4)+-- (2,4)+--+-- Note that (2,3) is preferred to (1,4).  This works exactly the same way as+-- the merging of two streams using 'wSerial' works.+--+-- The fromWSerial type combinator can be used to switch to this style of+-- composition. Alternatively, a type annotation can be used to specify the+-- type of the stream as 'WSerial'.+--++-- $monadExercise+--+-- Streamly code is usually written in a way that is agnostic of the+-- specific monadic composition type. We use a polymorphic type with a+-- 'IsStream' type class constraint. When running the stream we can choose the+-- specific mode of composition. For example take a look at the following code.+--+-- >>> :{+-- composed :: (Stream.IsStream t, Monad (t IO)) => t IO ()+-- composed = do+--     sz <- sizes+--     cl <- colors+--     sh <- shapes+--     Stream.fromEffect $ print (sz, cl, sh)+--     where+--     sizes  = Stream.fromFoldable [1, 2, 3]+--     colors = Stream.fromFoldable ["red", "green", "blue"]+--     shapes = Stream.fromFoldable ["triangle", "square", "circle"]+-- :}+--+-- Now we can interpret this in whatever way we want:+--+-- @+-- main = Stream.'drain' $ Stream.'fromSerial'  $ composed+-- main = Stream.'drain' $ Stream.'fromWSerial' $ composed+-- main = Stream.'drain' $ Stream.'fromAsync'   $ composed+-- main = Stream.'drain' $ Stream.'fromWAsync'  $ composed+-- main = Stream.'drain' $ Stream.'fromParallel' $ composed+-- @+--+--  As an exercise try to figure out the output of this code for each mode of+--  composition.++-- $functor+--+-- 'fmap' transforms a stream by mapping a function on all elements of the+-- stream. 'fmap' behaves in the same way for all stream types, it is always+-- serial.+--+-- >>> (Stream.toList $ fmap show $ Stream.fromFoldable [1..10]) >>= print+-- ["1","2","3","4","5","6","7","8","9","10"]+--+-- Also see functions 'mapM' and 'sequence' from "Streamly.Prelude" module+-- which can map actions concurrently depending on the type of the input stream.++-- $applicative+--+-- Applicative is precisely the same as the 'ap' operation of 'Monad'. For+-- zipping applicatives separate types 'ZipSerial' and 'ZipAsync' are+-- provided.+--+-- The following is an example of 'Serial' applicative, it runs all iterations+-- serially:+--+-- >>> p n = Stream.fromEffect (print n) >> return n+-- >>> s1 = p 1 <> p 2+-- >>> s2 = p 3 <> p 4+--+-- >>> (Stream.toList $ Stream.fromSerial $ (,) <$> s1 <*> s2) >>= print+-- 1+-- 3+-- 4+-- 2+-- 3+-- 4+-- [(1,3),(1,4),(2,3),(2,4)]+--+-- Similarly, 'WSerial' applicative runs the iterations in an interleaved+-- order but being serial it too takes a total of 17 seconds:+--+-- >>> (Stream.toList $ Stream.fromWSerial $ (,) <$> s1 <*> s2) >>= print+-- 1+-- 3+-- 2+-- 3+-- 4+-- 4+-- [(1,3),(2,3),(1,4),(2,4)]++-- $zipping+--+-- Zipping is a special transformation where the corresponding elements of two+-- streams are combined together using a zip function producing a new stream of+-- outputs. Two different types are provided for serial and concurrent zipping.+-- These types provide an applicative instance that can be used to lift+-- functions to zip the argument streams.+-- Also see the zipping functions in the "Streamly.Prelude" module.++-- $serialzip+--+-- The applicative instance of 'ZipSerial' type zips streams serially.+-- 'fromZipSerial' type combinator can be used to switch to serial applicative+-- zip composition:+--+-- >>> p n = Stream.fromEffect (print n) >> return n+-- >>> s1 = Stream.fromSerial $ p 1 <> p 2+-- >>> s2 = Stream.fromSerial $ p 3 <> p 4+-- >>> (Stream.toList $ Stream.fromZipSerial $ (,) <$> s1 <*> s2) >>= print+-- 1+-- 3+-- 2+-- 4+-- [(1,3),(2,4)]+--++-- $furtherReading+--+-- * Read the concurrent streams tutorial+-- * See the examples in <https://github.com/composewell/streamly-examples streamly-examples> repo.
+ docs/building.md view
@@ -0,0 +1,109 @@+# Build Guide++## Building++### Compiler (GHC) Versions++GHC 8.6 and above are recommended.  For best performance use GHC 8.8 or+8.10 along with `fusion-plugin` (see below).  Benchmarks show that GHC+8.8 has significantly better performance than GHC 8.6 in many cases.++GHC 9.0 has some performance issues, please see [this+issue](https://github.com/composewell/streamly/issues/1061) for details.+However, upcoming minor version updates may fix some of these issues.++### Distributions++Tested with stackage `lts-18.0` and `nix 21.05`.++### Memory requirements++Building streamly itself may require upto 4GB memory. Depending on the+size of the application you may require 1-16GB memory to build. For most+applications up to 8GB of memory should be sufficient.++To reduce the memory footprint you may want to break big modules into+smaller ones and reduce unnecessary inlining on large functions. You can+also use the `-Rghc-timing` GHC option to report the memory usage during+compilation.++See the "Build times and space considerations" section below for more+details.++### Compilation Options++#### Recommended Options++Add `fusion-plugin` to the `build-depends` section of your program in+the cabal file and use the following GHC options:++```+  -O2+  -fdicts-strict+  -fmax-worker-args=16+  -fspec-constr-recursive=16+  -fplugin Fusion.Plugin+```++Important Notes:++1. [fusion-plugin](https://hackage.haskell.org/package/fusion-plugin) can+   improve performance significantly by better stream fusion, many+   cases. If the perform regresses due to fusion-plugin please open+   an issue.  You may remove the `-fplugin` option for regular builds+   but it is recommended for deployment builds and performance+   benchmarking. Note, for GHC 8.4 or lower fusion-plugin cannot be used.+2. In certain cases it is possible that GHC takes too long to compile+   with `-fspec-constr-recursive=16`, if that happens please reduce the+   value or remove that option.+3. At the very least `-O -fdicts-strict` compilation options are+   absolutely required to avoid issues in some cases. For example, the+   program `main = S.drain $ S.concatMap S.fromList $ S.repeat []` may+   hog memory without these options.++See [Explanation](#explanation) for details about these flags.++#### Explanation++* `-fdicts-strict` is needed to avoid [a GHC+issue](https://gitlab.haskell.org/ghc/ghc/issues/17745) leading to+memory leak in some cases.++* `-fspec-constr-recursive` is needed for better stream fusion by enabling+the `SpecConstr` optimization in more cases. Large values used with this flag+may lead to huge compilation times and code bloat, if that happens please avoid+it or use a lower value (e.g. 3 or 4).++* `-fmax-worker-args` is needed for better stream fusion by enabling the+`SpecConstr` optimization in some important cases.++* `-fplugin=Fusion.Plugin` enables predictable stream fusion+optimization in certain cases by helping the compiler inline internal+bindings and therefore enabling case-of-case optimization. In some+cases, especially in some file IO benchmarks, it can make a difference of+5-10x better performance.++### Multi-core Parallelism++Concurrency without a threaded runtime may be a bit more efficient. Do not use+threaded runtime unless you really need multi-core parallelism. To get+multi-core parallelism use the following GHC options:++  `-threaded -with-rtsopts "-N"`++## Platform Specific Features++Streamly supports Linux, macOS and Windows operating systems. Some+modules and functionality may depend on specific OS kernel features.+Features/modules may get disabled if the kernel/OS does not support it.++### Linux++* File system events notification module is supported only for kernel versions+  2.6.36 onwards.++### Mac OSX++* File system events notification module requires macOS 10.7+ with+  Xcode/macOS SDK installed (depends on `Cocoa` framework). However, we only+  test on latest three versions of the OS.
+ docs/getting-started.md view
@@ -0,0 +1,296 @@+<!--+Portions (c) 2020, Google LLC.+SPDX-License-Identifer: BSD-3-Clause+-->++# Getting started with the `streamly` package++This guide will show you how to write a simple program that uses+[Streamly][], using the [`cabal`](https://www.haskell.org/cabal/) build+manager for Haskell.++<!-- TODO: Add instructions for `stack` and `nix`.++If you are using `stack` or `nix` please make sure to add the latest+version from Hackage to your tool configuration.  -->++No prior knowledge of either Haskell or of `cabal` is needed.  We do+however assume that you are using a command-line shell on a POSIX+operating system.  If you are running Windows&trade; then you may need+to run a command-line shell under `msys` and some of the commands+below may also need to be changed in small ways to make them work.++**Note**: If you are new to Haskell you may find the [Haskell Getting+Started Guide][haskell-getting-started] to be useful.++If you know your way around Haskell, and have an up to date toolchain+already installed, then you can jump straight to the section titled+"[_Prepare Your Build Directory_](#prepare-your-build-directory)".++## Getting started with `streamly` using `cabal`++To get started, you will need a recent `cabal` binary to be installed+on your system.++### Installing `cabal`++A pre-packaged `cabal` binary may already be available for your+operating system.++For example, on Debian GNU/Linux, you could install `cabal` using::++```+$ sudo apt install cabal-install+```++### Installing `ghc`++You would also need to install the Glasgow Haskell Compiler `ghc`.  In+most operating systems, using the system's package manager to install+`cabal` would also bring in a version of `ghc` as a dependency.++Please verify that `ghc` is present:++```+$ ghc --version+The Glorious Glasgow Haskell Compilation System, version 8.0.2+```++If `ghc` isn't present, please install it using your operating+system's package manager. For example, on Debian GNU/Linux, use:++```+$ sudo apt install ghc+```++### Update `cabal` if necessary++Many operating systems ship an old version of `cabal`; in order to use+`streamly` you should use `cabal` version 3.0 (or later).++You can check the installed version of `cabal` by using its+`--version` flag:++```+$ which cabal+/usr/bin/cabal+$ /usr/bin/cabal --version+cabal-install version 1.24.0.2+compiled using version 1.24.2.0 of the Cabal library+```++In this example, the installed `cabal` binary is too old for our+needs. It would need to be upgraded.++You can ask `cabal` to upgrade itself (please see+<https://www.haskell.org/cabal/>):++```+$ cabal install Cabal cabal-install+Resolving dependencies...+Downloading base16-bytestring-0.1.1.7...+... lots of build output ...+Building cabal-install-3.0.0.0...+Installed cabal-install-3.0.0.0+```++`cabal` will usually place its compiled binaries inside the directory+`$HOME/.cabal/bin`.++You can verify the version of your newly installed binary by using the+`--version` flag again:++```+$ $HOME/.cabal/bin/cabal --version+cabal-install version 3.0.0.0+compiled using version 3.0.2.0 of the Cabal library+```++If you have upgraded `cabal`, do be sure to specify `$HOME/.cabal/bin`+early in your `PATH` shell variable, so that the new binary gets used+instead of the older version on your system.++```+$ PATH=$HOME/.cabal/bin:$PATH+```++Once you have `cabal` version 3.0 (or later) successfully installed,+please refresh its package list by using `cabal update`.++```+$ cabal update+Downloading the latest package list from hackage.haskell.org+```++### Prepare Your Build Directory++Next, create a build directory, so that you can use `cabal`'s isolated+builds feature.++```+$ mkdir streamly-play+$ cd streamly-play+```++Run `cabal init` to create an initial set of project files:++```+$ cabal init --minimal --dependency base --dependency streamly++Generating LICENSE...+... other messages ...+Generating Main.hs...+Generating streamly-play.cabal...++Warning: no synopsis given. You should edit the .cabal file and add one.+You may want to edit the .cabal file and add a Description field.+```++This invocation will set up a build with two build dependencies,+namely `base` and `streamly`.  You can add additional dependencies+later, by editing the `build-depends` section of the generated cabal+file `streamly-play.cabal`.  Please see the [Cabal User+Guide](https://www.haskell.org/cabal/users-guide/) for more+information on how to configure `cabal`.++This invocation also creates a skeletal `Main.hs` program which we+will use later.++### Try `streamly` in the GHCi REPL++You can now try out `streamly` using the `GHCi` interpreter's+read-eval-print-loop (REPL) facility.++To start up the GHCi REPL using the released `streamly` version on+Hackage, please use:++```+$ cabal repl --build-depends streamly+... plenty of build messaages, the first time around ...+GHCi, version 8.8.3: https://www.haskell.org/ghc/  :? for help+[1 of 1] Compiling Main             ( Main.hs, interpreted )+Ok, one module loaded.+*Main>+```++Once at the `*Main>` prompt, you can import `streamly` and use it+directly:++```+*Main> import qualified Streamly.Prelude as Stream++*Main Stream> Stream.drain $ Stream.mapM print $ Stream.fromList [1..3]+1+2+3+*Main Stream>+```++For the curious, here is a high level overview of what these lines+do:++1. `import qualified Streamly.Prelude as Stream` imports the Streamly+   prelude into GHCi, and makes it available as module `Stream`.+2. `[1..3]` generates the Haskell list `[1, 2, 3]`.+3. `Stream.fromList` transforms that list into a stream of integers.+4. `Stream.mapM print` transforms the stream of integers into a stream of+   actions that would print those integers when executed.+5. `Stream.drain` transforms that stream of actions into an IO action that+   `main` or GHCi's REPL can execute.++#### Using a specific version of `streamly` in the REPL++You can also ask `cabal` to use a specific version of `streamly` by+adding a version number constraint to the `--build-depends` flag:++```+$ cabal repl --build-depends streamly==0.8.0+[1 of 1] Compiling Main             ( Main.hs, interpreted )+Ok, modules loaded: Main.+*Main>+```++#### (Advanced) Using the development version of `streamly` in the REPL++To use the development version of `streamly`, we need to configure+`cabal` to fetch it from Github.++Create a `cabal.project` file in the current directory with the+following content:++```+packages: .+source-repository-package+  type: git+  location: https://github.com/composewell/streamly+  tag: master+```++With this file present, `cabal` will fetch and build the current+version of `streamly` from Github every time it is run.  For example:++```+$ cabal repl+... fetches the 'master' branch of streamly from Github ...+... build messages ...+[1 of 1] Compiling Main     v        ( Main.hs, interpreted )+Ok, modules loaded: Main.+*Main>+```++### Using `streamly` in a standalone program++Let us now turn the single-line stanza above into a standalone program+that uses `streamly`.++Edit `Main.hs` to contain the following:++```haskell+module Main where++import qualified Streamly.Prelude as Stream++main :: IO ()+main = Stream.drain $ Stream.mapM print $ Stream.fromList [1..3]+```++Build and run this program using `cabal run`:++```+$ cabal run+... build messages ...+1+2+3+```++## Which version of `streamly` should you use?++If you are new to Streamly, we recommend using latest [stable release+of streamly][streamly-hackage] on Hackage.++If you need access to cutting edge features (and do not mind the+occasional breakage), please use the [development version of+streamly][streamly-github] on Github.+++## Next Steps++If you got this far successfully, congratulations!++* For an overview of the `streamly` package, please read the+  [Streamly Quick Overview](README.md).+* Please browse the code examples in the+  [`Streamly examples repository`][streamly-examples].+* If you would like to start on a real world project, please take a+  look at the [Streamly Build Guide](./docs/building.md).+* For comprehensive documentation please visit the+  [Streamly Homepage][Streamly].++<!-- Markdown Links -->++ [Streamly]: https://streamly.composewell.com/+ [streamly-hackage]: https://hackage.haskell.org/package/streamly+ [streamly-github]: https://github.com/composewell/streamly+ [streamly-examples]: https://github.com/composewell/streamly-examples+ [haskell-getting-started]: https://github.com/composewell/haskell-dev/blob/master/getting-started.rst
+ docs/interoperation.md view
@@ -0,0 +1,11 @@+# Interoperation with streaming libraries++We can use `unfoldr` and `uncons` operations to convert one streaming+type to another. See the following interoperation examples in the+[streamly-examples](https://github.com/composewell/streamly-examples)+repository.++* [Interoperation with `streaming`](https://github.com/composewell/streamly-examples/blob/master/examples/Interop/Streaming.hs)+* [Interoperation with `pipes`](https://github.com/composewell/streamly-examples/blob/master/examples/Interop/Pipes.hs)+* [Interoperation with `conduit`](https://github.com/composewell/streamly-examples/blob/master/examples/Interop/Conduit.hs)+* [Interoperation with `vector`](https://github.com/composewell/streamly-examples/blob/master/examples/Interop/Vector.hs)
+ docs/monad-transformers.md view
@@ -0,0 +1,65 @@+# Monad Transformers++In the stream tutorials we mostly used streams in the IO monad.  In+general, the type `SerialT` is a monad transformer, @SerialT m a@+represents a stream of values of type 'a' in some underlying monad+'m'. For example, @SerialT IO Int@ is a stream of 'Int' in 'IO'+monad. Similarly, `SerialT Identity Int` would be a pure stream+equivalent to `[a]`.++Similarly we have monad transformer types for other stream types as well+viz.  'WSerialT', 'AsyncT', 'WAsyncT' and 'ParallelT'.++To lift a value from an underlying monad in a monad transformer stack into a+singleton stream use 'lift' and to lift from an IO action use 'liftIO'.++```+>>> import Control.Monad.IO.Class (liftIO)+>>> Stream.drain $ liftIO $ putStrLn "Hello world!"+Hello world!++>>> import Control.Monad.Trans.Class (MonadTrans(lift))+>>> Stream.drain $ lift $ putStrLn "Hello world!"+Hello world!+```++## Using Monad Transformers++Common monad transformers can be used with streamly serial streams, without any+issues. `ReaderT` can be used with concurrent streams as well without any+issues.++The semantics of monads other than `ReaderT` with concurrent streams are+not yet finalized and will change in future, therefore, as of now they are not+recommended to be used with concurrent streams.++## Ordering of Monad Transformers++In most cases it is a good idea to keep streamly as the top level monad.+[This+example](https://github.com/composewell/streamly-examples/blob/master/examples/ControlFlow.hs)+demonstrates how various control flow modifying monads can be combined+with streamly stream monads.++## State Sharing+### Serial Applications++Read only global state can always be shared using the `Reader` monad.+Read-write global state can be shared either using an `IORef` in the `Reader`+monad or using the `State` monad.++See `AcidRain.hs` example for a usage of `StateT` in the serially executing+portion of the program.++### Concurrent Applications++The current recommended method for sharing modifiable global state across+concurrent tasks is to put the shared state inside an `IORef` in a `Reader`+monad or just share the `IORef` by passing it to the required functions. The+`IORef` can be updated atomically using `atomicModifyIORef`.++The `CirclingSquare.hs` example shares an `IORef` across parallel tasks.++## See also++* [Examples of control flow monads with Streamly](https://github.com/composewell/streamly-examples/blob/master/examples/ControlFlow.hs)
+ docs/optimizing.md view
@@ -0,0 +1,98 @@+# Optimization Guide++## Performance Optimizations++A "closed loop" is any streamly code that generates a stream using+unfold (or conceptually any stream generation combinator) and ends+up eliminating it with a fold (conceptually any stream elimination+combinator). It is essentially a loop processing multiple elements in+a stream sequence, just like a `for` or `while` loop in imperative+programming.++Closed loops are generated in a modular fashion by stream generation,+transformation and elimination combinators in streamly. Combinators+transfer data to the next stream pipeline stage using data constructors.+These data constructors are eliminated by the compiler using `stream+fusion` optimizations, generating a very efficient loop.++However, stream fusion optimization depends on proper inlining of the+combinators involved. The fusion-plugin package mentioned earlier+fills gaps for several optimizations that GHC does not perform+automatically. It automatically inlines the internal definitions+that involve the constructors we want to eliminate. In some cases+fusion-plugin may not help and programmer may have to annotate the code+manually for complete fusion. In this section we mention some of the+cases where programmer annotation may help in stream fusion.++Remember, you need to worry about performance only where it matters, try+to optimize the fast path and not everything blindly.++### INLINE annotations++It may help to add INLINE annotations on any intermediate functions+involved in a closed loop. In some cases you may have to add an inline+phase as well as described below.++Usually GHC has three inline phases - the first phase is pahse-2, the+second phase is phase-1 and the last one is phase-0.++#### Early INLINE++Generally, you only have to inline the combinators or functions+participating in a loop and not the whole loop itself.  But sometimes+you may want to inline the whole loop itself inside a larger+function. In most cases you can just add an INLINE pragma on+the function containing the loop. But you may need some special+considerations in some (not common) cases.++In some cases you may have to use INLINE[2] instead of INLINE which+means inline the function early in phase-2.  This may sometimes be+needed on the because the performance of several combinators in streamly+depends on getting inlined in phase-2 and if you use a plain `INLINE`+annotation GHC may decide to delay the inlining in some cases. This is+not very common but may be needed sometimes. Perhaps GHC can be fixed or+we can resolve this using fusion-plugin in future.++#### Delayed INLINE++When a function is passed to a higher order function e.g. a function+passed to `concatMap` or `unfoldMany` then we want the function to be+inlined after the higher order is inlined so that proper fusion of the+higher order function can occur. For such cases we usually add INLINE[1]+on the function being passed to instruct GHC not to inline it too early.++### Strictness annotations++* Strictness annotations on data, specially the data used as accumulator in+  folds and scans, can help in improving performance.+* Strictness annotations on function arguments can help the compiler unbox+  constructors in certain cases, improving performance.+* Sometimes using `-XStrict` extension can help improve performance, if so you+  may be missing some strictness annotations. `-XStrict` can be used as an aid+  to detect missing annotations, using it blindly may regress performance.++### Use tail recursion++Do not use a strict `foldr` or lazy `foldl` unless you know what you are+doing.  Use lazy `foldr` for lazily transforming the stream and strict+`foldl` for reducing the stream.  If you are manually writing recursive+code, try to use tail recursion where possible.++## Build times and space considerations++Haskell, being a pure functional language, confers special powers on+GHC. It allows GHC to do whole program optimization. In a closed loop+all the components of the loop are inlined and GHC fuses them together,+performs many optimizing transformations and churns out an optimized+fused loop code. Let's call it whole-loop-optimization.++To be able to fuse the loop by whole-loop-optimization all the parts of the+loop must be operated on by GHC at the same time to fuse them together. The+amount of time and memory required to do so depends on the size of the loop.+Huge loops can take a lot of time and memory. We have seen GHC take 4-5 GB of+memory when a lot of combinators are used in a single module.++If a module takes too much time and space we can break it into multiple+modules moving some non-inlined parts in another module. There is+another advantage of breaking large modules, it can take advantage of+parallel compilation if they do not depend on each other.
+ docs/performance.md view
@@ -0,0 +1,7 @@+# Performance++Streamly is highly optimized for performance, it is designed for+high performing, concurrent and scalable applications. Please see the+[streaming-benchmarks](https://github.com/composewell/streaming-benchmarks)+package for microbencmarks measuring the performance of streamly and comparing+it with other streaming libraries.
+ docs/resources.md view
@@ -0,0 +1,18 @@+# Related Resources++## Talks++* [Streamly: Declarative Concurrency And Dataflow Programming In Haskell](https://www.youtube.com/watch?v=uzsqgdMMgtk) by Harendra Kumar at FnConf19+* [High Performance Haskell](https://www.youtube.com/watch?v=aJvwORrBJ0o) by Harendra Kumar at FnConf18++## Related Papers++* [Faster Coroutine Pipelines: A Reconstruction by RUBEN P. PIETERS, TOM SCHRIJVERS](https://rubenpieters.github.io/assets/papers/JFP20-pipes.pdf)++## Ecosystem Packages++* [Search on Hackage](https://hackage.haskell.org/packages/search?terms=streamly)++## Commercial Users++* [Juspay Technologies](https://www.juspay.in/)
+ docs/streamly-docs.cabal view
@@ -0,0 +1,30 @@+cabal-version:      2.2+-- Reasons for having a separate package for docs:+-- * Leaner main package and better modularity+-- * This package can be forked out as an independent package+-- * We can have code examples in haddock with more dependencies+-- * Documentation can be released independent of the library+-- * We do not want too many doc modules in the main library+name:               streamly-docs+version:            0.0.0+synopsis:           Documentation for Streamly+description:        Documentation for Streamly+build-type:         Simple++-------------------------------------------------------------------------------+-- Library+-------------------------------------------------------------------------------++library+  default-language: Haskell2010+  ghc-options:      -Wall+  hs-source-dirs:    .+  exposed-modules:+    Tutorial+    ConcurrentStreams+    ReactiveProgramming++  build-depends:+      base              >= 4.9   &&  < 5+    , transformers      >= 0.4   && < 0.6+    , streamly
docs/streamly-vs-async.md view
@@ -30,7 +30,7 @@  You can write all of your program in a streamly monad and use the full power of the library.  Streamly can be used as a direct replacement of the IO monad with-no loss of performance, and no change in code except using `liftIO` or `yieldM`+no loss of performance, and no change in code except using `liftIO` or `fromEffect` to run any IO actions.  Streamly IO monads (e.g. `SerialT IO`) are just a generalization of the IO monad with non-deterministic composition of streams added on top.@@ -69,17 +69,17 @@ concurrently:  ```haskell-  urls <- S.toList $ parallely $ getURL 2 |: getURL 1 |: S.nil+  urls <- S.toList $ fromParallel $ getURL 2 |: getURL 1 |: S.nil ```  This would return the results in their arrival order i.e. first 1 and then 2. If you want to preserve the order of the results, use the lookahead style-stream `aheadly` instead. In the following example both URLs are fetched+using `fromAhead` instead. In the following example both URLs are fetched concurrently, and even though URL 1 arrives before URL 2 the results will return 2 first and then 1.  ```haskell-  urls <- S.toList $ aheadly $ getURL 2 |: getURL 1 |: S.nil+  urls <- S.toList $ fromAhead $ getURL 2 |: getURL 1 |: S.nil ```  ### concurrently_@@ -87,7 +87,7 @@ Use `drain` instead of `toList` to run the actions but ignore the results:  ```haskell-  S.drain $ parallely $ getURL 1 |: getURL 2 |: S.nil+  S.drain $ fromParallel $ getURL 1 |: getURL 2 |: S.nil ```  ### Concurrent Applicative@@ -97,8 +97,8 @@ function:  ```haskell-  tuples <- S.toList $ zipAsyncly $-              (,) <$> S.yieldM (getURLString 1) <*> S.yieldM (getURLText 2)+  tuples <- S.toList $ fromZipAsync $+              (,) <$> S.fromEffect (getURLString 1) <*> S.fromEffect (getURLText 2) ```  ### race@@ -112,14 +112,14 @@ arrives:  ```haskell-  urls <- S.toList $ S.take 1 $ parallely $ getURL 1 |: getURL 2 |: S.nil+  urls <- S.toList $ S.take 1 $ fromParallel $ getURL 1 |: getURL 2 |: S.nil ```  After the first result arrives, the rest of the actions are canceled automatically.  In general, we can take first `n` results as they arrive:  ```haskell-  urls <- S.toList $ S.take 2 $ parallely $ getURL 1 |: getURL 2 |: S.nil+  urls <- S.toList $ S.take 2 $ fromParallel $ getURL 1 |: getURL 2 |: S.nil ```  #### `race` Using Exceptions@@ -135,7 +135,7 @@   instance Exception Result    main = do-      url <- try $ S.drain $ parallely $+      url <- try $ S.drain $ fromParallel $                    (getURL 2 >>= throwM . Result)                 |: (getURL 1 >>= throwM . Result)                 |: S.nil@@ -152,21 +152,21 @@ actions:  ```haskell-  urls <- S.toList $ aheadly $ S.fromFoldableM $ fmap getURL [1..3]+  urls <- S.toList $ fromAhead $ S.fromFoldableM $ fmap getURL [1..3] ```  You can first convert a `Foldable` into a stream and then map an action on the stream concurrently:  ```haskell-  urls <- S.toList $ aheadly $ S.mapM getURL $ foldMap return [1..3]+  urls <- S.toList $ fromAhead $ S.mapM getURL $ foldMap return [1..3] ```  You can map a monadic action to a `Foldable` container to convert it into a stream and at the same time fold it:  ```haskell-  urls <- S.toList $ aheadly $ foldMap (S.yieldM . getURL) [1..3]+  urls <- S.toList $ fromAhead $ foldMap (S.fromEffect . getURL) [1..3] ```  ### replicateConcurrently@@ -178,7 +178,7 @@ module documentation for more details.  ```haskell-  xs <- S.toList $ parallely $ S.replicateM 2 $ getURL 1+  xs <- S.toList $ fromParallel $ S.replicateM 2 $ getURL 1 ```  ### Functor@@ -189,13 +189,13 @@ To map serially just use `fmap`:  ```haskell-  xs <- S.toList $ parallely $ fmap (+1) $ return 1 |: return 2 |: S.nil+  xs <- S.toList $ fromParallel $ fmap (+1) $ return 1 |: return 2 |: S.nil ```  To map a monadic action concurrently on all elements of the stream use `mapM`:  ```haskell-  xs <- S.toList $ parallely $ S.mapM (\x -> return (x + 1))+  xs <- S.toList $ fromParallel $ S.mapM (\x -> return (x + 1))                            $ return 1 |: return 2 |: S.nil ```
+ docs/streamly-vs-list-time.svg view
@@ -0,0 +1,3 @@+<?xml version="1.0" encoding="UTF-8"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+    "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd"><svg xmlns="http://www.w3.org/2000/svg" height="600.0000" stroke-opacity="1" viewBox="0 0 800 600" font-size="1" width="800.0000" xmlns:xlink="http://www.w3.org/1999/xlink" stroke="rgb(0,0,0)" version="1.1"><defs></defs><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(255,255,255)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 0.0000,0.0000 v 600.0000 h 800.0000 v -600.0000 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 118.4035,20.1694 ZM 120.5852,10.3901 h -1.7454 v -2.7977 l 1.9507,-0.1540 l 0.4363,-3.3881 h 3.1314 v 3.3881 h 3.0544 v 2.9517 h -3.0544 v 5.1078 c 0.0000,1.0780 0.4492,1.5529 0.4492 1.5529c 0.4492,0.4748 1.1935,0.4748 1.1935 0.4748c 0.3080,0.0000 0.6289,-0.0770 0.6289 -0.0770c 0.3208,-0.0770 0.5775,-0.1797 0.5775 -0.1797l 0.5903,2.7464 c -0.5133,0.1540 -1.2064,0.3080 -1.2064 0.3080c -0.6930,0.1540 -1.6170,0.1540 -1.6170 0.1540c -1.1807,-0.0000 -2.0149,-0.3593 -2.0149 -0.3593c -0.8342,-0.3593 -1.3604,-1.0010 -1.3604 -1.0010c -0.5262,-0.6417 -0.7700,-1.5529 -0.7700 -1.5529c -0.2438,-0.9112 -0.2438,-2.0149 -0.2438 -2.0149v -5.1591 ZM 128.2341,20.1694 ZM 131.7762,5.5647 c -0.9497,-0.0000 -1.5657,-0.5518 -1.5657 -0.5518c -0.6160,-0.5518 -0.6160,-1.4245 -0.6160 -1.4245c 0.0000,-0.8727 0.6160,-1.4117 0.6160 -1.4117c 0.6160,-0.5390 1.5657,-0.5390 1.5657 -0.5390c 0.9754,0.0000 1.5785,0.5390 1.5785 0.5390c 0.6032,0.5390 0.6032,1.4117 0.6032 1.4117c 0.0000,0.8727 -0.6032,1.4245 -0.6032 1.4245c -0.6032,0.5518 -1.5785,0.5518 -1.5785 0.5518ZM 131.7762,5.5647 ZM 129.9025,7.4384 h 3.7731 v 12.7310 h -3.7731 v -12.7310 ZM 135.3183,20.1694 ZM 136.9867,7.4384 h 3.0801 l 0.2567,1.6427 h 0.1027 c 0.7957,-0.7957 1.6940,-1.3732 1.6940 -1.3732c 0.8984,-0.5775 2.1561,-0.5775 2.1561 -0.5775c 1.3604,0.0000 2.1946,0.5518 2.1946 0.5518c 0.8342,0.5518 1.3219,1.5785 1.3219 1.5785c 0.8470,-0.8727 1.7839,-1.5015 1.7839 -1.5015c 0.9369,-0.6289 2.2202,-0.6289 2.2202 -0.6289c 2.0534,0.0000 3.0159,1.3732 3.0159 1.3732c 0.9625,1.3732 0.9625,3.7603 0.9625 3.7603v 7.9055 h -3.7731 v -7.4179 c 0.0000,-1.3860 -0.3722,-1.8994 -0.3722 -1.8994c -0.3722,-0.5133 -1.1935,-0.5133 -1.1935 -0.5133c -0.9497,-0.0000 -2.1817,1.2320 -2.1817 1.2320v 8.5986 h -3.7731 v -7.4179 c 0.0000,-1.3860 -0.3722,-1.8994 -0.3722 -1.8994c -0.3722,-0.5133 -1.1935,-0.5133 -1.1935 -0.5133c -0.9754,-0.0000 -2.1561,1.2320 -2.1561 1.2320v 8.5986 h -3.7731 v -12.7310 ZM 157.3152,20.1694 ZM 158.2392,13.8039 c 0.0000,-1.5400 0.5133,-2.7849 0.5133 -2.7849c 0.5133,-1.2449 1.3475,-2.1047 1.3475 -2.1047c 0.8342,-0.8599 1.9122,-1.3219 1.9122 -1.3219c 1.0780,-0.4620 2.2331,-0.4620 2.2331 -0.4620c 1.3604,0.0000 2.3742,0.4620 2.3742 0.4620c 1.0139,0.4620 1.6940,1.2834 1.6940 1.2834c 0.6802,0.8214 1.0139,1.9379 1.0139 1.9379c 0.3337,1.1165 0.3337,2.4256 0.3337 2.4256c 0.0000,0.5133 -0.0513,0.9369 -0.0513 0.9369c -0.0513,0.4235 -0.1027,0.6545 -0.1027 0.6545h -7.6232 c 0.2567,1.4630 1.1422,2.1176 1.1422 2.1176c 0.8855,0.6545 2.1689,0.6545 2.1689 0.6545c 1.3604,0.0000 2.7464,-0.8470 2.7464 -0.8470l 1.2577,2.2844 c -0.9754,0.6674 -2.1689,1.0524 -2.1689 1.0524c -1.1935,0.3850 -2.3486,0.3850 -2.3486 0.3850c -1.3604,-0.0000 -2.5411,-0.4492 -2.5411 -0.4492c -1.1807,-0.4492 -2.0534,-1.3090 -2.0534 -1.3090c -0.8727,-0.8599 -1.3604,-2.0919 -1.3604 -2.0919c -0.4877,-1.2320 -0.4877,-2.8234 -0.4877 -2.8234ZM 158.2392,13.8039 ZM 166.4528,12.4949 c 0.0000,-1.1037 -0.4877,-1.7967 -0.4877 -1.7967c -0.4877,-0.6930 -1.6427,-0.6930 -1.6427 -0.6930c -0.8984,-0.0000 -1.5785,0.6032 -1.5785 0.6032c -0.6802,0.6032 -0.8855,1.8866 -0.8855 1.8866h 4.5945 ZM 175.9497,20.1694 ZM 178.1314,10.3901 h -1.7454 v -2.7977 l 1.9507,-0.1540 l 0.4363,-3.3881 h 3.1314 v 3.3881 h 3.0544 v 2.9517 h -3.0544 v 5.1078 c 0.0000,1.0780 0.4492,1.5529 0.4492 1.5529c 0.4492,0.4748 1.1935,0.4748 1.1935 0.4748c 0.3080,0.0000 0.6289,-0.0770 0.6289 -0.0770c 0.3208,-0.0770 0.5775,-0.1797 0.5775 -0.1797l 0.5903,2.7464 c -0.5133,0.1540 -1.2064,0.3080 -1.2064 0.3080c -0.6930,0.1540 -1.6170,0.1540 -1.6170 0.1540c -1.1807,-0.0000 -2.0149,-0.3593 -2.0149 -0.3593c -0.8342,-0.3593 -1.3604,-1.0010 -1.3604 -1.0010c -0.5262,-0.6417 -0.7700,-1.5529 -0.7700 -1.5529c -0.2438,-0.9112 -0.2438,-2.0149 -0.2438 -2.0149v -5.1591 ZM 185.4723,20.1694 ZM 186.6786,16.6273 c 0.0000,-2.0021 1.6940,-3.1314 1.6940 -3.1314c 1.6940,-1.1294 5.4671,-1.5144 5.4671 -1.5144c -0.0513,-0.8470 -0.5133,-1.3475 -0.5133 -1.3475c -0.4620,-0.5005 -1.4887,-0.5005 -1.4887 -0.5005c -0.8214,-0.0000 -1.6427,0.3080 -1.6427 0.3080c -0.8214,0.3080 -1.7454,0.8470 -1.7454 0.8470l -1.3347,-2.4897 c 1.2320,-0.7444 2.5796,-1.2064 2.5796 -1.2064c 1.3475,-0.4620 2.8619,-0.4620 2.8619 -0.4620c 2.4641,0.0000 3.7603,1.3989 3.7603 1.3989c 1.2962,1.3989 1.2962,4.3506 1.2962 4.3506v 7.2895 h -3.0801 l -0.2823,-1.3090 h -0.0770 c -0.8214,0.7187 -1.7325,1.1679 -1.7325 1.1679c -0.9112,0.4492 -1.9892,0.4492 -1.9892 0.4492c -0.8727,-0.0000 -1.5657,-0.2952 -1.5657 -0.2952c -0.6930,-0.2952 -1.1807,-0.8214 -1.1807 -0.8214c -0.4877,-0.5262 -0.7572,-1.2192 -0.7572 -1.2192c -0.2695,-0.6930 -0.2695,-1.5144 -0.2695 -1.5144ZM 186.6786,16.6273 ZM 190.2721,16.3450 c 0.0000,0.6160 0.3978,0.9112 0.3978 0.9112c 0.3978,0.2952 1.0652,0.2952 1.0652 0.2952c 0.6674,0.0000 1.1294,-0.2823 1.1294 -0.2823c 0.4620,-0.2823 0.9754,-0.7957 0.9754 -0.7957v -2.2331 c -2.0277,0.2823 -2.7977,0.8214 -2.7977 0.8214c -0.7700,0.5390 -0.7700,1.2834 -0.7700 1.2834ZM 199.1786,20.1694 ZM 200.8470,2.1766 h 3.6704 v 10.3183 h 0.1027 l 4.0298,-5.0565 h 4.1068 l -4.4661,5.2361 l 4.7998,7.4949 h -4.0811 l -2.8747,-4.9538 l -1.6170,1.8224 v 3.1314 h -3.6704 v -17.9928 ZM 212.5257,20.1694 ZM 213.4497,13.8039 c 0.0000,-1.5400 0.5133,-2.7849 0.5133 -2.7849c 0.5133,-1.2449 1.3475,-2.1047 1.3475 -2.1047c 0.8342,-0.8599 1.9122,-1.3219 1.9122 -1.3219c 1.0780,-0.4620 2.2331,-0.4620 2.2331 -0.4620c 1.3604,0.0000 2.3742,0.4620 2.3742 0.4620c 1.0139,0.4620 1.6940,1.2834 1.6940 1.2834c 0.6802,0.8214 1.0139,1.9379 1.0139 1.9379c 0.3337,1.1165 0.3337,2.4256 0.3337 2.4256c 0.0000,0.5133 -0.0513,0.9369 -0.0513 0.9369c -0.0513,0.4235 -0.1027,0.6545 -0.1027 0.6545h -7.6232 c 0.2567,1.4630 1.1422,2.1176 1.1422 2.1176c 0.8855,0.6545 2.1689,0.6545 2.1689 0.6545c 1.3604,0.0000 2.7464,-0.8470 2.7464 -0.8470l 1.2577,2.2844 c -0.9754,0.6674 -2.1689,1.0524 -2.1689 1.0524c -1.1935,0.3850 -2.3486,0.3850 -2.3486 0.3850c -1.3604,-0.0000 -2.5411,-0.4492 -2.5411 -0.4492c -1.1807,-0.4492 -2.0534,-1.3090 -2.0534 -1.3090c -0.8727,-0.8599 -1.3604,-2.0919 -1.3604 -2.0919c -0.4877,-1.2320 -0.4877,-2.8234 -0.4877 -2.8234ZM 213.4497,13.8039 ZM 221.6632,12.4949 c 0.0000,-1.1037 -0.4877,-1.7967 -0.4877 -1.7967c -0.4877,-0.6930 -1.6427,-0.6930 -1.6427 -0.6930c -0.8984,-0.0000 -1.5785,0.6032 -1.5785 0.6032c -0.6802,0.6032 -0.8855,1.8866 -0.8855 1.8866h 4.5945 ZM 225.8214,20.1694 ZM 227.4897,7.4384 h 3.0801 l 0.2567,1.6170 h 0.1027 c 0.8214,-0.7700 1.7967,-1.3475 1.7967 -1.3475c 0.9754,-0.5775 2.2844,-0.5775 2.2844 -0.5775c 2.0791,0.0000 3.0159,1.3604 3.0159 1.3604c 0.9369,1.3604 0.9369,3.7731 0.9369 3.7731v 7.9055 h -3.7731 v -7.4179 c 0.0000,-1.3860 -0.3722,-1.8994 -0.3722 -1.8994c -0.3722,-0.5133 -1.1935,-0.5133 -1.1935 -0.5133c -0.7187,-0.0000 -1.2320,0.3208 -1.2320 0.3208c -0.5133,0.3208 -1.1294,0.9112 -1.1294 0.9112v 8.5986 h -3.7731 v -12.7310 ZM 245.8419,20.1694 ZM 247.5103,2.1766 h 3.7731 v 4.4148 l -0.1027,1.9507 c 0.7444,-0.6674 1.6042,-1.0395 1.6042 -1.0395c 0.8599,-0.3722 1.7582,-0.3722 1.7582 -0.3722c 1.1550,0.0000 2.0791,0.4620 2.0791 0.4620c 0.9240,0.4620 1.5785,1.2962 1.5785 1.2962c 0.6545,0.8342 1.0010,2.0277 1.0010 2.0277c 0.3465,1.1935 0.3465,2.6566 0.3465 2.6566c 0.0000,1.6427 -0.4492,2.9261 -0.4492 2.9261c -0.4492,1.2834 -1.2064,2.1689 -1.2064 2.1689c -0.7572,0.8855 -1.7197,1.3475 -1.7197 1.3475c -0.9625,0.4620 -1.9892,0.4620 -1.9892 0.4620c -0.8470,-0.0000 -1.7069,-0.4107 -1.7069 -0.4107c -0.8599,-0.4107 -1.6042,-1.2320 -1.6042 -1.2320h -0.1027 l -0.3080,1.3347 h -2.9517 v -17.9928 ZM 247.5103,2.1766 ZM 251.2834,16.5760 c 0.5133,0.4620 1.0267,0.6417 1.0267 0.6417c 0.5133,0.1797 1.0010,0.1797 1.0010 0.1797c 0.9754,0.0000 1.6684,-0.8855 1.6684 -0.8855c 0.6930,-0.8855 0.6930,-2.8619 0.6930 -2.8619c 0.0000,-3.4394 -2.2074,-3.4394 -2.2074 -3.4394c -1.1294,-0.0000 -2.1817,1.1550 -2.1817 1.1550v 5.2105 ZM 260.3439,20.1694 ZM 262.2947,22.0175 c 0.1797,0.0513 0.4107,0.1027 0.4107 0.1027c 0.2310,0.0513 0.4363,0.0513 0.4363 0.0513c 0.9497,0.0000 1.4630,-0.4620 1.4630 -0.4620c 0.5133,-0.4620 0.7700,-1.2064 0.7700 -1.2064l 0.1797,-0.6674 l -4.9025,-12.3973 h 3.7988 l 1.8224,5.4671 c 0.2823,0.8727 0.5133,1.7710 0.5133 1.7710c 0.2310,0.8984 0.4877,1.8480 0.4877 1.8480h 0.1027 c 0.2053,-0.8984 0.4235,-1.8095 0.4235 -1.8095c 0.2182,-0.9112 0.4492,-1.8095 0.4492 -1.8095l 1.5400,-5.4671 h 3.6191 l -4.4148,12.8593 c -0.4620,1.2064 -0.9625,2.1176 -0.9625 2.1176c -0.5005,0.9112 -1.1550,1.5144 -1.1550 1.5144c -0.6545,0.6032 -1.4887,0.9112 -1.4887 0.9112c -0.8342,0.3080 -1.9636,0.3080 -1.9636 0.3080c -0.5903,-0.0000 -1.0010,-0.0642 -1.0010 -0.0642c -0.4107,-0.0642 -0.7957,-0.1925 -0.7957 -0.1925l 0.6674,-2.8747 h 0.0000 ZM 279.0554,20.1694 ZM 281.1345,5.9754 l -0.1283,-3.4138 h 3.7988 l -0.1283,3.4138 l -0.7444,5.1078 h -2.0534 ZM 286.7556,20.1694 ZM 288.4240,2.1766 h 3.7731 v 14.1940 c 0.0000,0.5903 0.2182,0.8214 0.2182 0.8214c 0.2182,0.2310 0.4492,0.2310 0.4492 0.2310h 0.2182 c 0.0000,0.0000 0.2438,-0.0513 0.2438 -0.0513l 0.4620,2.7977 c -0.3080,0.1283 -0.7829,0.2182 -0.7829 0.2182c -0.4748,0.0898 -1.1165,0.0898 -1.1165 0.0898c -0.9754,-0.0000 -1.6427,-0.3080 -1.6427 -0.3080c -0.6674,-0.3080 -1.0652,-0.8599 -1.0652 -0.8599c -0.3978,-0.5518 -0.5775,-1.3347 -0.5775 -1.3347c -0.1797,-0.7829 -0.1797,-1.7582 -0.1797 -1.7582v -14.0400 ZM 294.0965,20.1694 ZM 297.6386,5.5647 c -0.9497,-0.0000 -1.5657,-0.5518 -1.5657 -0.5518c -0.6160,-0.5518 -0.6160,-1.4245 -0.6160 -1.4245c 0.0000,-0.8727 0.6160,-1.4117 0.6160 -1.4117c 0.6160,-0.5390 1.5657,-0.5390 1.5657 -0.5390c 0.9754,0.0000 1.5785,0.5390 1.5785 0.5390c 0.6032,0.5390 0.6032,1.4117 0.6032 1.4117c 0.0000,0.8727 -0.6032,1.4245 -0.6032 1.4245c -0.6032,0.5518 -1.5785,0.5518 -1.5785 0.5518ZM 297.6386,5.5647 ZM 295.7649,7.4384 h 3.7731 v 12.7310 h -3.7731 v -12.7310 ZM 301.1807,20.1694 ZM 303.4138,16.3450 c 0.8727,0.6674 1.6684,1.0010 1.6684 1.0010c 0.7957,0.3337 1.6170,0.3337 1.6170 0.3337c 0.8470,0.0000 1.2320,-0.2823 1.2320 -0.2823c 0.3850,-0.2823 0.3850,-0.7957 0.3850 -0.7957c 0.0000,-0.3080 -0.2182,-0.5518 -0.2182 -0.5518c -0.2182,-0.2438 -0.5903,-0.4492 -0.5903 -0.4492c -0.3722,-0.2053 -0.8342,-0.3722 -0.8342 -0.3722c -0.4620,-0.1668 -0.9497,-0.3722 -0.9497 -0.3722c -0.5903,-0.2310 -1.1807,-0.5390 -1.1807 -0.5390c -0.5903,-0.3080 -1.0780,-0.7572 -1.0780 -0.7572c -0.4877,-0.4492 -0.7957,-1.0524 -0.7957 -1.0524c -0.3080,-0.6032 -0.3080,-1.3989 -0.3080 -1.3989c 0.0000,-0.8727 0.3465,-1.6170 0.3465 -1.6170c 0.3465,-0.7444 0.9882,-1.2577 0.9882 -1.2577c 0.6417,-0.5133 1.5400,-0.8085 1.5400 -0.8085c 0.8984,-0.2952 2.0021,-0.2952 2.0021 -0.2952c 1.4630,0.0000 2.5667,0.5005 2.5667 0.5005c 1.1037,0.5005 1.9251,1.1165 1.9251 1.1165l -1.6940,2.2587 c -0.6930,-0.5133 -1.3604,-0.7957 -1.3604 -0.7957c -0.6674,-0.2823 -1.3347,-0.2823 -1.3347 -0.2823c -1.4374,-0.0000 -1.4374,1.0010 -1.4374 1.0010c 0.0000,0.3080 0.2053,0.5262 0.2053 0.5262c 0.2053,0.2182 0.5518,0.3978 0.5518 0.3978c 0.3465,0.1797 0.7957,0.3465 0.7957 0.3465c 0.4492,0.1668 0.9369,0.3465 0.9369 0.3465c 0.6160,0.2310 1.2192,0.5262 1.2192 0.5262c 0.6032,0.2952 1.1037,0.7315 1.1037 0.7315c 0.5005,0.4363 0.8085,1.0652 0.8085 1.0652c 0.3080,0.6289 0.3080,1.5015 0.3080 1.5015c 0.0000,0.8727 -0.3337,1.6170 -0.3337 1.6170c -0.3337,0.7444 -1.0010,1.2962 -1.0010 1.2962c -0.6674,0.5518 -1.6427,0.8727 -1.6427 0.8727c -0.9754,0.3208 -2.2587,0.3208 -2.2587 0.3208c -1.2577,-0.0000 -2.5796,-0.4877 -2.5796 -0.4877c -1.3219,-0.4877 -2.2972,-1.2834 -2.2972 -1.2834ZM 312.5513,20.1694 ZM 314.7331,10.3901 h -1.7454 v -2.7977 l 1.9507,-0.1540 l 0.4363,-3.3881 h 3.1314 v 3.3881 h 3.0544 v 2.9517 h -3.0544 v 5.1078 c 0.0000,1.0780 0.4492,1.5529 0.4492 1.5529c 0.4492,0.4748 1.1935,0.4748 1.1935 0.4748c 0.3080,0.0000 0.6289,-0.0770 0.6289 -0.0770c 0.3208,-0.0770 0.5775,-0.1797 0.5775 -0.1797l 0.5903,2.7464 c -0.5133,0.1540 -1.2064,0.3080 -1.2064 0.3080c -0.6930,0.1540 -1.6170,0.1540 -1.6170 0.1540c -1.1807,-0.0000 -2.0149,-0.3593 -2.0149 -0.3593c -0.8342,-0.3593 -1.3604,-1.0010 -1.3604 -1.0010c -0.5262,-0.6417 -0.7700,-1.5529 -0.7700 -1.5529c -0.2438,-0.9112 -0.2438,-2.0149 -0.2438 -2.0149v -5.1591 ZM 322.3819,20.1694 ZM 324.4610,5.9754 l -0.1283,-3.4138 h 3.7988 l -0.1283,3.4138 l -0.7444,5.1078 h -2.0534 ZM 335.4209,20.1694 ZM 336.6273,16.6273 c 0.0000,-2.0021 1.6940,-3.1314 1.6940 -3.1314c 1.6940,-1.1294 5.4671,-1.5144 5.4671 -1.5144c -0.0513,-0.8470 -0.5133,-1.3475 -0.5133 -1.3475c -0.4620,-0.5005 -1.4887,-0.5005 -1.4887 -0.5005c -0.8214,-0.0000 -1.6427,0.3080 -1.6427 0.3080c -0.8214,0.3080 -1.7454,0.8470 -1.7454 0.8470l -1.3347,-2.4897 c 1.2320,-0.7444 2.5796,-1.2064 2.5796 -1.2064c 1.3475,-0.4620 2.8619,-0.4620 2.8619 -0.4620c 2.4641,0.0000 3.7603,1.3989 3.7603 1.3989c 1.2962,1.3989 1.2962,4.3506 1.2962 4.3506v 7.2895 h -3.0801 l -0.2823,-1.3090 h -0.0770 c -0.8214,0.7187 -1.7325,1.1679 -1.7325 1.1679c -0.9112,0.4492 -1.9892,0.4492 -1.9892 0.4492c -0.8727,-0.0000 -1.5657,-0.2952 -1.5657 -0.2952c -0.6930,-0.2952 -1.1807,-0.8214 -1.1807 -0.8214c -0.4877,-0.5262 -0.7572,-1.2192 -0.7572 -1.2192c -0.2695,-0.6930 -0.2695,-1.5144 -0.2695 -1.5144ZM 336.6273,16.6273 ZM 340.2207,16.3450 c 0.0000,0.6160 0.3978,0.9112 0.3978 0.9112c 0.3978,0.2952 1.0652,0.2952 1.0652 0.2952c 0.6674,0.0000 1.1294,-0.2823 1.1294 -0.2823c 0.4620,-0.2823 0.9754,-0.7957 0.9754 -0.7957v -2.2331 c -2.0277,0.2823 -2.7977,0.8214 -2.7977 0.8214c -0.7700,0.5390 -0.7700,1.2834 -0.7700 1.2834ZM 349.1273,20.1694 ZM 351.3604,16.3450 c 0.8727,0.6674 1.6684,1.0010 1.6684 1.0010c 0.7957,0.3337 1.6170,0.3337 1.6170 0.3337c 0.8470,0.0000 1.2320,-0.2823 1.2320 -0.2823c 0.3850,-0.2823 0.3850,-0.7957 0.3850 -0.7957c 0.0000,-0.3080 -0.2182,-0.5518 -0.2182 -0.5518c -0.2182,-0.2438 -0.5903,-0.4492 -0.5903 -0.4492c -0.3722,-0.2053 -0.8342,-0.3722 -0.8342 -0.3722c -0.4620,-0.1668 -0.9497,-0.3722 -0.9497 -0.3722c -0.5903,-0.2310 -1.1807,-0.5390 -1.1807 -0.5390c -0.5903,-0.3080 -1.0780,-0.7572 -1.0780 -0.7572c -0.4877,-0.4492 -0.7957,-1.0524 -0.7957 -1.0524c -0.3080,-0.6032 -0.3080,-1.3989 -0.3080 -1.3989c 0.0000,-0.8727 0.3465,-1.6170 0.3465 -1.6170c 0.3465,-0.7444 0.9882,-1.2577 0.9882 -1.2577c 0.6417,-0.5133 1.5400,-0.8085 1.5400 -0.8085c 0.8984,-0.2952 2.0021,-0.2952 2.0021 -0.2952c 1.4630,0.0000 2.5667,0.5005 2.5667 0.5005c 1.1037,0.5005 1.9251,1.1165 1.9251 1.1165l -1.6940,2.2587 c -0.6930,-0.5133 -1.3604,-0.7957 -1.3604 -0.7957c -0.6674,-0.2823 -1.3347,-0.2823 -1.3347 -0.2823c -1.4374,-0.0000 -1.4374,1.0010 -1.4374 1.0010c 0.0000,0.3080 0.2053,0.5262 0.2053 0.5262c 0.2053,0.2182 0.5518,0.3978 0.5518 0.3978c 0.3465,0.1797 0.7957,0.3465 0.7957 0.3465c 0.4492,0.1668 0.9369,0.3465 0.9369 0.3465c 0.6160,0.2310 1.2192,0.5262 1.2192 0.5262c 0.6032,0.2952 1.1037,0.7315 1.1037 0.7315c 0.5005,0.4363 0.8085,1.0652 0.8085 1.0652c 0.3080,0.6289 0.3080,1.5015 0.3080 1.5015c 0.0000,0.8727 -0.3337,1.6170 -0.3337 1.6170c -0.3337,0.7444 -1.0010,1.2962 -1.0010 1.2962c -0.6674,0.5518 -1.6427,0.8727 -1.6427 0.8727c -0.9754,0.3208 -2.2587,0.3208 -2.2587 0.3208c -1.2577,-0.0000 -2.5796,-0.4877 -2.5796 -0.4877c -1.3219,-0.4877 -2.2972,-1.2834 -2.2972 -1.2834ZM 365.8368,20.1694 ZM 367.5051,7.4384 h 3.0801 l 0.2567,1.6427 h 0.1027 c 0.7957,-0.7957 1.6940,-1.3732 1.6940 -1.3732c 0.8984,-0.5775 2.1561,-0.5775 2.1561 -0.5775c 1.3604,0.0000 2.1946,0.5518 2.1946 0.5518c 0.8342,0.5518 1.3219,1.5785 1.3219 1.5785c 0.8470,-0.8727 1.7839,-1.5015 1.7839 -1.5015c 0.9369,-0.6289 2.2202,-0.6289 2.2202 -0.6289c 2.0534,0.0000 3.0159,1.3732 3.0159 1.3732c 0.9625,1.3732 0.9625,3.7603 0.9625 3.7603v 7.9055 h -3.7731 v -7.4179 c 0.0000,-1.3860 -0.3722,-1.8994 -0.3722 -1.8994c -0.3722,-0.5133 -1.1935,-0.5133 -1.1935 -0.5133c -0.9497,-0.0000 -2.1817,1.2320 -2.1817 1.2320v 8.5986 h -3.7731 v -7.4179 c 0.0000,-1.3860 -0.3722,-1.8994 -0.3722 -1.8994c -0.3722,-0.5133 -1.1935,-0.5133 -1.1935 -0.5133c -0.9754,-0.0000 -2.1561,1.2320 -2.1561 1.2320v 8.5986 h -3.7731 v -12.7310 ZM 387.8337,20.1694 ZM 389.3737,7.4384 h 3.7731 v 7.4179 c 0.0000,1.3860 0.3850,1.8994 0.3850 1.8994c 0.3850,0.5133 1.2064,0.5133 1.2064 0.5133c 0.7187,0.0000 1.2064,-0.3337 1.2064 -0.3337c 0.4877,-0.3337 1.0524,-1.0780 1.0524 -1.0780v -8.4189 h 3.7731 v 12.7310 h -3.0801 l -0.2823,-1.7710 h -0.0770 c -0.8214,0.9754 -1.7582,1.5272 -1.7582 1.5272c -0.9369,0.5518 -2.2459,0.5518 -2.2459 0.5518c -2.0791,-0.0000 -3.0159,-1.3604 -3.0159 -1.3604c -0.9369,-1.3604 -0.9369,-3.7731 -0.9369 -3.7731v -7.9055 ZM 402.4127,20.1694 ZM 404.0811,2.1766 h 3.7731 v 14.1940 c 0.0000,0.5903 0.2182,0.8214 0.2182 0.8214c 0.2182,0.2310 0.4492,0.2310 0.4492 0.2310h 0.2182 c 0.0000,0.0000 0.2438,-0.0513 0.2438 -0.0513l 0.4620,2.7977 c -0.3080,0.1283 -0.7829,0.2182 -0.7829 0.2182c -0.4748,0.0898 -1.1165,0.0898 -1.1165 0.0898c -0.9754,-0.0000 -1.6427,-0.3080 -1.6427 -0.3080c -0.6674,-0.3080 -1.0652,-0.8599 -1.0652 -0.8599c -0.3978,-0.5518 -0.5775,-1.3347 -0.5775 -1.3347c -0.1797,-0.7829 -0.1797,-1.7582 -0.1797 -1.7582v -14.0400 ZM 409.7536,20.1694 ZM 411.9353,10.3901 h -1.7454 v -2.7977 l 1.9507,-0.1540 l 0.4363,-3.3881 h 3.1314 v 3.3881 h 3.0544 v 2.9517 h -3.0544 v 5.1078 c 0.0000,1.0780 0.4492,1.5529 0.4492 1.5529c 0.4492,0.4748 1.1935,0.4748 1.1935 0.4748c 0.3080,0.0000 0.6289,-0.0770 0.6289 -0.0770c 0.3208,-0.0770 0.5775,-0.1797 0.5775 -0.1797l 0.5903,2.7464 c -0.5133,0.1540 -1.2064,0.3080 -1.2064 0.3080c -0.6930,0.1540 -1.6170,0.1540 -1.6170 0.1540c -1.1807,-0.0000 -2.0149,-0.3593 -2.0149 -0.3593c -0.8342,-0.3593 -1.3604,-1.0010 -1.3604 -1.0010c -0.5262,-0.6417 -0.7700,-1.5529 -0.7700 -1.5529c -0.2438,-0.9112 -0.2438,-2.0149 -0.2438 -2.0149v -5.1591 ZM 419.5842,20.1694 ZM 423.1263,5.5647 c -0.9497,-0.0000 -1.5657,-0.5518 -1.5657 -0.5518c -0.6160,-0.5518 -0.6160,-1.4245 -0.6160 -1.4245c 0.0000,-0.8727 0.6160,-1.4117 0.6160 -1.4117c 0.6160,-0.5390 1.5657,-0.5390 1.5657 -0.5390c 0.9754,0.0000 1.5785,0.5390 1.5785 0.5390c 0.6032,0.5390 0.6032,1.4117 0.6032 1.4117c 0.0000,0.8727 -0.6032,1.4245 -0.6032 1.4245c -0.6032,0.5518 -1.5785,0.5518 -1.5785 0.5518ZM 423.1263,5.5647 ZM 421.2526,7.4384 h 3.7731 v 12.7310 h -3.7731 v -12.7310 ZM 426.6684,20.1694 ZM 432.1099,21.1704 v 3.7218 h -3.7731 v -17.4538 h 3.0801 l 0.2567,1.2577 h 0.1027 c 0.7444,-0.6674 1.6812,-1.1165 1.6812 -1.1165c 0.9369,-0.4492 1.9379,-0.4492 1.9379 -0.4492c 1.1550,0.0000 2.0791,0.4620 2.0791 0.4620c 0.9240,0.4620 1.5657,1.3090 1.5657 1.3090c 0.6417,0.8470 0.9882,2.0406 0.9882 2.0406c 0.3465,1.1935 0.3465,2.6566 0.3465 2.6566c 0.0000,1.6427 -0.4492,2.9132 -0.4492 2.9132c -0.4492,1.2705 -1.2064,2.1561 -1.2064 2.1561c -0.7572,0.8855 -1.7197,1.3475 -1.7197 1.3475c -0.9625,0.4620 -1.9892,0.4620 -1.9892 0.4620c -0.8214,-0.0000 -1.5914,-0.3465 -1.5914 -0.3465c -0.7700,-0.3465 -1.4374,-0.9882 -1.4374 -0.9882ZM 432.1099,21.1704 ZM 432.1099,16.5760 c 0.5133,0.4620 1.0267,0.6417 1.0267 0.6417c 0.5133,0.1797 1.0010,0.1797 1.0010 0.1797c 0.9754,0.0000 1.6684,-0.8855 1.6684 -0.8855c 0.6930,-0.8855 0.6930,-2.8619 0.6930 -2.8619c 0.0000,-3.4394 -2.2074,-3.4394 -2.2074 -3.4394c -1.1037,-0.0000 -2.1817,1.1550 -2.1817 1.1550v 5.2105 ZM 441.3758,20.1694 ZM 443.0441,2.1766 h 3.7731 v 14.1940 c 0.0000,0.5903 0.2182,0.8214 0.2182 0.8214c 0.2182,0.2310 0.4492,0.2310 0.4492 0.2310h 0.2182 c 0.0000,0.0000 0.2438,-0.0513 0.2438 -0.0513l 0.4620,2.7977 c -0.3080,0.1283 -0.7829,0.2182 -0.7829 0.2182c -0.4748,0.0898 -1.1165,0.0898 -1.1165 0.0898c -0.9754,-0.0000 -1.6427,-0.3080 -1.6427 -0.3080c -0.6674,-0.3080 -1.0652,-0.8599 -1.0652 -0.8599c -0.3978,-0.5518 -0.5775,-1.3347 -0.5775 -1.3347c -0.1797,-0.7829 -0.1797,-1.7582 -0.1797 -1.7582v -14.0400 ZM 448.7166,20.1694 ZM 449.6407,13.8039 c 0.0000,-1.5400 0.5133,-2.7849 0.5133 -2.7849c 0.5133,-1.2449 1.3475,-2.1047 1.3475 -2.1047c 0.8342,-0.8599 1.9122,-1.3219 1.9122 -1.3219c 1.0780,-0.4620 2.2331,-0.4620 2.2331 -0.4620c 1.3604,0.0000 2.3742,0.4620 2.3742 0.4620c 1.0139,0.4620 1.6940,1.2834 1.6940 1.2834c 0.6802,0.8214 1.0139,1.9379 1.0139 1.9379c 0.3337,1.1165 0.3337,2.4256 0.3337 2.4256c 0.0000,0.5133 -0.0513,0.9369 -0.0513 0.9369c -0.0513,0.4235 -0.1027,0.6545 -0.1027 0.6545h -7.6232 c 0.2567,1.4630 1.1422,2.1176 1.1422 2.1176c 0.8855,0.6545 2.1689,0.6545 2.1689 0.6545c 1.3604,0.0000 2.7464,-0.8470 2.7464 -0.8470l 1.2577,2.2844 c -0.9754,0.6674 -2.1689,1.0524 -2.1689 1.0524c -1.1935,0.3850 -2.3486,0.3850 -2.3486 0.3850c -1.3604,-0.0000 -2.5411,-0.4492 -2.5411 -0.4492c -1.1807,-0.4492 -2.0534,-1.3090 -2.0534 -1.3090c -0.8727,-0.8599 -1.3604,-2.0919 -1.3604 -2.0919c -0.4877,-1.2320 -0.4877,-2.8234 -0.4877 -2.8234ZM 449.6407,13.8039 ZM 457.8542,12.4949 c 0.0000,-1.1037 -0.4877,-1.7967 -0.4877 -1.7967c -0.4877,-0.6930 -1.6427,-0.6930 -1.6427 -0.6930c -0.8984,-0.0000 -1.5785,0.6032 -1.5785 0.6032c -0.6802,0.6032 -0.8855,1.8866 -0.8855 1.8866h 4.5945 ZM 462.0123,20.1694 ZM 464.2454,16.3450 c 0.8727,0.6674 1.6684,1.0010 1.6684 1.0010c 0.7957,0.3337 1.6170,0.3337 1.6170 0.3337c 0.8470,0.0000 1.2320,-0.2823 1.2320 -0.2823c 0.3850,-0.2823 0.3850,-0.7957 0.3850 -0.7957c 0.0000,-0.3080 -0.2182,-0.5518 -0.2182 -0.5518c -0.2182,-0.2438 -0.5903,-0.4492 -0.5903 -0.4492c -0.3722,-0.2053 -0.8342,-0.3722 -0.8342 -0.3722c -0.4620,-0.1668 -0.9497,-0.3722 -0.9497 -0.3722c -0.5903,-0.2310 -1.1807,-0.5390 -1.1807 -0.5390c -0.5903,-0.3080 -1.0780,-0.7572 -1.0780 -0.7572c -0.4877,-0.4492 -0.7957,-1.0524 -0.7957 -1.0524c -0.3080,-0.6032 -0.3080,-1.3989 -0.3080 -1.3989c 0.0000,-0.8727 0.3465,-1.6170 0.3465 -1.6170c 0.3465,-0.7444 0.9882,-1.2577 0.9882 -1.2577c 0.6417,-0.5133 1.5400,-0.8085 1.5400 -0.8085c 0.8984,-0.2952 2.0021,-0.2952 2.0021 -0.2952c 1.4630,0.0000 2.5667,0.5005 2.5667 0.5005c 1.1037,0.5005 1.9251,1.1165 1.9251 1.1165l -1.6940,2.2587 c -0.6930,-0.5133 -1.3604,-0.7957 -1.3604 -0.7957c -0.6674,-0.2823 -1.3347,-0.2823 -1.3347 -0.2823c -1.4374,-0.0000 -1.4374,1.0010 -1.4374 1.0010c 0.0000,0.3080 0.2053,0.5262 0.2053 0.5262c 0.2053,0.2182 0.5518,0.3978 0.5518 0.3978c 0.3465,0.1797 0.7957,0.3465 0.7957 0.3465c 0.4492,0.1668 0.9369,0.3465 0.9369 0.3465c 0.6160,0.2310 1.2192,0.5262 1.2192 0.5262c 0.6032,0.2952 1.1037,0.7315 1.1037 0.7315c 0.5005,0.4363 0.8085,1.0652 0.8085 1.0652c 0.3080,0.6289 0.3080,1.5015 0.3080 1.5015c 0.0000,0.8727 -0.3337,1.6170 -0.3337 1.6170c -0.3337,0.7444 -1.0010,1.2962 -1.0010 1.2962c -0.6674,0.5518 -1.6427,0.8727 -1.6427 0.8727c -0.9754,0.3208 -2.2587,0.3208 -2.2587 0.3208c -1.2577,-0.0000 -2.5796,-0.4877 -2.5796 -0.4877c -1.3219,-0.4877 -2.2972,-1.2834 -2.2972 -1.2834ZM 478.7218,20.1694 ZM 479.6458,13.8039 c 0.0000,-1.5914 0.5133,-2.8362 0.5133 -2.8362c 0.5133,-1.2449 1.3732,-2.0919 1.3732 -2.0919c 0.8599,-0.8470 1.9892,-1.2962 1.9892 -1.2962c 1.1294,-0.4492 2.3357,-0.4492 2.3357 -0.4492c 1.2064,0.0000 2.3229,0.4492 2.3229 0.4492c 1.1165,0.4492 1.9764,1.2962 1.9764 1.2962c 0.8599,0.8470 1.3732,2.0919 1.3732 2.0919c 0.5133,1.2449 0.5133,2.8362 0.5133 2.8362c 0.0000,1.5914 -0.5133,2.8362 -0.5133 2.8362c -0.5133,1.2449 -1.3732,2.0919 -1.3732 2.0919c -0.8599,0.8470 -1.9764,1.2962 -1.9764 1.2962c -1.1165,0.4492 -2.3229,0.4492 -2.3229 0.4492c -1.2064,-0.0000 -2.3357,-0.4492 -2.3357 -0.4492c -1.1294,-0.4492 -1.9892,-1.2962 -1.9892 -1.2962c -0.8599,-0.8470 -1.3732,-2.0919 -1.3732 -2.0919c -0.5133,-1.2449 -0.5133,-2.8362 -0.5133 -2.8362ZM 479.6458,13.8039 ZM 483.5216,13.8039 c 0.0000,1.6684 0.5775,2.6437 0.5775 2.6437c 0.5775,0.9754 1.7582,0.9754 1.7582 0.9754c 1.1550,0.0000 1.7454,-0.9754 1.7454 -0.9754c 0.5903,-0.9754 0.5903,-2.6437 0.5903 -2.6437c 0.0000,-1.6684 -0.5903,-2.6437 -0.5903 -2.6437c -0.5903,-0.9754 -1.7454,-0.9754 -1.7454 -0.9754c -1.1807,-0.0000 -1.7582,0.9754 -1.7582 0.9754c -0.5775,0.9754 -0.5775,2.6437 -0.5775 2.6437ZM 492.8388,20.1694 ZM 501.6940,5.1027 c -0.7187,-0.2567 -1.3090,-0.2567 -1.3090 -0.2567c -0.6930,-0.0000 -1.0780,0.4235 -1.0780 0.4235c -0.3850,0.4235 -0.3850,1.3989 -0.3850 1.3989v 0.7700 h 2.2844 v 2.9517 h -2.2844 v 9.7793 h -3.7731 v -9.7793 h -1.6940 v -2.7977 l 1.6940,-0.1283 v -0.6930 c 0.0000,-1.0010 0.2438,-1.8994 0.2438 -1.8994c 0.2438,-0.8984 0.8085,-1.5657 0.8085 -1.5657c 0.5647,-0.6674 1.4630,-1.0524 1.4630 -1.0524c 0.8984,-0.3850 2.1817,-0.3850 2.1817 -0.3850c 0.7957,0.0000 1.4502,0.1540 1.4502 0.1540c 0.6545,0.1540 1.0909,0.3080 1.0909 0.3080ZM 506.9302,20.1694 ZM 509.0092,5.9754 l -0.1283,-3.4138 h 3.7988 l -0.1283,3.4138 l -0.7444,5.1078 h -2.0534 ZM 514.6304,20.1694 ZM 520.0719,21.1704 v 3.7218 h -3.7731 v -17.4538 h 3.0801 l 0.2567,1.2577 h 0.1027 c 0.7444,-0.6674 1.6812,-1.1165 1.6812 -1.1165c 0.9369,-0.4492 1.9379,-0.4492 1.9379 -0.4492c 1.1550,0.0000 2.0791,0.4620 2.0791 0.4620c 0.9240,0.4620 1.5657,1.3090 1.5657 1.3090c 0.6417,0.8470 0.9882,2.0406 0.9882 2.0406c 0.3465,1.1935 0.3465,2.6566 0.3465 2.6566c 0.0000,1.6427 -0.4492,2.9132 -0.4492 2.9132c -0.4492,1.2705 -1.2064,2.1561 -1.2064 2.1561c -0.7572,0.8855 -1.7197,1.3475 -1.7197 1.3475c -0.9625,0.4620 -1.9892,0.4620 -1.9892 0.4620c -0.8214,-0.0000 -1.5914,-0.3465 -1.5914 -0.3465c -0.7700,-0.3465 -1.4374,-0.9882 -1.4374 -0.9882ZM 520.0719,21.1704 ZM 520.0719,16.5760 c 0.5133,0.4620 1.0267,0.6417 1.0267 0.6417c 0.5133,0.1797 1.0010,0.1797 1.0010 0.1797c 0.9754,0.0000 1.6684,-0.8855 1.6684 -0.8855c 0.6930,-0.8855 0.6930,-2.8619 0.6930 -2.8619c 0.0000,-3.4394 -2.2074,-3.4394 -2.2074 -3.4394c -1.1037,-0.0000 -2.1817,1.1550 -2.1817 1.1550v 5.2105 ZM 529.3378,20.1694 ZM 530.8778,7.4384 h 3.7731 v 7.4179 c 0.0000,1.3860 0.3850,1.8994 0.3850 1.8994c 0.3850,0.5133 1.2064,0.5133 1.2064 0.5133c 0.7187,0.0000 1.2064,-0.3337 1.2064 -0.3337c 0.4877,-0.3337 1.0524,-1.0780 1.0524 -1.0780v -8.4189 h 3.7731 v 12.7310 h -3.0801 l -0.2823,-1.7710 h -0.0770 c -0.8214,0.9754 -1.7582,1.5272 -1.7582 1.5272c -0.9369,0.5518 -2.2459,0.5518 -2.2459 0.5518c -2.0791,-0.0000 -3.0159,-1.3604 -3.0159 -1.3604c -0.9369,-1.3604 -0.9369,-3.7731 -0.9369 -3.7731v -7.9055 ZM 543.9168,20.1694 ZM 545.5852,7.4384 h 3.0801 l 0.2567,2.2331 h 0.1027 c 0.6930,-1.3090 1.6684,-1.9251 1.6684 -1.9251c 0.9754,-0.6160 1.9507,-0.6160 1.9507 -0.6160c 0.5390,0.0000 0.8855,0.0642 0.8855 0.0642c 0.3465,0.0642 0.6289,0.1925 0.6289 0.1925l -0.6160,3.2598 c -0.3593,-0.1027 -0.6674,-0.1540 -0.6674 -0.1540c -0.3080,-0.0513 -0.7187,-0.0513 -0.7187 -0.0513c -0.7187,-0.0000 -1.5015,0.5133 -1.5015 0.5133c -0.7829,0.5133 -1.2962,1.8224 -1.2962 1.8224v 7.3922 h -3.7731 v -12.7310 ZM 553.8758,20.1694 ZM 554.7998,13.8039 c 0.0000,-1.5400 0.5133,-2.7849 0.5133 -2.7849c 0.5133,-1.2449 1.3475,-2.1047 1.3475 -2.1047c 0.8342,-0.8599 1.9122,-1.3219 1.9122 -1.3219c 1.0780,-0.4620 2.2331,-0.4620 2.2331 -0.4620c 1.3604,0.0000 2.3742,0.4620 2.3742 0.4620c 1.0139,0.4620 1.6940,1.2834 1.6940 1.2834c 0.6802,0.8214 1.0139,1.9379 1.0139 1.9379c 0.3337,1.1165 0.3337,2.4256 0.3337 2.4256c 0.0000,0.5133 -0.0513,0.9369 -0.0513 0.9369c -0.0513,0.4235 -0.1027,0.6545 -0.1027 0.6545h -7.6232 c 0.2567,1.4630 1.1422,2.1176 1.1422 2.1176c 0.8855,0.6545 2.1689,0.6545 2.1689 0.6545c 1.3604,0.0000 2.7464,-0.8470 2.7464 -0.8470l 1.2577,2.2844 c -0.9754,0.6674 -2.1689,1.0524 -2.1689 1.0524c -1.1935,0.3850 -2.3486,0.3850 -2.3486 0.3850c -1.3604,-0.0000 -2.5411,-0.4492 -2.5411 -0.4492c -1.1807,-0.4492 -2.0534,-1.3090 -2.0534 -1.3090c -0.8727,-0.8599 -1.3604,-2.0919 -1.3604 -2.0919c -0.4877,-1.2320 -0.4877,-2.8234 -0.4877 -2.8234ZM 554.7998,13.8039 ZM 563.0133,12.4949 c 0.0000,-1.1037 -0.4877,-1.7967 -0.4877 -1.7967c -0.4877,-0.6930 -1.6427,-0.6930 -1.6427 -0.6930c -0.8984,-0.0000 -1.5785,0.6032 -1.5785 0.6032c -0.6802,0.6032 -0.8855,1.8866 -0.8855 1.8866h 4.5945 ZM 567.1715,20.1694 ZM 568.2752,12.3409 h 6.3142 v 2.6694 h -6.3142 v -2.6694 ZM 575.6930,20.1694 ZM 577.9261,16.3450 c 0.8727,0.6674 1.6684,1.0010 1.6684 1.0010c 0.7957,0.3337 1.6170,0.3337 1.6170 0.3337c 0.8470,0.0000 1.2320,-0.2823 1.2320 -0.2823c 0.3850,-0.2823 0.3850,-0.7957 0.3850 -0.7957c 0.0000,-0.3080 -0.2182,-0.5518 -0.2182 -0.5518c -0.2182,-0.2438 -0.5903,-0.4492 -0.5903 -0.4492c -0.3722,-0.2053 -0.8342,-0.3722 -0.8342 -0.3722c -0.4620,-0.1668 -0.9497,-0.3722 -0.9497 -0.3722c -0.5903,-0.2310 -1.1807,-0.5390 -1.1807 -0.5390c -0.5903,-0.3080 -1.0780,-0.7572 -1.0780 -0.7572c -0.4877,-0.4492 -0.7957,-1.0524 -0.7957 -1.0524c -0.3080,-0.6032 -0.3080,-1.3989 -0.3080 -1.3989c 0.0000,-0.8727 0.3465,-1.6170 0.3465 -1.6170c 0.3465,-0.7444 0.9882,-1.2577 0.9882 -1.2577c 0.6417,-0.5133 1.5400,-0.8085 1.5400 -0.8085c 0.8984,-0.2952 2.0021,-0.2952 2.0021 -0.2952c 1.4630,0.0000 2.5667,0.5005 2.5667 0.5005c 1.1037,0.5005 1.9251,1.1165 1.9251 1.1165l -1.6940,2.2587 c -0.6930,-0.5133 -1.3604,-0.7957 -1.3604 -0.7957c -0.6674,-0.2823 -1.3347,-0.2823 -1.3347 -0.2823c -1.4374,-0.0000 -1.4374,1.0010 -1.4374 1.0010c 0.0000,0.3080 0.2053,0.5262 0.2053 0.5262c 0.2053,0.2182 0.5518,0.3978 0.5518 0.3978c 0.3465,0.1797 0.7957,0.3465 0.7957 0.3465c 0.4492,0.1668 0.9369,0.3465 0.9369 0.3465c 0.6160,0.2310 1.2192,0.5262 1.2192 0.5262c 0.6032,0.2952 1.1037,0.7315 1.1037 0.7315c 0.5005,0.4363 0.8085,1.0652 0.8085 1.0652c 0.3080,0.6289 0.3080,1.5015 0.3080 1.5015c 0.0000,0.8727 -0.3337,1.6170 -0.3337 1.6170c -0.3337,0.7444 -1.0010,1.2962 -1.0010 1.2962c -0.6674,0.5518 -1.6427,0.8727 -1.6427 0.8727c -0.9754,0.3208 -2.2587,0.3208 -2.2587 0.3208c -1.2577,-0.0000 -2.5796,-0.4877 -2.5796 -0.4877c -1.3219,-0.4877 -2.2972,-1.2834 -2.2972 -1.2834ZM 587.0637,20.1694 ZM 589.2454,10.3901 h -1.7454 v -2.7977 l 1.9507,-0.1540 l 0.4363,-3.3881 h 3.1314 v 3.3881 h 3.0544 v 2.9517 h -3.0544 v 5.1078 c 0.0000,1.0780 0.4492,1.5529 0.4492 1.5529c 0.4492,0.4748 1.1935,0.4748 1.1935 0.4748c 0.3080,0.0000 0.6289,-0.0770 0.6289 -0.0770c 0.3208,-0.0770 0.5775,-0.1797 0.5775 -0.1797l 0.5903,2.7464 c -0.5133,0.1540 -1.2064,0.3080 -1.2064 0.3080c -0.6930,0.1540 -1.6170,0.1540 -1.6170 0.1540c -1.1807,-0.0000 -2.0149,-0.3593 -2.0149 -0.3593c -0.8342,-0.3593 -1.3604,-1.0010 -1.3604 -1.0010c -0.5262,-0.6417 -0.7700,-1.5529 -0.7700 -1.5529c -0.2438,-0.9112 -0.2438,-2.0149 -0.2438 -2.0149v -5.1591 ZM 596.8943,20.1694 ZM 598.5626,7.4384 h 3.0801 l 0.2567,2.2331 h 0.1027 c 0.6930,-1.3090 1.6684,-1.9251 1.6684 -1.9251c 0.9754,-0.6160 1.9507,-0.6160 1.9507 -0.6160c 0.5390,0.0000 0.8855,0.0642 0.8855 0.0642c 0.3465,0.0642 0.6289,0.1925 0.6289 0.1925l -0.6160,3.2598 c -0.3593,-0.1027 -0.6674,-0.1540 -0.6674 -0.1540c -0.3080,-0.0513 -0.7187,-0.0513 -0.7187 -0.0513c -0.7187,-0.0000 -1.5015,0.5133 -1.5015 0.5133c -0.7829,0.5133 -1.2962,1.8224 -1.2962 1.8224v 7.3922 h -3.7731 v -12.7310 ZM 606.8532,20.1694 ZM 607.7772,13.8039 c 0.0000,-1.5400 0.5133,-2.7849 0.5133 -2.7849c 0.5133,-1.2449 1.3475,-2.1047 1.3475 -2.1047c 0.8342,-0.8599 1.9122,-1.3219 1.9122 -1.3219c 1.0780,-0.4620 2.2331,-0.4620 2.2331 -0.4620c 1.3604,0.0000 2.3742,0.4620 2.3742 0.4620c 1.0139,0.4620 1.6940,1.2834 1.6940 1.2834c 0.6802,0.8214 1.0139,1.9379 1.0139 1.9379c 0.3337,1.1165 0.3337,2.4256 0.3337 2.4256c 0.0000,0.5133 -0.0513,0.9369 -0.0513 0.9369c -0.0513,0.4235 -0.1027,0.6545 -0.1027 0.6545h -7.6232 c 0.2567,1.4630 1.1422,2.1176 1.1422 2.1176c 0.8855,0.6545 2.1689,0.6545 2.1689 0.6545c 1.3604,0.0000 2.7464,-0.8470 2.7464 -0.8470l 1.2577,2.2844 c -0.9754,0.6674 -2.1689,1.0524 -2.1689 1.0524c -1.1935,0.3850 -2.3486,0.3850 -2.3486 0.3850c -1.3604,-0.0000 -2.5411,-0.4492 -2.5411 -0.4492c -1.1807,-0.4492 -2.0534,-1.3090 -2.0534 -1.3090c -0.8727,-0.8599 -1.3604,-2.0919 -1.3604 -2.0919c -0.4877,-1.2320 -0.4877,-2.8234 -0.4877 -2.8234ZM 607.7772,13.8039 ZM 615.9908,12.4949 c 0.0000,-1.1037 -0.4877,-1.7967 -0.4877 -1.7967c -0.4877,-0.6930 -1.6427,-0.6930 -1.6427 -0.6930c -0.8984,-0.0000 -1.5785,0.6032 -1.5785 0.6032c -0.6802,0.6032 -0.8855,1.8866 -0.8855 1.8866h 4.5945 ZM 619.8665,20.1694 ZM 621.0729,16.6273 c 0.0000,-2.0021 1.6940,-3.1314 1.6940 -3.1314c 1.6940,-1.1294 5.4671,-1.5144 5.4671 -1.5144c -0.0513,-0.8470 -0.5133,-1.3475 -0.5133 -1.3475c -0.4620,-0.5005 -1.4887,-0.5005 -1.4887 -0.5005c -0.8214,-0.0000 -1.6427,0.3080 -1.6427 0.3080c -0.8214,0.3080 -1.7454,0.8470 -1.7454 0.8470l -1.3347,-2.4897 c 1.2320,-0.7444 2.5796,-1.2064 2.5796 -1.2064c 1.3475,-0.4620 2.8619,-0.4620 2.8619 -0.4620c 2.4641,0.0000 3.7603,1.3989 3.7603 1.3989c 1.2962,1.3989 1.2962,4.3506 1.2962 4.3506v 7.2895 h -3.0801 l -0.2823,-1.3090 h -0.0770 c -0.8214,0.7187 -1.7325,1.1679 -1.7325 1.1679c -0.9112,0.4492 -1.9892,0.4492 -1.9892 0.4492c -0.8727,-0.0000 -1.5657,-0.2952 -1.5657 -0.2952c -0.6930,-0.2952 -1.1807,-0.8214 -1.1807 -0.8214c -0.4877,-0.5262 -0.7572,-1.2192 -0.7572 -1.2192c -0.2695,-0.6930 -0.2695,-1.5144 -0.2695 -1.5144ZM 621.0729,16.6273 ZM 624.6663,16.3450 c 0.0000,0.6160 0.3978,0.9112 0.3978 0.9112c 0.3978,0.2952 1.0652,0.2952 1.0652 0.2952c 0.6674,0.0000 1.1294,-0.2823 1.1294 -0.2823c 0.4620,-0.2823 0.9754,-0.7957 0.9754 -0.7957v -2.2331 c -2.0277,0.2823 -2.7977,0.8214 -2.7977 0.8214c -0.7700,0.5390 -0.7700,1.2834 -0.7700 1.2834ZM 633.5729,20.1694 ZM 635.2413,7.4384 h 3.0801 l 0.2567,1.6427 h 0.1027 c 0.7957,-0.7957 1.6940,-1.3732 1.6940 -1.3732c 0.8984,-0.5775 2.1561,-0.5775 2.1561 -0.5775c 1.3604,0.0000 2.1946,0.5518 2.1946 0.5518c 0.8342,0.5518 1.3219,1.5785 1.3219 1.5785c 0.8470,-0.8727 1.7839,-1.5015 1.7839 -1.5015c 0.9369,-0.6289 2.2202,-0.6289 2.2202 -0.6289c 2.0534,0.0000 3.0159,1.3732 3.0159 1.3732c 0.9625,1.3732 0.9625,3.7603 0.9625 3.7603v 7.9055 h -3.7731 v -7.4179 c 0.0000,-1.3860 -0.3722,-1.8994 -0.3722 -1.8994c -0.3722,-0.5133 -1.1935,-0.5133 -1.1935 -0.5133c -0.9497,-0.0000 -2.1817,1.2320 -2.1817 1.2320v 8.5986 h -3.7731 v -7.4179 c 0.0000,-1.3860 -0.3722,-1.8994 -0.3722 -1.8994c -0.3722,-0.5133 -1.1935,-0.5133 -1.1935 -0.5133c -0.9754,-0.0000 -2.1561,1.2320 -2.1561 1.2320v 8.5986 h -3.7731 v -12.7310 ZM 655.5698,20.1694 ZM 657.2382,2.1766 h 3.7731 v 14.1940 c 0.0000,0.5903 0.2182,0.8214 0.2182 0.8214c 0.2182,0.2310 0.4492,0.2310 0.4492 0.2310h 0.2182 c 0.0000,0.0000 0.2438,-0.0513 0.2438 -0.0513l 0.4620,2.7977 c -0.3080,0.1283 -0.7829,0.2182 -0.7829 0.2182c -0.4748,0.0898 -1.1165,0.0898 -1.1165 0.0898c -0.9754,-0.0000 -1.6427,-0.3080 -1.6427 -0.3080c -0.6674,-0.3080 -1.0652,-0.8599 -1.0652 -0.8599c -0.3978,-0.5518 -0.5775,-1.3347 -0.5775 -1.3347c -0.1797,-0.7829 -0.1797,-1.7582 -0.1797 -1.7582v -14.0400 ZM 662.9107,20.1694 ZM 664.8614,22.0175 c 0.1797,0.0513 0.4107,0.1027 0.4107 0.1027c 0.2310,0.0513 0.4363,0.0513 0.4363 0.0513c 0.9497,0.0000 1.4630,-0.4620 1.4630 -0.4620c 0.5133,-0.4620 0.7700,-1.2064 0.7700 -1.2064l 0.1797,-0.6674 l -4.9025,-12.3973 h 3.7988 l 1.8224,5.4671 c 0.2823,0.8727 0.5133,1.7710 0.5133 1.7710c 0.2310,0.8984 0.4877,1.8480 0.4877 1.8480h 0.1027 c 0.2053,-0.8984 0.4235,-1.8095 0.4235 -1.8095c 0.2182,-0.9112 0.4492,-1.8095 0.4492 -1.8095l 1.5400,-5.4671 h 3.6191 l -4.4148,12.8593 c -0.4620,1.2064 -0.9625,2.1176 -0.9625 2.1176c -0.5005,0.9112 -1.1550,1.5144 -1.1550 1.5144c -0.6545,0.6032 -1.4887,0.9112 -1.4887 0.9112c -0.8342,0.3080 -1.9636,0.3080 -1.9636 0.3080c -0.5903,-0.0000 -1.0010,-0.0642 -1.0010 -0.0642c -0.4107,-0.0642 -0.7957,-0.1925 -0.7957 -0.1925l 0.6674,-2.8747 h 0.0000 ZM 676.2834,20.1694 ZM 678.3624,5.9754 l -0.1283,-3.4138 h 3.7988 l -0.1283,3.4138 l -0.7444,5.1078 h -2.0534 Z"/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(211,211,211)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-dashoffset="0.0" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-dasharray="4.999999999999998,4.999999999999998"><path d="M 80.4034,444.0000 h 709.5966 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(211,211,211)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-dashoffset="0.0" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-dasharray="4.999999999999998,4.999999999999998"><path d="M 80.4034,364.6000 h 709.5966 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(211,211,211)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-dashoffset="0.0" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-dasharray="4.999999999999998,4.999999999999998"><path d="M 80.4034,285.2000 h 709.5966 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(211,211,211)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-dashoffset="0.0" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-dasharray="4.999999999999998,4.999999999999998"><path d="M 80.4034,205.8000 h 709.5966 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(211,211,211)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-dashoffset="0.0" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-dasharray="4.999999999999998,4.999999999999998"><path d="M 80.4034,126.4000 h 709.5966 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(211,211,211)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-dashoffset="0.0" stroke-linecap="butt" stroke-miterlimit="10.0" stroke-dasharray="4.999999999999998,4.999999999999998"><path d="M 80.4034,47.0000 h 709.5966 "/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,255)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip1"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip1)"><path d="M 95.4034,364.6000 v -306.3549 h 17.0946 v 306.3549 Z"/></g></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,128,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip2"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip2)"><path d="M 112.4980,364.6000 v -219.0632 h 17.0946 v 219.0632 Z"/></g></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(255,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip3"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip3)"><path d="M 129.5927,364.6000 v -80.0608 h 17.0946 v 80.0608 Z"/></g></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(255,165,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip4"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip4)"><path d="M 146.6873,364.6000 v -60.1654 h 17.0946 v 60.1654 Z"/></g></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(255,255,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip5"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip5)"><path d="M 163.7820,364.6000 v -53.0481 h 17.0946 v 53.0481 Z"/></g></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(238,130,238)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip6"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip6)"><path d="M 180.8766,364.6000 v -48.1404 h 17.0946 v 48.1404 Z"/></g></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,255)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip7"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip7)"><path d="M 197.9713,364.6000 v -42.4556 h 17.0946 v 42.4556 Z"/></g></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,128,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip8"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip8)"><path d="M 215.0659,364.6000 v -38.4431 h 17.0946 v 38.4431 Z"/></g></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(255,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip9"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip9)"><path d="M 232.1605,364.6000 v -32.7179 h 17.0946 v 32.7179 Z"/></g></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(255,165,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip10"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip10)"><path d="M 249.2552,364.6000 v -32.6952 h 17.0946 v 32.6952 Z"/></g></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(255,255,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip11"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip11)"><path d="M 266.3498,364.6000 v -32.2955 h 17.0946 v 32.2955 Z"/></g></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(238,130,238)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip12"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip12)"><path d="M 283.4445,364.6000 v -31.8824 h 17.0946 v 31.8824 Z"/></g></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,255)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip13"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip13)"><path d="M 300.5391,364.6000 v -27.0567 h 17.0946 v 27.0567 Z"/></g></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,128,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip14"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip14)"><path d="M 317.6338,364.6000 v -20.1385 h 17.0946 v 20.1385 Z"/></g></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(255,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip15"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip15)"><path d="M 334.7284,364.6000 v -12.6729 h 17.0946 v 12.6729 Z"/></g></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(255,165,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip16"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip16)"><path d="M 351.8231,364.6000 v -4.1066 h 17.0946 v 4.1066 Z"/></g></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(255,255,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip17"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip17)"><path d="M 368.9177,364.6000 v -1.3991 h 17.0946 v 1.3991 Z"/></g></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(238,130,238)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip18"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip18)"><path d="M 386.0124,364.6000 v 2.7767 h 17.0946 v -2.7767 Z"/></g></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,255)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip19"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip19)"><path d="M 403.1070,364.6000 v 7.7712 h 17.0946 v -7.7712 Z"/></g></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip20"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip20)"><path d="M 95.4034,364.6000 v -306.3549 h 17.0946 v 306.3549 Z"/></g></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip21"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip21)"><path d="M 112.4980,364.6000 v -219.0632 h 17.0946 v 219.0632 Z"/></g></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip22"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip22)"><path d="M 129.5927,364.6000 v -80.0608 h 17.0946 v 80.0608 Z"/></g></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip23"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip23)"><path d="M 146.6873,364.6000 v -60.1654 h 17.0946 v 60.1654 Z"/></g></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip24"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip24)"><path d="M 163.7820,364.6000 v -53.0481 h 17.0946 v 53.0481 Z"/></g></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip25"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip25)"><path d="M 180.8766,364.6000 v -48.1404 h 17.0946 v 48.1404 Z"/></g></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip26"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip26)"><path d="M 197.9713,364.6000 v -42.4556 h 17.0946 v 42.4556 Z"/></g></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip27"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip27)"><path d="M 215.0659,364.6000 v -38.4431 h 17.0946 v 38.4431 Z"/></g></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip28"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip28)"><path d="M 232.1605,364.6000 v -32.7179 h 17.0946 v 32.7179 Z"/></g></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip29"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip29)"><path d="M 249.2552,364.6000 v -32.6952 h 17.0946 v 32.6952 Z"/></g></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip30"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip30)"><path d="M 266.3498,364.6000 v -32.2955 h 17.0946 v 32.2955 Z"/></g></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip31"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip31)"><path d="M 283.4445,364.6000 v -31.8824 h 17.0946 v 31.8824 Z"/></g></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip32"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip32)"><path d="M 300.5391,364.6000 v -27.0567 h 17.0946 v 27.0567 Z"/></g></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip33"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip33)"><path d="M 317.6338,364.6000 v -20.1385 h 17.0946 v 20.1385 Z"/></g></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip34"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip34)"><path d="M 334.7284,364.6000 v -12.6729 h 17.0946 v 12.6729 Z"/></g></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip35"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip35)"><path d="M 351.8231,364.6000 v -4.1066 h 17.0946 v 4.1066 Z"/></g></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip36"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip36)"><path d="M 368.9177,364.6000 v -1.3991 h 17.0946 v 1.3991 Z"/></g></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip37"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip37)"><path d="M 386.0124,364.6000 v 2.7767 h 17.0946 v -2.7767 Z"/></g></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><defs><clipPath id="myClip38"><path d="M 80.4034,47.0000 v 397.0000 h 709.5966 v -397.0000 Z"/></clipPath></defs><g clip-path="url(#myClip38)"><path d="M 403.1070,364.6000 v 7.7712 h 17.0946 v -7.7712 Z"/></g></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="square" stroke-miterlimit="10.0"><path d="M 80.4034,444.0000 v -397.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,444.0000 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,436.0600 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,428.1200 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,420.1800 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,412.2400 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,404.3000 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,396.3600 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,388.4200 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,380.4800 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,372.5400 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,364.6000 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,356.6600 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,348.7200 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,340.7800 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,332.8400 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,324.9000 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,316.9600 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,309.0200 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,301.0800 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,293.1400 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,285.2000 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,277.2600 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,269.3200 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,261.3800 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,253.4400 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,245.5000 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,237.5600 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,229.6200 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,221.6800 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,213.7400 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,205.8000 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,197.8600 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,189.9200 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,181.9800 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,174.0400 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,166.1000 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,158.1600 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,150.2200 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,142.2800 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,134.3400 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,126.4000 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,118.4600 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,110.5200 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,102.5800 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,94.6400 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,86.7000 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,78.7600 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,70.8200 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,62.8800 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,54.9400 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,47.0000 h 2.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,444.0000 h 5.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,364.6000 h 5.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,285.2000 h 5.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,205.8000 h 5.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,126.4000 h 5.0000 "/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 80.4034,47.0000 h 5.0000 "/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 35.1681,448.8235 ZM 36.3298,447.8235 h 2.1471 v -6.9118 h -1.7059 v -0.7794 c 0.6471,-0.1176 1.1250,-0.2868 1.1250 -0.2868c 0.4779,-0.1691 0.8603,-0.4044 0.8603 -0.4044h 0.9265 v 8.3824 h 1.9412 v 1.0000 h -5.2941 v -1.0000 ZM 42.4769,448.8235 ZM 46.5504,438.3824 h 0.8824 l -3.9265,12.7941 h -0.8824 ZM 47.6239,448.8235 ZM 48.5798,446.9265 c 0.4118,0.4265 0.9779,0.7500 0.9779 0.7500c 0.5662,0.3235 1.3897,0.3235 1.3897 0.3235c 0.4265,0.0000 0.8015,-0.1544 0.8015 -0.1544c 0.3750,-0.1544 0.6544,-0.4338 0.6544 -0.4338c 0.2794,-0.2794 0.4412,-0.6765 0.4412 -0.6765c 0.1618,-0.3971 0.1618,-0.8824 0.1618 -0.8824c 0.0000,-0.9706 -0.5441,-1.5147 -0.5441 -1.5147c -0.5441,-0.5441 -1.4559,-0.5441 -1.4559 -0.5441c -0.4853,-0.0000 -0.8309,0.1471 -0.8309 0.1471c -0.3456,0.1471 -0.7721,0.4265 -0.7721 0.4265l -0.6471,-0.4118 l 0.3088,-4.5147 h 4.6912 v 1.0441 h -3.6324 l -0.2500,2.7794 c 0.3382,-0.1765 0.6765,-0.2794 0.6765 -0.2794c 0.3382,-0.1029 0.7647,-0.1029 0.7647 -0.1029c 0.6029,0.0000 1.1324,0.1765 1.1324 0.1765c 0.5294,0.1765 0.9265,0.5368 0.9265 0.5368c 0.3971,0.3603 0.6250,0.9118 0.6250 0.9118c 0.2279,0.5515 0.2279,1.3162 0.2279 1.3162c 0.0000,0.7647 -0.2647,1.3529 -0.2647 1.3529c -0.2647,0.5882 -0.7059,0.9926 -0.7059 0.9926c -0.4412,0.4044 -1.0074,0.6176 -1.0074 0.6176c -0.5662,0.2132 -1.1838,0.2132 -1.1838 0.2132c -0.5588,-0.0000 -1.0221,-0.1103 -1.0221 -0.1103c -0.4632,-0.1103 -0.8382,-0.2868 -0.8382 -0.2868c -0.3750,-0.1765 -0.6765,-0.4044 -0.6765 -0.4044c -0.3015,-0.2279 -0.5368,-0.4779 -0.5368 -0.4779ZM 54.9328,448.8235 ZM 56.0945,447.8235 h 2.1471 v -6.9118 h -1.7059 v -0.7794 c 0.6471,-0.1176 1.1250,-0.2868 1.1250 -0.2868c 0.4779,-0.1691 0.8603,-0.4044 0.8603 -0.4044h 0.9265 v 8.3824 h 1.9412 v 1.0000 h -5.2941 v -1.0000 ZM 65.2122,448.8235 ZM 67.7563,445.0882 l -2.1618,-3.4118 h 1.3088 l 0.9559,1.5735 c 0.1618,0.2941 0.3382,0.5956 0.3382 0.5956c 0.1765,0.3015 0.3676,0.5956 0.3676 0.5956h 0.0588 c 0.1618,-0.2941 0.3235,-0.5956 0.3235 -0.5956c 0.1618,-0.3015 0.3235,-0.5956 0.3235 -0.5956l 0.8676,-1.5735 h 1.2647 l -2.1618,3.5441 l 2.3235,3.6029 h -1.3088 l -1.0441,-1.6618 l -0.3824,-0.6471 c 0.0000,0.0000 -0.3971,-0.6324 -0.3971 -0.6324h -0.0588 c -0.1912,0.3088 -0.3676,0.6250 -0.3676 0.6250c -0.1765,0.3162 -0.3529,0.6544 -0.3529 0.6544l -0.9706,1.6618 h -1.2647 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 54.9328,369.4235 ZM 56.0945,368.4235 h 2.1471 v -6.9118 h -1.7059 v -0.7794 c 0.6471,-0.1176 1.1250,-0.2868 1.1250 -0.2868c 0.4779,-0.1691 0.8603,-0.4044 0.8603 -0.4044h 0.9265 v 8.3824 h 1.9412 v 1.0000 h -5.2941 v -1.0000 ZM 65.2122,369.4235 ZM 67.7563,365.6882 l -2.1618,-3.4118 h 1.3088 l 0.9559,1.5735 c 0.1618,0.2941 0.3382,0.5956 0.3382 0.5956c 0.1765,0.3015 0.3676,0.5956 0.3676 0.5956h 0.0588 c 0.1618,-0.2941 0.3235,-0.5956 0.3235 -0.5956c 0.1618,-0.3015 0.3235,-0.5956 0.3235 -0.5956l 0.8676,-1.5735 h 1.2647 l -2.1618,3.5441 l 2.3235,3.6029 h -1.3088 l -1.0441,-1.6618 l -0.3824,-0.6471 c 0.0000,0.0000 -0.3971,-0.6324 -0.3971 -0.6324h -0.0588 c -0.1912,0.3088 -0.3676,0.6250 -0.3676 0.6250c -0.1765,0.3162 -0.3529,0.6544 -0.3529 0.6544l -0.9706,1.6618 h -1.2647 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 46.8298,290.0235 ZM 47.7857,288.1265 c 0.4118,0.4265 0.9779,0.7500 0.9779 0.7500c 0.5662,0.3235 1.3897,0.3235 1.3897 0.3235c 0.4265,0.0000 0.8015,-0.1544 0.8015 -0.1544c 0.3750,-0.1544 0.6544,-0.4338 0.6544 -0.4338c 0.2794,-0.2794 0.4412,-0.6765 0.4412 -0.6765c 0.1618,-0.3971 0.1618,-0.8824 0.1618 -0.8824c 0.0000,-0.9706 -0.5441,-1.5147 -0.5441 -1.5147c -0.5441,-0.5441 -1.4559,-0.5441 -1.4559 -0.5441c -0.4853,-0.0000 -0.8309,0.1471 -0.8309 0.1471c -0.3456,0.1471 -0.7721,0.4265 -0.7721 0.4265l -0.6471,-0.4118 l 0.3088,-4.5147 h 4.6912 v 1.0441 h -3.6324 l -0.2500,2.7794 c 0.3382,-0.1765 0.6765,-0.2794 0.6765 -0.2794c 0.3382,-0.1029 0.7647,-0.1029 0.7647 -0.1029c 0.6029,0.0000 1.1324,0.1765 1.1324 0.1765c 0.5294,0.1765 0.9265,0.5368 0.9265 0.5368c 0.3971,0.3603 0.6250,0.9118 0.6250 0.9118c 0.2279,0.5515 0.2279,1.3162 0.2279 1.3162c 0.0000,0.7647 -0.2647,1.3529 -0.2647 1.3529c -0.2647,0.5882 -0.7059,0.9926 -0.7059 0.9926c -0.4412,0.4044 -1.0074,0.6176 -1.0074 0.6176c -0.5662,0.2132 -1.1838,0.2132 -1.1838 0.2132c -0.5588,-0.0000 -1.0221,-0.1103 -1.0221 -0.1103c -0.4632,-0.1103 -0.8382,-0.2868 -0.8382 -0.2868c -0.3750,-0.1765 -0.6765,-0.4044 -0.6765 -0.4044c -0.3015,-0.2279 -0.5368,-0.4779 -0.5368 -0.4779ZM 54.1387,290.0235 ZM 55.3004,289.0235 h 2.1471 v -6.9118 h -1.7059 v -0.7794 c 0.6471,-0.1176 1.1250,-0.2868 1.1250 -0.2868c 0.4779,-0.1691 0.8603,-0.4044 0.8603 -0.4044h 0.9265 v 8.3824 h 1.9412 v 1.0000 h -5.2941 v -1.0000 ZM 64.4181,290.0235 ZM 66.9622,286.2882 l -2.1618,-3.4118 h 1.3088 l 0.9559,1.5735 c 0.1618,0.2941 0.3382,0.5956 0.3382 0.5956c 0.1765,0.3015 0.3676,0.5956 0.3676 0.5956h 0.0588 c 0.1618,-0.2941 0.3235,-0.5956 0.3235 -0.5956c 0.1618,-0.3015 0.3235,-0.5956 0.3235 -0.5956l 0.8676,-1.5735 h 1.2647 l -2.1618,3.5441 l 2.3235,3.6029 h -1.3088 l -1.0441,-1.6618 l -0.3824,-0.6471 c 0.0000,0.0000 -0.3971,-0.6324 -0.3971 -0.6324h -0.0588 c -0.1912,0.3088 -0.3676,0.6250 -0.3676 0.6250c -0.1765,0.3162 -0.3529,0.6544 -0.3529 0.6544l -0.9706,1.6618 h -1.2647 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 40.3151,210.6235 ZM 41.4769,209.6235 h 2.1471 v -6.9118 h -1.7059 v -0.7794 c 0.6471,-0.1176 1.1250,-0.2868 1.1250 -0.2868c 0.4779,-0.1691 0.8603,-0.4044 0.8603 -0.4044h 0.9265 v 8.3824 h 1.9412 v 1.0000 h -5.2941 v -1.0000 ZM 47.6239,210.6235 ZM 51.2857,210.8000 c -1.4265,-0.0000 -2.2206,-1.2647 -2.2206 -1.2647c -0.7941,-1.2647 -0.7941,-3.6324 -0.7941 -3.6324c 0.0000,-2.3676 0.7941,-3.6029 0.7941 -3.6029c 0.7941,-1.2353 2.2206,-1.2353 2.2206 -1.2353c 1.4118,0.0000 2.2059,1.2353 2.2059 1.2353c 0.7941,1.2353 0.7941,3.6029 0.7941 3.6029c 0.0000,2.3676 -0.7941,3.6324 -0.7941 3.6324c -0.7941,1.2647 -2.2059,1.2647 -2.2059 1.2647ZM 51.2857,210.8000 ZM 51.2857,209.8294 c 0.4118,0.0000 0.7426,-0.2279 0.7426 -0.2279c 0.3309,-0.2279 0.5735,-0.7059 0.5735 -0.7059c 0.2426,-0.4779 0.3750,-1.2206 0.3750 -1.2206c 0.1324,-0.7426 0.1324,-1.7721 0.1324 -1.7721c 0.0000,-1.0294 -0.1324,-1.7647 -0.1324 -1.7647c -0.1324,-0.7353 -0.3750,-1.1985 -0.3750 -1.1985c -0.2426,-0.4632 -0.5735,-0.6838 -0.5735 -0.6838c -0.3309,-0.2206 -0.7426,-0.2206 -0.7426 -0.2206c -0.4118,-0.0000 -0.7500,0.2206 -0.7500 0.2206c -0.3382,0.2206 -0.5809,0.6838 -0.5809 0.6838c -0.2426,0.4632 -0.3750,1.1985 -0.3750 1.1985c -0.1324,0.7353 -0.1324,1.7647 -0.1324 1.7647c 0.0000,2.0588 0.5074,2.9926 0.5074 2.9926c 0.5074,0.9338 1.3309,0.9338 1.3309 0.9338ZM 54.9328,210.6235 ZM 56.0945,209.6235 h 2.1471 v -6.9118 h -1.7059 v -0.7794 c 0.6471,-0.1176 1.1250,-0.2868 1.1250 -0.2868c 0.4779,-0.1691 0.8603,-0.4044 0.8603 -0.4044h 0.9265 v 8.3824 h 1.9412 v 1.0000 h -5.2941 v -1.0000 ZM 65.2122,210.6235 ZM 67.7563,206.8882 l -2.1618,-3.4118 h 1.3088 l 0.9559,1.5735 c 0.1618,0.2941 0.3382,0.5956 0.3382 0.5956c 0.1765,0.3015 0.3676,0.5956 0.3676 0.5956h 0.0588 c 0.1618,-0.2941 0.3235,-0.5956 0.3235 -0.5956c 0.1618,-0.3015 0.3235,-0.5956 0.3235 -0.5956l 0.8676,-1.5735 h 1.2647 l -2.1618,3.5441 l 2.3235,3.6029 h -1.3088 l -1.0441,-1.6618 l -0.3824,-0.6471 c 0.0000,0.0000 -0.3971,-0.6324 -0.3971 -0.6324h -0.0588 c -0.1912,0.3088 -0.3676,0.6250 -0.3676 0.6250c -0.1765,0.3162 -0.3529,0.6544 -0.3529 0.6544l -0.9706,1.6618 h -1.2647 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 40.3151,131.2235 ZM 41.4769,130.2235 h 2.1471 v -6.9118 h -1.7059 v -0.7794 c 0.6471,-0.1176 1.1250,-0.2868 1.1250 -0.2868c 0.4779,-0.1691 0.8603,-0.4044 0.8603 -0.4044h 0.9265 v 8.3824 h 1.9412 v 1.0000 h -5.2941 v -1.0000 ZM 47.6239,131.2235 ZM 48.5798,129.3265 c 0.4118,0.4265 0.9779,0.7500 0.9779 0.7500c 0.5662,0.3235 1.3897,0.3235 1.3897 0.3235c 0.4265,0.0000 0.8015,-0.1544 0.8015 -0.1544c 0.3750,-0.1544 0.6544,-0.4338 0.6544 -0.4338c 0.2794,-0.2794 0.4412,-0.6765 0.4412 -0.6765c 0.1618,-0.3971 0.1618,-0.8824 0.1618 -0.8824c 0.0000,-0.9706 -0.5441,-1.5147 -0.5441 -1.5147c -0.5441,-0.5441 -1.4559,-0.5441 -1.4559 -0.5441c -0.4853,-0.0000 -0.8309,0.1471 -0.8309 0.1471c -0.3456,0.1471 -0.7721,0.4265 -0.7721 0.4265l -0.6471,-0.4118 l 0.3088,-4.5147 h 4.6912 v 1.0441 h -3.6324 l -0.2500,2.7794 c 0.3382,-0.1765 0.6765,-0.2794 0.6765 -0.2794c 0.3382,-0.1029 0.7647,-0.1029 0.7647 -0.1029c 0.6029,0.0000 1.1324,0.1765 1.1324 0.1765c 0.5294,0.1765 0.9265,0.5368 0.9265 0.5368c 0.3971,0.3603 0.6250,0.9118 0.6250 0.9118c 0.2279,0.5515 0.2279,1.3162 0.2279 1.3162c 0.0000,0.7647 -0.2647,1.3529 -0.2647 1.3529c -0.2647,0.5882 -0.7059,0.9926 -0.7059 0.9926c -0.4412,0.4044 -1.0074,0.6176 -1.0074 0.6176c -0.5662,0.2132 -1.1838,0.2132 -1.1838 0.2132c -0.5588,-0.0000 -1.0221,-0.1103 -1.0221 -0.1103c -0.4632,-0.1103 -0.8382,-0.2868 -0.8382 -0.2868c -0.3750,-0.1765 -0.6765,-0.4044 -0.6765 -0.4044c -0.3015,-0.2279 -0.5368,-0.4779 -0.5368 -0.4779ZM 54.9328,131.2235 ZM 56.0945,130.2235 h 2.1471 v -6.9118 h -1.7059 v -0.7794 c 0.6471,-0.1176 1.1250,-0.2868 1.1250 -0.2868c 0.4779,-0.1691 0.8603,-0.4044 0.8603 -0.4044h 0.9265 v 8.3824 h 1.9412 v 1.0000 h -5.2941 v -1.0000 ZM 65.2122,131.2235 ZM 67.7563,127.4882 l -2.1618,-3.4118 h 1.3088 l 0.9559,1.5735 c 0.1618,0.2941 0.3382,0.5956 0.3382 0.5956c 0.1765,0.3015 0.3676,0.5956 0.3676 0.5956h 0.0588 c 0.1618,-0.2941 0.3235,-0.5956 0.3235 -0.5956c 0.1618,-0.3015 0.3235,-0.5956 0.3235 -0.5956l 0.8676,-1.5735 h 1.2647 l -2.1618,3.5441 l 2.3235,3.6029 h -1.3088 l -1.0441,-1.6618 l -0.3824,-0.6471 c 0.0000,0.0000 -0.3971,-0.6324 -0.3971 -0.6324h -0.0588 c -0.1912,0.3088 -0.3676,0.6250 -0.3676 0.6250c -0.1765,0.3162 -0.3529,0.6544 -0.3529 0.6544l -0.9706,1.6618 h -1.2647 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 39.6828,51.8235 ZM 40.2710,51.1029 c 1.0588,-1.0588 1.8824,-1.9118 1.8824 -1.9118c 0.8235,-0.8529 1.3824,-1.5809 1.3824 -1.5809c 0.5588,-0.7279 0.8529,-1.3382 0.8529 -1.3382c 0.2941,-0.6103 0.2941,-1.1838 0.2941 -1.1838c 0.0000,-0.8088 -0.4412,-1.3235 -0.4412 -1.3235c -0.4412,-0.5147 -1.3382,-0.5147 -1.3382 -0.5147c -0.5882,-0.0000 -1.0882,0.3309 -1.0882 0.3309c -0.5000,0.3309 -0.9118,0.8015 -0.9118 0.8015l -0.6912,-0.6912 c 0.5882,-0.6471 1.2500,-1.0368 1.2500 -1.0368c 0.6618,-0.3897 1.5882,-0.3897 1.5882 -0.3897c 1.3088,0.0000 2.0588,0.7574 2.0588 0.7574c 0.7500,0.7574 0.7500,2.0074 0.7500 2.0074c 0.0000,0.6618 -0.2868,1.3309 -0.2868 1.3309c -0.2868,0.6691 -0.7941,1.3824 -0.7941 1.3824c -0.5074,0.7132 -1.2059,1.4853 -1.2059 1.4853c -0.6985,0.7721 -1.5368,1.6397 -1.5368 1.6397c 0.3824,-0.0294 0.7941,-0.0588 0.7941 -0.0588c 0.4118,-0.0294 0.7794,-0.0294 0.7794 -0.0294h 2.7206 v 1.0441 h -6.0588 v -0.7206 ZM 46.9916,51.8235 ZM 50.6534,52.0000 c -1.4265,-0.0000 -2.2206,-1.2647 -2.2206 -1.2647c -0.7941,-1.2647 -0.7941,-3.6324 -0.7941 -3.6324c 0.0000,-2.3676 0.7941,-3.6029 0.7941 -3.6029c 0.7941,-1.2353 2.2206,-1.2353 2.2206 -1.2353c 1.4118,0.0000 2.2059,1.2353 2.2059 1.2353c 0.7941,1.2353 0.7941,3.6029 0.7941 3.6029c 0.0000,2.3676 -0.7941,3.6324 -0.7941 3.6324c -0.7941,1.2647 -2.2059,1.2647 -2.2059 1.2647ZM 50.6534,52.0000 ZM 50.6534,51.0294 c 0.4118,0.0000 0.7426,-0.2279 0.7426 -0.2279c 0.3309,-0.2279 0.5735,-0.7059 0.5735 -0.7059c 0.2426,-0.4779 0.3750,-1.2206 0.3750 -1.2206c 0.1324,-0.7426 0.1324,-1.7721 0.1324 -1.7721c 0.0000,-1.0294 -0.1324,-1.7647 -0.1324 -1.7647c -0.1324,-0.7353 -0.3750,-1.1985 -0.3750 -1.1985c -0.2426,-0.4632 -0.5735,-0.6838 -0.5735 -0.6838c -0.3309,-0.2206 -0.7426,-0.2206 -0.7426 -0.2206c -0.4118,-0.0000 -0.7500,0.2206 -0.7500 0.2206c -0.3382,0.2206 -0.5809,0.6838 -0.5809 0.6838c -0.2426,0.4632 -0.3750,1.1985 -0.3750 1.1985c -0.1324,0.7353 -0.1324,1.7647 -0.1324 1.7647c 0.0000,2.0588 0.5074,2.9926 0.5074 2.9926c 0.5074,0.9338 1.3309,0.9338 1.3309 0.9338ZM 54.3004,51.8235 ZM 55.4622,50.8235 h 2.1471 v -6.9118 h -1.7059 v -0.7794 c 0.6471,-0.1176 1.1250,-0.2868 1.1250 -0.2868c 0.4779,-0.1691 0.8603,-0.4044 0.8603 -0.4044h 0.9265 v 8.3824 h 1.9412 v 1.0000 h -5.2941 v -1.0000 ZM 64.5798,51.8235 ZM 67.1239,48.0882 l -2.1618,-3.4118 h 1.3088 l 0.9559,1.5735 c 0.1618,0.2941 0.3382,0.5956 0.3382 0.5956c 0.1765,0.3015 0.3676,0.5956 0.3676 0.5956h 0.0588 c 0.1618,-0.2941 0.3235,-0.5956 0.3235 -0.5956c 0.1618,-0.3015 0.3235,-0.5956 0.3235 -0.5956l 0.8676,-1.5735 h 1.2647 l -2.1618,3.5441 l 2.3235,3.6029 h -1.3088 l -1.0441,-1.6618 l -0.3824,-0.6471 c 0.0000,0.0000 -0.3971,-0.6324 -0.3971 -0.6324h -0.0588 c -0.1912,0.3088 -0.3676,0.6250 -0.3676 0.6250c -0.1765,0.3162 -0.3529,0.6544 -0.3529 0.6544l -0.9706,1.6618 h -1.2647 Z"/></g><g stroke-linejoin="miter" stroke-opacity="1.0" fill-opacity="0.0" stroke="rgb(0,0,0)" stroke-width="0.9999999999999997" fill="rgb(0,0,0)" stroke-linecap="square" stroke-miterlimit="10.0"><path d="M 80.4034,444.0000 h 709.5966 "/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 187.3992,470.0000 ZM 188.7773,458.0336 h 1.3782 v 10.4202 c 0.0000,0.3361 0.1176,0.4706 0.1176 0.4706c 0.1176,0.1345 0.2689,0.1345 0.2689 0.1345h 0.1261 c 0.0000,0.0000 0.1765,-0.0336 0.1765 -0.0336l 0.1849,1.0420 c -0.1345,0.0672 -0.3193,0.1008 -0.3193 0.1008c -0.1849,0.0336 -0.4706,0.0336 -0.4706 0.0336c -0.7899,-0.0000 -1.1261,-0.4706 -1.1261 -0.4706c -0.3361,-0.4706 -0.3361,-1.3782 -0.3361 -1.3782v -10.3193 ZM 191.6849,470.0000 ZM 193.7689,460.1513 c -0.4034,-0.0000 -0.6807,-0.2521 -0.6807 -0.2521c -0.2773,-0.2521 -0.2773,-0.6387 -0.2773 -0.6387c 0.0000,-0.4034 0.2773,-0.6471 0.2773 -0.6471c 0.2773,-0.2437 0.6807,-0.2437 0.6807 -0.2437c 0.4034,0.0000 0.6807,0.2437 0.6807 0.2437c 0.2773,0.2437 0.2773,0.6471 0.2773 0.6471c 0.0000,0.3866 -0.2773,0.6387 -0.2773 0.6387c -0.2773,0.2521 -0.6807,0.2521 -0.6807 0.2521ZM 193.7689,460.1513 ZM 193.0630,461.8319 h 1.3782 v 8.1681 h -1.3782 v -8.1681 ZM 195.8193,470.0000 ZM 196.9790,468.1513 c 0.5378,0.4370 1.1008,0.7059 1.1008 0.7059c 0.5630,0.2689 1.3025,0.2689 1.3025 0.2689c 0.8067,0.0000 1.2101,-0.3697 1.2101 -0.3697c 0.4034,-0.3697 0.4034,-0.9076 0.4034 -0.9076c 0.0000,-0.3193 -0.1681,-0.5546 -0.1681 -0.5546c -0.1681,-0.2353 -0.4286,-0.4118 -0.4286 -0.4118c -0.2605,-0.1765 -0.5966,-0.3109 -0.5966 -0.3109l -0.6723,-0.2689 c -0.4370,-0.1513 -0.8739,-0.3445 -0.8739 -0.3445c -0.4370,-0.1933 -0.7815,-0.4706 -0.7815 -0.4706c -0.3445,-0.2773 -0.5630,-0.6471 -0.5630 -0.6471c -0.2185,-0.3697 -0.2185,-0.8908 -0.2185 -0.8908c 0.0000,-0.4874 0.1933,-0.9160 0.1933 -0.9160c 0.1933,-0.4286 0.5546,-0.7395 0.5546 -0.7395c 0.3613,-0.3109 0.8824,-0.4874 0.8824 -0.4874c 0.5210,-0.1765 1.1765,-0.1765 1.1765 -0.1765c 0.7731,0.0000 1.4202,0.2689 1.4202 0.2689c 0.6471,0.2689 1.1176,0.6555 1.1176 0.6555l -0.6555,0.8739 c -0.4202,-0.3193 -0.8739,-0.5210 -0.8739 -0.5210c -0.4538,-0.2017 -0.9916,-0.2017 -0.9916 -0.2017c -0.7731,-0.0000 -1.1345,0.3529 -1.1345 0.3529c -0.3613,0.3529 -0.3613,0.8235 -0.3613 0.8235c 0.0000,0.2857 0.1513,0.4958 0.1513 0.4958c 0.1513,0.2101 0.4034,0.3697 0.4034 0.3697c 0.2521,0.1597 0.5798,0.2857 0.5798 0.2857c 0.3277,0.1261 0.6807,0.2605 0.6807 0.2605c 0.4370,0.1681 0.8824,0.3529 0.8824 0.3529c 0.4454,0.1849 0.7983,0.4622 0.7983 0.4622c 0.3529,0.2773 0.5798,0.6807 0.5798 0.6807c 0.2269,0.4034 0.2269,0.9748 0.2269 0.9748c 0.0000,0.5042 -0.1933,0.9412 -0.1933 0.9412c -0.1933,0.4370 -0.5714,0.7731 -0.5714 0.7731c -0.3782,0.3361 -0.9412,0.5294 -0.9412 0.5294c -0.5630,0.1933 -1.2857,0.1933 -1.2857 0.1933c -0.8739,-0.0000 -1.6639,-0.3193 -1.6639 -0.3193c -0.7899,-0.3193 -1.3782,-0.8067 -1.3782 -0.8067ZM 202.8613,470.0000 ZM 204.4748,462.9580 h -1.2101 v -1.0420 l 1.2773,-0.0840 l 0.1681,-2.2857 h 1.1597 v 2.2857 h 2.2017 v 1.1261 h -2.2017 v 4.5378 c 0.0000,0.7563 0.2773,1.1681 0.2773 1.1681c 0.2773,0.4118 0.9832,0.4118 0.9832 0.4118c 0.2185,0.0000 0.4706,-0.0672 0.4706 -0.0672c 0.2521,-0.0672 0.4538,-0.1513 0.4538 -0.1513l 0.2689,1.0420 c -0.3361,0.1176 -0.7311,0.2101 -0.7311 0.2101c -0.3950,0.0924 -0.7815,0.0924 -0.7815 0.0924c -0.6555,-0.0000 -1.1008,-0.2017 -1.1008 -0.2017c -0.4454,-0.2017 -0.7227,-0.5546 -0.7227 -0.5546c -0.2773,-0.3529 -0.3950,-0.8571 -0.3950 -0.8571c -0.1176,-0.5042 -0.1176,-1.1092 -0.1176 -1.1092v -4.5210 ZM 208.5420,470.0000 ZM 213.1975,458.0672 h 1.0084 l -4.4874,14.6218 h -1.0084 ZM 214.4244,470.0000 ZM 217.1807,470.6891 v 2.7563 h -1.3782 v -11.6134 h 1.1429 l 0.1176,0.9412 h 0.0504 c 0.5546,-0.4706 1.2185,-0.8067 1.2185 -0.8067c 0.6639,-0.3361 1.3866,-0.3361 1.3866 -0.3361c 0.7899,0.0000 1.3950,0.2941 1.3950 0.2941c 0.6050,0.2941 1.0084,0.8403 1.0084 0.8403c 0.4034,0.5462 0.6134,1.3109 0.6134 1.3109c 0.2101,0.7647 0.2101,1.7227 0.2101 1.7227c 0.0000,1.0420 -0.2857,1.8571 -0.2857 1.8571c -0.2857,0.8151 -0.7731,1.3866 -0.7731 1.3866c -0.4874,0.5714 -1.1261,0.8655 -1.1261 0.8655c -0.6387,0.2941 -1.3445,0.2941 -1.3445 0.2941c -0.5714,-0.0000 -1.1345,-0.2521 -1.1345 -0.2521c -0.5630,-0.2521 -1.1345,-0.6891 -1.1345 -0.6891ZM 217.1807,470.6891 ZM 217.1807,468.1849 c 0.5546,0.4706 1.0756,0.6639 1.0756 0.6639c 0.5210,0.1933 0.9244,0.1933 0.9244 0.1933c 0.5042,0.0000 0.9328,-0.2269 0.9328 -0.2269c 0.4286,-0.2269 0.7395,-0.6387 0.7395 -0.6387c 0.3109,-0.4118 0.4874,-1.0168 0.4874 -1.0168c 0.1765,-0.6050 0.1765,-1.3613 0.1765 -1.3613c 0.0000,-0.6723 -0.1176,-1.2269 -0.1176 -1.2269c -0.1176,-0.5546 -0.3782,-0.9496 -0.3782 -0.9496c -0.2605,-0.3950 -0.6723,-0.6134 -0.6723 -0.6134c -0.4118,-0.2185 -0.9832,-0.2185 -0.9832 -0.2185c -0.5210,-0.0000 -1.0504,0.2857 -1.0504 0.2857c -0.5294,0.2857 -1.1345,0.8235 -1.1345 0.8235v 4.2857 ZM 223.7521,470.0000 ZM 225.0126,461.8319 h 1.3950 v 4.9916 c 0.0000,1.1597 0.3613,1.6723 0.3613 1.6723c 0.3613,0.5126 1.1681,0.5126 1.1681 0.5126c 0.6387,0.0000 1.1261,-0.3277 1.1261 -0.3277c 0.4874,-0.3277 1.0756,-1.0504 1.0756 -1.0504v -5.7983 h 1.3782 v 8.1681 h -1.1429 l -0.1176,-1.2773 h -0.0504 c -0.5714,0.6723 -1.2017,1.0756 -1.2017 1.0756c -0.6303,0.4034 -1.4874,0.4034 -1.4874 0.4034c -1.3109,-0.0000 -1.9076,-0.8067 -1.9076 -0.8067c -0.5966,-0.8067 -0.5966,-2.3866 -0.5966 -2.3866v -5.1765 ZM 232.8950,470.0000 ZM 234.2731,461.8319 h 1.1429 l 0.1176,1.4790 h 0.0504 c 0.4202,-0.7731 1.0168,-1.2269 1.0168 -1.2269c 0.5966,-0.4538 1.3025,-0.4538 1.3025 -0.4538c 0.4874,0.0000 0.8739,0.1681 0.8739 0.1681l -0.2689,1.2101 c -0.2017,-0.0672 -0.3697,-0.1008 -0.3697 -0.1008c -0.1681,-0.0336 -0.4202,-0.0336 -0.4202 -0.0336c -0.5210,-0.0000 -1.0840,0.4202 -1.0840 0.4202c -0.5630,0.4202 -0.9832,1.4622 -0.9832 1.4622v 5.2437 h -1.3782 v -8.1681 ZM 238.5588,470.0000 ZM 239.3319,465.9328 c 0.0000,-1.0084 0.3109,-1.8067 0.3109 -1.8067c 0.3109,-0.7983 0.8235,-1.3529 0.8235 -1.3529c 0.5126,-0.5546 1.1681,-0.8487 1.1681 -0.8487c 0.6555,-0.2941 1.3613,-0.2941 1.3613 -0.2941c 0.7731,0.0000 1.3866,0.2689 1.3866 0.2689c 0.6134,0.2689 1.0252,0.7731 1.0252 0.7731c 0.4118,0.5042 0.6303,1.2101 0.6303 1.2101c 0.2185,0.7059 0.2185,1.5798 0.2185 1.5798c 0.0000,0.4538 -0.0504,0.7563 -0.0504 0.7563h -5.5126 c 0.0840,1.3277 0.8151,2.1008 0.8151 2.1008c 0.7311,0.7731 1.9076,0.7731 1.9076 0.7731c 0.5882,0.0000 1.0840,-0.1765 1.0840 -0.1765c 0.4958,-0.1765 0.9496,-0.4622 0.9496 -0.4622l 0.4874,0.9076 c -0.5378,0.3361 -1.1933,0.5882 -1.1933 0.5882c -0.6555,0.2521 -1.4958,0.2521 -1.4958 0.2521c -0.8235,-0.0000 -1.5378,-0.2941 -1.5378 -0.2941c -0.7143,-0.2941 -1.2437,-0.8403 -1.2437 -0.8403c -0.5294,-0.5462 -0.8319,-1.3361 -0.8319 -1.3361c -0.3025,-0.7899 -0.3025,-1.7983 -0.3025 -1.7983ZM 239.3319,465.9328 ZM 245.0462,465.3109 c 0.0000,-1.2605 -0.5294,-1.9244 -0.5294 -1.9244c -0.5294,-0.6639 -1.4874,-0.6639 -1.4874 -0.6639c -0.4370,-0.0000 -0.8319,0.1765 -0.8319 0.1765c -0.3950,0.1765 -0.7143,0.5042 -0.7143 0.5042c -0.3193,0.3277 -0.5294,0.8067 -0.5294 0.8067c -0.2101,0.4790 -0.2773,1.1008 -0.2773 1.1008h 4.3697 ZM 246.8950,470.0000 ZM 247.5840,465.2605 h 3.8655 v 1.0588 h -3.8655 v -1.0588 ZM 252.1218,470.0000 ZM 253.2815,468.1513 c 0.5378,0.4370 1.1008,0.7059 1.1008 0.7059c 0.5630,0.2689 1.3025,0.2689 1.3025 0.2689c 0.8067,0.0000 1.2101,-0.3697 1.2101 -0.3697c 0.4034,-0.3697 0.4034,-0.9076 0.4034 -0.9076c 0.0000,-0.3193 -0.1681,-0.5546 -0.1681 -0.5546c -0.1681,-0.2353 -0.4286,-0.4118 -0.4286 -0.4118c -0.2605,-0.1765 -0.5966,-0.3109 -0.5966 -0.3109l -0.6723,-0.2689 c -0.4370,-0.1513 -0.8739,-0.3445 -0.8739 -0.3445c -0.4370,-0.1933 -0.7815,-0.4706 -0.7815 -0.4706c -0.3445,-0.2773 -0.5630,-0.6471 -0.5630 -0.6471c -0.2185,-0.3697 -0.2185,-0.8908 -0.2185 -0.8908c 0.0000,-0.4874 0.1933,-0.9160 0.1933 -0.9160c 0.1933,-0.4286 0.5546,-0.7395 0.5546 -0.7395c 0.3613,-0.3109 0.8824,-0.4874 0.8824 -0.4874c 0.5210,-0.1765 1.1765,-0.1765 1.1765 -0.1765c 0.7731,0.0000 1.4202,0.2689 1.4202 0.2689c 0.6471,0.2689 1.1176,0.6555 1.1176 0.6555l -0.6555,0.8739 c -0.4202,-0.3193 -0.8739,-0.5210 -0.8739 -0.5210c -0.4538,-0.2017 -0.9916,-0.2017 -0.9916 -0.2017c -0.7731,-0.0000 -1.1345,0.3529 -1.1345 0.3529c -0.3613,0.3529 -0.3613,0.8235 -0.3613 0.8235c 0.0000,0.2857 0.1513,0.4958 0.1513 0.4958c 0.1513,0.2101 0.4034,0.3697 0.4034 0.3697c 0.2521,0.1597 0.5798,0.2857 0.5798 0.2857c 0.3277,0.1261 0.6807,0.2605 0.6807 0.2605c 0.4370,0.1681 0.8824,0.3529 0.8824 0.3529c 0.4454,0.1849 0.7983,0.4622 0.7983 0.4622c 0.3529,0.2773 0.5798,0.6807 0.5798 0.6807c 0.2269,0.4034 0.2269,0.9748 0.2269 0.9748c 0.0000,0.5042 -0.1933,0.9412 -0.1933 0.9412c -0.1933,0.4370 -0.5714,0.7731 -0.5714 0.7731c -0.3782,0.3361 -0.9412,0.5294 -0.9412 0.5294c -0.5630,0.1933 -1.2857,0.1933 -1.2857 0.1933c -0.8739,-0.0000 -1.6639,-0.3193 -1.6639 -0.3193c -0.7899,-0.3193 -1.3782,-0.8067 -1.3782 -0.8067ZM 259.1639,470.0000 ZM 260.7773,462.9580 h -1.2101 v -1.0420 l 1.2773,-0.0840 l 0.1681,-2.2857 h 1.1597 v 2.2857 h 2.2017 v 1.1261 h -2.2017 v 4.5378 c 0.0000,0.7563 0.2773,1.1681 0.2773 1.1681c 0.2773,0.4118 0.9832,0.4118 0.9832 0.4118c 0.2185,0.0000 0.4706,-0.0672 0.4706 -0.0672c 0.2521,-0.0672 0.4538,-0.1513 0.4538 -0.1513l 0.2689,1.0420 c -0.3361,0.1176 -0.7311,0.2101 -0.7311 0.2101c -0.3950,0.0924 -0.7815,0.0924 -0.7815 0.0924c -0.6555,-0.0000 -1.1008,-0.2017 -1.1008 -0.2017c -0.4454,-0.2017 -0.7227,-0.5546 -0.7227 -0.5546c -0.2773,-0.3529 -0.3950,-0.8571 -0.3950 -0.8571c -0.1176,-0.5042 -0.1176,-1.1092 -0.1176 -1.1092v -4.5210 ZM 264.8445,470.0000 ZM 266.2227,461.8319 h 1.1429 l 0.1176,1.4790 h 0.0504 c 0.4202,-0.7731 1.0168,-1.2269 1.0168 -1.2269c 0.5966,-0.4538 1.3025,-0.4538 1.3025 -0.4538c 0.4874,0.0000 0.8739,0.1681 0.8739 0.1681l -0.2689,1.2101 c -0.2017,-0.0672 -0.3697,-0.1008 -0.3697 -0.1008c -0.1681,-0.0336 -0.4202,-0.0336 -0.4202 -0.0336c -0.5210,-0.0000 -1.0840,0.4202 -1.0840 0.4202c -0.5630,0.4202 -0.9832,1.4622 -0.9832 1.4622v 5.2437 h -1.3782 v -8.1681 ZM 270.5084,470.0000 ZM 271.2815,465.9328 c 0.0000,-1.0084 0.3109,-1.8067 0.3109 -1.8067c 0.3109,-0.7983 0.8235,-1.3529 0.8235 -1.3529c 0.5126,-0.5546 1.1681,-0.8487 1.1681 -0.8487c 0.6555,-0.2941 1.3613,-0.2941 1.3613 -0.2941c 0.7731,0.0000 1.3866,0.2689 1.3866 0.2689c 0.6134,0.2689 1.0252,0.7731 1.0252 0.7731c 0.4118,0.5042 0.6303,1.2101 0.6303 1.2101c 0.2185,0.7059 0.2185,1.5798 0.2185 1.5798c 0.0000,0.4538 -0.0504,0.7563 -0.0504 0.7563h -5.5126 c 0.0840,1.3277 0.8151,2.1008 0.8151 2.1008c 0.7311,0.7731 1.9076,0.7731 1.9076 0.7731c 0.5882,0.0000 1.0840,-0.1765 1.0840 -0.1765c 0.4958,-0.1765 0.9496,-0.4622 0.9496 -0.4622l 0.4874,0.9076 c -0.5378,0.3361 -1.1933,0.5882 -1.1933 0.5882c -0.6555,0.2521 -1.4958,0.2521 -1.4958 0.2521c -0.8235,-0.0000 -1.5378,-0.2941 -1.5378 -0.2941c -0.7143,-0.2941 -1.2437,-0.8403 -1.2437 -0.8403c -0.5294,-0.5462 -0.8319,-1.3361 -0.8319 -1.3361c -0.3025,-0.7899 -0.3025,-1.7983 -0.3025 -1.7983ZM 271.2815,465.9328 ZM 276.9958,465.3109 c 0.0000,-1.2605 -0.5294,-1.9244 -0.5294 -1.9244c -0.5294,-0.6639 -1.4874,-0.6639 -1.4874 -0.6639c -0.4370,-0.0000 -0.8319,0.1765 -0.8319 0.1765c -0.3950,0.1765 -0.7143,0.5042 -0.7143 0.5042c -0.3193,0.3277 -0.5294,0.8067 -0.5294 0.8067c -0.2101,0.4790 -0.2773,1.1008 -0.2773 1.1008h 4.3697 ZM 278.6092,470.0000 ZM 279.5840,467.8824 c 0.0000,-1.3445 1.2017,-2.0588 1.2017 -2.0588c 1.2017,-0.7143 3.8235,-1.0000 3.8235 -1.0000c 0.0000,-0.3866 -0.0756,-0.7563 -0.0756 -0.7563c -0.0756,-0.3697 -0.2689,-0.6555 -0.2689 -0.6555c -0.1933,-0.2857 -0.5126,-0.4622 -0.5126 -0.4622c -0.3193,-0.1765 -0.8235,-0.1765 -0.8235 -0.1765c -0.7227,-0.0000 -1.3361,0.2689 -1.3361 0.2689c -0.6134,0.2689 -1.1008,0.6050 -1.1008 0.6050l -0.5546,-0.9580 c 0.5714,-0.3697 1.3950,-0.7143 1.3950 -0.7143c 0.8235,-0.3445 1.8151,-0.3445 1.8151 -0.3445c 1.4958,0.0000 2.1681,0.9160 2.1681 0.9160c 0.6723,0.9160 0.6723,2.4454 0.6723 2.4454v 5.0084 h -1.1429 l -0.1176,-0.9748 h -0.0336 c -0.5882,0.4874 -1.2689,0.8319 -1.2689 0.8319c -0.6807,0.3445 -1.4370,0.3445 -1.4370 0.3445c -1.0420,-0.0000 -1.7227,-0.6050 -1.7227 -0.6050c -0.6807,-0.6050 -0.6807,-1.7143 -0.6807 -1.7143ZM 279.5840,467.8824 ZM 280.9454,467.7815 c 0.0000,0.7059 0.4118,1.0084 0.4118 1.0084c 0.4118,0.3025 1.0168,0.3025 1.0168 0.3025c 0.5882,0.0000 1.1176,-0.2773 1.1176 -0.2773c 0.5294,-0.2773 1.1176,-0.8151 1.1176 -0.8151v -2.2689 c -1.0252,0.1345 -1.7311,0.3193 -1.7311 0.3193c -0.7059,0.1849 -1.1345,0.4370 -1.1345 0.4370c -0.4286,0.2521 -0.6134,0.5798 -0.6134 0.5798c -0.1849,0.3277 -0.1849,0.7143 -0.1849 0.7143ZM 287.2143,470.0000 ZM 288.5924,461.8319 h 1.1429 l 0.1176,1.1765 h 0.0504 c 0.5378,-0.5882 1.1681,-0.9832 1.1681 -0.9832c 0.6303,-0.3950 1.3697,-0.3950 1.3697 -0.3950c 0.9412,0.0000 1.4706,0.4118 1.4706 0.4118c 0.5294,0.4118 0.7815,1.1513 0.7815 1.1513c 0.6387,-0.7059 1.2857,-1.1345 1.2857 -1.1345c 0.6471,-0.4286 1.4034,-0.4286 1.4034 -0.4286c 1.2605,0.0000 1.8739,0.8067 1.8739 0.8067c 0.6134,0.8067 0.6134,2.3866 0.6134 2.3866v 5.1765 h -1.3782 v -4.9916 c 0.0000,-1.1597 -0.3697,-1.6723 -0.3697 -1.6723c -0.3697,-0.5126 -1.1429,-0.5126 -1.1429 -0.5126c -0.9244,-0.0000 -2.0504,1.2605 -2.0504 1.2605v 5.9160 h -1.3782 v -4.9916 c 0.0000,-1.1597 -0.3697,-1.6723 -0.3697 -1.6723c -0.3697,-0.5126 -1.1597,-0.5126 -1.1597 -0.5126c -0.9244,-0.0000 -2.0504,1.2605 -2.0504 1.2605v 5.9160 h -1.3782 v -8.1681 ZM 301.1471,470.0000 ZM 302.5252,458.0336 h 1.3782 v 10.4202 c 0.0000,0.3361 0.1176,0.4706 0.1176 0.4706c 0.1176,0.1345 0.2689,0.1345 0.2689 0.1345h 0.1261 c 0.0000,0.0000 0.1765,-0.0336 0.1765 -0.0336l 0.1849,1.0420 c -0.1345,0.0672 -0.3193,0.1008 -0.3193 0.1008c -0.1849,0.0336 -0.4706,0.0336 -0.4706 0.0336c -0.7899,-0.0000 -1.1261,-0.4706 -1.1261 -0.4706c -0.3361,-0.4706 -0.3361,-1.3782 -0.3361 -1.3782v -10.3193 ZM 305.4328,470.0000 ZM 306.2563,472.2521 l 0.3025,0.0756 c 0.0000,0.0000 0.3193,0.0420 0.3193 0.0420c 0.7059,0.0000 1.1513,-0.4958 1.1513 -0.4958c 0.4454,-0.4958 0.6975,-1.2521 0.6975 -1.2521l 0.1849,-0.6050 l -3.2773,-8.1849 h 1.4286 l 1.6639,4.5210 c 0.1849,0.5378 0.3950,1.1345 0.3950 1.1345c 0.2101,0.5966 0.3950,1.1681 0.3950 1.1681h 0.0672 c 0.1849,-0.5546 0.3529,-1.1597 0.3529 -1.1597c 0.1681,-0.6050 0.3361,-1.1429 0.3361 -1.1429l 1.4622,-4.5210 h 1.3445 l -3.0756,8.8403 c -0.2185,0.6050 -0.4874,1.1261 -0.4874 1.1261c -0.2689,0.5210 -0.6387,0.8992 -0.6387 0.8992c -0.3697,0.3782 -0.8403,0.5966 -0.8403 0.5966c -0.4706,0.2185 -1.0924,0.2185 -1.0924 0.2185c -0.2857,-0.0000 -0.5210,-0.0420 -0.5210 -0.0420c -0.2353,-0.0420 -0.4370,-0.1261 -0.4370 -0.1261l 0.2689,-1.0924 h 0.0000 ZM 313.2815,470.0000 ZM 316.8782,472.9580 c -1.0420,-1.6807 -1.6303,-3.5462 -1.6303 -3.5462c -0.5882,-1.8655 -0.5882,-4.0840 -0.5882 -4.0840c 0.0000,-2.2185 0.5882,-4.0756 0.5882 -4.0756c 0.5882,-1.8571 1.6303,-3.5546 1.6303 -3.5546l 0.8571,0.4034 c -0.9748,1.6134 -1.4538,3.4538 -1.4538 3.4538c -0.4790,1.8403 -0.4790,3.7731 -0.4790 3.7731c 0.0000,1.9328 0.4790,3.7731 0.4790 3.7731c 0.4790,1.8403 1.4538,3.4538 1.4538 3.4538l -0.8571,0.4034 h 0.0000 ZM 318.3739,470.0000 ZM 321.2815,465.7311 l -2.4706,-3.8992 h 1.4958 l 1.0924,1.7983 c 0.1849,0.3361 0.3866,0.6807 0.3866 0.6807c 0.2017,0.3445 0.4202,0.6807 0.4202 0.6807h 0.0672 c 0.1849,-0.3361 0.3697,-0.6807 0.3697 -0.6807c 0.1849,-0.3445 0.3697,-0.6807 0.3697 -0.6807l 0.9916,-1.7983 h 1.4454 l -2.4706,4.0504 l 2.6555,4.1176 h -1.4958 l -1.1933,-1.8992 l -0.4370,-0.7395 c 0.0000,0.0000 -0.4538,-0.7227 -0.4538 -0.7227h -0.0672 c -0.2185,0.3529 -0.4202,0.7143 -0.4202 0.7143c -0.2017,0.3613 -0.4034,0.7479 -0.4034 0.7479l -1.1092,1.8992 h -1.4454 ZM 325.8697,470.0000 ZM 326.5084,472.5546 c 0.9748,-1.6134 1.4538,-3.4538 1.4538 -3.4538c 0.4790,-1.8403 0.4790,-3.7731 0.4790 -3.7731c 0.0000,-1.9328 -0.4790,-3.7731 -0.4790 -3.7731c -0.4790,-1.8403 -1.4538,-3.4538 -1.4538 -3.4538l 0.8571,-0.4034 c 1.0420,1.6975 1.6303,3.5546 1.6303 3.5546c 0.5882,1.8571 0.5882,4.0756 0.5882 4.0756c 0.0000,2.2185 -0.5882,4.0840 -0.5882 4.0840c -0.5882,1.8655 -1.6303,3.5462 -1.6303 3.5462l -0.8571,-0.4034 h 0.0000 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,255)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 10.0000,480.0000 v 14.0000 h 22.0000 v -14.0000 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 39.1029,489.2500 ZM 39.7941,485.6912 c 0.0000,-0.8676 0.2574,-1.5662 0.2574 -1.5662c 0.2574,-0.6985 0.6838,-1.1838 0.6838 -1.1838c 0.4265,-0.4853 0.9853,-0.7500 0.9853 -0.7500c 0.5588,-0.2647 1.1765,-0.2647 1.1765 -0.2647c 0.6176,0.0000 1.0735,0.2206 1.0735 0.2206c 0.4559,0.2206 0.9265,0.6029 0.9265 0.6029l -0.0588,-1.2206 v -2.7500 h 1.2206 v 10.4706 h -1.0000 l -0.1029,-0.8382 h -0.0441 c -0.4265,0.4118 -0.9779,0.7132 -0.9779 0.7132c -0.5515,0.3015 -1.1838,0.3015 -1.1838 0.3015c -1.3529,-0.0000 -2.1544,-0.9706 -2.1544 -0.9706c -0.8015,-0.9706 -0.8015,-2.7647 -0.8015 -2.7647ZM 39.7941,485.6912 ZM 41.0441,485.6765 c 0.0000,1.2941 0.5147,2.0147 0.5147 2.0147c 0.5147,0.7206 1.4559,0.7206 1.4559 0.7206c 0.5000,0.0000 0.9412,-0.2426 0.9412 -0.2426c 0.4412,-0.2426 0.8824,-0.7426 0.8824 -0.7426v -3.7353 c -0.4559,-0.4118 -0.8750,-0.5809 -0.8750 -0.5809c -0.4191,-0.1691 -0.8603,-0.1691 -0.8603 -0.1691c -0.4265,-0.0000 -0.8015,0.1985 -0.8015 0.1985c -0.3750,0.1985 -0.6544,0.5588 -0.6544 0.5588c -0.2794,0.3603 -0.4412,0.8603 -0.4412 0.8603c -0.1618,0.5000 -0.1618,1.1176 -0.1618 1.1176ZM 47.2647,489.2500 ZM 48.4706,482.1029 h 1.0000 l 0.1029,1.2941 h 0.0441 c 0.3676,-0.6765 0.8897,-1.0735 0.8897 -1.0735c 0.5221,-0.3971 1.1397,-0.3971 1.1397 -0.3971c 0.4265,0.0000 0.7647,0.1471 0.7647 0.1471l -0.2353,1.0588 c -0.1765,-0.0588 -0.3235,-0.0882 -0.3235 -0.0882c -0.1471,-0.0294 -0.3676,-0.0294 -0.3676 -0.0294c -0.4559,-0.0000 -0.9485,0.3676 -0.9485 0.3676c -0.4926,0.3676 -0.8603,1.2794 -0.8603 1.2794v 4.5882 h -1.2059 v -7.1471 ZM 52.2206,489.2500 ZM 52.8971,485.6912 c 0.0000,-0.8971 0.2721,-1.5956 0.2721 -1.5956c 0.2721,-0.6985 0.7279,-1.1838 0.7279 -1.1838c 0.4559,-0.4853 1.0515,-0.7353 1.0515 -0.7353c 0.5956,-0.2500 1.2574,-0.2500 1.2574 -0.2500c 0.6618,0.0000 1.2574,0.2500 1.2574 0.2500c 0.5956,0.2500 1.0515,0.7353 1.0515 0.7353c 0.4559,0.4853 0.7279,1.1838 0.7279 1.1838c 0.2721,0.6985 0.2721,1.5956 0.2721 1.5956c 0.0000,0.8824 -0.2721,1.5809 -0.2721 1.5809c -0.2721,0.6985 -0.7279,1.1765 -0.7279 1.1765c -0.4559,0.4779 -1.0515,0.7279 -1.0515 0.7279c -0.5956,0.2500 -1.2574,0.2500 -1.2574 0.2500c -0.6618,-0.0000 -1.2574,-0.2500 -1.2574 -0.2500c -0.5956,-0.2500 -1.0515,-0.7279 -1.0515 -0.7279c -0.4559,-0.4779 -0.7279,-1.1765 -0.7279 -1.1765c -0.2721,-0.6985 -0.2721,-1.5809 -0.2721 -1.5809ZM 52.8971,485.6912 ZM 54.1471,485.6912 c 0.0000,0.6176 0.1471,1.1176 0.1471 1.1176c 0.1471,0.5000 0.4191,0.8603 0.4191 0.8603c 0.2721,0.3603 0.6544,0.5588 0.6544 0.5588c 0.3824,0.1985 0.8382,0.1985 0.8382 0.1985c 0.4559,0.0000 0.8382,-0.1985 0.8382 -0.1985c 0.3824,-0.1985 0.6544,-0.5588 0.6544 -0.5588c 0.2721,-0.3603 0.4191,-0.8603 0.4191 -0.8603c 0.1471,-0.5000 0.1471,-1.1176 0.1471 -1.1176c 0.0000,-0.6176 -0.1471,-1.1250 -0.1471 -1.1250c -0.1471,-0.5074 -0.4191,-0.8750 -0.4191 -0.8750c -0.2721,-0.3676 -0.6544,-0.5662 -0.6544 -0.5662c -0.3824,-0.1985 -0.8382,-0.1985 -0.8382 -0.1985c -0.4559,-0.0000 -0.8382,0.1985 -0.8382 0.1985c -0.3824,0.1985 -0.6544,0.5662 -0.6544 0.5662c -0.2721,0.3676 -0.4191,0.8750 -0.4191 0.8750c -0.1471,0.5074 -0.1471,1.1250 -0.1471 1.1250ZM 60.1912,489.2500 ZM 62.6029,489.8529 v 2.4118 h -1.2059 v -10.1618 h 1.0000 l 0.1029,0.8235 h 0.0441 c 0.4853,-0.4118 1.0662,-0.7059 1.0662 -0.7059c 0.5809,-0.2941 1.2132,-0.2941 1.2132 -0.2941c 0.6912,0.0000 1.2206,0.2574 1.2206 0.2574c 0.5294,0.2574 0.8824,0.7353 0.8824 0.7353c 0.3529,0.4779 0.5368,1.1471 0.5368 1.1471c 0.1838,0.6691 0.1838,1.5074 0.1838 1.5074c 0.0000,0.9118 -0.2500,1.6250 -0.2500 1.6250c -0.2500,0.7132 -0.6765,1.2132 -0.6765 1.2132c -0.4265,0.5000 -0.9853,0.7574 -0.9853 0.7574c -0.5588,0.2574 -1.1765,0.2574 -1.1765 0.2574c -0.5000,-0.0000 -0.9926,-0.2206 -0.9926 -0.2206c -0.4926,-0.2206 -0.9926,-0.6029 -0.9926 -0.6029ZM 62.6029,489.8529 ZM 62.6029,487.6618 c 0.4853,0.4118 0.9412,0.5809 0.9412 0.5809c 0.4559,0.1691 0.8088,0.1691 0.8088 0.1691c 0.4412,0.0000 0.8162,-0.1985 0.8162 -0.1985c 0.3750,-0.1985 0.6471,-0.5588 0.6471 -0.5588c 0.2721,-0.3603 0.4265,-0.8897 0.4265 -0.8897c 0.1544,-0.5294 0.1544,-1.1912 0.1544 -1.1912c 0.0000,-0.5882 -0.1029,-1.0735 -0.1029 -1.0735c -0.1029,-0.4853 -0.3309,-0.8309 -0.3309 -0.8309c -0.2279,-0.3456 -0.5882,-0.5368 -0.5882 -0.5368c -0.3603,-0.1912 -0.8603,-0.1912 -0.8603 -0.1912c -0.4559,-0.0000 -0.9191,0.2500 -0.9191 0.2500c -0.4632,0.2500 -0.9926,0.7206 -0.9926 0.7206v 3.7500 ZM 68.3529,489.2500 ZM 68.9559,485.1029 h 3.3824 v 0.9265 h -3.3824 v -0.9265 ZM 72.9265,489.2500 ZM 74.1324,482.1029 h 1.0000 l 0.1029,1.0294 h 0.0441 c 0.4706,-0.5147 1.0221,-0.8603 1.0221 -0.8603c 0.5515,-0.3456 1.1985,-0.3456 1.1985 -0.3456c 0.8235,0.0000 1.2868,0.3603 1.2868 0.3603c 0.4632,0.3603 0.6838,1.0074 0.6838 1.0074c 0.5588,-0.6176 1.1250,-0.9926 1.1250 -0.9926c 0.5662,-0.3750 1.2279,-0.3750 1.2279 -0.3750c 1.1029,0.0000 1.6397,0.7059 1.6397 0.7059c 0.5368,0.7059 0.5368,2.0882 0.5368 2.0882v 4.5294 h -1.2059 v -4.3676 c 0.0000,-1.0147 -0.3235,-1.4632 -0.3235 -1.4632c -0.3235,-0.4485 -1.0000,-0.4485 -1.0000 -0.4485c -0.8088,-0.0000 -1.7941,1.1029 -1.7941 1.1029v 5.1765 h -1.2059 v -4.3676 c 0.0000,-1.0147 -0.3235,-1.4632 -0.3235 -1.4632c -0.3235,-0.4485 -1.0147,-0.4485 -1.0147 -0.4485c -0.8088,-0.0000 -1.7941,1.1029 -1.7941 1.1029v 5.1765 h -1.2059 v -7.1471 ZM 85.1176,489.2500 ZM 85.9706,487.3971 c 0.0000,-1.1765 1.0515,-1.8015 1.0515 -1.8015c 1.0515,-0.6250 3.3456,-0.8750 3.3456 -0.8750c 0.0000,-0.3382 -0.0662,-0.6618 -0.0662 -0.6618c -0.0662,-0.3235 -0.2353,-0.5735 -0.2353 -0.5735c -0.1691,-0.2500 -0.4485,-0.4044 -0.4485 -0.4044c -0.2794,-0.1544 -0.7206,-0.1544 -0.7206 -0.1544c -0.6324,-0.0000 -1.1691,0.2353 -1.1691 0.2353c -0.5368,0.2353 -0.9632,0.5294 -0.9632 0.5294l -0.4853,-0.8382 c 0.5000,-0.3235 1.2206,-0.6250 1.2206 -0.6250c 0.7206,-0.3015 1.5882,-0.3015 1.5882 -0.3015c 1.3088,0.0000 1.8971,0.8015 1.8971 0.8015c 0.5882,0.8015 0.5882,2.1397 0.5882 2.1397v 4.3824 h -1.0000 l -0.1029,-0.8529 h -0.0294 c -0.5147,0.4265 -1.1103,0.7279 -1.1103 0.7279c -0.5956,0.3015 -1.2574,0.3015 -1.2574 0.3015c -0.9118,-0.0000 -1.5074,-0.5294 -1.5074 -0.5294c -0.5956,-0.5294 -0.5956,-1.5000 -0.5956 -1.5000ZM 85.9706,487.3971 ZM 87.1618,487.3088 c 0.0000,0.6176 0.3603,0.8824 0.3603 0.8824c 0.3603,0.2647 0.8897,0.2647 0.8897 0.2647c 0.5147,0.0000 0.9779,-0.2426 0.9779 -0.2426c 0.4632,-0.2426 0.9779,-0.7132 0.9779 -0.7132v -1.9853 c -0.8971,0.1176 -1.5147,0.2794 -1.5147 0.2794c -0.6176,0.1618 -0.9926,0.3824 -0.9926 0.3824c -0.3750,0.2206 -0.5368,0.5074 -0.5368 0.5074c -0.1618,0.2868 -0.1618,0.6250 -0.1618 0.6250ZM 92.6471,489.2500 ZM 95.0588,489.8529 v 2.4118 h -1.2059 v -10.1618 h 1.0000 l 0.1029,0.8235 h 0.0441 c 0.4853,-0.4118 1.0662,-0.7059 1.0662 -0.7059c 0.5809,-0.2941 1.2132,-0.2941 1.2132 -0.2941c 0.6912,0.0000 1.2206,0.2574 1.2206 0.2574c 0.5294,0.2574 0.8824,0.7353 0.8824 0.7353c 0.3529,0.4779 0.5368,1.1471 0.5368 1.1471c 0.1838,0.6691 0.1838,1.5074 0.1838 1.5074c 0.0000,0.9118 -0.2500,1.6250 -0.2500 1.6250c -0.2500,0.7132 -0.6765,1.2132 -0.6765 1.2132c -0.4265,0.5000 -0.9853,0.7574 -0.9853 0.7574c -0.5588,0.2574 -1.1765,0.2574 -1.1765 0.2574c -0.5000,-0.0000 -0.9926,-0.2206 -0.9926 -0.2206c -0.4926,-0.2206 -0.9926,-0.6029 -0.9926 -0.6029ZM 95.0588,489.8529 ZM 95.0588,487.6618 c 0.4853,0.4118 0.9412,0.5809 0.9412 0.5809c 0.4559,0.1691 0.8088,0.1691 0.8088 0.1691c 0.4412,0.0000 0.8162,-0.1985 0.8162 -0.1985c 0.3750,-0.1985 0.6471,-0.5588 0.6471 -0.5588c 0.2721,-0.3603 0.4265,-0.8897 0.4265 -0.8897c 0.1544,-0.5294 0.1544,-1.1912 0.1544 -1.1912c 0.0000,-0.5882 -0.1029,-1.0735 -0.1029 -1.0735c -0.1029,-0.4853 -0.3309,-0.8309 -0.3309 -0.8309c -0.2279,-0.3456 -0.5882,-0.5368 -0.5882 -0.5368c -0.3603,-0.1912 -0.8603,-0.1912 -0.8603 -0.1912c -0.4559,-0.0000 -0.9191,0.2500 -0.9191 0.2500c -0.4632,0.2500 -0.9926,0.7206 -0.9926 0.7206v 3.7500 ZM 103.7794,489.2500 ZM 106.3235,485.5147 l -2.1618,-3.4118 h 1.3088 l 0.9559,1.5735 c 0.1618,0.2941 0.3382,0.5956 0.3382 0.5956c 0.1765,0.3015 0.3676,0.5956 0.3676 0.5956h 0.0588 c 0.1618,-0.2941 0.3235,-0.5956 0.3235 -0.5956c 0.1618,-0.3015 0.3235,-0.5956 0.3235 -0.5956l 0.8676,-1.5735 h 1.2647 l -2.1618,3.5441 l 2.3235,3.6029 h -1.3088 l -1.0441,-1.6618 l -0.3824,-0.6471 c 0.0000,0.0000 -0.3971,-0.6324 -0.3971 -0.6324h -0.0588 c -0.1912,0.3088 -0.3676,0.6250 -0.3676 0.6250c -0.1765,0.3162 -0.3529,0.6544 -0.3529 0.6544l -0.9706,1.6618 h -1.2647 ZM 113.3088,489.2500 ZM 117.7794,485.6912 v -2.7206 c 0.0000,-0.3824 0.0221,-0.9044 0.0221 -0.9044c 0.0221,-0.5221 0.0515,-0.9044 0.0515 -0.9044h -0.0588 c -0.1765,0.3382 -0.3676,0.6618 -0.3676 0.6618c -0.1912,0.3235 -0.3971,0.6618 -0.3971 0.6618l -2.1912,3.2059 h 2.9412 ZM 117.7794,485.6912 ZM 120.2059,486.6618 h -1.2794 v 2.5882 h -1.1471 v -2.5882 h -4.2206 v -0.7941 l 4.0147,-6.0000 h 1.3529 v 5.8235 h 1.2794 v 0.9706 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,128,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 139.9265,480.0000 v 14.0000 h 22.0000 v -14.0000 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 169.0294,489.2500 ZM 173.4559,479.7647 c -0.3971,-0.1765 -0.8088,-0.1765 -0.8088 -0.1765c -1.0000,-0.0000 -1.0000,1.3824 -1.0000 1.3824v 1.1324 h 1.5147 v 0.9853 h -1.5147 v 6.1618 h -1.2059 v -6.1618 h -0.9706 v -0.9118 l 0.9706,-0.0735 v -1.1324 c 0.0000,-1.1029 0.5074,-1.7353 0.5074 -1.7353c 0.5074,-0.6324 1.5809,-0.6324 1.5809 -0.6324c 0.3382,0.0000 0.6397,0.0662 0.6397 0.0662c 0.3015,0.0662 0.5515,0.1691 0.5515 0.1691ZM 173.3235,489.2500 ZM 175.1471,480.6324 c -0.3529,-0.0000 -0.5956,-0.2206 -0.5956 -0.2206c -0.2426,-0.2206 -0.2426,-0.5588 -0.2426 -0.5588c 0.0000,-0.3529 0.2426,-0.5662 0.2426 -0.5662c 0.2426,-0.2132 0.5956,-0.2132 0.5956 -0.2132c 0.3529,0.0000 0.5956,0.2132 0.5956 0.2132c 0.2426,0.2132 0.2426,0.5662 0.2426 0.5662c 0.0000,0.3382 -0.2426,0.5588 -0.2426 0.5588c -0.2426,0.2206 -0.5956,0.2206 -0.5956 0.2206ZM 175.1471,480.6324 ZM 174.5294,482.1029 h 1.2059 v 7.1471 h -1.2059 v -7.1471 ZM 176.9412,489.2500 ZM 178.1471,478.7794 h 1.2059 v 9.1176 c 0.0000,0.2941 0.1029,0.4118 0.1029 0.4118c 0.1029,0.1176 0.2353,0.1176 0.2353 0.1176h 0.1103 c 0.0000,0.0000 0.1544,-0.0294 0.1544 -0.0294l 0.1618,0.9118 c -0.1176,0.0588 -0.2794,0.0882 -0.2794 0.0882c -0.1618,0.0294 -0.4118,0.0294 -0.4118 0.0294c -0.6912,-0.0000 -0.9853,-0.4118 -0.9853 -0.4118c -0.2941,-0.4118 -0.2941,-1.2059 -0.2941 -1.2059v -9.0294 ZM 180.6912,489.2500 ZM 182.1029,483.0882 h -1.0588 v -0.9118 l 1.1176,-0.0735 l 0.1471,-2.0000 h 1.0147 v 2.0000 h 1.9265 v 0.9853 h -1.9265 v 3.9706 c 0.0000,0.6618 0.2426,1.0221 0.2426 1.0221c 0.2426,0.3603 0.8603,0.3603 0.8603 0.3603c 0.1912,0.0000 0.4118,-0.0588 0.4118 -0.0588c 0.2206,-0.0588 0.3971,-0.1324 0.3971 -0.1324l 0.2353,0.9118 c -0.2941,0.1029 -0.6397,0.1838 -0.6397 0.1838c -0.3456,0.0809 -0.6838,0.0809 -0.6838 0.0809c -0.5735,-0.0000 -0.9632,-0.1765 -0.9632 -0.1765c -0.3897,-0.1765 -0.6324,-0.4853 -0.6324 -0.4853c -0.2426,-0.3088 -0.3456,-0.7500 -0.3456 -0.7500c -0.1029,-0.4412 -0.1029,-0.9706 -0.1029 -0.9706v -3.9559 ZM 185.5147,489.2500 ZM 186.1912,485.6912 c 0.0000,-0.8824 0.2721,-1.5809 0.2721 -1.5809c 0.2721,-0.6985 0.7206,-1.1838 0.7206 -1.1838c 0.4485,-0.4853 1.0221,-0.7426 1.0221 -0.7426c 0.5735,-0.2574 1.1912,-0.2574 1.1912 -0.2574c 0.6765,0.0000 1.2132,0.2353 1.2132 0.2353c 0.5368,0.2353 0.8971,0.6765 0.8971 0.6765c 0.3603,0.4412 0.5515,1.0588 0.5515 1.0588c 0.1912,0.6176 0.1912,1.3824 0.1912 1.3824c 0.0000,0.3971 -0.0441,0.6618 -0.0441 0.6618h -4.8235 c 0.0735,1.1618 0.7132,1.8382 0.7132 1.8382c 0.6397,0.6765 1.6691,0.6765 1.6691 0.6765c 0.5147,0.0000 0.9485,-0.1544 0.9485 -0.1544c 0.4338,-0.1544 0.8309,-0.4044 0.8309 -0.4044l 0.4265,0.7941 c -0.4706,0.2941 -1.0441,0.5147 -1.0441 0.5147c -0.5735,0.2206 -1.3088,0.2206 -1.3088 0.2206c -0.7206,-0.0000 -1.3456,-0.2574 -1.3456 -0.2574c -0.6250,-0.2574 -1.0882,-0.7353 -1.0882 -0.7353c -0.4632,-0.4779 -0.7279,-1.1691 -0.7279 -1.1691c -0.2647,-0.6912 -0.2647,-1.5735 -0.2647 -1.5735ZM 186.1912,485.6912 ZM 191.1912,485.1471 c 0.0000,-1.1029 -0.4632,-1.6838 -0.4632 -1.6838c -0.4632,-0.5809 -1.3015,-0.5809 -1.3015 -0.5809c -0.3824,-0.0000 -0.7279,0.1544 -0.7279 0.1544c -0.3456,0.1544 -0.6250,0.4412 -0.6250 0.4412c -0.2794,0.2868 -0.4632,0.7059 -0.4632 0.7059c -0.1838,0.4191 -0.2426,0.9632 -0.2426 0.9632h 3.8235 ZM 192.8088,489.2500 ZM 194.0147,482.1029 h 1.0000 l 0.1029,1.2941 h 0.0441 c 0.3676,-0.6765 0.8897,-1.0735 0.8897 -1.0735c 0.5221,-0.3971 1.1397,-0.3971 1.1397 -0.3971c 0.4265,0.0000 0.7647,0.1471 0.7647 0.1471l -0.2353,1.0588 c -0.1765,-0.0588 -0.3235,-0.0882 -0.3235 -0.0882c -0.1471,-0.0294 -0.3676,-0.0294 -0.3676 -0.0294c -0.4559,-0.0000 -0.9485,0.3676 -0.9485 0.3676c -0.4926,0.3676 -0.8603,1.2794 -0.8603 1.2794v 4.5882 h -1.2059 v -7.1471 ZM 197.9118,489.2500 ZM 198.5147,485.1029 h 3.3824 v 0.9265 h -3.3824 v -0.9265 ZM 202.4853,489.2500 ZM 203.1765,485.6912 c 0.0000,-0.8676 0.2574,-1.5662 0.2574 -1.5662c 0.2574,-0.6985 0.6838,-1.1838 0.6838 -1.1838c 0.4265,-0.4853 0.9853,-0.7500 0.9853 -0.7500c 0.5588,-0.2647 1.1765,-0.2647 1.1765 -0.2647c 0.6176,0.0000 1.0735,0.2206 1.0735 0.2206c 0.4559,0.2206 0.9265,0.6029 0.9265 0.6029l -0.0588,-1.2206 v -2.7500 h 1.2206 v 10.4706 h -1.0000 l -0.1029,-0.8382 h -0.0441 c -0.4265,0.4118 -0.9779,0.7132 -0.9779 0.7132c -0.5515,0.3015 -1.1838,0.3015 -1.1838 0.3015c -1.3529,-0.0000 -2.1544,-0.9706 -2.1544 -0.9706c -0.8015,-0.9706 -0.8015,-2.7647 -0.8015 -2.7647ZM 203.1765,485.6912 ZM 204.4265,485.6765 c 0.0000,1.2941 0.5147,2.0147 0.5147 2.0147c 0.5147,0.7206 1.4559,0.7206 1.4559 0.7206c 0.5000,0.0000 0.9412,-0.2426 0.9412 -0.2426c 0.4412,-0.2426 0.8824,-0.7426 0.8824 -0.7426v -3.7353 c -0.4559,-0.4118 -0.8750,-0.5809 -0.8750 -0.5809c -0.4191,-0.1691 -0.8603,-0.1691 -0.8603 -0.1691c -0.4265,-0.0000 -0.8015,0.1985 -0.8015 0.1985c -0.3750,0.1985 -0.6544,0.5588 -0.6544 0.5588c -0.2794,0.3603 -0.4412,0.8603 -0.4412 0.8603c -0.1618,0.5000 -0.1618,1.1176 -0.1618 1.1176ZM 210.6471,489.2500 ZM 211.8529,482.1029 h 1.0000 l 0.1029,1.2941 h 0.0441 c 0.3676,-0.6765 0.8897,-1.0735 0.8897 -1.0735c 0.5221,-0.3971 1.1397,-0.3971 1.1397 -0.3971c 0.4265,0.0000 0.7647,0.1471 0.7647 0.1471l -0.2353,1.0588 c -0.1765,-0.0588 -0.3235,-0.0882 -0.3235 -0.0882c -0.1471,-0.0294 -0.3676,-0.0294 -0.3676 -0.0294c -0.4559,-0.0000 -0.9485,0.3676 -0.9485 0.3676c -0.4926,0.3676 -0.8603,1.2794 -0.8603 1.2794v 4.5882 h -1.2059 v -7.1471 ZM 215.6029,489.2500 ZM 216.2794,485.6912 c 0.0000,-0.8971 0.2721,-1.5956 0.2721 -1.5956c 0.2721,-0.6985 0.7279,-1.1838 0.7279 -1.1838c 0.4559,-0.4853 1.0515,-0.7353 1.0515 -0.7353c 0.5956,-0.2500 1.2574,-0.2500 1.2574 -0.2500c 0.6618,0.0000 1.2574,0.2500 1.2574 0.2500c 0.5956,0.2500 1.0515,0.7353 1.0515 0.7353c 0.4559,0.4853 0.7279,1.1838 0.7279 1.1838c 0.2721,0.6985 0.2721,1.5956 0.2721 1.5956c 0.0000,0.8824 -0.2721,1.5809 -0.2721 1.5809c -0.2721,0.6985 -0.7279,1.1765 -0.7279 1.1765c -0.4559,0.4779 -1.0515,0.7279 -1.0515 0.7279c -0.5956,0.2500 -1.2574,0.2500 -1.2574 0.2500c -0.6618,-0.0000 -1.2574,-0.2500 -1.2574 -0.2500c -0.5956,-0.2500 -1.0515,-0.7279 -1.0515 -0.7279c -0.4559,-0.4779 -0.7279,-1.1765 -0.7279 -1.1765c -0.2721,-0.6985 -0.2721,-1.5809 -0.2721 -1.5809ZM 216.2794,485.6912 ZM 217.5294,485.6912 c 0.0000,0.6176 0.1471,1.1176 0.1471 1.1176c 0.1471,0.5000 0.4191,0.8603 0.4191 0.8603c 0.2721,0.3603 0.6544,0.5588 0.6544 0.5588c 0.3824,0.1985 0.8382,0.1985 0.8382 0.1985c 0.4559,0.0000 0.8382,-0.1985 0.8382 -0.1985c 0.3824,-0.1985 0.6544,-0.5588 0.6544 -0.5588c 0.2721,-0.3603 0.4191,-0.8603 0.4191 -0.8603c 0.1471,-0.5000 0.1471,-1.1176 0.1471 -1.1176c 0.0000,-0.6176 -0.1471,-1.1250 -0.1471 -1.1250c -0.1471,-0.5074 -0.4191,-0.8750 -0.4191 -0.8750c -0.2721,-0.3676 -0.6544,-0.5662 -0.6544 -0.5662c -0.3824,-0.1985 -0.8382,-0.1985 -0.8382 -0.1985c -0.4559,-0.0000 -0.8382,0.1985 -0.8382 0.1985c -0.3824,0.1985 -0.6544,0.5662 -0.6544 0.5662c -0.2721,0.3676 -0.4191,0.8750 -0.4191 0.8750c -0.1471,0.5074 -0.1471,1.1250 -0.1471 1.1250ZM 223.5735,489.2500 ZM 225.9853,489.8529 v 2.4118 h -1.2059 v -10.1618 h 1.0000 l 0.1029,0.8235 h 0.0441 c 0.4853,-0.4118 1.0662,-0.7059 1.0662 -0.7059c 0.5809,-0.2941 1.2132,-0.2941 1.2132 -0.2941c 0.6912,0.0000 1.2206,0.2574 1.2206 0.2574c 0.5294,0.2574 0.8824,0.7353 0.8824 0.7353c 0.3529,0.4779 0.5368,1.1471 0.5368 1.1471c 0.1838,0.6691 0.1838,1.5074 0.1838 1.5074c 0.0000,0.9118 -0.2500,1.6250 -0.2500 1.6250c -0.2500,0.7132 -0.6765,1.2132 -0.6765 1.2132c -0.4265,0.5000 -0.9853,0.7574 -0.9853 0.7574c -0.5588,0.2574 -1.1765,0.2574 -1.1765 0.2574c -0.5000,-0.0000 -0.9926,-0.2206 -0.9926 -0.2206c -0.4926,-0.2206 -0.9926,-0.6029 -0.9926 -0.6029ZM 225.9853,489.8529 ZM 225.9853,487.6618 c 0.4853,0.4118 0.9412,0.5809 0.9412 0.5809c 0.4559,0.1691 0.8088,0.1691 0.8088 0.1691c 0.4412,0.0000 0.8162,-0.1985 0.8162 -0.1985c 0.3750,-0.1985 0.6471,-0.5588 0.6471 -0.5588c 0.2721,-0.3603 0.4265,-0.8897 0.4265 -0.8897c 0.1544,-0.5294 0.1544,-1.1912 0.1544 -1.1912c 0.0000,-0.5882 -0.1029,-1.0735 -0.1029 -1.0735c -0.1029,-0.4853 -0.3309,-0.8309 -0.3309 -0.8309c -0.2279,-0.3456 -0.5882,-0.5368 -0.5882 -0.5368c -0.3603,-0.1912 -0.8603,-0.1912 -0.8603 -0.1912c -0.4559,-0.0000 -0.9191,0.2500 -0.9191 0.2500c -0.4632,0.2500 -0.9926,0.7206 -0.9926 0.7206v 3.7500 ZM 234.7059,489.2500 ZM 237.2500,485.5147 l -2.1618,-3.4118 h 1.3088 l 0.9559,1.5735 c 0.1618,0.2941 0.3382,0.5956 0.3382 0.5956c 0.1765,0.3015 0.3676,0.5956 0.3676 0.5956h 0.0588 c 0.1618,-0.2941 0.3235,-0.5956 0.3235 -0.5956c 0.1618,-0.3015 0.3235,-0.5956 0.3235 -0.5956l 0.8676,-1.5735 h 1.2647 l -2.1618,3.5441 l 2.3235,3.6029 h -1.3088 l -1.0441,-1.6618 l -0.3824,-0.6471 c 0.0000,0.0000 -0.3971,-0.6324 -0.3971 -0.6324h -0.0588 c -0.1912,0.3088 -0.3676,0.6250 -0.3676 0.6250c -0.1765,0.3162 -0.3529,0.6544 -0.3529 0.6544l -0.9706,1.6618 h -1.2647 ZM 244.2353,489.2500 ZM 248.7059,485.6912 v -2.7206 c 0.0000,-0.3824 0.0221,-0.9044 0.0221 -0.9044c 0.0221,-0.5221 0.0515,-0.9044 0.0515 -0.9044h -0.0588 c -0.1765,0.3382 -0.3676,0.6618 -0.3676 0.6618c -0.1912,0.3235 -0.3971,0.6618 -0.3971 0.6618l -2.1912,3.2059 h 2.9412 ZM 248.7059,485.6912 ZM 251.1324,486.6618 h -1.2794 v 2.5882 h -1.1471 v -2.5882 h -4.2206 v -0.7941 l 4.0147,-6.0000 h 1.3529 v 5.8235 h 1.2794 v 0.9706 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(255,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 288.1471,480.0000 v 14.0000 h 22.0000 v -14.0000 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 317.2500,489.2500 ZM 321.6765,479.7647 c -0.3971,-0.1765 -0.8088,-0.1765 -0.8088 -0.1765c -1.0000,-0.0000 -1.0000,1.3824 -1.0000 1.3824v 1.1324 h 1.5147 v 0.9853 h -1.5147 v 6.1618 h -1.2059 v -6.1618 h -0.9706 v -0.9118 l 0.9706,-0.0735 v -1.1324 c 0.0000,-1.1029 0.5074,-1.7353 0.5074 -1.7353c 0.5074,-0.6324 1.5809,-0.6324 1.5809 -0.6324c 0.3382,0.0000 0.6397,0.0662 0.6397 0.0662c 0.3015,0.0662 0.5515,0.1691 0.5515 0.1691ZM 321.5441,489.2500 ZM 323.3676,480.6324 c -0.3529,-0.0000 -0.5956,-0.2206 -0.5956 -0.2206c -0.2426,-0.2206 -0.2426,-0.5588 -0.2426 -0.5588c 0.0000,-0.3529 0.2426,-0.5662 0.2426 -0.5662c 0.2426,-0.2132 0.5956,-0.2132 0.5956 -0.2132c 0.3529,0.0000 0.5956,0.2132 0.5956 0.2132c 0.2426,0.2132 0.2426,0.5662 0.2426 0.5662c 0.0000,0.3382 -0.2426,0.5588 -0.2426 0.5588c -0.2426,0.2206 -0.5956,0.2206 -0.5956 0.2206ZM 323.3676,480.6324 ZM 322.7500,482.1029 h 1.2059 v 7.1471 h -1.2059 v -7.1471 ZM 325.1618,489.2500 ZM 326.3676,478.7794 h 1.2059 v 9.1176 c 0.0000,0.2941 0.1029,0.4118 0.1029 0.4118c 0.1029,0.1176 0.2353,0.1176 0.2353 0.1176h 0.1103 c 0.0000,0.0000 0.1544,-0.0294 0.1544 -0.0294l 0.1618,0.9118 c -0.1176,0.0588 -0.2794,0.0882 -0.2794 0.0882c -0.1618,0.0294 -0.4118,0.0294 -0.4118 0.0294c -0.6912,-0.0000 -0.9853,-0.4118 -0.9853 -0.4118c -0.2941,-0.4118 -0.2941,-1.2059 -0.2941 -1.2059v -9.0294 ZM 328.9118,489.2500 ZM 330.3235,483.0882 h -1.0588 v -0.9118 l 1.1176,-0.0735 l 0.1471,-2.0000 h 1.0147 v 2.0000 h 1.9265 v 0.9853 h -1.9265 v 3.9706 c 0.0000,0.6618 0.2426,1.0221 0.2426 1.0221c 0.2426,0.3603 0.8603,0.3603 0.8603 0.3603c 0.1912,0.0000 0.4118,-0.0588 0.4118 -0.0588c 0.2206,-0.0588 0.3971,-0.1324 0.3971 -0.1324l 0.2353,0.9118 c -0.2941,0.1029 -0.6397,0.1838 -0.6397 0.1838c -0.3456,0.0809 -0.6838,0.0809 -0.6838 0.0809c -0.5735,-0.0000 -0.9632,-0.1765 -0.9632 -0.1765c -0.3897,-0.1765 -0.6324,-0.4853 -0.6324 -0.4853c -0.2426,-0.3088 -0.3456,-0.7500 -0.3456 -0.7500c -0.1029,-0.4412 -0.1029,-0.9706 -0.1029 -0.9706v -3.9559 ZM 333.7353,489.2500 ZM 334.4118,485.6912 c 0.0000,-0.8824 0.2721,-1.5809 0.2721 -1.5809c 0.2721,-0.6985 0.7206,-1.1838 0.7206 -1.1838c 0.4485,-0.4853 1.0221,-0.7426 1.0221 -0.7426c 0.5735,-0.2574 1.1912,-0.2574 1.1912 -0.2574c 0.6765,0.0000 1.2132,0.2353 1.2132 0.2353c 0.5368,0.2353 0.8971,0.6765 0.8971 0.6765c 0.3603,0.4412 0.5515,1.0588 0.5515 1.0588c 0.1912,0.6176 0.1912,1.3824 0.1912 1.3824c 0.0000,0.3971 -0.0441,0.6618 -0.0441 0.6618h -4.8235 c 0.0735,1.1618 0.7132,1.8382 0.7132 1.8382c 0.6397,0.6765 1.6691,0.6765 1.6691 0.6765c 0.5147,0.0000 0.9485,-0.1544 0.9485 -0.1544c 0.4338,-0.1544 0.8309,-0.4044 0.8309 -0.4044l 0.4265,0.7941 c -0.4706,0.2941 -1.0441,0.5147 -1.0441 0.5147c -0.5735,0.2206 -1.3088,0.2206 -1.3088 0.2206c -0.7206,-0.0000 -1.3456,-0.2574 -1.3456 -0.2574c -0.6250,-0.2574 -1.0882,-0.7353 -1.0882 -0.7353c -0.4632,-0.4779 -0.7279,-1.1691 -0.7279 -1.1691c -0.2647,-0.6912 -0.2647,-1.5735 -0.2647 -1.5735ZM 334.4118,485.6912 ZM 339.4118,485.1471 c 0.0000,-1.1029 -0.4632,-1.6838 -0.4632 -1.6838c -0.4632,-0.5809 -1.3015,-0.5809 -1.3015 -0.5809c -0.3824,-0.0000 -0.7279,0.1544 -0.7279 0.1544c -0.3456,0.1544 -0.6250,0.4412 -0.6250 0.4412c -0.2794,0.2868 -0.4632,0.7059 -0.4632 0.7059c -0.1838,0.4191 -0.2426,0.9632 -0.2426 0.9632h 3.8235 ZM 341.0294,489.2500 ZM 342.2353,482.1029 h 1.0000 l 0.1029,1.2941 h 0.0441 c 0.3676,-0.6765 0.8897,-1.0735 0.8897 -1.0735c 0.5221,-0.3971 1.1397,-0.3971 1.1397 -0.3971c 0.4265,0.0000 0.7647,0.1471 0.7647 0.1471l -0.2353,1.0588 c -0.1765,-0.0588 -0.3235,-0.0882 -0.3235 -0.0882c -0.1471,-0.0294 -0.3676,-0.0294 -0.3676 -0.0294c -0.4559,-0.0000 -0.9485,0.3676 -0.9485 0.3676c -0.4926,0.3676 -0.8603,1.2794 -0.8603 1.2794v 4.5882 h -1.2059 v -7.1471 ZM 346.1324,489.2500 ZM 346.7353,485.1029 h 3.3824 v 0.9265 h -3.3824 v -0.9265 ZM 350.7059,489.2500 ZM 351.7206,487.6324 c 0.4706,0.3824 0.9632,0.6176 0.9632 0.6176c 0.4926,0.2353 1.1397,0.2353 1.1397 0.2353c 0.7059,0.0000 1.0588,-0.3235 1.0588 -0.3235c 0.3529,-0.3235 0.3529,-0.7941 0.3529 -0.7941c 0.0000,-0.2794 -0.1471,-0.4853 -0.1471 -0.4853c -0.1471,-0.2059 -0.3750,-0.3603 -0.3750 -0.3603c -0.2279,-0.1544 -0.5221,-0.2721 -0.5221 -0.2721l -0.5882,-0.2353 c -0.3824,-0.1324 -0.7647,-0.3015 -0.7647 -0.3015c -0.3824,-0.1691 -0.6838,-0.4118 -0.6838 -0.4118c -0.3015,-0.2426 -0.4926,-0.5662 -0.4926 -0.5662c -0.1912,-0.3235 -0.1912,-0.7794 -0.1912 -0.7794c 0.0000,-0.4265 0.1691,-0.8015 0.1691 -0.8015c 0.1691,-0.3750 0.4853,-0.6471 0.4853 -0.6471c 0.3162,-0.2721 0.7721,-0.4265 0.7721 -0.4265c 0.4559,-0.1544 1.0294,-0.1544 1.0294 -0.1544c 0.6765,0.0000 1.2426,0.2353 1.2426 0.2353c 0.5662,0.2353 0.9779,0.5735 0.9779 0.5735l -0.5735,0.7647 c -0.3676,-0.2794 -0.7647,-0.4559 -0.7647 -0.4559c -0.3971,-0.1765 -0.8676,-0.1765 -0.8676 -0.1765c -0.6765,-0.0000 -0.9926,0.3088 -0.9926 0.3088c -0.3162,0.3088 -0.3162,0.7206 -0.3162 0.7206c 0.0000,0.2500 0.1324,0.4338 0.1324 0.4338c 0.1324,0.1838 0.3529,0.3235 0.3529 0.3235c 0.2206,0.1397 0.5074,0.2500 0.5074 0.2500c 0.2868,0.1103 0.5956,0.2279 0.5956 0.2279c 0.3824,0.1471 0.7721,0.3088 0.7721 0.3088c 0.3897,0.1618 0.6985,0.4044 0.6985 0.4044c 0.3088,0.2426 0.5074,0.5956 0.5074 0.5956c 0.1985,0.3529 0.1985,0.8529 0.1985 0.8529c 0.0000,0.4412 -0.1691,0.8235 -0.1691 0.8235c -0.1691,0.3824 -0.5000,0.6765 -0.5000 0.6765c -0.3309,0.2941 -0.8235,0.4632 -0.8235 0.4632c -0.4926,0.1691 -1.1250,0.1691 -1.1250 0.1691c -0.7647,-0.0000 -1.4559,-0.2794 -1.4559 -0.2794c -0.6912,-0.2794 -1.2059,-0.7059 -1.2059 -0.7059ZM 356.8676,489.2500 ZM 357.5441,485.6912 c 0.0000,-0.8971 0.2794,-1.5956 0.2794 -1.5956c 0.2794,-0.6985 0.7500,-1.1838 0.7500 -1.1838c 0.4706,-0.4853 1.0956,-0.7353 1.0956 -0.7353c 0.6250,-0.2500 1.3162,-0.2500 1.3162 -0.2500c 0.7059,0.0000 1.2132,0.2574 1.2132 0.2574c 0.5074,0.2574 0.8750,0.5956 0.8750 0.5956l -0.6029,0.7794 c -0.3235,-0.2794 -0.6691,-0.4559 -0.6691 -0.4559c -0.3456,-0.1765 -0.7721,-0.1765 -0.7721 -0.1765c -0.4853,-0.0000 -0.8971,0.1985 -0.8971 0.1985c -0.4118,0.1985 -0.7059,0.5662 -0.7059 0.5662c -0.2941,0.3676 -0.4632,0.8750 -0.4632 0.8750c -0.1691,0.5074 -0.1691,1.1250 -0.1691 1.1250c 0.0000,0.6176 0.1618,1.1176 0.1618 1.1176c 0.1618,0.5000 0.4485,0.8603 0.4485 0.8603c 0.2868,0.3603 0.6985,0.5588 0.6985 0.5588c 0.4118,0.1985 0.8971,0.1985 0.8971 0.1985c 0.5147,0.0000 0.9338,-0.2132 0.9338 -0.2132c 0.4191,-0.2132 0.7426,-0.5074 0.7426 -0.5074l 0.5441,0.7941 c -0.4853,0.4265 -1.0809,0.6765 -1.0809 0.6765c -0.5956,0.2500 -1.2426,0.2500 -1.2426 0.2500c -0.7059,-0.0000 -1.3235,-0.2500 -1.3235 -0.2500c -0.6176,-0.2500 -1.0662,-0.7279 -1.0662 -0.7279c -0.4485,-0.4779 -0.7059,-1.1765 -0.7059 -1.1765c -0.2574,-0.6985 -0.2574,-1.5809 -0.2574 -1.5809ZM 363.4265,489.2500 ZM 364.2794,487.3971 c 0.0000,-1.1765 1.0515,-1.8015 1.0515 -1.8015c 1.0515,-0.6250 3.3456,-0.8750 3.3456 -0.8750c 0.0000,-0.3382 -0.0662,-0.6618 -0.0662 -0.6618c -0.0662,-0.3235 -0.2353,-0.5735 -0.2353 -0.5735c -0.1691,-0.2500 -0.4485,-0.4044 -0.4485 -0.4044c -0.2794,-0.1544 -0.7206,-0.1544 -0.7206 -0.1544c -0.6324,-0.0000 -1.1691,0.2353 -1.1691 0.2353c -0.5368,0.2353 -0.9632,0.5294 -0.9632 0.5294l -0.4853,-0.8382 c 0.5000,-0.3235 1.2206,-0.6250 1.2206 -0.6250c 0.7206,-0.3015 1.5882,-0.3015 1.5882 -0.3015c 1.3088,0.0000 1.8971,0.8015 1.8971 0.8015c 0.5882,0.8015 0.5882,2.1397 0.5882 2.1397v 4.3824 h -1.0000 l -0.1029,-0.8529 h -0.0294 c -0.5147,0.4265 -1.1103,0.7279 -1.1103 0.7279c -0.5956,0.3015 -1.2574,0.3015 -1.2574 0.3015c -0.9118,-0.0000 -1.5074,-0.5294 -1.5074 -0.5294c -0.5956,-0.5294 -0.5956,-1.5000 -0.5956 -1.5000ZM 364.2794,487.3971 ZM 365.4706,487.3088 c 0.0000,0.6176 0.3603,0.8824 0.3603 0.8824c 0.3603,0.2647 0.8897,0.2647 0.8897 0.2647c 0.5147,0.0000 0.9779,-0.2426 0.9779 -0.2426c 0.4632,-0.2426 0.9779,-0.7132 0.9779 -0.7132v -1.9853 c -0.8971,0.1176 -1.5147,0.2794 -1.5147 0.2794c -0.6176,0.1618 -0.9926,0.3824 -0.9926 0.3824c -0.3750,0.2206 -0.5368,0.5074 -0.5368 0.5074c -0.1618,0.2868 -0.1618,0.6250 -0.1618 0.6250ZM 370.9559,489.2500 ZM 372.1618,482.1029 h 1.0000 l 0.1029,1.0294 h 0.0441 c 0.5147,-0.5147 1.0809,-0.8603 1.0809 -0.8603c 0.5662,-0.3456 1.3162,-0.3456 1.3162 -0.3456c 1.1324,0.0000 1.6544,0.7059 1.6544 0.7059c 0.5221,0.7059 0.5221,2.0882 0.5221 2.0882v 4.5294 h -1.2059 v -4.3676 c 0.0000,-1.0147 -0.3235,-1.4632 -0.3235 -1.4632c -0.3235,-0.4485 -1.0294,-0.4485 -1.0294 -0.4485c -0.5588,-0.0000 -0.9853,0.2794 -0.9853 0.2794c -0.4265,0.2794 -0.9706,0.8235 -0.9706 0.8235v 5.1765 h -1.2059 v -7.1471 ZM 381.9706,489.2500 ZM 384.5147,485.5147 l -2.1618,-3.4118 h 1.3088 l 0.9559,1.5735 c 0.1618,0.2941 0.3382,0.5956 0.3382 0.5956c 0.1765,0.3015 0.3676,0.5956 0.3676 0.5956h 0.0588 c 0.1618,-0.2941 0.3235,-0.5956 0.3235 -0.5956c 0.1618,-0.3015 0.3235,-0.5956 0.3235 -0.5956l 0.8676,-1.5735 h 1.2647 l -2.1618,3.5441 l 2.3235,3.6029 h -1.3088 l -1.0441,-1.6618 l -0.3824,-0.6471 c 0.0000,0.0000 -0.3971,-0.6324 -0.3971 -0.6324h -0.0588 c -0.1912,0.3088 -0.3676,0.6250 -0.3676 0.6250c -0.1765,0.3162 -0.3529,0.6544 -0.3529 0.6544l -0.9706,1.6618 h -1.2647 ZM 391.5000,489.2500 ZM 395.9706,485.6912 v -2.7206 c 0.0000,-0.3824 0.0221,-0.9044 0.0221 -0.9044c 0.0221,-0.5221 0.0515,-0.9044 0.0515 -0.9044h -0.0588 c -0.1765,0.3382 -0.3676,0.6618 -0.3676 0.6618c -0.1912,0.3235 -0.3971,0.6618 -0.3971 0.6618l -2.1912,3.2059 h 2.9412 ZM 395.9706,485.6912 ZM 398.3971,486.6618 h -1.2794 v 2.5882 h -1.1471 v -2.5882 h -4.2206 v -0.7941 l 4.0147,-6.0000 h 1.3529 v 5.8235 h 1.2794 v 0.9706 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(255,165,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 417.9559,480.0000 v 14.0000 h 22.0000 v -14.0000 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 447.0588,489.2500 ZM 448.4706,483.0882 h -1.0588 v -0.9118 l 1.1176,-0.0735 l 0.1471,-2.0000 h 1.0147 v 2.0000 h 1.9265 v 0.9853 h -1.9265 v 3.9706 c 0.0000,0.6618 0.2426,1.0221 0.2426 1.0221c 0.2426,0.3603 0.8603,0.3603 0.8603 0.3603c 0.1912,0.0000 0.4118,-0.0588 0.4118 -0.0588c 0.2206,-0.0588 0.3971,-0.1324 0.3971 -0.1324l 0.2353,0.9118 c -0.2941,0.1029 -0.6397,0.1838 -0.6397 0.1838c -0.3456,0.0809 -0.6838,0.0809 -0.6838 0.0809c -0.5735,-0.0000 -0.9632,-0.1765 -0.9632 -0.1765c -0.3897,-0.1765 -0.6324,-0.4853 -0.6324 -0.4853c -0.2426,-0.3088 -0.3456,-0.7500 -0.3456 -0.7500c -0.1029,-0.4412 -0.1029,-0.9706 -0.1029 -0.9706v -3.9559 ZM 451.7647,489.2500 ZM 452.6176,487.3971 c 0.0000,-1.1765 1.0515,-1.8015 1.0515 -1.8015c 1.0515,-0.6250 3.3456,-0.8750 3.3456 -0.8750c 0.0000,-0.3382 -0.0662,-0.6618 -0.0662 -0.6618c -0.0662,-0.3235 -0.2353,-0.5735 -0.2353 -0.5735c -0.1691,-0.2500 -0.4485,-0.4044 -0.4485 -0.4044c -0.2794,-0.1544 -0.7206,-0.1544 -0.7206 -0.1544c -0.6324,-0.0000 -1.1691,0.2353 -1.1691 0.2353c -0.5368,0.2353 -0.9632,0.5294 -0.9632 0.5294l -0.4853,-0.8382 c 0.5000,-0.3235 1.2206,-0.6250 1.2206 -0.6250c 0.7206,-0.3015 1.5882,-0.3015 1.5882 -0.3015c 1.3088,0.0000 1.8971,0.8015 1.8971 0.8015c 0.5882,0.8015 0.5882,2.1397 0.5882 2.1397v 4.3824 h -1.0000 l -0.1029,-0.8529 h -0.0294 c -0.5147,0.4265 -1.1103,0.7279 -1.1103 0.7279c -0.5956,0.3015 -1.2574,0.3015 -1.2574 0.3015c -0.9118,-0.0000 -1.5074,-0.5294 -1.5074 -0.5294c -0.5956,-0.5294 -0.5956,-1.5000 -0.5956 -1.5000ZM 452.6176,487.3971 ZM 453.8088,487.3088 c 0.0000,0.6176 0.3603,0.8824 0.3603 0.8824c 0.3603,0.2647 0.8897,0.2647 0.8897 0.2647c 0.5147,0.0000 0.9779,-0.2426 0.9779 -0.2426c 0.4632,-0.2426 0.9779,-0.7132 0.9779 -0.7132v -1.9853 c -0.8971,0.1176 -1.5147,0.2794 -1.5147 0.2794c -0.6176,0.1618 -0.9926,0.3824 -0.9926 0.3824c -0.3750,0.2206 -0.5368,0.5074 -0.5368 0.5074c -0.1618,0.2868 -0.1618,0.6250 -0.1618 0.6250ZM 459.2941,489.2500 ZM 460.5000,478.7794 h 1.1912 v 7.0882 h 0.0441 l 3.0441,-3.7647 h 1.3382 l -2.3971,2.8676 l 2.7206,4.2794 h -1.3235 l -2.0882,-3.4412 l -1.3382,1.5588 v 1.8824 h -1.1912 v -10.4706 ZM 466.3088,489.2500 ZM 466.9853,485.6912 c 0.0000,-0.8824 0.2721,-1.5809 0.2721 -1.5809c 0.2721,-0.6985 0.7206,-1.1838 0.7206 -1.1838c 0.4485,-0.4853 1.0221,-0.7426 1.0221 -0.7426c 0.5735,-0.2574 1.1912,-0.2574 1.1912 -0.2574c 0.6765,0.0000 1.2132,0.2353 1.2132 0.2353c 0.5368,0.2353 0.8971,0.6765 0.8971 0.6765c 0.3603,0.4412 0.5515,1.0588 0.5515 1.0588c 0.1912,0.6176 0.1912,1.3824 0.1912 1.3824c 0.0000,0.3971 -0.0441,0.6618 -0.0441 0.6618h -4.8235 c 0.0735,1.1618 0.7132,1.8382 0.7132 1.8382c 0.6397,0.6765 1.6691,0.6765 1.6691 0.6765c 0.5147,0.0000 0.9485,-0.1544 0.9485 -0.1544c 0.4338,-0.1544 0.8309,-0.4044 0.8309 -0.4044l 0.4265,0.7941 c -0.4706,0.2941 -1.0441,0.5147 -1.0441 0.5147c -0.5735,0.2206 -1.3088,0.2206 -1.3088 0.2206c -0.7206,-0.0000 -1.3456,-0.2574 -1.3456 -0.2574c -0.6250,-0.2574 -1.0882,-0.7353 -1.0882 -0.7353c -0.4632,-0.4779 -0.7279,-1.1691 -0.7279 -1.1691c -0.2647,-0.6912 -0.2647,-1.5735 -0.2647 -1.5735ZM 466.9853,485.6912 ZM 471.9853,485.1471 c 0.0000,-1.1029 -0.4632,-1.6838 -0.4632 -1.6838c -0.4632,-0.5809 -1.3015,-0.5809 -1.3015 -0.5809c -0.3824,-0.0000 -0.7279,0.1544 -0.7279 0.1544c -0.3456,0.1544 -0.6250,0.4412 -0.6250 0.4412c -0.2794,0.2868 -0.4632,0.7059 -0.4632 0.7059c -0.1838,0.4191 -0.2426,0.9632 -0.2426 0.9632h 3.8235 ZM 473.6029,489.2500 ZM 474.2059,485.1029 h 3.3824 v 0.9265 h -3.3824 v -0.9265 ZM 478.1765,489.2500 ZM 479.3824,482.1029 h 1.0000 l 0.1029,1.0294 h 0.0441 c 0.4706,-0.5147 1.0221,-0.8603 1.0221 -0.8603c 0.5515,-0.3456 1.1985,-0.3456 1.1985 -0.3456c 0.8235,0.0000 1.2868,0.3603 1.2868 0.3603c 0.4632,0.3603 0.6838,1.0074 0.6838 1.0074c 0.5588,-0.6176 1.1250,-0.9926 1.1250 -0.9926c 0.5662,-0.3750 1.2279,-0.3750 1.2279 -0.3750c 1.1029,0.0000 1.6397,0.7059 1.6397 0.7059c 0.5368,0.7059 0.5368,2.0882 0.5368 2.0882v 4.5294 h -1.2059 v -4.3676 c 0.0000,-1.0147 -0.3235,-1.4632 -0.3235 -1.4632c -0.3235,-0.4485 -1.0000,-0.4485 -1.0000 -0.4485c -0.8088,-0.0000 -1.7941,1.1029 -1.7941 1.1029v 5.1765 h -1.2059 v -4.3676 c 0.0000,-1.0147 -0.3235,-1.4632 -0.3235 -1.4632c -0.3235,-0.4485 -1.0147,-0.4485 -1.0147 -0.4485c -0.8088,-0.0000 -1.7941,1.1029 -1.7941 1.1029v 5.1765 h -1.2059 v -7.1471 ZM 490.3676,489.2500 ZM 491.2206,487.3971 c 0.0000,-1.1765 1.0515,-1.8015 1.0515 -1.8015c 1.0515,-0.6250 3.3456,-0.8750 3.3456 -0.8750c 0.0000,-0.3382 -0.0662,-0.6618 -0.0662 -0.6618c -0.0662,-0.3235 -0.2353,-0.5735 -0.2353 -0.5735c -0.1691,-0.2500 -0.4485,-0.4044 -0.4485 -0.4044c -0.2794,-0.1544 -0.7206,-0.1544 -0.7206 -0.1544c -0.6324,-0.0000 -1.1691,0.2353 -1.1691 0.2353c -0.5368,0.2353 -0.9632,0.5294 -0.9632 0.5294l -0.4853,-0.8382 c 0.5000,-0.3235 1.2206,-0.6250 1.2206 -0.6250c 0.7206,-0.3015 1.5882,-0.3015 1.5882 -0.3015c 1.3088,0.0000 1.8971,0.8015 1.8971 0.8015c 0.5882,0.8015 0.5882,2.1397 0.5882 2.1397v 4.3824 h -1.0000 l -0.1029,-0.8529 h -0.0294 c -0.5147,0.4265 -1.1103,0.7279 -1.1103 0.7279c -0.5956,0.3015 -1.2574,0.3015 -1.2574 0.3015c -0.9118,-0.0000 -1.5074,-0.5294 -1.5074 -0.5294c -0.5956,-0.5294 -0.5956,-1.5000 -0.5956 -1.5000ZM 491.2206,487.3971 ZM 492.4118,487.3088 c 0.0000,0.6176 0.3603,0.8824 0.3603 0.8824c 0.3603,0.2647 0.8897,0.2647 0.8897 0.2647c 0.5147,0.0000 0.9779,-0.2426 0.9779 -0.2426c 0.4632,-0.2426 0.9779,-0.7132 0.9779 -0.7132v -1.9853 c -0.8971,0.1176 -1.5147,0.2794 -1.5147 0.2794c -0.6176,0.1618 -0.9926,0.3824 -0.9926 0.3824c -0.3750,0.2206 -0.5368,0.5074 -0.5368 0.5074c -0.1618,0.2868 -0.1618,0.6250 -0.1618 0.6250ZM 497.8971,489.2500 ZM 500.3088,489.8529 v 2.4118 h -1.2059 v -10.1618 h 1.0000 l 0.1029,0.8235 h 0.0441 c 0.4853,-0.4118 1.0662,-0.7059 1.0662 -0.7059c 0.5809,-0.2941 1.2132,-0.2941 1.2132 -0.2941c 0.6912,0.0000 1.2206,0.2574 1.2206 0.2574c 0.5294,0.2574 0.8824,0.7353 0.8824 0.7353c 0.3529,0.4779 0.5368,1.1471 0.5368 1.1471c 0.1838,0.6691 0.1838,1.5074 0.1838 1.5074c 0.0000,0.9118 -0.2500,1.6250 -0.2500 1.6250c -0.2500,0.7132 -0.6765,1.2132 -0.6765 1.2132c -0.4265,0.5000 -0.9853,0.7574 -0.9853 0.7574c -0.5588,0.2574 -1.1765,0.2574 -1.1765 0.2574c -0.5000,-0.0000 -0.9926,-0.2206 -0.9926 -0.2206c -0.4926,-0.2206 -0.9926,-0.6029 -0.9926 -0.6029ZM 500.3088,489.8529 ZM 500.3088,487.6618 c 0.4853,0.4118 0.9412,0.5809 0.9412 0.5809c 0.4559,0.1691 0.8088,0.1691 0.8088 0.1691c 0.4412,0.0000 0.8162,-0.1985 0.8162 -0.1985c 0.3750,-0.1985 0.6471,-0.5588 0.6471 -0.5588c 0.2721,-0.3603 0.4265,-0.8897 0.4265 -0.8897c 0.1544,-0.5294 0.1544,-1.1912 0.1544 -1.1912c 0.0000,-0.5882 -0.1029,-1.0735 -0.1029 -1.0735c -0.1029,-0.4853 -0.3309,-0.8309 -0.3309 -0.8309c -0.2279,-0.3456 -0.5882,-0.5368 -0.5882 -0.5368c -0.3603,-0.1912 -0.8603,-0.1912 -0.8603 -0.1912c -0.4559,-0.0000 -0.9191,0.2500 -0.9191 0.2500c -0.4632,0.2500 -0.9926,0.7206 -0.9926 0.7206v 3.7500 ZM 509.0294,489.2500 ZM 511.5735,485.5147 l -2.1618,-3.4118 h 1.3088 l 0.9559,1.5735 c 0.1618,0.2941 0.3382,0.5956 0.3382 0.5956c 0.1765,0.3015 0.3676,0.5956 0.3676 0.5956h 0.0588 c 0.1618,-0.2941 0.3235,-0.5956 0.3235 -0.5956c 0.1618,-0.3015 0.3235,-0.5956 0.3235 -0.5956l 0.8676,-1.5735 h 1.2647 l -2.1618,3.5441 l 2.3235,3.6029 h -1.3088 l -1.0441,-1.6618 l -0.3824,-0.6471 c 0.0000,0.0000 -0.3971,-0.6324 -0.3971 -0.6324h -0.0588 c -0.1912,0.3088 -0.3676,0.6250 -0.3676 0.6250c -0.1765,0.3162 -0.3529,0.6544 -0.3529 0.6544l -0.9706,1.6618 h -1.2647 ZM 518.5588,489.2500 ZM 523.0294,485.6912 v -2.7206 c 0.0000,-0.3824 0.0221,-0.9044 0.0221 -0.9044c 0.0221,-0.5221 0.0515,-0.9044 0.0515 -0.9044h -0.0588 c -0.1765,0.3382 -0.3676,0.6618 -0.3676 0.6618c -0.1912,0.3235 -0.3971,0.6618 -0.3971 0.6618l -2.1912,3.2059 h 2.9412 ZM 523.0294,485.6912 ZM 525.4559,486.6618 h -1.2794 v 2.5882 h -1.1471 v -2.5882 h -4.2206 v -0.7941 l 4.0147,-6.0000 h 1.3529 v 5.8235 h 1.2794 v 0.9706 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(255,255,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 10.0000,504.0000 v 14.0000 h 22.0000 v -14.0000 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 39.1029,513.2500 ZM 40.1176,511.6324 c 0.4706,0.3824 0.9632,0.6176 0.9632 0.6176c 0.4926,0.2353 1.1397,0.2353 1.1397 0.2353c 0.7059,0.0000 1.0588,-0.3235 1.0588 -0.3235c 0.3529,-0.3235 0.3529,-0.7941 0.3529 -0.7941c 0.0000,-0.2794 -0.1471,-0.4853 -0.1471 -0.4853c -0.1471,-0.2059 -0.3750,-0.3603 -0.3750 -0.3603c -0.2279,-0.1544 -0.5221,-0.2721 -0.5221 -0.2721l -0.5882,-0.2353 c -0.3824,-0.1324 -0.7647,-0.3015 -0.7647 -0.3015c -0.3824,-0.1691 -0.6838,-0.4118 -0.6838 -0.4118c -0.3015,-0.2426 -0.4926,-0.5662 -0.4926 -0.5662c -0.1912,-0.3235 -0.1912,-0.7794 -0.1912 -0.7794c 0.0000,-0.4265 0.1691,-0.8015 0.1691 -0.8015c 0.1691,-0.3750 0.4853,-0.6471 0.4853 -0.6471c 0.3162,-0.2721 0.7721,-0.4265 0.7721 -0.4265c 0.4559,-0.1544 1.0294,-0.1544 1.0294 -0.1544c 0.6765,0.0000 1.2426,0.2353 1.2426 0.2353c 0.5662,0.2353 0.9779,0.5735 0.9779 0.5735l -0.5735,0.7647 c -0.3676,-0.2794 -0.7647,-0.4559 -0.7647 -0.4559c -0.3971,-0.1765 -0.8676,-0.1765 -0.8676 -0.1765c -0.6765,-0.0000 -0.9926,0.3088 -0.9926 0.3088c -0.3162,0.3088 -0.3162,0.7206 -0.3162 0.7206c 0.0000,0.2500 0.1324,0.4338 0.1324 0.4338c 0.1324,0.1838 0.3529,0.3235 0.3529 0.3235c 0.2206,0.1397 0.5074,0.2500 0.5074 0.2500c 0.2868,0.1103 0.5956,0.2279 0.5956 0.2279c 0.3824,0.1471 0.7721,0.3088 0.7721 0.3088c 0.3897,0.1618 0.6985,0.4044 0.6985 0.4044c 0.3088,0.2426 0.5074,0.5956 0.5074 0.5956c 0.1985,0.3529 0.1985,0.8529 0.1985 0.8529c 0.0000,0.4412 -0.1691,0.8235 -0.1691 0.8235c -0.1691,0.3824 -0.5000,0.6765 -0.5000 0.6765c -0.3309,0.2941 -0.8235,0.4632 -0.8235 0.4632c -0.4926,0.1691 -1.1250,0.1691 -1.1250 0.1691c -0.7647,-0.0000 -1.4559,-0.2794 -1.4559 -0.2794c -0.6912,-0.2794 -1.2059,-0.7059 -1.2059 -0.7059ZM 45.2647,513.2500 ZM 45.9412,509.6912 c 0.0000,-0.8971 0.2794,-1.5956 0.2794 -1.5956c 0.2794,-0.6985 0.7500,-1.1838 0.7500 -1.1838c 0.4706,-0.4853 1.0956,-0.7353 1.0956 -0.7353c 0.6250,-0.2500 1.3162,-0.2500 1.3162 -0.2500c 0.7059,0.0000 1.2132,0.2574 1.2132 0.2574c 0.5074,0.2574 0.8750,0.5956 0.8750 0.5956l -0.6029,0.7794 c -0.3235,-0.2794 -0.6691,-0.4559 -0.6691 -0.4559c -0.3456,-0.1765 -0.7721,-0.1765 -0.7721 -0.1765c -0.4853,-0.0000 -0.8971,0.1985 -0.8971 0.1985c -0.4118,0.1985 -0.7059,0.5662 -0.7059 0.5662c -0.2941,0.3676 -0.4632,0.8750 -0.4632 0.8750c -0.1691,0.5074 -0.1691,1.1250 -0.1691 1.1250c 0.0000,0.6176 0.1618,1.1176 0.1618 1.1176c 0.1618,0.5000 0.4485,0.8603 0.4485 0.8603c 0.2868,0.3603 0.6985,0.5588 0.6985 0.5588c 0.4118,0.1985 0.8971,0.1985 0.8971 0.1985c 0.5147,0.0000 0.9338,-0.2132 0.9338 -0.2132c 0.4191,-0.2132 0.7426,-0.5074 0.7426 -0.5074l 0.5441,0.7941 c -0.4853,0.4265 -1.0809,0.6765 -1.0809 0.6765c -0.5956,0.2500 -1.2426,0.2500 -1.2426 0.2500c -0.7059,-0.0000 -1.3235,-0.2500 -1.3235 -0.2500c -0.6176,-0.2500 -1.0662,-0.7279 -1.0662 -0.7279c -0.4485,-0.4779 -0.7059,-1.1765 -0.7059 -1.1765c -0.2574,-0.6985 -0.2574,-1.5809 -0.2574 -1.5809ZM 51.8235,513.2500 ZM 52.6765,511.3971 c 0.0000,-1.1765 1.0515,-1.8015 1.0515 -1.8015c 1.0515,-0.6250 3.3456,-0.8750 3.3456 -0.8750c 0.0000,-0.3382 -0.0662,-0.6618 -0.0662 -0.6618c -0.0662,-0.3235 -0.2353,-0.5735 -0.2353 -0.5735c -0.1691,-0.2500 -0.4485,-0.4044 -0.4485 -0.4044c -0.2794,-0.1544 -0.7206,-0.1544 -0.7206 -0.1544c -0.6324,-0.0000 -1.1691,0.2353 -1.1691 0.2353c -0.5368,0.2353 -0.9632,0.5294 -0.9632 0.5294l -0.4853,-0.8382 c 0.5000,-0.3235 1.2206,-0.6250 1.2206 -0.6250c 0.7206,-0.3015 1.5882,-0.3015 1.5882 -0.3015c 1.3088,0.0000 1.8971,0.8015 1.8971 0.8015c 0.5882,0.8015 0.5882,2.1397 0.5882 2.1397v 4.3824 h -1.0000 l -0.1029,-0.8529 h -0.0294 c -0.5147,0.4265 -1.1103,0.7279 -1.1103 0.7279c -0.5956,0.3015 -1.2574,0.3015 -1.2574 0.3015c -0.9118,-0.0000 -1.5074,-0.5294 -1.5074 -0.5294c -0.5956,-0.5294 -0.5956,-1.5000 -0.5956 -1.5000ZM 52.6765,511.3971 ZM 53.8676,511.3088 c 0.0000,0.6176 0.3603,0.8824 0.3603 0.8824c 0.3603,0.2647 0.8897,0.2647 0.8897 0.2647c 0.5147,0.0000 0.9779,-0.2426 0.9779 -0.2426c 0.4632,-0.2426 0.9779,-0.7132 0.9779 -0.7132v -1.9853 c -0.8971,0.1176 -1.5147,0.2794 -1.5147 0.2794c -0.6176,0.1618 -0.9926,0.3824 -0.9926 0.3824c -0.3750,0.2206 -0.5368,0.5074 -0.5368 0.5074c -0.1618,0.2868 -0.1618,0.6250 -0.1618 0.6250ZM 59.3529,513.2500 ZM 60.5588,506.1029 h 1.0000 l 0.1029,1.0294 h 0.0441 c 0.5147,-0.5147 1.0809,-0.8603 1.0809 -0.8603c 0.5662,-0.3456 1.3162,-0.3456 1.3162 -0.3456c 1.1324,0.0000 1.6544,0.7059 1.6544 0.7059c 0.5221,0.7059 0.5221,2.0882 0.5221 2.0882v 4.5294 h -1.2059 v -4.3676 c 0.0000,-1.0147 -0.3235,-1.4632 -0.3235 -1.4632c -0.3235,-0.4485 -1.0294,-0.4485 -1.0294 -0.4485c -0.5588,-0.0000 -0.9853,0.2794 -0.9853 0.2794c -0.4265,0.2794 -0.9706,0.8235 -0.9706 0.8235v 5.1765 h -1.2059 v -7.1471 ZM 67.3971,513.2500 ZM 68.0000,509.1029 h 3.3824 v 0.9265 h -3.3824 v -0.9265 ZM 71.9706,513.2500 ZM 73.1765,506.1029 h 1.0000 l 0.1029,1.0294 h 0.0441 c 0.4706,-0.5147 1.0221,-0.8603 1.0221 -0.8603c 0.5515,-0.3456 1.1985,-0.3456 1.1985 -0.3456c 0.8235,0.0000 1.2868,0.3603 1.2868 0.3603c 0.4632,0.3603 0.6838,1.0074 0.6838 1.0074c 0.5588,-0.6176 1.1250,-0.9926 1.1250 -0.9926c 0.5662,-0.3750 1.2279,-0.3750 1.2279 -0.3750c 1.1029,0.0000 1.6397,0.7059 1.6397 0.7059c 0.5368,0.7059 0.5368,2.0882 0.5368 2.0882v 4.5294 h -1.2059 v -4.3676 c 0.0000,-1.0147 -0.3235,-1.4632 -0.3235 -1.4632c -0.3235,-0.4485 -1.0000,-0.4485 -1.0000 -0.4485c -0.8088,-0.0000 -1.7941,1.1029 -1.7941 1.1029v 5.1765 h -1.2059 v -4.3676 c 0.0000,-1.0147 -0.3235,-1.4632 -0.3235 -1.4632c -0.3235,-0.4485 -1.0147,-0.4485 -1.0147 -0.4485c -0.8088,-0.0000 -1.7941,1.1029 -1.7941 1.1029v 5.1765 h -1.2059 v -7.1471 ZM 84.1618,513.2500 ZM 85.0147,511.3971 c 0.0000,-1.1765 1.0515,-1.8015 1.0515 -1.8015c 1.0515,-0.6250 3.3456,-0.8750 3.3456 -0.8750c 0.0000,-0.3382 -0.0662,-0.6618 -0.0662 -0.6618c -0.0662,-0.3235 -0.2353,-0.5735 -0.2353 -0.5735c -0.1691,-0.2500 -0.4485,-0.4044 -0.4485 -0.4044c -0.2794,-0.1544 -0.7206,-0.1544 -0.7206 -0.1544c -0.6324,-0.0000 -1.1691,0.2353 -1.1691 0.2353c -0.5368,0.2353 -0.9632,0.5294 -0.9632 0.5294l -0.4853,-0.8382 c 0.5000,-0.3235 1.2206,-0.6250 1.2206 -0.6250c 0.7206,-0.3015 1.5882,-0.3015 1.5882 -0.3015c 1.3088,0.0000 1.8971,0.8015 1.8971 0.8015c 0.5882,0.8015 0.5882,2.1397 0.5882 2.1397v 4.3824 h -1.0000 l -0.1029,-0.8529 h -0.0294 c -0.5147,0.4265 -1.1103,0.7279 -1.1103 0.7279c -0.5956,0.3015 -1.2574,0.3015 -1.2574 0.3015c -0.9118,-0.0000 -1.5074,-0.5294 -1.5074 -0.5294c -0.5956,-0.5294 -0.5956,-1.5000 -0.5956 -1.5000ZM 85.0147,511.3971 ZM 86.2059,511.3088 c 0.0000,0.6176 0.3603,0.8824 0.3603 0.8824c 0.3603,0.2647 0.8897,0.2647 0.8897 0.2647c 0.5147,0.0000 0.9779,-0.2426 0.9779 -0.2426c 0.4632,-0.2426 0.9779,-0.7132 0.9779 -0.7132v -1.9853 c -0.8971,0.1176 -1.5147,0.2794 -1.5147 0.2794c -0.6176,0.1618 -0.9926,0.3824 -0.9926 0.3824c -0.3750,0.2206 -0.5368,0.5074 -0.5368 0.5074c -0.1618,0.2868 -0.1618,0.6250 -0.1618 0.6250ZM 91.6912,513.2500 ZM 94.1029,513.8529 v 2.4118 h -1.2059 v -10.1618 h 1.0000 l 0.1029,0.8235 h 0.0441 c 0.4853,-0.4118 1.0662,-0.7059 1.0662 -0.7059c 0.5809,-0.2941 1.2132,-0.2941 1.2132 -0.2941c 0.6912,0.0000 1.2206,0.2574 1.2206 0.2574c 0.5294,0.2574 0.8824,0.7353 0.8824 0.7353c 0.3529,0.4779 0.5368,1.1471 0.5368 1.1471c 0.1838,0.6691 0.1838,1.5074 0.1838 1.5074c 0.0000,0.9118 -0.2500,1.6250 -0.2500 1.6250c -0.2500,0.7132 -0.6765,1.2132 -0.6765 1.2132c -0.4265,0.5000 -0.9853,0.7574 -0.9853 0.7574c -0.5588,0.2574 -1.1765,0.2574 -1.1765 0.2574c -0.5000,-0.0000 -0.9926,-0.2206 -0.9926 -0.2206c -0.4926,-0.2206 -0.9926,-0.6029 -0.9926 -0.6029ZM 94.1029,513.8529 ZM 94.1029,511.6618 c 0.4853,0.4118 0.9412,0.5809 0.9412 0.5809c 0.4559,0.1691 0.8088,0.1691 0.8088 0.1691c 0.4412,0.0000 0.8162,-0.1985 0.8162 -0.1985c 0.3750,-0.1985 0.6471,-0.5588 0.6471 -0.5588c 0.2721,-0.3603 0.4265,-0.8897 0.4265 -0.8897c 0.1544,-0.5294 0.1544,-1.1912 0.1544 -1.1912c 0.0000,-0.5882 -0.1029,-1.0735 -0.1029 -1.0735c -0.1029,-0.4853 -0.3309,-0.8309 -0.3309 -0.8309c -0.2279,-0.3456 -0.5882,-0.5368 -0.5882 -0.5368c -0.3603,-0.1912 -0.8603,-0.1912 -0.8603 -0.1912c -0.4559,-0.0000 -0.9191,0.2500 -0.9191 0.2500c -0.4632,0.2500 -0.9926,0.7206 -0.9926 0.7206v 3.7500 ZM 102.8235,513.2500 ZM 105.3676,509.5147 l -2.1618,-3.4118 h 1.3088 l 0.9559,1.5735 c 0.1618,0.2941 0.3382,0.5956 0.3382 0.5956c 0.1765,0.3015 0.3676,0.5956 0.3676 0.5956h 0.0588 c 0.1618,-0.2941 0.3235,-0.5956 0.3235 -0.5956c 0.1618,-0.3015 0.3235,-0.5956 0.3235 -0.5956l 0.8676,-1.5735 h 1.2647 l -2.1618,3.5441 l 2.3235,3.6029 h -1.3088 l -1.0441,-1.6618 l -0.3824,-0.6471 c 0.0000,0.0000 -0.3971,-0.6324 -0.3971 -0.6324h -0.0588 c -0.1912,0.3088 -0.3676,0.6250 -0.3676 0.6250c -0.1765,0.3162 -0.3529,0.6544 -0.3529 0.6544l -0.9706,1.6618 h -1.2647 ZM 112.3529,513.2500 ZM 116.8235,509.6912 v -2.7206 c 0.0000,-0.3824 0.0221,-0.9044 0.0221 -0.9044c 0.0221,-0.5221 0.0515,-0.9044 0.0515 -0.9044h -0.0588 c -0.1765,0.3382 -0.3676,0.6618 -0.3676 0.6618c -0.1912,0.3235 -0.3971,0.6618 -0.3971 0.6618l -2.1912,3.2059 h 2.9412 ZM 116.8235,509.6912 ZM 119.2500,510.6618 h -1.2794 v 2.5882 h -1.1471 v -2.5882 h -4.2206 v -0.7941 l 4.0147,-6.0000 h 1.3529 v 5.8235 h 1.2794 v 0.9706 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(238,130,238)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 139.9265,504.0000 v 14.0000 h 22.0000 v -14.0000 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 169.0294,513.2500 ZM 169.4853,512.6029 l 3.7647,-5.5147 h -3.3529 v -0.9853 h 4.8824 v 0.6471 l -3.7647,5.5147 h 3.8824 v 0.9853 h -5.4118 v -0.6471 ZM 175.2794,513.2500 ZM 177.1029,504.6324 c -0.3529,-0.0000 -0.5956,-0.2206 -0.5956 -0.2206c -0.2426,-0.2206 -0.2426,-0.5588 -0.2426 -0.5588c 0.0000,-0.3529 0.2426,-0.5662 0.2426 -0.5662c 0.2426,-0.2132 0.5956,-0.2132 0.5956 -0.2132c 0.3529,0.0000 0.5956,0.2132 0.5956 0.2132c 0.2426,0.2132 0.2426,0.5662 0.2426 0.5662c 0.0000,0.3382 -0.2426,0.5588 -0.2426 0.5588c -0.2426,0.2206 -0.5956,0.2206 -0.5956 0.2206ZM 177.1029,504.6324 ZM 176.4853,506.1029 h 1.2059 v 7.1471 h -1.2059 v -7.1471 ZM 178.8971,513.2500 ZM 181.3088,513.8529 v 2.4118 h -1.2059 v -10.1618 h 1.0000 l 0.1029,0.8235 h 0.0441 c 0.4853,-0.4118 1.0662,-0.7059 1.0662 -0.7059c 0.5809,-0.2941 1.2132,-0.2941 1.2132 -0.2941c 0.6912,0.0000 1.2206,0.2574 1.2206 0.2574c 0.5294,0.2574 0.8824,0.7353 0.8824 0.7353c 0.3529,0.4779 0.5368,1.1471 0.5368 1.1471c 0.1838,0.6691 0.1838,1.5074 0.1838 1.5074c 0.0000,0.9118 -0.2500,1.6250 -0.2500 1.6250c -0.2500,0.7132 -0.6765,1.2132 -0.6765 1.2132c -0.4265,0.5000 -0.9853,0.7574 -0.9853 0.7574c -0.5588,0.2574 -1.1765,0.2574 -1.1765 0.2574c -0.5000,-0.0000 -0.9926,-0.2206 -0.9926 -0.2206c -0.4926,-0.2206 -0.9926,-0.6029 -0.9926 -0.6029ZM 181.3088,513.8529 ZM 181.3088,511.6618 c 0.4853,0.4118 0.9412,0.5809 0.9412 0.5809c 0.4559,0.1691 0.8088,0.1691 0.8088 0.1691c 0.4412,0.0000 0.8162,-0.1985 0.8162 -0.1985c 0.3750,-0.1985 0.6471,-0.5588 0.6471 -0.5588c 0.2721,-0.3603 0.4265,-0.8897 0.4265 -0.8897c 0.1544,-0.5294 0.1544,-1.1912 0.1544 -1.1912c 0.0000,-0.5882 -0.1029,-1.0735 -0.1029 -1.0735c -0.1029,-0.4853 -0.3309,-0.8309 -0.3309 -0.8309c -0.2279,-0.3456 -0.5882,-0.5368 -0.5882 -0.5368c -0.3603,-0.1912 -0.8603,-0.1912 -0.8603 -0.1912c -0.4559,-0.0000 -0.9191,0.2500 -0.9191 0.2500c -0.4632,0.2500 -0.9926,0.7206 -0.9926 0.7206v 3.7500 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,255)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 288.1471,504.0000 v 14.0000 h 22.0000 v -14.0000 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 317.2500,513.2500 ZM 321.6765,503.7647 c -0.3971,-0.1765 -0.8088,-0.1765 -0.8088 -0.1765c -1.0000,-0.0000 -1.0000,1.3824 -1.0000 1.3824v 1.1324 h 1.5147 v 0.9853 h -1.5147 v 6.1618 h -1.2059 v -6.1618 h -0.9706 v -0.9118 l 0.9706,-0.0735 v -1.1324 c 0.0000,-1.1029 0.5074,-1.7353 0.5074 -1.7353c 0.5074,-0.6324 1.5809,-0.6324 1.5809 -0.6324c 0.3382,0.0000 0.6397,0.0662 0.6397 0.0662c 0.3015,0.0662 0.5515,0.1691 0.5515 0.1691ZM 321.5441,513.2500 ZM 323.3676,504.6324 c -0.3529,-0.0000 -0.5956,-0.2206 -0.5956 -0.2206c -0.2426,-0.2206 -0.2426,-0.5588 -0.2426 -0.5588c 0.0000,-0.3529 0.2426,-0.5662 0.2426 -0.5662c 0.2426,-0.2132 0.5956,-0.2132 0.5956 -0.2132c 0.3529,0.0000 0.5956,0.2132 0.5956 0.2132c 0.2426,0.2132 0.2426,0.5662 0.2426 0.5662c 0.0000,0.3382 -0.2426,0.5588 -0.2426 0.5588c -0.2426,0.2206 -0.5956,0.2206 -0.5956 0.2206ZM 323.3676,504.6324 ZM 322.7500,506.1029 h 1.2059 v 7.1471 h -1.2059 v -7.1471 ZM 325.1618,513.2500 ZM 326.3676,502.7794 h 1.2059 v 9.1176 c 0.0000,0.2941 0.1029,0.4118 0.1029 0.4118c 0.1029,0.1176 0.2353,0.1176 0.2353 0.1176h 0.1103 c 0.0000,0.0000 0.1544,-0.0294 0.1544 -0.0294l 0.1618,0.9118 c -0.1176,0.0588 -0.2794,0.0882 -0.2794 0.0882c -0.1618,0.0294 -0.4118,0.0294 -0.4118 0.0294c -0.6912,-0.0000 -0.9853,-0.4118 -0.9853 -0.4118c -0.2941,-0.4118 -0.2941,-1.2059 -0.2941 -1.2059v -9.0294 ZM 328.9118,513.2500 ZM 330.3235,507.0882 h -1.0588 v -0.9118 l 1.1176,-0.0735 l 0.1471,-2.0000 h 1.0147 v 2.0000 h 1.9265 v 0.9853 h -1.9265 v 3.9706 c 0.0000,0.6618 0.2426,1.0221 0.2426 1.0221c 0.2426,0.3603 0.8603,0.3603 0.8603 0.3603c 0.1912,0.0000 0.4118,-0.0588 0.4118 -0.0588c 0.2206,-0.0588 0.3971,-0.1324 0.3971 -0.1324l 0.2353,0.9118 c -0.2941,0.1029 -0.6397,0.1838 -0.6397 0.1838c -0.3456,0.0809 -0.6838,0.0809 -0.6838 0.0809c -0.5735,-0.0000 -0.9632,-0.1765 -0.9632 -0.1765c -0.3897,-0.1765 -0.6324,-0.4853 -0.6324 -0.4853c -0.2426,-0.3088 -0.3456,-0.7500 -0.3456 -0.7500c -0.1029,-0.4412 -0.1029,-0.9706 -0.1029 -0.9706v -3.9559 ZM 333.7353,513.2500 ZM 334.4118,509.6912 c 0.0000,-0.8824 0.2721,-1.5809 0.2721 -1.5809c 0.2721,-0.6985 0.7206,-1.1838 0.7206 -1.1838c 0.4485,-0.4853 1.0221,-0.7426 1.0221 -0.7426c 0.5735,-0.2574 1.1912,-0.2574 1.1912 -0.2574c 0.6765,0.0000 1.2132,0.2353 1.2132 0.2353c 0.5368,0.2353 0.8971,0.6765 0.8971 0.6765c 0.3603,0.4412 0.5515,1.0588 0.5515 1.0588c 0.1912,0.6176 0.1912,1.3824 0.1912 1.3824c 0.0000,0.3971 -0.0441,0.6618 -0.0441 0.6618h -4.8235 c 0.0735,1.1618 0.7132,1.8382 0.7132 1.8382c 0.6397,0.6765 1.6691,0.6765 1.6691 0.6765c 0.5147,0.0000 0.9485,-0.1544 0.9485 -0.1544c 0.4338,-0.1544 0.8309,-0.4044 0.8309 -0.4044l 0.4265,0.7941 c -0.4706,0.2941 -1.0441,0.5147 -1.0441 0.5147c -0.5735,0.2206 -1.3088,0.2206 -1.3088 0.2206c -0.7206,-0.0000 -1.3456,-0.2574 -1.3456 -0.2574c -0.6250,-0.2574 -1.0882,-0.7353 -1.0882 -0.7353c -0.4632,-0.4779 -0.7279,-1.1691 -0.7279 -1.1691c -0.2647,-0.6912 -0.2647,-1.5735 -0.2647 -1.5735ZM 334.4118,509.6912 ZM 339.4118,509.1471 c 0.0000,-1.1029 -0.4632,-1.6838 -0.4632 -1.6838c -0.4632,-0.5809 -1.3015,-0.5809 -1.3015 -0.5809c -0.3824,-0.0000 -0.7279,0.1544 -0.7279 0.1544c -0.3456,0.1544 -0.6250,0.4412 -0.6250 0.4412c -0.2794,0.2868 -0.4632,0.7059 -0.4632 0.7059c -0.1838,0.4191 -0.2426,0.9632 -0.2426 0.9632h 3.8235 ZM 341.0294,513.2500 ZM 342.2353,506.1029 h 1.0000 l 0.1029,1.2941 h 0.0441 c 0.3676,-0.6765 0.8897,-1.0735 0.8897 -1.0735c 0.5221,-0.3971 1.1397,-0.3971 1.1397 -0.3971c 0.4265,0.0000 0.7647,0.1471 0.7647 0.1471l -0.2353,1.0588 c -0.1765,-0.0588 -0.3235,-0.0882 -0.3235 -0.0882c -0.1471,-0.0294 -0.3676,-0.0294 -0.3676 -0.0294c -0.4559,-0.0000 -0.9485,0.3676 -0.9485 0.3676c -0.4926,0.3676 -0.8603,1.2794 -0.8603 1.2794v 4.5882 h -1.2059 v -7.1471 ZM 346.1324,513.2500 ZM 346.7353,509.1029 h 3.3824 v 0.9265 h -3.3824 v -0.9265 ZM 350.7059,513.2500 ZM 352.1176,507.0882 h -1.0588 v -0.9118 l 1.1176,-0.0735 l 0.1471,-2.0000 h 1.0147 v 2.0000 h 1.9265 v 0.9853 h -1.9265 v 3.9706 c 0.0000,0.6618 0.2426,1.0221 0.2426 1.0221c 0.2426,0.3603 0.8603,0.3603 0.8603 0.3603c 0.1912,0.0000 0.4118,-0.0588 0.4118 -0.0588c 0.2206,-0.0588 0.3971,-0.1324 0.3971 -0.1324l 0.2353,0.9118 c -0.2941,0.1029 -0.6397,0.1838 -0.6397 0.1838c -0.3456,0.0809 -0.6838,0.0809 -0.6838 0.0809c -0.5735,-0.0000 -0.9632,-0.1765 -0.9632 -0.1765c -0.3897,-0.1765 -0.6324,-0.4853 -0.6324 -0.4853c -0.2426,-0.3088 -0.3456,-0.7500 -0.3456 -0.7500c -0.1029,-0.4412 -0.1029,-0.9706 -0.1029 -0.9706v -3.9559 ZM 355.4118,513.2500 ZM 356.2647,511.3971 c 0.0000,-1.1765 1.0515,-1.8015 1.0515 -1.8015c 1.0515,-0.6250 3.3456,-0.8750 3.3456 -0.8750c 0.0000,-0.3382 -0.0662,-0.6618 -0.0662 -0.6618c -0.0662,-0.3235 -0.2353,-0.5735 -0.2353 -0.5735c -0.1691,-0.2500 -0.4485,-0.4044 -0.4485 -0.4044c -0.2794,-0.1544 -0.7206,-0.1544 -0.7206 -0.1544c -0.6324,-0.0000 -1.1691,0.2353 -1.1691 0.2353c -0.5368,0.2353 -0.9632,0.5294 -0.9632 0.5294l -0.4853,-0.8382 c 0.5000,-0.3235 1.2206,-0.6250 1.2206 -0.6250c 0.7206,-0.3015 1.5882,-0.3015 1.5882 -0.3015c 1.3088,0.0000 1.8971,0.8015 1.8971 0.8015c 0.5882,0.8015 0.5882,2.1397 0.5882 2.1397v 4.3824 h -1.0000 l -0.1029,-0.8529 h -0.0294 c -0.5147,0.4265 -1.1103,0.7279 -1.1103 0.7279c -0.5956,0.3015 -1.2574,0.3015 -1.2574 0.3015c -0.9118,-0.0000 -1.5074,-0.5294 -1.5074 -0.5294c -0.5956,-0.5294 -0.5956,-1.5000 -0.5956 -1.5000ZM 356.2647,511.3971 ZM 357.4559,511.3088 c 0.0000,0.6176 0.3603,0.8824 0.3603 0.8824c 0.3603,0.2647 0.8897,0.2647 0.8897 0.2647c 0.5147,0.0000 0.9779,-0.2426 0.9779 -0.2426c 0.4632,-0.2426 0.9779,-0.7132 0.9779 -0.7132v -1.9853 c -0.8971,0.1176 -1.5147,0.2794 -1.5147 0.2794c -0.6176,0.1618 -0.9926,0.3824 -0.9926 0.3824c -0.3750,0.2206 -0.5368,0.5074 -0.5368 0.5074c -0.1618,0.2868 -0.1618,0.6250 -0.1618 0.6250ZM 362.9412,513.2500 ZM 364.1471,502.7794 h 1.1912 v 7.0882 h 0.0441 l 3.0441,-3.7647 h 1.3382 l -2.3971,2.8676 l 2.7206,4.2794 h -1.3235 l -2.0882,-3.4412 l -1.3382,1.5588 v 1.8824 h -1.1912 v -10.4706 ZM 369.9559,513.2500 ZM 370.6324,509.6912 c 0.0000,-0.8824 0.2721,-1.5809 0.2721 -1.5809c 0.2721,-0.6985 0.7206,-1.1838 0.7206 -1.1838c 0.4485,-0.4853 1.0221,-0.7426 1.0221 -0.7426c 0.5735,-0.2574 1.1912,-0.2574 1.1912 -0.2574c 0.6765,0.0000 1.2132,0.2353 1.2132 0.2353c 0.5368,0.2353 0.8971,0.6765 0.8971 0.6765c 0.3603,0.4412 0.5515,1.0588 0.5515 1.0588c 0.1912,0.6176 0.1912,1.3824 0.1912 1.3824c 0.0000,0.3971 -0.0441,0.6618 -0.0441 0.6618h -4.8235 c 0.0735,1.1618 0.7132,1.8382 0.7132 1.8382c 0.6397,0.6765 1.6691,0.6765 1.6691 0.6765c 0.5147,0.0000 0.9485,-0.1544 0.9485 -0.1544c 0.4338,-0.1544 0.8309,-0.4044 0.8309 -0.4044l 0.4265,0.7941 c -0.4706,0.2941 -1.0441,0.5147 -1.0441 0.5147c -0.5735,0.2206 -1.3088,0.2206 -1.3088 0.2206c -0.7206,-0.0000 -1.3456,-0.2574 -1.3456 -0.2574c -0.6250,-0.2574 -1.0882,-0.7353 -1.0882 -0.7353c -0.4632,-0.4779 -0.7279,-1.1691 -0.7279 -1.1691c -0.2647,-0.6912 -0.2647,-1.5735 -0.2647 -1.5735ZM 370.6324,509.6912 ZM 375.6324,509.1471 c 0.0000,-1.1029 -0.4632,-1.6838 -0.4632 -1.6838c -0.4632,-0.5809 -1.3015,-0.5809 -1.3015 -0.5809c -0.3824,-0.0000 -0.7279,0.1544 -0.7279 0.1544c -0.3456,0.1544 -0.6250,0.4412 -0.6250 0.4412c -0.2794,0.2868 -0.4632,0.7059 -0.4632 0.7059c -0.1838,0.4191 -0.2426,0.9632 -0.2426 0.9632h 3.8235 ZM 380.2206,513.2500 ZM 382.7647,509.5147 l -2.1618,-3.4118 h 1.3088 l 0.9559,1.5735 c 0.1618,0.2941 0.3382,0.5956 0.3382 0.5956c 0.1765,0.3015 0.3676,0.5956 0.3676 0.5956h 0.0588 c 0.1618,-0.2941 0.3235,-0.5956 0.3235 -0.5956c 0.1618,-0.3015 0.3235,-0.5956 0.3235 -0.5956l 0.8676,-1.5735 h 1.2647 l -2.1618,3.5441 l 2.3235,3.6029 h -1.3088 l -1.0441,-1.6618 l -0.3824,-0.6471 c 0.0000,0.0000 -0.3971,-0.6324 -0.3971 -0.6324h -0.0588 c -0.1912,0.3088 -0.3676,0.6250 -0.3676 0.6250c -0.1765,0.3162 -0.3529,0.6544 -0.3529 0.6544l -0.9706,1.6618 h -1.2647 ZM 389.7500,513.2500 ZM 394.2206,509.6912 v -2.7206 c 0.0000,-0.3824 0.0221,-0.9044 0.0221 -0.9044c 0.0221,-0.5221 0.0515,-0.9044 0.0515 -0.9044h -0.0588 c -0.1765,0.3382 -0.3676,0.6618 -0.3676 0.6618c -0.1912,0.3235 -0.3971,0.6618 -0.3971 0.6618l -2.1912,3.2059 h 2.9412 ZM 394.2206,509.6912 ZM 396.6471,510.6618 h -1.2794 v 2.5882 h -1.1471 v -2.5882 h -4.2206 v -0.7941 l 4.0147,-6.0000 h 1.3529 v 5.8235 h 1.2794 v 0.9706 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,128,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 417.9559,504.0000 v 14.0000 h 22.0000 v -14.0000 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 447.0588,513.2500 ZM 448.4706,507.0882 h -1.0588 v -0.9118 l 1.1176,-0.0735 l 0.1471,-2.0000 h 1.0147 v 2.0000 h 1.9265 v 0.9853 h -1.9265 v 3.9706 c 0.0000,0.6618 0.2426,1.0221 0.2426 1.0221c 0.2426,0.3603 0.8603,0.3603 0.8603 0.3603c 0.1912,0.0000 0.4118,-0.0588 0.4118 -0.0588c 0.2206,-0.0588 0.3971,-0.1324 0.3971 -0.1324l 0.2353,0.9118 c -0.2941,0.1029 -0.6397,0.1838 -0.6397 0.1838c -0.3456,0.0809 -0.6838,0.0809 -0.6838 0.0809c -0.5735,-0.0000 -0.9632,-0.1765 -0.9632 -0.1765c -0.3897,-0.1765 -0.6324,-0.4853 -0.6324 -0.4853c -0.2426,-0.3088 -0.3456,-0.7500 -0.3456 -0.7500c -0.1029,-0.4412 -0.1029,-0.9706 -0.1029 -0.9706v -3.9559 ZM 451.7647,513.2500 ZM 452.6176,511.3971 c 0.0000,-1.1765 1.0515,-1.8015 1.0515 -1.8015c 1.0515,-0.6250 3.3456,-0.8750 3.3456 -0.8750c 0.0000,-0.3382 -0.0662,-0.6618 -0.0662 -0.6618c -0.0662,-0.3235 -0.2353,-0.5735 -0.2353 -0.5735c -0.1691,-0.2500 -0.4485,-0.4044 -0.4485 -0.4044c -0.2794,-0.1544 -0.7206,-0.1544 -0.7206 -0.1544c -0.6324,-0.0000 -1.1691,0.2353 -1.1691 0.2353c -0.5368,0.2353 -0.9632,0.5294 -0.9632 0.5294l -0.4853,-0.8382 c 0.5000,-0.3235 1.2206,-0.6250 1.2206 -0.6250c 0.7206,-0.3015 1.5882,-0.3015 1.5882 -0.3015c 1.3088,0.0000 1.8971,0.8015 1.8971 0.8015c 0.5882,0.8015 0.5882,2.1397 0.5882 2.1397v 4.3824 h -1.0000 l -0.1029,-0.8529 h -0.0294 c -0.5147,0.4265 -1.1103,0.7279 -1.1103 0.7279c -0.5956,0.3015 -1.2574,0.3015 -1.2574 0.3015c -0.9118,-0.0000 -1.5074,-0.5294 -1.5074 -0.5294c -0.5956,-0.5294 -0.5956,-1.5000 -0.5956 -1.5000ZM 452.6176,511.3971 ZM 453.8088,511.3088 c 0.0000,0.6176 0.3603,0.8824 0.3603 0.8824c 0.3603,0.2647 0.8897,0.2647 0.8897 0.2647c 0.5147,0.0000 0.9779,-0.2426 0.9779 -0.2426c 0.4632,-0.2426 0.9779,-0.7132 0.9779 -0.7132v -1.9853 c -0.8971,0.1176 -1.5147,0.2794 -1.5147 0.2794c -0.6176,0.1618 -0.9926,0.3824 -0.9926 0.3824c -0.3750,0.2206 -0.5368,0.5074 -0.5368 0.5074c -0.1618,0.2868 -0.1618,0.6250 -0.1618 0.6250ZM 459.2941,513.2500 ZM 460.5000,502.7794 h 1.1912 v 7.0882 h 0.0441 l 3.0441,-3.7647 h 1.3382 l -2.3971,2.8676 l 2.7206,4.2794 h -1.3235 l -2.0882,-3.4412 l -1.3382,1.5588 v 1.8824 h -1.1912 v -10.4706 ZM 466.3088,513.2500 ZM 466.9853,509.6912 c 0.0000,-0.8824 0.2721,-1.5809 0.2721 -1.5809c 0.2721,-0.6985 0.7206,-1.1838 0.7206 -1.1838c 0.4485,-0.4853 1.0221,-0.7426 1.0221 -0.7426c 0.5735,-0.2574 1.1912,-0.2574 1.1912 -0.2574c 0.6765,0.0000 1.2132,0.2353 1.2132 0.2353c 0.5368,0.2353 0.8971,0.6765 0.8971 0.6765c 0.3603,0.4412 0.5515,1.0588 0.5515 1.0588c 0.1912,0.6176 0.1912,1.3824 0.1912 1.3824c 0.0000,0.3971 -0.0441,0.6618 -0.0441 0.6618h -4.8235 c 0.0735,1.1618 0.7132,1.8382 0.7132 1.8382c 0.6397,0.6765 1.6691,0.6765 1.6691 0.6765c 0.5147,0.0000 0.9485,-0.1544 0.9485 -0.1544c 0.4338,-0.1544 0.8309,-0.4044 0.8309 -0.4044l 0.4265,0.7941 c -0.4706,0.2941 -1.0441,0.5147 -1.0441 0.5147c -0.5735,0.2206 -1.3088,0.2206 -1.3088 0.2206c -0.7206,-0.0000 -1.3456,-0.2574 -1.3456 -0.2574c -0.6250,-0.2574 -1.0882,-0.7353 -1.0882 -0.7353c -0.4632,-0.4779 -0.7279,-1.1691 -0.7279 -1.1691c -0.2647,-0.6912 -0.2647,-1.5735 -0.2647 -1.5735ZM 466.9853,509.6912 ZM 471.9853,509.1471 c 0.0000,-1.1029 -0.4632,-1.6838 -0.4632 -1.6838c -0.4632,-0.5809 -1.3015,-0.5809 -1.3015 -0.5809c -0.3824,-0.0000 -0.7279,0.1544 -0.7279 0.1544c -0.3456,0.1544 -0.6250,0.4412 -0.6250 0.4412c -0.2794,0.2868 -0.4632,0.7059 -0.4632 0.7059c -0.1838,0.4191 -0.2426,0.9632 -0.2426 0.9632h 3.8235 ZM 473.6029,513.2500 ZM 474.2059,509.1029 h 3.3824 v 0.9265 h -3.3824 v -0.9265 ZM 478.1765,513.2500 ZM 479.1912,511.6324 c 0.4706,0.3824 0.9632,0.6176 0.9632 0.6176c 0.4926,0.2353 1.1397,0.2353 1.1397 0.2353c 0.7059,0.0000 1.0588,-0.3235 1.0588 -0.3235c 0.3529,-0.3235 0.3529,-0.7941 0.3529 -0.7941c 0.0000,-0.2794 -0.1471,-0.4853 -0.1471 -0.4853c -0.1471,-0.2059 -0.3750,-0.3603 -0.3750 -0.3603c -0.2279,-0.1544 -0.5221,-0.2721 -0.5221 -0.2721l -0.5882,-0.2353 c -0.3824,-0.1324 -0.7647,-0.3015 -0.7647 -0.3015c -0.3824,-0.1691 -0.6838,-0.4118 -0.6838 -0.4118c -0.3015,-0.2426 -0.4926,-0.5662 -0.4926 -0.5662c -0.1912,-0.3235 -0.1912,-0.7794 -0.1912 -0.7794c 0.0000,-0.4265 0.1691,-0.8015 0.1691 -0.8015c 0.1691,-0.3750 0.4853,-0.6471 0.4853 -0.6471c 0.3162,-0.2721 0.7721,-0.4265 0.7721 -0.4265c 0.4559,-0.1544 1.0294,-0.1544 1.0294 -0.1544c 0.6765,0.0000 1.2426,0.2353 1.2426 0.2353c 0.5662,0.2353 0.9779,0.5735 0.9779 0.5735l -0.5735,0.7647 c -0.3676,-0.2794 -0.7647,-0.4559 -0.7647 -0.4559c -0.3971,-0.1765 -0.8676,-0.1765 -0.8676 -0.1765c -0.6765,-0.0000 -0.9926,0.3088 -0.9926 0.3088c -0.3162,0.3088 -0.3162,0.7206 -0.3162 0.7206c 0.0000,0.2500 0.1324,0.4338 0.1324 0.4338c 0.1324,0.1838 0.3529,0.3235 0.3529 0.3235c 0.2206,0.1397 0.5074,0.2500 0.5074 0.2500c 0.2868,0.1103 0.5956,0.2279 0.5956 0.2279c 0.3824,0.1471 0.7721,0.3088 0.7721 0.3088c 0.3897,0.1618 0.6985,0.4044 0.6985 0.4044c 0.3088,0.2426 0.5074,0.5956 0.5074 0.5956c 0.1985,0.3529 0.1985,0.8529 0.1985 0.8529c 0.0000,0.4412 -0.1691,0.8235 -0.1691 0.8235c -0.1691,0.3824 -0.5000,0.6765 -0.5000 0.6765c -0.3309,0.2941 -0.8235,0.4632 -0.8235 0.4632c -0.4926,0.1691 -1.1250,0.1691 -1.1250 0.1691c -0.7647,-0.0000 -1.4559,-0.2794 -1.4559 -0.2794c -0.6912,-0.2794 -1.2059,-0.7059 -1.2059 -0.7059ZM 484.3382,513.2500 ZM 485.0147,509.6912 c 0.0000,-0.8971 0.2794,-1.5956 0.2794 -1.5956c 0.2794,-0.6985 0.7500,-1.1838 0.7500 -1.1838c 0.4706,-0.4853 1.0956,-0.7353 1.0956 -0.7353c 0.6250,-0.2500 1.3162,-0.2500 1.3162 -0.2500c 0.7059,0.0000 1.2132,0.2574 1.2132 0.2574c 0.5074,0.2574 0.8750,0.5956 0.8750 0.5956l -0.6029,0.7794 c -0.3235,-0.2794 -0.6691,-0.4559 -0.6691 -0.4559c -0.3456,-0.1765 -0.7721,-0.1765 -0.7721 -0.1765c -0.4853,-0.0000 -0.8971,0.1985 -0.8971 0.1985c -0.4118,0.1985 -0.7059,0.5662 -0.7059 0.5662c -0.2941,0.3676 -0.4632,0.8750 -0.4632 0.8750c -0.1691,0.5074 -0.1691,1.1250 -0.1691 1.1250c 0.0000,0.6176 0.1618,1.1176 0.1618 1.1176c 0.1618,0.5000 0.4485,0.8603 0.4485 0.8603c 0.2868,0.3603 0.6985,0.5588 0.6985 0.5588c 0.4118,0.1985 0.8971,0.1985 0.8971 0.1985c 0.5147,0.0000 0.9338,-0.2132 0.9338 -0.2132c 0.4191,-0.2132 0.7426,-0.5074 0.7426 -0.5074l 0.5441,0.7941 c -0.4853,0.4265 -1.0809,0.6765 -1.0809 0.6765c -0.5956,0.2500 -1.2426,0.2500 -1.2426 0.2500c -0.7059,-0.0000 -1.3235,-0.2500 -1.3235 -0.2500c -0.6176,-0.2500 -1.0662,-0.7279 -1.0662 -0.7279c -0.4485,-0.4779 -0.7059,-1.1765 -0.7059 -1.1765c -0.2574,-0.6985 -0.2574,-1.5809 -0.2574 -1.5809ZM 490.8971,513.2500 ZM 491.7500,511.3971 c 0.0000,-1.1765 1.0515,-1.8015 1.0515 -1.8015c 1.0515,-0.6250 3.3456,-0.8750 3.3456 -0.8750c 0.0000,-0.3382 -0.0662,-0.6618 -0.0662 -0.6618c -0.0662,-0.3235 -0.2353,-0.5735 -0.2353 -0.5735c -0.1691,-0.2500 -0.4485,-0.4044 -0.4485 -0.4044c -0.2794,-0.1544 -0.7206,-0.1544 -0.7206 -0.1544c -0.6324,-0.0000 -1.1691,0.2353 -1.1691 0.2353c -0.5368,0.2353 -0.9632,0.5294 -0.9632 0.5294l -0.4853,-0.8382 c 0.5000,-0.3235 1.2206,-0.6250 1.2206 -0.6250c 0.7206,-0.3015 1.5882,-0.3015 1.5882 -0.3015c 1.3088,0.0000 1.8971,0.8015 1.8971 0.8015c 0.5882,0.8015 0.5882,2.1397 0.5882 2.1397v 4.3824 h -1.0000 l -0.1029,-0.8529 h -0.0294 c -0.5147,0.4265 -1.1103,0.7279 -1.1103 0.7279c -0.5956,0.3015 -1.2574,0.3015 -1.2574 0.3015c -0.9118,-0.0000 -1.5074,-0.5294 -1.5074 -0.5294c -0.5956,-0.5294 -0.5956,-1.5000 -0.5956 -1.5000ZM 491.7500,511.3971 ZM 492.9412,511.3088 c 0.0000,0.6176 0.3603,0.8824 0.3603 0.8824c 0.3603,0.2647 0.8897,0.2647 0.8897 0.2647c 0.5147,0.0000 0.9779,-0.2426 0.9779 -0.2426c 0.4632,-0.2426 0.9779,-0.7132 0.9779 -0.7132v -1.9853 c -0.8971,0.1176 -1.5147,0.2794 -1.5147 0.2794c -0.6176,0.1618 -0.9926,0.3824 -0.9926 0.3824c -0.3750,0.2206 -0.5368,0.5074 -0.5368 0.5074c -0.1618,0.2868 -0.1618,0.6250 -0.1618 0.6250ZM 498.4265,513.2500 ZM 499.6324,506.1029 h 1.0000 l 0.1029,1.0294 h 0.0441 c 0.5147,-0.5147 1.0809,-0.8603 1.0809 -0.8603c 0.5662,-0.3456 1.3162,-0.3456 1.3162 -0.3456c 1.1324,0.0000 1.6544,0.7059 1.6544 0.7059c 0.5221,0.7059 0.5221,2.0882 0.5221 2.0882v 4.5294 h -1.2059 v -4.3676 c 0.0000,-1.0147 -0.3235,-1.4632 -0.3235 -1.4632c -0.3235,-0.4485 -1.0294,-0.4485 -1.0294 -0.4485c -0.5588,-0.0000 -0.9853,0.2794 -0.9853 0.2794c -0.4265,0.2794 -0.9706,0.8235 -0.9706 0.8235v 5.1765 h -1.2059 v -7.1471 ZM 509.4412,513.2500 ZM 511.9853,509.5147 l -2.1618,-3.4118 h 1.3088 l 0.9559,1.5735 c 0.1618,0.2941 0.3382,0.5956 0.3382 0.5956c 0.1765,0.3015 0.3676,0.5956 0.3676 0.5956h 0.0588 c 0.1618,-0.2941 0.3235,-0.5956 0.3235 -0.5956c 0.1618,-0.3015 0.3235,-0.5956 0.3235 -0.5956l 0.8676,-1.5735 h 1.2647 l -2.1618,3.5441 l 2.3235,3.6029 h -1.3088 l -1.0441,-1.6618 l -0.3824,-0.6471 c 0.0000,0.0000 -0.3971,-0.6324 -0.3971 -0.6324h -0.0588 c -0.1912,0.3088 -0.3676,0.6250 -0.3676 0.6250c -0.1765,0.3162 -0.3529,0.6544 -0.3529 0.6544l -0.9706,1.6618 h -1.2647 ZM 518.9706,513.2500 ZM 523.4412,509.6912 v -2.7206 c 0.0000,-0.3824 0.0221,-0.9044 0.0221 -0.9044c 0.0221,-0.5221 0.0515,-0.9044 0.0515 -0.9044h -0.0588 c -0.1765,0.3382 -0.3676,0.6618 -0.3676 0.6618c -0.1912,0.3235 -0.3971,0.6618 -0.3971 0.6618l -2.1912,3.2059 h 2.9412 ZM 523.4412,509.6912 ZM 525.8676,510.6618 h -1.2794 v 2.5882 h -1.1471 v -2.5882 h -4.2206 v -0.7941 l 4.0147,-6.0000 h 1.3529 v 5.8235 h 1.2794 v 0.9706 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(255,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 10.0000,528.0000 v 14.0000 h 22.0000 v -14.0000 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 39.1029,537.2500 ZM 39.7941,533.6912 c 0.0000,-0.8676 0.2574,-1.5662 0.2574 -1.5662c 0.2574,-0.6985 0.6838,-1.1838 0.6838 -1.1838c 0.4265,-0.4853 0.9853,-0.7500 0.9853 -0.7500c 0.5588,-0.2647 1.1765,-0.2647 1.1765 -0.2647c 0.6176,0.0000 1.0735,0.2206 1.0735 0.2206c 0.4559,0.2206 0.9265,0.6029 0.9265 0.6029l -0.0588,-1.2206 v -2.7500 h 1.2206 v 10.4706 h -1.0000 l -0.1029,-0.8382 h -0.0441 c -0.4265,0.4118 -0.9779,0.7132 -0.9779 0.7132c -0.5515,0.3015 -1.1838,0.3015 -1.1838 0.3015c -1.3529,-0.0000 -2.1544,-0.9706 -2.1544 -0.9706c -0.8015,-0.9706 -0.8015,-2.7647 -0.8015 -2.7647ZM 39.7941,533.6912 ZM 41.0441,533.6765 c 0.0000,1.2941 0.5147,2.0147 0.5147 2.0147c 0.5147,0.7206 1.4559,0.7206 1.4559 0.7206c 0.5000,0.0000 0.9412,-0.2426 0.9412 -0.2426c 0.4412,-0.2426 0.8824,-0.7426 0.8824 -0.7426v -3.7353 c -0.4559,-0.4118 -0.8750,-0.5809 -0.8750 -0.5809c -0.4191,-0.1691 -0.8603,-0.1691 -0.8603 -0.1691c -0.4265,-0.0000 -0.8015,0.1985 -0.8015 0.1985c -0.3750,0.1985 -0.6544,0.5588 -0.6544 0.5588c -0.2794,0.3603 -0.4412,0.8603 -0.4412 0.8603c -0.1618,0.5000 -0.1618,1.1176 -0.1618 1.1176ZM 47.2647,537.2500 ZM 48.4706,530.1029 h 1.0000 l 0.1029,1.2941 h 0.0441 c 0.3676,-0.6765 0.8897,-1.0735 0.8897 -1.0735c 0.5221,-0.3971 1.1397,-0.3971 1.1397 -0.3971c 0.4265,0.0000 0.7647,0.1471 0.7647 0.1471l -0.2353,1.0588 c -0.1765,-0.0588 -0.3235,-0.0882 -0.3235 -0.0882c -0.1471,-0.0294 -0.3676,-0.0294 -0.3676 -0.0294c -0.4559,-0.0000 -0.9485,0.3676 -0.9485 0.3676c -0.4926,0.3676 -0.8603,1.2794 -0.8603 1.2794v 4.5882 h -1.2059 v -7.1471 ZM 52.2206,537.2500 ZM 52.8971,533.6912 c 0.0000,-0.8971 0.2721,-1.5956 0.2721 -1.5956c 0.2721,-0.6985 0.7279,-1.1838 0.7279 -1.1838c 0.4559,-0.4853 1.0515,-0.7353 1.0515 -0.7353c 0.5956,-0.2500 1.2574,-0.2500 1.2574 -0.2500c 0.6618,0.0000 1.2574,0.2500 1.2574 0.2500c 0.5956,0.2500 1.0515,0.7353 1.0515 0.7353c 0.4559,0.4853 0.7279,1.1838 0.7279 1.1838c 0.2721,0.6985 0.2721,1.5956 0.2721 1.5956c 0.0000,0.8824 -0.2721,1.5809 -0.2721 1.5809c -0.2721,0.6985 -0.7279,1.1765 -0.7279 1.1765c -0.4559,0.4779 -1.0515,0.7279 -1.0515 0.7279c -0.5956,0.2500 -1.2574,0.2500 -1.2574 0.2500c -0.6618,-0.0000 -1.2574,-0.2500 -1.2574 -0.2500c -0.5956,-0.2500 -1.0515,-0.7279 -1.0515 -0.7279c -0.4559,-0.4779 -0.7279,-1.1765 -0.7279 -1.1765c -0.2721,-0.6985 -0.2721,-1.5809 -0.2721 -1.5809ZM 52.8971,533.6912 ZM 54.1471,533.6912 c 0.0000,0.6176 0.1471,1.1176 0.1471 1.1176c 0.1471,0.5000 0.4191,0.8603 0.4191 0.8603c 0.2721,0.3603 0.6544,0.5588 0.6544 0.5588c 0.3824,0.1985 0.8382,0.1985 0.8382 0.1985c 0.4559,0.0000 0.8382,-0.1985 0.8382 -0.1985c 0.3824,-0.1985 0.6544,-0.5588 0.6544 -0.5588c 0.2721,-0.3603 0.4191,-0.8603 0.4191 -0.8603c 0.1471,-0.5000 0.1471,-1.1176 0.1471 -1.1176c 0.0000,-0.6176 -0.1471,-1.1250 -0.1471 -1.1250c -0.1471,-0.5074 -0.4191,-0.8750 -0.4191 -0.8750c -0.2721,-0.3676 -0.6544,-0.5662 -0.6544 -0.5662c -0.3824,-0.1985 -0.8382,-0.1985 -0.8382 -0.1985c -0.4559,-0.0000 -0.8382,0.1985 -0.8382 0.1985c -0.3824,0.1985 -0.6544,0.5662 -0.6544 0.5662c -0.2721,0.3676 -0.4191,0.8750 -0.4191 0.8750c -0.1471,0.5074 -0.1471,1.1250 -0.1471 1.1250ZM 60.1912,537.2500 ZM 62.6029,537.8529 v 2.4118 h -1.2059 v -10.1618 h 1.0000 l 0.1029,0.8235 h 0.0441 c 0.4853,-0.4118 1.0662,-0.7059 1.0662 -0.7059c 0.5809,-0.2941 1.2132,-0.2941 1.2132 -0.2941c 0.6912,0.0000 1.2206,0.2574 1.2206 0.2574c 0.5294,0.2574 0.8824,0.7353 0.8824 0.7353c 0.3529,0.4779 0.5368,1.1471 0.5368 1.1471c 0.1838,0.6691 0.1838,1.5074 0.1838 1.5074c 0.0000,0.9118 -0.2500,1.6250 -0.2500 1.6250c -0.2500,0.7132 -0.6765,1.2132 -0.6765 1.2132c -0.4265,0.5000 -0.9853,0.7574 -0.9853 0.7574c -0.5588,0.2574 -1.1765,0.2574 -1.1765 0.2574c -0.5000,-0.0000 -0.9926,-0.2206 -0.9926 -0.2206c -0.4926,-0.2206 -0.9926,-0.6029 -0.9926 -0.6029ZM 62.6029,537.8529 ZM 62.6029,535.6618 c 0.4853,0.4118 0.9412,0.5809 0.9412 0.5809c 0.4559,0.1691 0.8088,0.1691 0.8088 0.1691c 0.4412,0.0000 0.8162,-0.1985 0.8162 -0.1985c 0.3750,-0.1985 0.6471,-0.5588 0.6471 -0.5588c 0.2721,-0.3603 0.4265,-0.8897 0.4265 -0.8897c 0.1544,-0.5294 0.1544,-1.1912 0.1544 -1.1912c 0.0000,-0.5882 -0.1029,-1.0735 -0.1029 -1.0735c -0.1029,-0.4853 -0.3309,-0.8309 -0.3309 -0.8309c -0.2279,-0.3456 -0.5882,-0.5368 -0.5882 -0.5368c -0.3603,-0.1912 -0.8603,-0.1912 -0.8603 -0.1912c -0.4559,-0.0000 -0.9191,0.2500 -0.9191 0.2500c -0.4632,0.2500 -0.9926,0.7206 -0.9926 0.7206v 3.7500 ZM 68.3529,537.2500 ZM 68.9559,533.1029 h 3.3824 v 0.9265 h -3.3824 v -0.9265 ZM 72.9265,537.2500 ZM 73.6029,533.6912 c 0.0000,-0.8971 0.2721,-1.5956 0.2721 -1.5956c 0.2721,-0.6985 0.7279,-1.1838 0.7279 -1.1838c 0.4559,-0.4853 1.0515,-0.7353 1.0515 -0.7353c 0.5956,-0.2500 1.2574,-0.2500 1.2574 -0.2500c 0.6618,0.0000 1.2574,0.2500 1.2574 0.2500c 0.5956,0.2500 1.0515,0.7353 1.0515 0.7353c 0.4559,0.4853 0.7279,1.1838 0.7279 1.1838c 0.2721,0.6985 0.2721,1.5956 0.2721 1.5956c 0.0000,0.8824 -0.2721,1.5809 -0.2721 1.5809c -0.2721,0.6985 -0.7279,1.1765 -0.7279 1.1765c -0.4559,0.4779 -1.0515,0.7279 -1.0515 0.7279c -0.5956,0.2500 -1.2574,0.2500 -1.2574 0.2500c -0.6618,-0.0000 -1.2574,-0.2500 -1.2574 -0.2500c -0.5956,-0.2500 -1.0515,-0.7279 -1.0515 -0.7279c -0.4559,-0.4779 -0.7279,-1.1765 -0.7279 -1.1765c -0.2721,-0.6985 -0.2721,-1.5809 -0.2721 -1.5809ZM 73.6029,533.6912 ZM 74.8529,533.6912 c 0.0000,0.6176 0.1471,1.1176 0.1471 1.1176c 0.1471,0.5000 0.4191,0.8603 0.4191 0.8603c 0.2721,0.3603 0.6544,0.5588 0.6544 0.5588c 0.3824,0.1985 0.8382,0.1985 0.8382 0.1985c 0.4559,0.0000 0.8382,-0.1985 0.8382 -0.1985c 0.3824,-0.1985 0.6544,-0.5588 0.6544 -0.5588c 0.2721,-0.3603 0.4191,-0.8603 0.4191 -0.8603c 0.1471,-0.5000 0.1471,-1.1176 0.1471 -1.1176c 0.0000,-0.6176 -0.1471,-1.1250 -0.1471 -1.1250c -0.1471,-0.5074 -0.4191,-0.8750 -0.4191 -0.8750c -0.2721,-0.3676 -0.6544,-0.5662 -0.6544 -0.5662c -0.3824,-0.1985 -0.8382,-0.1985 -0.8382 -0.1985c -0.4559,-0.0000 -0.8382,0.1985 -0.8382 0.1985c -0.3824,0.1985 -0.6544,0.5662 -0.6544 0.5662c -0.2721,0.3676 -0.4191,0.8750 -0.4191 0.8750c -0.1471,0.5074 -0.1471,1.1250 -0.1471 1.1250ZM 80.8971,537.2500 ZM 82.1029,530.1029 h 1.0000 l 0.1029,1.0294 h 0.0441 c 0.5147,-0.5147 1.0809,-0.8603 1.0809 -0.8603c 0.5662,-0.3456 1.3162,-0.3456 1.3162 -0.3456c 1.1324,0.0000 1.6544,0.7059 1.6544 0.7059c 0.5221,0.7059 0.5221,2.0882 0.5221 2.0882v 4.5294 h -1.2059 v -4.3676 c 0.0000,-1.0147 -0.3235,-1.4632 -0.3235 -1.4632c -0.3235,-0.4485 -1.0294,-0.4485 -1.0294 -0.4485c -0.5588,-0.0000 -0.9853,0.2794 -0.9853 0.2794c -0.4265,0.2794 -0.9706,0.8235 -0.9706 0.8235v 5.1765 h -1.2059 v -7.1471 ZM 88.9412,537.2500 ZM 89.6176,533.6912 c 0.0000,-0.8824 0.2721,-1.5809 0.2721 -1.5809c 0.2721,-0.6985 0.7206,-1.1838 0.7206 -1.1838c 0.4485,-0.4853 1.0221,-0.7426 1.0221 -0.7426c 0.5735,-0.2574 1.1912,-0.2574 1.1912 -0.2574c 0.6765,0.0000 1.2132,0.2353 1.2132 0.2353c 0.5368,0.2353 0.8971,0.6765 0.8971 0.6765c 0.3603,0.4412 0.5515,1.0588 0.5515 1.0588c 0.1912,0.6176 0.1912,1.3824 0.1912 1.3824c 0.0000,0.3971 -0.0441,0.6618 -0.0441 0.6618h -4.8235 c 0.0735,1.1618 0.7132,1.8382 0.7132 1.8382c 0.6397,0.6765 1.6691,0.6765 1.6691 0.6765c 0.5147,0.0000 0.9485,-0.1544 0.9485 -0.1544c 0.4338,-0.1544 0.8309,-0.4044 0.8309 -0.4044l 0.4265,0.7941 c -0.4706,0.2941 -1.0441,0.5147 -1.0441 0.5147c -0.5735,0.2206 -1.3088,0.2206 -1.3088 0.2206c -0.7206,-0.0000 -1.3456,-0.2574 -1.3456 -0.2574c -0.6250,-0.2574 -1.0882,-0.7353 -1.0882 -0.7353c -0.4632,-0.4779 -0.7279,-1.1691 -0.7279 -1.1691c -0.2647,-0.6912 -0.2647,-1.5735 -0.2647 -1.5735ZM 89.6176,533.6912 ZM 94.6176,533.1471 c 0.0000,-1.1029 -0.4632,-1.6838 -0.4632 -1.6838c -0.4632,-0.5809 -1.3015,-0.5809 -1.3015 -0.5809c -0.3824,-0.0000 -0.7279,0.1544 -0.7279 0.1544c -0.3456,0.1544 -0.6250,0.4412 -0.6250 0.4412c -0.2794,0.2868 -0.4632,0.7059 -0.4632 0.7059c -0.1838,0.4191 -0.2426,0.9632 -0.2426 0.9632h 3.8235 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(255,165,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 139.9265,528.0000 v 14.0000 h 22.0000 v -14.0000 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 169.0294,537.2500 ZM 169.7206,533.6912 c 0.0000,-0.8676 0.2574,-1.5662 0.2574 -1.5662c 0.2574,-0.6985 0.6838,-1.1838 0.6838 -1.1838c 0.4265,-0.4853 0.9853,-0.7500 0.9853 -0.7500c 0.5588,-0.2647 1.1765,-0.2647 1.1765 -0.2647c 0.6176,0.0000 1.0735,0.2206 1.0735 0.2206c 0.4559,0.2206 0.9265,0.6029 0.9265 0.6029l -0.0588,-1.2206 v -2.7500 h 1.2206 v 10.4706 h -1.0000 l -0.1029,-0.8382 h -0.0441 c -0.4265,0.4118 -0.9779,0.7132 -0.9779 0.7132c -0.5515,0.3015 -1.1838,0.3015 -1.1838 0.3015c -1.3529,-0.0000 -2.1544,-0.9706 -2.1544 -0.9706c -0.8015,-0.9706 -0.8015,-2.7647 -0.8015 -2.7647ZM 169.7206,533.6912 ZM 170.9706,533.6765 c 0.0000,1.2941 0.5147,2.0147 0.5147 2.0147c 0.5147,0.7206 1.4559,0.7206 1.4559 0.7206c 0.5000,0.0000 0.9412,-0.2426 0.9412 -0.2426c 0.4412,-0.2426 0.8824,-0.7426 0.8824 -0.7426v -3.7353 c -0.4559,-0.4118 -0.8750,-0.5809 -0.8750 -0.5809c -0.4191,-0.1691 -0.8603,-0.1691 -0.8603 -0.1691c -0.4265,-0.0000 -0.8015,0.1985 -0.8015 0.1985c -0.3750,0.1985 -0.6544,0.5588 -0.6544 0.5588c -0.2794,0.3603 -0.4412,0.8603 -0.4412 0.8603c -0.1618,0.5000 -0.1618,1.1176 -0.1618 1.1176ZM 177.1912,537.2500 ZM 178.3971,530.1029 h 1.0000 l 0.1029,1.2941 h 0.0441 c 0.3676,-0.6765 0.8897,-1.0735 0.8897 -1.0735c 0.5221,-0.3971 1.1397,-0.3971 1.1397 -0.3971c 0.4265,0.0000 0.7647,0.1471 0.7647 0.1471l -0.2353,1.0588 c -0.1765,-0.0588 -0.3235,-0.0882 -0.3235 -0.0882c -0.1471,-0.0294 -0.3676,-0.0294 -0.3676 -0.0294c -0.4559,-0.0000 -0.9485,0.3676 -0.9485 0.3676c -0.4926,0.3676 -0.8603,1.2794 -0.8603 1.2794v 4.5882 h -1.2059 v -7.1471 ZM 182.1471,537.2500 ZM 182.8235,533.6912 c 0.0000,-0.8971 0.2721,-1.5956 0.2721 -1.5956c 0.2721,-0.6985 0.7279,-1.1838 0.7279 -1.1838c 0.4559,-0.4853 1.0515,-0.7353 1.0515 -0.7353c 0.5956,-0.2500 1.2574,-0.2500 1.2574 -0.2500c 0.6618,0.0000 1.2574,0.2500 1.2574 0.2500c 0.5956,0.2500 1.0515,0.7353 1.0515 0.7353c 0.4559,0.4853 0.7279,1.1838 0.7279 1.1838c 0.2721,0.6985 0.2721,1.5956 0.2721 1.5956c 0.0000,0.8824 -0.2721,1.5809 -0.2721 1.5809c -0.2721,0.6985 -0.7279,1.1765 -0.7279 1.1765c -0.4559,0.4779 -1.0515,0.7279 -1.0515 0.7279c -0.5956,0.2500 -1.2574,0.2500 -1.2574 0.2500c -0.6618,-0.0000 -1.2574,-0.2500 -1.2574 -0.2500c -0.5956,-0.2500 -1.0515,-0.7279 -1.0515 -0.7279c -0.4559,-0.4779 -0.7279,-1.1765 -0.7279 -1.1765c -0.2721,-0.6985 -0.2721,-1.5809 -0.2721 -1.5809ZM 182.8235,533.6912 ZM 184.0735,533.6912 c 0.0000,0.6176 0.1471,1.1176 0.1471 1.1176c 0.1471,0.5000 0.4191,0.8603 0.4191 0.8603c 0.2721,0.3603 0.6544,0.5588 0.6544 0.5588c 0.3824,0.1985 0.8382,0.1985 0.8382 0.1985c 0.4559,0.0000 0.8382,-0.1985 0.8382 -0.1985c 0.3824,-0.1985 0.6544,-0.5588 0.6544 -0.5588c 0.2721,-0.3603 0.4191,-0.8603 0.4191 -0.8603c 0.1471,-0.5000 0.1471,-1.1176 0.1471 -1.1176c 0.0000,-0.6176 -0.1471,-1.1250 -0.1471 -1.1250c -0.1471,-0.5074 -0.4191,-0.8750 -0.4191 -0.8750c -0.2721,-0.3676 -0.6544,-0.5662 -0.6544 -0.5662c -0.3824,-0.1985 -0.8382,-0.1985 -0.8382 -0.1985c -0.4559,-0.0000 -0.8382,0.1985 -0.8382 0.1985c -0.3824,0.1985 -0.6544,0.5662 -0.6544 0.5662c -0.2721,0.3676 -0.4191,0.8750 -0.4191 0.8750c -0.1471,0.5074 -0.1471,1.1250 -0.1471 1.1250ZM 190.1176,537.2500 ZM 192.5294,537.8529 v 2.4118 h -1.2059 v -10.1618 h 1.0000 l 0.1029,0.8235 h 0.0441 c 0.4853,-0.4118 1.0662,-0.7059 1.0662 -0.7059c 0.5809,-0.2941 1.2132,-0.2941 1.2132 -0.2941c 0.6912,0.0000 1.2206,0.2574 1.2206 0.2574c 0.5294,0.2574 0.8824,0.7353 0.8824 0.7353c 0.3529,0.4779 0.5368,1.1471 0.5368 1.1471c 0.1838,0.6691 0.1838,1.5074 0.1838 1.5074c 0.0000,0.9118 -0.2500,1.6250 -0.2500 1.6250c -0.2500,0.7132 -0.6765,1.2132 -0.6765 1.2132c -0.4265,0.5000 -0.9853,0.7574 -0.9853 0.7574c -0.5588,0.2574 -1.1765,0.2574 -1.1765 0.2574c -0.5000,-0.0000 -0.9926,-0.2206 -0.9926 -0.2206c -0.4926,-0.2206 -0.9926,-0.6029 -0.9926 -0.6029ZM 192.5294,537.8529 ZM 192.5294,535.6618 c 0.4853,0.4118 0.9412,0.5809 0.9412 0.5809c 0.4559,0.1691 0.8088,0.1691 0.8088 0.1691c 0.4412,0.0000 0.8162,-0.1985 0.8162 -0.1985c 0.3750,-0.1985 0.6471,-0.5588 0.6471 -0.5588c 0.2721,-0.3603 0.4265,-0.8897 0.4265 -0.8897c 0.1544,-0.5294 0.1544,-1.1912 0.1544 -1.1912c 0.0000,-0.5882 -0.1029,-1.0735 -0.1029 -1.0735c -0.1029,-0.4853 -0.3309,-0.8309 -0.3309 -0.8309c -0.2279,-0.3456 -0.5882,-0.5368 -0.5882 -0.5368c -0.3603,-0.1912 -0.8603,-0.1912 -0.8603 -0.1912c -0.4559,-0.0000 -0.9191,0.2500 -0.9191 0.2500c -0.4632,0.2500 -0.9926,0.7206 -0.9926 0.7206v 3.7500 ZM 198.2794,537.2500 ZM 198.6176,527.6029 h 1.2647 l 1.0147,5.2500 c 0.1324,0.7941 0.2794,1.5588 0.2794 1.5588c 0.1471,0.7647 0.2794,1.5588 0.2794 1.5588h 0.0588 c 0.1618,-0.7941 0.3382,-1.5662 0.3382 -1.5662c 0.1765,-0.7721 0.3382,-1.5515 0.3382 -1.5515l 1.3382,-5.2500 h 1.1176 l 1.3382,5.2500 c 0.1765,0.7647 0.3529,1.5441 0.3529 1.5441c 0.1765,0.7794 0.3529,1.5735 0.3529 1.5735h 0.0588 c 0.1324,-0.7941 0.2647,-1.5662 0.2647 -1.5662c 0.1324,-0.7721 0.2794,-1.5515 0.2794 -1.5515l 1.0147,-5.2500 h 1.1765 l -2.0000,9.6471 h -1.4706 l -1.4559,-5.8088 c -0.1324,-0.5588 -0.2426,-1.0956 -0.2426 -1.0956c -0.1103,-0.5368 -0.2279,-1.0956 -0.2279 -1.0956h -0.0588 c -0.1176,0.5588 -0.2426,1.0956 -0.2426 1.0956c -0.1250,0.5368 -0.2426,1.0956 -0.2426 1.0956l -1.4265,5.8088 h -1.4559 ZM 209.8382,537.2500 ZM 211.0441,526.7794 h 1.2059 v 2.8529 l -0.0441,1.4706 c 0.5147,-0.4853 1.0735,-0.8309 1.0735 -0.8309c 0.5588,-0.3456 1.3088,-0.3456 1.3088 -0.3456c 1.1324,0.0000 1.6544,0.7059 1.6544 0.7059c 0.5221,0.7059 0.5221,2.0882 0.5221 2.0882v 4.5294 h -1.2059 v -4.3676 c 0.0000,-1.0147 -0.3235,-1.4632 -0.3235 -1.4632c -0.3235,-0.4485 -1.0294,-0.4485 -1.0294 -0.4485c -0.5588,-0.0000 -0.9853,0.2794 -0.9853 0.2794c -0.4265,0.2794 -0.9706,0.8235 -0.9706 0.8235v 5.1765 h -1.2059 v -10.4706 ZM 217.8382,537.2500 ZM 219.6618,528.6324 c -0.3529,-0.0000 -0.5956,-0.2206 -0.5956 -0.2206c -0.2426,-0.2206 -0.2426,-0.5588 -0.2426 -0.5588c 0.0000,-0.3529 0.2426,-0.5662 0.2426 -0.5662c 0.2426,-0.2132 0.5956,-0.2132 0.5956 -0.2132c 0.3529,0.0000 0.5956,0.2132 0.5956 0.2132c 0.2426,0.2132 0.2426,0.5662 0.2426 0.5662c 0.0000,0.3382 -0.2426,0.5588 -0.2426 0.5588c -0.2426,0.2206 -0.5956,0.2206 -0.5956 0.2206ZM 219.6618,528.6324 ZM 219.0441,530.1029 h 1.2059 v 7.1471 h -1.2059 v -7.1471 ZM 221.4559,537.2500 ZM 222.6618,526.7794 h 1.2059 v 9.1176 c 0.0000,0.2941 0.1029,0.4118 0.1029 0.4118c 0.1029,0.1176 0.2353,0.1176 0.2353 0.1176h 0.1103 c 0.0000,0.0000 0.1544,-0.0294 0.1544 -0.0294l 0.1618,0.9118 c -0.1176,0.0588 -0.2794,0.0882 -0.2794 0.0882c -0.1618,0.0294 -0.4118,0.0294 -0.4118 0.0294c -0.6912,-0.0000 -0.9853,-0.4118 -0.9853 -0.4118c -0.2941,-0.4118 -0.2941,-1.2059 -0.2941 -1.2059v -9.0294 ZM 225.2059,537.2500 ZM 225.8824,533.6912 c 0.0000,-0.8824 0.2721,-1.5809 0.2721 -1.5809c 0.2721,-0.6985 0.7206,-1.1838 0.7206 -1.1838c 0.4485,-0.4853 1.0221,-0.7426 1.0221 -0.7426c 0.5735,-0.2574 1.1912,-0.2574 1.1912 -0.2574c 0.6765,0.0000 1.2132,0.2353 1.2132 0.2353c 0.5368,0.2353 0.8971,0.6765 0.8971 0.6765c 0.3603,0.4412 0.5515,1.0588 0.5515 1.0588c 0.1912,0.6176 0.1912,1.3824 0.1912 1.3824c 0.0000,0.3971 -0.0441,0.6618 -0.0441 0.6618h -4.8235 c 0.0735,1.1618 0.7132,1.8382 0.7132 1.8382c 0.6397,0.6765 1.6691,0.6765 1.6691 0.6765c 0.5147,0.0000 0.9485,-0.1544 0.9485 -0.1544c 0.4338,-0.1544 0.8309,-0.4044 0.8309 -0.4044l 0.4265,0.7941 c -0.4706,0.2941 -1.0441,0.5147 -1.0441 0.5147c -0.5735,0.2206 -1.3088,0.2206 -1.3088 0.2206c -0.7206,-0.0000 -1.3456,-0.2574 -1.3456 -0.2574c -0.6250,-0.2574 -1.0882,-0.7353 -1.0882 -0.7353c -0.4632,-0.4779 -0.7279,-1.1691 -0.7279 -1.1691c -0.2647,-0.6912 -0.2647,-1.5735 -0.2647 -1.5735ZM 225.8824,533.6912 ZM 230.8824,533.1471 c 0.0000,-1.1029 -0.4632,-1.6838 -0.4632 -1.6838c -0.4632,-0.5809 -1.3015,-0.5809 -1.3015 -0.5809c -0.3824,-0.0000 -0.7279,0.1544 -0.7279 0.1544c -0.3456,0.1544 -0.6250,0.4412 -0.6250 0.4412c -0.2794,0.2868 -0.4632,0.7059 -0.4632 0.7059c -0.1838,0.4191 -0.2426,0.9632 -0.2426 0.9632h 3.8235 ZM 232.5000,537.2500 ZM 233.1029,533.1029 h 3.3824 v 0.9265 h -3.3824 v -0.9265 ZM 237.0735,537.2500 ZM 241.5000,527.7647 c -0.3971,-0.1765 -0.8088,-0.1765 -0.8088 -0.1765c -1.0000,-0.0000 -1.0000,1.3824 -1.0000 1.3824v 1.1324 h 1.5147 v 0.9853 h -1.5147 v 6.1618 h -1.2059 v -6.1618 h -0.9706 v -0.9118 l 0.9706,-0.0735 v -1.1324 c 0.0000,-1.1029 0.5074,-1.7353 0.5074 -1.7353c 0.5074,-0.6324 1.5809,-0.6324 1.5809 -0.6324c 0.3382,0.0000 0.6397,0.0662 0.6397 0.0662c 0.3015,0.0662 0.5515,0.1691 0.5515 0.1691ZM 241.0735,537.2500 ZM 241.9265,535.3971 c 0.0000,-1.1765 1.0515,-1.8015 1.0515 -1.8015c 1.0515,-0.6250 3.3456,-0.8750 3.3456 -0.8750c 0.0000,-0.3382 -0.0662,-0.6618 -0.0662 -0.6618c -0.0662,-0.3235 -0.2353,-0.5735 -0.2353 -0.5735c -0.1691,-0.2500 -0.4485,-0.4044 -0.4485 -0.4044c -0.2794,-0.1544 -0.7206,-0.1544 -0.7206 -0.1544c -0.6324,-0.0000 -1.1691,0.2353 -1.1691 0.2353c -0.5368,0.2353 -0.9632,0.5294 -0.9632 0.5294l -0.4853,-0.8382 c 0.5000,-0.3235 1.2206,-0.6250 1.2206 -0.6250c 0.7206,-0.3015 1.5882,-0.3015 1.5882 -0.3015c 1.3088,0.0000 1.8971,0.8015 1.8971 0.8015c 0.5882,0.8015 0.5882,2.1397 0.5882 2.1397v 4.3824 h -1.0000 l -0.1029,-0.8529 h -0.0294 c -0.5147,0.4265 -1.1103,0.7279 -1.1103 0.7279c -0.5956,0.3015 -1.2574,0.3015 -1.2574 0.3015c -0.9118,-0.0000 -1.5074,-0.5294 -1.5074 -0.5294c -0.5956,-0.5294 -0.5956,-1.5000 -0.5956 -1.5000ZM 241.9265,535.3971 ZM 243.1176,535.3088 c 0.0000,0.6176 0.3603,0.8824 0.3603 0.8824c 0.3603,0.2647 0.8897,0.2647 0.8897 0.2647c 0.5147,0.0000 0.9779,-0.2426 0.9779 -0.2426c 0.4632,-0.2426 0.9779,-0.7132 0.9779 -0.7132v -1.9853 c -0.8971,0.1176 -1.5147,0.2794 -1.5147 0.2794c -0.6176,0.1618 -0.9926,0.3824 -0.9926 0.3824c -0.3750,0.2206 -0.5368,0.5074 -0.5368 0.5074c -0.1618,0.2868 -0.1618,0.6250 -0.1618 0.6250ZM 248.6029,537.2500 ZM 249.8088,526.7794 h 1.2059 v 9.1176 c 0.0000,0.2941 0.1029,0.4118 0.1029 0.4118c 0.1029,0.1176 0.2353,0.1176 0.2353 0.1176h 0.1103 c 0.0000,0.0000 0.1544,-0.0294 0.1544 -0.0294l 0.1618,0.9118 c -0.1176,0.0588 -0.2794,0.0882 -0.2794 0.0882c -0.1618,0.0294 -0.4118,0.0294 -0.4118 0.0294c -0.6912,-0.0000 -0.9853,-0.4118 -0.9853 -0.4118c -0.2941,-0.4118 -0.2941,-1.2059 -0.2941 -1.2059v -9.0294 ZM 252.3529,537.2500 ZM 253.3676,535.6324 c 0.4706,0.3824 0.9632,0.6176 0.9632 0.6176c 0.4926,0.2353 1.1397,0.2353 1.1397 0.2353c 0.7059,0.0000 1.0588,-0.3235 1.0588 -0.3235c 0.3529,-0.3235 0.3529,-0.7941 0.3529 -0.7941c 0.0000,-0.2794 -0.1471,-0.4853 -0.1471 -0.4853c -0.1471,-0.2059 -0.3750,-0.3603 -0.3750 -0.3603c -0.2279,-0.1544 -0.5221,-0.2721 -0.5221 -0.2721l -0.5882,-0.2353 c -0.3824,-0.1324 -0.7647,-0.3015 -0.7647 -0.3015c -0.3824,-0.1691 -0.6838,-0.4118 -0.6838 -0.4118c -0.3015,-0.2426 -0.4926,-0.5662 -0.4926 -0.5662c -0.1912,-0.3235 -0.1912,-0.7794 -0.1912 -0.7794c 0.0000,-0.4265 0.1691,-0.8015 0.1691 -0.8015c 0.1691,-0.3750 0.4853,-0.6471 0.4853 -0.6471c 0.3162,-0.2721 0.7721,-0.4265 0.7721 -0.4265c 0.4559,-0.1544 1.0294,-0.1544 1.0294 -0.1544c 0.6765,0.0000 1.2426,0.2353 1.2426 0.2353c 0.5662,0.2353 0.9779,0.5735 0.9779 0.5735l -0.5735,0.7647 c -0.3676,-0.2794 -0.7647,-0.4559 -0.7647 -0.4559c -0.3971,-0.1765 -0.8676,-0.1765 -0.8676 -0.1765c -0.6765,-0.0000 -0.9926,0.3088 -0.9926 0.3088c -0.3162,0.3088 -0.3162,0.7206 -0.3162 0.7206c 0.0000,0.2500 0.1324,0.4338 0.1324 0.4338c 0.1324,0.1838 0.3529,0.3235 0.3529 0.3235c 0.2206,0.1397 0.5074,0.2500 0.5074 0.2500c 0.2868,0.1103 0.5956,0.2279 0.5956 0.2279c 0.3824,0.1471 0.7721,0.3088 0.7721 0.3088c 0.3897,0.1618 0.6985,0.4044 0.6985 0.4044c 0.3088,0.2426 0.5074,0.5956 0.5074 0.5956c 0.1985,0.3529 0.1985,0.8529 0.1985 0.8529c 0.0000,0.4412 -0.1691,0.8235 -0.1691 0.8235c -0.1691,0.3824 -0.5000,0.6765 -0.5000 0.6765c -0.3309,0.2941 -0.8235,0.4632 -0.8235 0.4632c -0.4926,0.1691 -1.1250,0.1691 -1.1250 0.1691c -0.7647,-0.0000 -1.4559,-0.2794 -1.4559 -0.2794c -0.6912,-0.2794 -1.2059,-0.7059 -1.2059 -0.7059ZM 258.5147,537.2500 ZM 259.1912,533.6912 c 0.0000,-0.8824 0.2721,-1.5809 0.2721 -1.5809c 0.2721,-0.6985 0.7206,-1.1838 0.7206 -1.1838c 0.4485,-0.4853 1.0221,-0.7426 1.0221 -0.7426c 0.5735,-0.2574 1.1912,-0.2574 1.1912 -0.2574c 0.6765,0.0000 1.2132,0.2353 1.2132 0.2353c 0.5368,0.2353 0.8971,0.6765 0.8971 0.6765c 0.3603,0.4412 0.5515,1.0588 0.5515 1.0588c 0.1912,0.6176 0.1912,1.3824 0.1912 1.3824c 0.0000,0.3971 -0.0441,0.6618 -0.0441 0.6618h -4.8235 c 0.0735,1.1618 0.7132,1.8382 0.7132 1.8382c 0.6397,0.6765 1.6691,0.6765 1.6691 0.6765c 0.5147,0.0000 0.9485,-0.1544 0.9485 -0.1544c 0.4338,-0.1544 0.8309,-0.4044 0.8309 -0.4044l 0.4265,0.7941 c -0.4706,0.2941 -1.0441,0.5147 -1.0441 0.5147c -0.5735,0.2206 -1.3088,0.2206 -1.3088 0.2206c -0.7206,-0.0000 -1.3456,-0.2574 -1.3456 -0.2574c -0.6250,-0.2574 -1.0882,-0.7353 -1.0882 -0.7353c -0.4632,-0.4779 -0.7279,-1.1691 -0.7279 -1.1691c -0.2647,-0.6912 -0.2647,-1.5735 -0.2647 -1.5735ZM 259.1912,533.6912 ZM 264.1912,533.1471 c 0.0000,-1.1029 -0.4632,-1.6838 -0.4632 -1.6838c -0.4632,-0.5809 -1.3015,-0.5809 -1.3015 -0.5809c -0.3824,-0.0000 -0.7279,0.1544 -0.7279 0.1544c -0.3456,0.1544 -0.6250,0.4412 -0.6250 0.4412c -0.2794,0.2868 -0.4632,0.7059 -0.4632 0.7059c -0.1838,0.4191 -0.2426,0.9632 -0.2426 0.9632h 3.8235 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(255,255,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 288.1471,528.0000 v 14.0000 h 22.0000 v -14.0000 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 317.2500,537.2500 ZM 317.9412,533.6912 c 0.0000,-0.8676 0.2574,-1.5662 0.2574 -1.5662c 0.2574,-0.6985 0.6838,-1.1838 0.6838 -1.1838c 0.4265,-0.4853 0.9853,-0.7500 0.9853 -0.7500c 0.5588,-0.2647 1.1765,-0.2647 1.1765 -0.2647c 0.6176,0.0000 1.0735,0.2206 1.0735 0.2206c 0.4559,0.2206 0.9265,0.6029 0.9265 0.6029l -0.0588,-1.2206 v -2.7500 h 1.2206 v 10.4706 h -1.0000 l -0.1029,-0.8382 h -0.0441 c -0.4265,0.4118 -0.9779,0.7132 -0.9779 0.7132c -0.5515,0.3015 -1.1838,0.3015 -1.1838 0.3015c -1.3529,-0.0000 -2.1544,-0.9706 -2.1544 -0.9706c -0.8015,-0.9706 -0.8015,-2.7647 -0.8015 -2.7647ZM 317.9412,533.6912 ZM 319.1912,533.6765 c 0.0000,1.2941 0.5147,2.0147 0.5147 2.0147c 0.5147,0.7206 1.4559,0.7206 1.4559 0.7206c 0.5000,0.0000 0.9412,-0.2426 0.9412 -0.2426c 0.4412,-0.2426 0.8824,-0.7426 0.8824 -0.7426v -3.7353 c -0.4559,-0.4118 -0.8750,-0.5809 -0.8750 -0.5809c -0.4191,-0.1691 -0.8603,-0.1691 -0.8603 -0.1691c -0.4265,-0.0000 -0.8015,0.1985 -0.8015 0.1985c -0.3750,0.1985 -0.6544,0.5588 -0.6544 0.5588c -0.2794,0.3603 -0.4412,0.8603 -0.4412 0.8603c -0.1618,0.5000 -0.1618,1.1176 -0.1618 1.1176ZM 325.4118,537.2500 ZM 326.6176,530.1029 h 1.0000 l 0.1029,1.2941 h 0.0441 c 0.3676,-0.6765 0.8897,-1.0735 0.8897 -1.0735c 0.5221,-0.3971 1.1397,-0.3971 1.1397 -0.3971c 0.4265,0.0000 0.7647,0.1471 0.7647 0.1471l -0.2353,1.0588 c -0.1765,-0.0588 -0.3235,-0.0882 -0.3235 -0.0882c -0.1471,-0.0294 -0.3676,-0.0294 -0.3676 -0.0294c -0.4559,-0.0000 -0.9485,0.3676 -0.9485 0.3676c -0.4926,0.3676 -0.8603,1.2794 -0.8603 1.2794v 4.5882 h -1.2059 v -7.1471 ZM 330.3676,537.2500 ZM 331.0441,533.6912 c 0.0000,-0.8971 0.2721,-1.5956 0.2721 -1.5956c 0.2721,-0.6985 0.7279,-1.1838 0.7279 -1.1838c 0.4559,-0.4853 1.0515,-0.7353 1.0515 -0.7353c 0.5956,-0.2500 1.2574,-0.2500 1.2574 -0.2500c 0.6618,0.0000 1.2574,0.2500 1.2574 0.2500c 0.5956,0.2500 1.0515,0.7353 1.0515 0.7353c 0.4559,0.4853 0.7279,1.1838 0.7279 1.1838c 0.2721,0.6985 0.2721,1.5956 0.2721 1.5956c 0.0000,0.8824 -0.2721,1.5809 -0.2721 1.5809c -0.2721,0.6985 -0.7279,1.1765 -0.7279 1.1765c -0.4559,0.4779 -1.0515,0.7279 -1.0515 0.7279c -0.5956,0.2500 -1.2574,0.2500 -1.2574 0.2500c -0.6618,-0.0000 -1.2574,-0.2500 -1.2574 -0.2500c -0.5956,-0.2500 -1.0515,-0.7279 -1.0515 -0.7279c -0.4559,-0.4779 -0.7279,-1.1765 -0.7279 -1.1765c -0.2721,-0.6985 -0.2721,-1.5809 -0.2721 -1.5809ZM 331.0441,533.6912 ZM 332.2941,533.6912 c 0.0000,0.6176 0.1471,1.1176 0.1471 1.1176c 0.1471,0.5000 0.4191,0.8603 0.4191 0.8603c 0.2721,0.3603 0.6544,0.5588 0.6544 0.5588c 0.3824,0.1985 0.8382,0.1985 0.8382 0.1985c 0.4559,0.0000 0.8382,-0.1985 0.8382 -0.1985c 0.3824,-0.1985 0.6544,-0.5588 0.6544 -0.5588c 0.2721,-0.3603 0.4191,-0.8603 0.4191 -0.8603c 0.1471,-0.5000 0.1471,-1.1176 0.1471 -1.1176c 0.0000,-0.6176 -0.1471,-1.1250 -0.1471 -1.1250c -0.1471,-0.5074 -0.4191,-0.8750 -0.4191 -0.8750c -0.2721,-0.3676 -0.6544,-0.5662 -0.6544 -0.5662c -0.3824,-0.1985 -0.8382,-0.1985 -0.8382 -0.1985c -0.4559,-0.0000 -0.8382,0.1985 -0.8382 0.1985c -0.3824,0.1985 -0.6544,0.5662 -0.6544 0.5662c -0.2721,0.3676 -0.4191,0.8750 -0.4191 0.8750c -0.1471,0.5074 -0.1471,1.1250 -0.1471 1.1250ZM 338.3382,537.2500 ZM 340.7500,537.8529 v 2.4118 h -1.2059 v -10.1618 h 1.0000 l 0.1029,0.8235 h 0.0441 c 0.4853,-0.4118 1.0662,-0.7059 1.0662 -0.7059c 0.5809,-0.2941 1.2132,-0.2941 1.2132 -0.2941c 0.6912,0.0000 1.2206,0.2574 1.2206 0.2574c 0.5294,0.2574 0.8824,0.7353 0.8824 0.7353c 0.3529,0.4779 0.5368,1.1471 0.5368 1.1471c 0.1838,0.6691 0.1838,1.5074 0.1838 1.5074c 0.0000,0.9118 -0.2500,1.6250 -0.2500 1.6250c -0.2500,0.7132 -0.6765,1.2132 -0.6765 1.2132c -0.4265,0.5000 -0.9853,0.7574 -0.9853 0.7574c -0.5588,0.2574 -1.1765,0.2574 -1.1765 0.2574c -0.5000,-0.0000 -0.9926,-0.2206 -0.9926 -0.2206c -0.4926,-0.2206 -0.9926,-0.6029 -0.9926 -0.6029ZM 340.7500,537.8529 ZM 340.7500,535.6618 c 0.4853,0.4118 0.9412,0.5809 0.9412 0.5809c 0.4559,0.1691 0.8088,0.1691 0.8088 0.1691c 0.4412,0.0000 0.8162,-0.1985 0.8162 -0.1985c 0.3750,-0.1985 0.6471,-0.5588 0.6471 -0.5588c 0.2721,-0.3603 0.4265,-0.8897 0.4265 -0.8897c 0.1544,-0.5294 0.1544,-1.1912 0.1544 -1.1912c 0.0000,-0.5882 -0.1029,-1.0735 -0.1029 -1.0735c -0.1029,-0.4853 -0.3309,-0.8309 -0.3309 -0.8309c -0.2279,-0.3456 -0.5882,-0.5368 -0.5882 -0.5368c -0.3603,-0.1912 -0.8603,-0.1912 -0.8603 -0.1912c -0.4559,-0.0000 -0.9191,0.2500 -0.9191 0.2500c -0.4632,0.2500 -0.9926,0.7206 -0.9926 0.7206v 3.7500 ZM 346.5000,537.2500 ZM 347.1029,533.1029 h 3.3824 v 0.9265 h -3.3824 v -0.9265 ZM 351.0735,537.2500 ZM 351.7500,533.6912 c 0.0000,-0.8971 0.2721,-1.5956 0.2721 -1.5956c 0.2721,-0.6985 0.7279,-1.1838 0.7279 -1.1838c 0.4559,-0.4853 1.0515,-0.7353 1.0515 -0.7353c 0.5956,-0.2500 1.2574,-0.2500 1.2574 -0.2500c 0.6618,0.0000 1.2574,0.2500 1.2574 0.2500c 0.5956,0.2500 1.0515,0.7353 1.0515 0.7353c 0.4559,0.4853 0.7279,1.1838 0.7279 1.1838c 0.2721,0.6985 0.2721,1.5956 0.2721 1.5956c 0.0000,0.8824 -0.2721,1.5809 -0.2721 1.5809c -0.2721,0.6985 -0.7279,1.1765 -0.7279 1.1765c -0.4559,0.4779 -1.0515,0.7279 -1.0515 0.7279c -0.5956,0.2500 -1.2574,0.2500 -1.2574 0.2500c -0.6618,-0.0000 -1.2574,-0.2500 -1.2574 -0.2500c -0.5956,-0.2500 -1.0515,-0.7279 -1.0515 -0.7279c -0.4559,-0.4779 -0.7279,-1.1765 -0.7279 -1.1765c -0.2721,-0.6985 -0.2721,-1.5809 -0.2721 -1.5809ZM 351.7500,533.6912 ZM 353.0000,533.6912 c 0.0000,0.6176 0.1471,1.1176 0.1471 1.1176c 0.1471,0.5000 0.4191,0.8603 0.4191 0.8603c 0.2721,0.3603 0.6544,0.5588 0.6544 0.5588c 0.3824,0.1985 0.8382,0.1985 0.8382 0.1985c 0.4559,0.0000 0.8382,-0.1985 0.8382 -0.1985c 0.3824,-0.1985 0.6544,-0.5588 0.6544 -0.5588c 0.2721,-0.3603 0.4191,-0.8603 0.4191 -0.8603c 0.1471,-0.5000 0.1471,-1.1176 0.1471 -1.1176c 0.0000,-0.6176 -0.1471,-1.1250 -0.1471 -1.1250c -0.1471,-0.5074 -0.4191,-0.8750 -0.4191 -0.8750c -0.2721,-0.3676 -0.6544,-0.5662 -0.6544 -0.5662c -0.3824,-0.1985 -0.8382,-0.1985 -0.8382 -0.1985c -0.4559,-0.0000 -0.8382,0.1985 -0.8382 0.1985c -0.3824,0.1985 -0.6544,0.5662 -0.6544 0.5662c -0.2721,0.3676 -0.4191,0.8750 -0.4191 0.8750c -0.1471,0.5074 -0.1471,1.1250 -0.1471 1.1250ZM 359.0441,537.2500 ZM 360.2500,530.1029 h 1.0000 l 0.1029,1.0294 h 0.0441 c 0.5147,-0.5147 1.0809,-0.8603 1.0809 -0.8603c 0.5662,-0.3456 1.3162,-0.3456 1.3162 -0.3456c 1.1324,0.0000 1.6544,0.7059 1.6544 0.7059c 0.5221,0.7059 0.5221,2.0882 0.5221 2.0882v 4.5294 h -1.2059 v -4.3676 c 0.0000,-1.0147 -0.3235,-1.4632 -0.3235 -1.4632c -0.3235,-0.4485 -1.0294,-0.4485 -1.0294 -0.4485c -0.5588,-0.0000 -0.9853,0.2794 -0.9853 0.2794c -0.4265,0.2794 -0.9706,0.8235 -0.9706 0.8235v 5.1765 h -1.2059 v -7.1471 ZM 367.0882,537.2500 ZM 367.7647,533.6912 c 0.0000,-0.8824 0.2721,-1.5809 0.2721 -1.5809c 0.2721,-0.6985 0.7206,-1.1838 0.7206 -1.1838c 0.4485,-0.4853 1.0221,-0.7426 1.0221 -0.7426c 0.5735,-0.2574 1.1912,-0.2574 1.1912 -0.2574c 0.6765,0.0000 1.2132,0.2353 1.2132 0.2353c 0.5368,0.2353 0.8971,0.6765 0.8971 0.6765c 0.3603,0.4412 0.5515,1.0588 0.5515 1.0588c 0.1912,0.6176 0.1912,1.3824 0.1912 1.3824c 0.0000,0.3971 -0.0441,0.6618 -0.0441 0.6618h -4.8235 c 0.0735,1.1618 0.7132,1.8382 0.7132 1.8382c 0.6397,0.6765 1.6691,0.6765 1.6691 0.6765c 0.5147,0.0000 0.9485,-0.1544 0.9485 -0.1544c 0.4338,-0.1544 0.8309,-0.4044 0.8309 -0.4044l 0.4265,0.7941 c -0.4706,0.2941 -1.0441,0.5147 -1.0441 0.5147c -0.5735,0.2206 -1.3088,0.2206 -1.3088 0.2206c -0.7206,-0.0000 -1.3456,-0.2574 -1.3456 -0.2574c -0.6250,-0.2574 -1.0882,-0.7353 -1.0882 -0.7353c -0.4632,-0.4779 -0.7279,-1.1691 -0.7279 -1.1691c -0.2647,-0.6912 -0.2647,-1.5735 -0.2647 -1.5735ZM 367.7647,533.6912 ZM 372.7647,533.1471 c 0.0000,-1.1029 -0.4632,-1.6838 -0.4632 -1.6838c -0.4632,-0.5809 -1.3015,-0.5809 -1.3015 -0.5809c -0.3824,-0.0000 -0.7279,0.1544 -0.7279 0.1544c -0.3456,0.1544 -0.6250,0.4412 -0.6250 0.4412c -0.2794,0.2868 -0.4632,0.7059 -0.4632 0.7059c -0.1838,0.4191 -0.2426,0.9632 -0.2426 0.9632h 3.8235 ZM 377.3529,537.2500 ZM 379.8971,533.5147 l -2.1618,-3.4118 h 1.3088 l 0.9559,1.5735 c 0.1618,0.2941 0.3382,0.5956 0.3382 0.5956c 0.1765,0.3015 0.3676,0.5956 0.3676 0.5956h 0.0588 c 0.1618,-0.2941 0.3235,-0.5956 0.3235 -0.5956c 0.1618,-0.3015 0.3235,-0.5956 0.3235 -0.5956l 0.8676,-1.5735 h 1.2647 l -2.1618,3.5441 l 2.3235,3.6029 h -1.3088 l -1.0441,-1.6618 l -0.3824,-0.6471 c 0.0000,0.0000 -0.3971,-0.6324 -0.3971 -0.6324h -0.0588 c -0.1912,0.3088 -0.3676,0.6250 -0.3676 0.6250c -0.1765,0.3162 -0.3529,0.6544 -0.3529 0.6544l -0.9706,1.6618 h -1.2647 ZM 386.8824,537.2500 ZM 391.3529,533.6912 v -2.7206 c 0.0000,-0.3824 0.0221,-0.9044 0.0221 -0.9044c 0.0221,-0.5221 0.0515,-0.9044 0.0515 -0.9044h -0.0588 c -0.1765,0.3382 -0.3676,0.6618 -0.3676 0.6618c -0.1912,0.3235 -0.3971,0.6618 -0.3971 0.6618l -2.1912,3.2059 h 2.9412 ZM 391.3529,533.6912 ZM 393.7794,534.6618 h -1.2794 v 2.5882 h -1.1471 v -2.5882 h -4.2206 v -0.7941 l 4.0147,-6.0000 h 1.3529 v 5.8235 h 1.2794 v 0.9706 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(238,130,238)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 417.9559,528.0000 v 14.0000 h 22.0000 v -14.0000 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 447.0588,537.2500 ZM 447.7500,533.6912 c 0.0000,-0.8676 0.2574,-1.5662 0.2574 -1.5662c 0.2574,-0.6985 0.6838,-1.1838 0.6838 -1.1838c 0.4265,-0.4853 0.9853,-0.7500 0.9853 -0.7500c 0.5588,-0.2647 1.1765,-0.2647 1.1765 -0.2647c 0.6176,0.0000 1.0735,0.2206 1.0735 0.2206c 0.4559,0.2206 0.9265,0.6029 0.9265 0.6029l -0.0588,-1.2206 v -2.7500 h 1.2206 v 10.4706 h -1.0000 l -0.1029,-0.8382 h -0.0441 c -0.4265,0.4118 -0.9779,0.7132 -0.9779 0.7132c -0.5515,0.3015 -1.1838,0.3015 -1.1838 0.3015c -1.3529,-0.0000 -2.1544,-0.9706 -2.1544 -0.9706c -0.8015,-0.9706 -0.8015,-2.7647 -0.8015 -2.7647ZM 447.7500,533.6912 ZM 449.0000,533.6765 c 0.0000,1.2941 0.5147,2.0147 0.5147 2.0147c 0.5147,0.7206 1.4559,0.7206 1.4559 0.7206c 0.5000,0.0000 0.9412,-0.2426 0.9412 -0.2426c 0.4412,-0.2426 0.8824,-0.7426 0.8824 -0.7426v -3.7353 c -0.4559,-0.4118 -0.8750,-0.5809 -0.8750 -0.5809c -0.4191,-0.1691 -0.8603,-0.1691 -0.8603 -0.1691c -0.4265,-0.0000 -0.8015,0.1985 -0.8015 0.1985c -0.3750,0.1985 -0.6544,0.5588 -0.6544 0.5588c -0.2794,0.3603 -0.4412,0.8603 -0.4412 0.8603c -0.1618,0.5000 -0.1618,1.1176 -0.1618 1.1176ZM 455.2206,537.2500 ZM 456.4265,530.1029 h 1.0000 l 0.1029,1.2941 h 0.0441 c 0.3676,-0.6765 0.8897,-1.0735 0.8897 -1.0735c 0.5221,-0.3971 1.1397,-0.3971 1.1397 -0.3971c 0.4265,0.0000 0.7647,0.1471 0.7647 0.1471l -0.2353,1.0588 c -0.1765,-0.0588 -0.3235,-0.0882 -0.3235 -0.0882c -0.1471,-0.0294 -0.3676,-0.0294 -0.3676 -0.0294c -0.4559,-0.0000 -0.9485,0.3676 -0.9485 0.3676c -0.4926,0.3676 -0.8603,1.2794 -0.8603 1.2794v 4.5882 h -1.2059 v -7.1471 ZM 460.1765,537.2500 ZM 460.8529,533.6912 c 0.0000,-0.8971 0.2721,-1.5956 0.2721 -1.5956c 0.2721,-0.6985 0.7279,-1.1838 0.7279 -1.1838c 0.4559,-0.4853 1.0515,-0.7353 1.0515 -0.7353c 0.5956,-0.2500 1.2574,-0.2500 1.2574 -0.2500c 0.6618,0.0000 1.2574,0.2500 1.2574 0.2500c 0.5956,0.2500 1.0515,0.7353 1.0515 0.7353c 0.4559,0.4853 0.7279,1.1838 0.7279 1.1838c 0.2721,0.6985 0.2721,1.5956 0.2721 1.5956c 0.0000,0.8824 -0.2721,1.5809 -0.2721 1.5809c -0.2721,0.6985 -0.7279,1.1765 -0.7279 1.1765c -0.4559,0.4779 -1.0515,0.7279 -1.0515 0.7279c -0.5956,0.2500 -1.2574,0.2500 -1.2574 0.2500c -0.6618,-0.0000 -1.2574,-0.2500 -1.2574 -0.2500c -0.5956,-0.2500 -1.0515,-0.7279 -1.0515 -0.7279c -0.4559,-0.4779 -0.7279,-1.1765 -0.7279 -1.1765c -0.2721,-0.6985 -0.2721,-1.5809 -0.2721 -1.5809ZM 460.8529,533.6912 ZM 462.1029,533.6912 c 0.0000,0.6176 0.1471,1.1176 0.1471 1.1176c 0.1471,0.5000 0.4191,0.8603 0.4191 0.8603c 0.2721,0.3603 0.6544,0.5588 0.6544 0.5588c 0.3824,0.1985 0.8382,0.1985 0.8382 0.1985c 0.4559,0.0000 0.8382,-0.1985 0.8382 -0.1985c 0.3824,-0.1985 0.6544,-0.5588 0.6544 -0.5588c 0.2721,-0.3603 0.4191,-0.8603 0.4191 -0.8603c 0.1471,-0.5000 0.1471,-1.1176 0.1471 -1.1176c 0.0000,-0.6176 -0.1471,-1.1250 -0.1471 -1.1250c -0.1471,-0.5074 -0.4191,-0.8750 -0.4191 -0.8750c -0.2721,-0.3676 -0.6544,-0.5662 -0.6544 -0.5662c -0.3824,-0.1985 -0.8382,-0.1985 -0.8382 -0.1985c -0.4559,-0.0000 -0.8382,0.1985 -0.8382 0.1985c -0.3824,0.1985 -0.6544,0.5662 -0.6544 0.5662c -0.2721,0.3676 -0.4191,0.8750 -0.4191 0.8750c -0.1471,0.5074 -0.1471,1.1250 -0.1471 1.1250ZM 468.1471,537.2500 ZM 470.5588,537.8529 v 2.4118 h -1.2059 v -10.1618 h 1.0000 l 0.1029,0.8235 h 0.0441 c 0.4853,-0.4118 1.0662,-0.7059 1.0662 -0.7059c 0.5809,-0.2941 1.2132,-0.2941 1.2132 -0.2941c 0.6912,0.0000 1.2206,0.2574 1.2206 0.2574c 0.5294,0.2574 0.8824,0.7353 0.8824 0.7353c 0.3529,0.4779 0.5368,1.1471 0.5368 1.1471c 0.1838,0.6691 0.1838,1.5074 0.1838 1.5074c 0.0000,0.9118 -0.2500,1.6250 -0.2500 1.6250c -0.2500,0.7132 -0.6765,1.2132 -0.6765 1.2132c -0.4265,0.5000 -0.9853,0.7574 -0.9853 0.7574c -0.5588,0.2574 -1.1765,0.2574 -1.1765 0.2574c -0.5000,-0.0000 -0.9926,-0.2206 -0.9926 -0.2206c -0.4926,-0.2206 -0.9926,-0.6029 -0.9926 -0.6029ZM 470.5588,537.8529 ZM 470.5588,535.6618 c 0.4853,0.4118 0.9412,0.5809 0.9412 0.5809c 0.4559,0.1691 0.8088,0.1691 0.8088 0.1691c 0.4412,0.0000 0.8162,-0.1985 0.8162 -0.1985c 0.3750,-0.1985 0.6471,-0.5588 0.6471 -0.5588c 0.2721,-0.3603 0.4265,-0.8897 0.4265 -0.8897c 0.1544,-0.5294 0.1544,-1.1912 0.1544 -1.1912c 0.0000,-0.5882 -0.1029,-1.0735 -0.1029 -1.0735c -0.1029,-0.4853 -0.3309,-0.8309 -0.3309 -0.8309c -0.2279,-0.3456 -0.5882,-0.5368 -0.5882 -0.5368c -0.3603,-0.1912 -0.8603,-0.1912 -0.8603 -0.1912c -0.4559,-0.0000 -0.9191,0.2500 -0.9191 0.2500c -0.4632,0.2500 -0.9926,0.7206 -0.9926 0.7206v 3.7500 ZM 476.3088,537.2500 ZM 476.6471,527.6029 h 1.2647 l 1.0147,5.2500 c 0.1324,0.7941 0.2794,1.5588 0.2794 1.5588c 0.1471,0.7647 0.2794,1.5588 0.2794 1.5588h 0.0588 c 0.1618,-0.7941 0.3382,-1.5662 0.3382 -1.5662c 0.1765,-0.7721 0.3382,-1.5515 0.3382 -1.5515l 1.3382,-5.2500 h 1.1176 l 1.3382,5.2500 c 0.1765,0.7647 0.3529,1.5441 0.3529 1.5441c 0.1765,0.7794 0.3529,1.5735 0.3529 1.5735h 0.0588 c 0.1324,-0.7941 0.2647,-1.5662 0.2647 -1.5662c 0.1324,-0.7721 0.2794,-1.5515 0.2794 -1.5515l 1.0147,-5.2500 h 1.1765 l -2.0000,9.6471 h -1.4706 l -1.4559,-5.8088 c -0.1324,-0.5588 -0.2426,-1.0956 -0.2426 -1.0956c -0.1103,-0.5368 -0.2279,-1.0956 -0.2279 -1.0956h -0.0588 c -0.1176,0.5588 -0.2426,1.0956 -0.2426 1.0956c -0.1250,0.5368 -0.2426,1.0956 -0.2426 1.0956l -1.4265,5.8088 h -1.4559 ZM 487.8676,537.2500 ZM 489.0735,526.7794 h 1.2059 v 2.8529 l -0.0441,1.4706 c 0.5147,-0.4853 1.0735,-0.8309 1.0735 -0.8309c 0.5588,-0.3456 1.3088,-0.3456 1.3088 -0.3456c 1.1324,0.0000 1.6544,0.7059 1.6544 0.7059c 0.5221,0.7059 0.5221,2.0882 0.5221 2.0882v 4.5294 h -1.2059 v -4.3676 c 0.0000,-1.0147 -0.3235,-1.4632 -0.3235 -1.4632c -0.3235,-0.4485 -1.0294,-0.4485 -1.0294 -0.4485c -0.5588,-0.0000 -0.9853,0.2794 -0.9853 0.2794c -0.4265,0.2794 -0.9706,0.8235 -0.9706 0.8235v 5.1765 h -1.2059 v -10.4706 ZM 495.8676,537.2500 ZM 497.6912,528.6324 c -0.3529,-0.0000 -0.5956,-0.2206 -0.5956 -0.2206c -0.2426,-0.2206 -0.2426,-0.5588 -0.2426 -0.5588c 0.0000,-0.3529 0.2426,-0.5662 0.2426 -0.5662c 0.2426,-0.2132 0.5956,-0.2132 0.5956 -0.2132c 0.3529,0.0000 0.5956,0.2132 0.5956 0.2132c 0.2426,0.2132 0.2426,0.5662 0.2426 0.5662c 0.0000,0.3382 -0.2426,0.5588 -0.2426 0.5588c -0.2426,0.2206 -0.5956,0.2206 -0.5956 0.2206ZM 497.6912,528.6324 ZM 497.0735,530.1029 h 1.2059 v 7.1471 h -1.2059 v -7.1471 ZM 499.4853,537.2500 ZM 500.6912,526.7794 h 1.2059 v 9.1176 c 0.0000,0.2941 0.1029,0.4118 0.1029 0.4118c 0.1029,0.1176 0.2353,0.1176 0.2353 0.1176h 0.1103 c 0.0000,0.0000 0.1544,-0.0294 0.1544 -0.0294l 0.1618,0.9118 c -0.1176,0.0588 -0.2794,0.0882 -0.2794 0.0882c -0.1618,0.0294 -0.4118,0.0294 -0.4118 0.0294c -0.6912,-0.0000 -0.9853,-0.4118 -0.9853 -0.4118c -0.2941,-0.4118 -0.2941,-1.2059 -0.2941 -1.2059v -9.0294 ZM 503.2353,537.2500 ZM 503.9118,533.6912 c 0.0000,-0.8824 0.2721,-1.5809 0.2721 -1.5809c 0.2721,-0.6985 0.7206,-1.1838 0.7206 -1.1838c 0.4485,-0.4853 1.0221,-0.7426 1.0221 -0.7426c 0.5735,-0.2574 1.1912,-0.2574 1.1912 -0.2574c 0.6765,0.0000 1.2132,0.2353 1.2132 0.2353c 0.5368,0.2353 0.8971,0.6765 0.8971 0.6765c 0.3603,0.4412 0.5515,1.0588 0.5515 1.0588c 0.1912,0.6176 0.1912,1.3824 0.1912 1.3824c 0.0000,0.3971 -0.0441,0.6618 -0.0441 0.6618h -4.8235 c 0.0735,1.1618 0.7132,1.8382 0.7132 1.8382c 0.6397,0.6765 1.6691,0.6765 1.6691 0.6765c 0.5147,0.0000 0.9485,-0.1544 0.9485 -0.1544c 0.4338,-0.1544 0.8309,-0.4044 0.8309 -0.4044l 0.4265,0.7941 c -0.4706,0.2941 -1.0441,0.5147 -1.0441 0.5147c -0.5735,0.2206 -1.3088,0.2206 -1.3088 0.2206c -0.7206,-0.0000 -1.3456,-0.2574 -1.3456 -0.2574c -0.6250,-0.2574 -1.0882,-0.7353 -1.0882 -0.7353c -0.4632,-0.4779 -0.7279,-1.1691 -0.7279 -1.1691c -0.2647,-0.6912 -0.2647,-1.5735 -0.2647 -1.5735ZM 503.9118,533.6912 ZM 508.9118,533.1471 c 0.0000,-1.1029 -0.4632,-1.6838 -0.4632 -1.6838c -0.4632,-0.5809 -1.3015,-0.5809 -1.3015 -0.5809c -0.3824,-0.0000 -0.7279,0.1544 -0.7279 0.1544c -0.3456,0.1544 -0.6250,0.4412 -0.6250 0.4412c -0.2794,0.2868 -0.4632,0.7059 -0.4632 0.7059c -0.1838,0.4191 -0.2426,0.9632 -0.2426 0.9632h 3.8235 ZM 510.5294,537.2500 ZM 511.1324,533.1029 h 3.3824 v 0.9265 h -3.3824 v -0.9265 ZM 515.1029,537.2500 ZM 516.5147,531.0882 h -1.0588 v -0.9118 l 1.1176,-0.0735 l 0.1471,-2.0000 h 1.0147 v 2.0000 h 1.9265 v 0.9853 h -1.9265 v 3.9706 c 0.0000,0.6618 0.2426,1.0221 0.2426 1.0221c 0.2426,0.3603 0.8603,0.3603 0.8603 0.3603c 0.1912,0.0000 0.4118,-0.0588 0.4118 -0.0588c 0.2206,-0.0588 0.3971,-0.1324 0.3971 -0.1324l 0.2353,0.9118 c -0.2941,0.1029 -0.6397,0.1838 -0.6397 0.1838c -0.3456,0.0809 -0.6838,0.0809 -0.6838 0.0809c -0.5735,-0.0000 -0.9632,-0.1765 -0.9632 -0.1765c -0.3897,-0.1765 -0.6324,-0.4853 -0.6324 -0.4853c -0.2426,-0.3088 -0.3456,-0.7500 -0.3456 -0.7500c -0.1029,-0.4412 -0.1029,-0.9706 -0.1029 -0.9706v -3.9559 ZM 520.0735,537.2500 ZM 521.2794,530.1029 h 1.0000 l 0.1029,1.2941 h 0.0441 c 0.3676,-0.6765 0.8897,-1.0735 0.8897 -1.0735c 0.5221,-0.3971 1.1397,-0.3971 1.1397 -0.3971c 0.4265,0.0000 0.7647,0.1471 0.7647 0.1471l -0.2353,1.0588 c -0.1765,-0.0588 -0.3235,-0.0882 -0.3235 -0.0882c -0.1471,-0.0294 -0.3676,-0.0294 -0.3676 -0.0294c -0.4559,-0.0000 -0.9485,0.3676 -0.9485 0.3676c -0.4926,0.3676 -0.8603,1.2794 -0.8603 1.2794v 4.5882 h -1.2059 v -7.1471 ZM 525.1765,537.2500 ZM 526.2794,530.1029 h 1.2206 v 4.3676 c 0.0000,1.0147 0.3162,1.4632 0.3162 1.4632c 0.3162,0.4485 1.0221,0.4485 1.0221 0.4485c 0.5588,0.0000 0.9853,-0.2868 0.9853 -0.2868c 0.4265,-0.2868 0.9412,-0.9191 0.9412 -0.9191v -5.0735 h 1.2059 v 7.1471 h -1.0000 l -0.1029,-1.1176 h -0.0441 c -0.5000,0.5882 -1.0515,0.9412 -1.0515 0.9412c -0.5515,0.3529 -1.3015,0.3529 -1.3015 0.3529c -1.1471,-0.0000 -1.6691,-0.7059 -1.6691 -0.7059c -0.5221,-0.7059 -0.5221,-2.0882 -0.5221 -2.0882v -4.5294 ZM 533.1765,537.2500 ZM 533.8529,533.6912 c 0.0000,-0.8824 0.2721,-1.5809 0.2721 -1.5809c 0.2721,-0.6985 0.7206,-1.1838 0.7206 -1.1838c 0.4485,-0.4853 1.0221,-0.7426 1.0221 -0.7426c 0.5735,-0.2574 1.1912,-0.2574 1.1912 -0.2574c 0.6765,0.0000 1.2132,0.2353 1.2132 0.2353c 0.5368,0.2353 0.8971,0.6765 0.8971 0.6765c 0.3603,0.4412 0.5515,1.0588 0.5515 1.0588c 0.1912,0.6176 0.1912,1.3824 0.1912 1.3824c 0.0000,0.3971 -0.0441,0.6618 -0.0441 0.6618h -4.8235 c 0.0735,1.1618 0.7132,1.8382 0.7132 1.8382c 0.6397,0.6765 1.6691,0.6765 1.6691 0.6765c 0.5147,0.0000 0.9485,-0.1544 0.9485 -0.1544c 0.4338,-0.1544 0.8309,-0.4044 0.8309 -0.4044l 0.4265,0.7941 c -0.4706,0.2941 -1.0441,0.5147 -1.0441 0.5147c -0.5735,0.2206 -1.3088,0.2206 -1.3088 0.2206c -0.7206,-0.0000 -1.3456,-0.2574 -1.3456 -0.2574c -0.6250,-0.2574 -1.0882,-0.7353 -1.0882 -0.7353c -0.4632,-0.4779 -0.7279,-1.1691 -0.7279 -1.1691c -0.2647,-0.6912 -0.2647,-1.5735 -0.2647 -1.5735ZM 533.8529,533.6912 ZM 538.8529,533.1471 c 0.0000,-1.1029 -0.4632,-1.6838 -0.4632 -1.6838c -0.4632,-0.5809 -1.3015,-0.5809 -1.3015 -0.5809c -0.3824,-0.0000 -0.7279,0.1544 -0.7279 0.1544c -0.3456,0.1544 -0.6250,0.4412 -0.6250 0.4412c -0.2794,0.2868 -0.4632,0.7059 -0.4632 0.7059c -0.1838,0.4191 -0.2426,0.9632 -0.2426 0.9632h 3.8235 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,255)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 10.0000,552.0000 v 14.0000 h 22.0000 v -14.0000 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 39.1029,561.2500 ZM 39.7941,557.6912 c 0.0000,-0.8676 0.2574,-1.5662 0.2574 -1.5662c 0.2574,-0.6985 0.6838,-1.1838 0.6838 -1.1838c 0.4265,-0.4853 0.9853,-0.7500 0.9853 -0.7500c 0.5588,-0.2647 1.1765,-0.2647 1.1765 -0.2647c 0.6176,0.0000 1.0735,0.2206 1.0735 0.2206c 0.4559,0.2206 0.9265,0.6029 0.9265 0.6029l -0.0588,-1.2206 v -2.7500 h 1.2206 v 10.4706 h -1.0000 l -0.1029,-0.8382 h -0.0441 c -0.4265,0.4118 -0.9779,0.7132 -0.9779 0.7132c -0.5515,0.3015 -1.1838,0.3015 -1.1838 0.3015c -1.3529,-0.0000 -2.1544,-0.9706 -2.1544 -0.9706c -0.8015,-0.9706 -0.8015,-2.7647 -0.8015 -2.7647ZM 39.7941,557.6912 ZM 41.0441,557.6765 c 0.0000,1.2941 0.5147,2.0147 0.5147 2.0147c 0.5147,0.7206 1.4559,0.7206 1.4559 0.7206c 0.5000,0.0000 0.9412,-0.2426 0.9412 -0.2426c 0.4412,-0.2426 0.8824,-0.7426 0.8824 -0.7426v -3.7353 c -0.4559,-0.4118 -0.8750,-0.5809 -0.8750 -0.5809c -0.4191,-0.1691 -0.8603,-0.1691 -0.8603 -0.1691c -0.4265,-0.0000 -0.8015,0.1985 -0.8015 0.1985c -0.3750,0.1985 -0.6544,0.5588 -0.6544 0.5588c -0.2794,0.3603 -0.4412,0.8603 -0.4412 0.8603c -0.1618,0.5000 -0.1618,1.1176 -0.1618 1.1176ZM 47.2647,561.2500 ZM 48.4706,554.1029 h 1.0000 l 0.1029,1.2941 h 0.0441 c 0.3676,-0.6765 0.8897,-1.0735 0.8897 -1.0735c 0.5221,-0.3971 1.1397,-0.3971 1.1397 -0.3971c 0.4265,0.0000 0.7647,0.1471 0.7647 0.1471l -0.2353,1.0588 c -0.1765,-0.0588 -0.3235,-0.0882 -0.3235 -0.0882c -0.1471,-0.0294 -0.3676,-0.0294 -0.3676 -0.0294c -0.4559,-0.0000 -0.9485,0.3676 -0.9485 0.3676c -0.4926,0.3676 -0.8603,1.2794 -0.8603 1.2794v 4.5882 h -1.2059 v -7.1471 ZM 52.2206,561.2500 ZM 52.8971,557.6912 c 0.0000,-0.8971 0.2721,-1.5956 0.2721 -1.5956c 0.2721,-0.6985 0.7279,-1.1838 0.7279 -1.1838c 0.4559,-0.4853 1.0515,-0.7353 1.0515 -0.7353c 0.5956,-0.2500 1.2574,-0.2500 1.2574 -0.2500c 0.6618,0.0000 1.2574,0.2500 1.2574 0.2500c 0.5956,0.2500 1.0515,0.7353 1.0515 0.7353c 0.4559,0.4853 0.7279,1.1838 0.7279 1.1838c 0.2721,0.6985 0.2721,1.5956 0.2721 1.5956c 0.0000,0.8824 -0.2721,1.5809 -0.2721 1.5809c -0.2721,0.6985 -0.7279,1.1765 -0.7279 1.1765c -0.4559,0.4779 -1.0515,0.7279 -1.0515 0.7279c -0.5956,0.2500 -1.2574,0.2500 -1.2574 0.2500c -0.6618,-0.0000 -1.2574,-0.2500 -1.2574 -0.2500c -0.5956,-0.2500 -1.0515,-0.7279 -1.0515 -0.7279c -0.4559,-0.4779 -0.7279,-1.1765 -0.7279 -1.1765c -0.2721,-0.6985 -0.2721,-1.5809 -0.2721 -1.5809ZM 52.8971,557.6912 ZM 54.1471,557.6912 c 0.0000,0.6176 0.1471,1.1176 0.1471 1.1176c 0.1471,0.5000 0.4191,0.8603 0.4191 0.8603c 0.2721,0.3603 0.6544,0.5588 0.6544 0.5588c 0.3824,0.1985 0.8382,0.1985 0.8382 0.1985c 0.4559,0.0000 0.8382,-0.1985 0.8382 -0.1985c 0.3824,-0.1985 0.6544,-0.5588 0.6544 -0.5588c 0.2721,-0.3603 0.4191,-0.8603 0.4191 -0.8603c 0.1471,-0.5000 0.1471,-1.1176 0.1471 -1.1176c 0.0000,-0.6176 -0.1471,-1.1250 -0.1471 -1.1250c -0.1471,-0.5074 -0.4191,-0.8750 -0.4191 -0.8750c -0.2721,-0.3676 -0.6544,-0.5662 -0.6544 -0.5662c -0.3824,-0.1985 -0.8382,-0.1985 -0.8382 -0.1985c -0.4559,-0.0000 -0.8382,0.1985 -0.8382 0.1985c -0.3824,0.1985 -0.6544,0.5662 -0.6544 0.5662c -0.2721,0.3676 -0.4191,0.8750 -0.4191 0.8750c -0.1471,0.5074 -0.1471,1.1250 -0.1471 1.1250ZM 60.1912,561.2500 ZM 62.6029,561.8529 v 2.4118 h -1.2059 v -10.1618 h 1.0000 l 0.1029,0.8235 h 0.0441 c 0.4853,-0.4118 1.0662,-0.7059 1.0662 -0.7059c 0.5809,-0.2941 1.2132,-0.2941 1.2132 -0.2941c 0.6912,0.0000 1.2206,0.2574 1.2206 0.2574c 0.5294,0.2574 0.8824,0.7353 0.8824 0.7353c 0.3529,0.4779 0.5368,1.1471 0.5368 1.1471c 0.1838,0.6691 0.1838,1.5074 0.1838 1.5074c 0.0000,0.9118 -0.2500,1.6250 -0.2500 1.6250c -0.2500,0.7132 -0.6765,1.2132 -0.6765 1.2132c -0.4265,0.5000 -0.9853,0.7574 -0.9853 0.7574c -0.5588,0.2574 -1.1765,0.2574 -1.1765 0.2574c -0.5000,-0.0000 -0.9926,-0.2206 -0.9926 -0.2206c -0.4926,-0.2206 -0.9926,-0.6029 -0.9926 -0.6029ZM 62.6029,561.8529 ZM 62.6029,559.6618 c 0.4853,0.4118 0.9412,0.5809 0.9412 0.5809c 0.4559,0.1691 0.8088,0.1691 0.8088 0.1691c 0.4412,0.0000 0.8162,-0.1985 0.8162 -0.1985c 0.3750,-0.1985 0.6471,-0.5588 0.6471 -0.5588c 0.2721,-0.3603 0.4265,-0.8897 0.4265 -0.8897c 0.1544,-0.5294 0.1544,-1.1912 0.1544 -1.1912c 0.0000,-0.5882 -0.1029,-1.0735 -0.1029 -1.0735c -0.1029,-0.4853 -0.3309,-0.8309 -0.3309 -0.8309c -0.2279,-0.3456 -0.5882,-0.5368 -0.5882 -0.5368c -0.3603,-0.1912 -0.8603,-0.1912 -0.8603 -0.1912c -0.4559,-0.0000 -0.9191,0.2500 -0.9191 0.2500c -0.4632,0.2500 -0.9926,0.7206 -0.9926 0.7206v 3.7500 ZM 68.3529,561.2500 ZM 68.9559,557.1029 h 3.3824 v 0.9265 h -3.3824 v -0.9265 ZM 72.9265,561.2500 ZM 73.9412,559.6324 c 0.4706,0.3824 0.9632,0.6176 0.9632 0.6176c 0.4926,0.2353 1.1397,0.2353 1.1397 0.2353c 0.7059,0.0000 1.0588,-0.3235 1.0588 -0.3235c 0.3529,-0.3235 0.3529,-0.7941 0.3529 -0.7941c 0.0000,-0.2794 -0.1471,-0.4853 -0.1471 -0.4853c -0.1471,-0.2059 -0.3750,-0.3603 -0.3750 -0.3603c -0.2279,-0.1544 -0.5221,-0.2721 -0.5221 -0.2721l -0.5882,-0.2353 c -0.3824,-0.1324 -0.7647,-0.3015 -0.7647 -0.3015c -0.3824,-0.1691 -0.6838,-0.4118 -0.6838 -0.4118c -0.3015,-0.2426 -0.4926,-0.5662 -0.4926 -0.5662c -0.1912,-0.3235 -0.1912,-0.7794 -0.1912 -0.7794c 0.0000,-0.4265 0.1691,-0.8015 0.1691 -0.8015c 0.1691,-0.3750 0.4853,-0.6471 0.4853 -0.6471c 0.3162,-0.2721 0.7721,-0.4265 0.7721 -0.4265c 0.4559,-0.1544 1.0294,-0.1544 1.0294 -0.1544c 0.6765,0.0000 1.2426,0.2353 1.2426 0.2353c 0.5662,0.2353 0.9779,0.5735 0.9779 0.5735l -0.5735,0.7647 c -0.3676,-0.2794 -0.7647,-0.4559 -0.7647 -0.4559c -0.3971,-0.1765 -0.8676,-0.1765 -0.8676 -0.1765c -0.6765,-0.0000 -0.9926,0.3088 -0.9926 0.3088c -0.3162,0.3088 -0.3162,0.7206 -0.3162 0.7206c 0.0000,0.2500 0.1324,0.4338 0.1324 0.4338c 0.1324,0.1838 0.3529,0.3235 0.3529 0.3235c 0.2206,0.1397 0.5074,0.2500 0.5074 0.2500c 0.2868,0.1103 0.5956,0.2279 0.5956 0.2279c 0.3824,0.1471 0.7721,0.3088 0.7721 0.3088c 0.3897,0.1618 0.6985,0.4044 0.6985 0.4044c 0.3088,0.2426 0.5074,0.5956 0.5074 0.5956c 0.1985,0.3529 0.1985,0.8529 0.1985 0.8529c 0.0000,0.4412 -0.1691,0.8235 -0.1691 0.8235c -0.1691,0.3824 -0.5000,0.6765 -0.5000 0.6765c -0.3309,0.2941 -0.8235,0.4632 -0.8235 0.4632c -0.4926,0.1691 -1.1250,0.1691 -1.1250 0.1691c -0.7647,-0.0000 -1.4559,-0.2794 -1.4559 -0.2794c -0.6912,-0.2794 -1.2059,-0.7059 -1.2059 -0.7059ZM 79.0882,561.2500 ZM 79.7647,557.6912 c 0.0000,-0.8971 0.2794,-1.5956 0.2794 -1.5956c 0.2794,-0.6985 0.7500,-1.1838 0.7500 -1.1838c 0.4706,-0.4853 1.0956,-0.7353 1.0956 -0.7353c 0.6250,-0.2500 1.3162,-0.2500 1.3162 -0.2500c 0.7059,0.0000 1.2132,0.2574 1.2132 0.2574c 0.5074,0.2574 0.8750,0.5956 0.8750 0.5956l -0.6029,0.7794 c -0.3235,-0.2794 -0.6691,-0.4559 -0.6691 -0.4559c -0.3456,-0.1765 -0.7721,-0.1765 -0.7721 -0.1765c -0.4853,-0.0000 -0.8971,0.1985 -0.8971 0.1985c -0.4118,0.1985 -0.7059,0.5662 -0.7059 0.5662c -0.2941,0.3676 -0.4632,0.8750 -0.4632 0.8750c -0.1691,0.5074 -0.1691,1.1250 -0.1691 1.1250c 0.0000,0.6176 0.1618,1.1176 0.1618 1.1176c 0.1618,0.5000 0.4485,0.8603 0.4485 0.8603c 0.2868,0.3603 0.6985,0.5588 0.6985 0.5588c 0.4118,0.1985 0.8971,0.1985 0.8971 0.1985c 0.5147,0.0000 0.9338,-0.2132 0.9338 -0.2132c 0.4191,-0.2132 0.7426,-0.5074 0.7426 -0.5074l 0.5441,0.7941 c -0.4853,0.4265 -1.0809,0.6765 -1.0809 0.6765c -0.5956,0.2500 -1.2426,0.2500 -1.2426 0.2500c -0.7059,-0.0000 -1.3235,-0.2500 -1.3235 -0.2500c -0.6176,-0.2500 -1.0662,-0.7279 -1.0662 -0.7279c -0.4485,-0.4779 -0.7059,-1.1765 -0.7059 -1.1765c -0.2574,-0.6985 -0.2574,-1.5809 -0.2574 -1.5809ZM 85.6471,561.2500 ZM 86.5000,559.3971 c 0.0000,-1.1765 1.0515,-1.8015 1.0515 -1.8015c 1.0515,-0.6250 3.3456,-0.8750 3.3456 -0.8750c 0.0000,-0.3382 -0.0662,-0.6618 -0.0662 -0.6618c -0.0662,-0.3235 -0.2353,-0.5735 -0.2353 -0.5735c -0.1691,-0.2500 -0.4485,-0.4044 -0.4485 -0.4044c -0.2794,-0.1544 -0.7206,-0.1544 -0.7206 -0.1544c -0.6324,-0.0000 -1.1691,0.2353 -1.1691 0.2353c -0.5368,0.2353 -0.9632,0.5294 -0.9632 0.5294l -0.4853,-0.8382 c 0.5000,-0.3235 1.2206,-0.6250 1.2206 -0.6250c 0.7206,-0.3015 1.5882,-0.3015 1.5882 -0.3015c 1.3088,0.0000 1.8971,0.8015 1.8971 0.8015c 0.5882,0.8015 0.5882,2.1397 0.5882 2.1397v 4.3824 h -1.0000 l -0.1029,-0.8529 h -0.0294 c -0.5147,0.4265 -1.1103,0.7279 -1.1103 0.7279c -0.5956,0.3015 -1.2574,0.3015 -1.2574 0.3015c -0.9118,-0.0000 -1.5074,-0.5294 -1.5074 -0.5294c -0.5956,-0.5294 -0.5956,-1.5000 -0.5956 -1.5000ZM 86.5000,559.3971 ZM 87.6912,559.3088 c 0.0000,0.6176 0.3603,0.8824 0.3603 0.8824c 0.3603,0.2647 0.8897,0.2647 0.8897 0.2647c 0.5147,0.0000 0.9779,-0.2426 0.9779 -0.2426c 0.4632,-0.2426 0.9779,-0.7132 0.9779 -0.7132v -1.9853 c -0.8971,0.1176 -1.5147,0.2794 -1.5147 0.2794c -0.6176,0.1618 -0.9926,0.3824 -0.9926 0.3824c -0.3750,0.2206 -0.5368,0.5074 -0.5368 0.5074c -0.1618,0.2868 -0.1618,0.6250 -0.1618 0.6250ZM 93.1765,561.2500 ZM 94.3824,554.1029 h 1.0000 l 0.1029,1.0294 h 0.0441 c 0.5147,-0.5147 1.0809,-0.8603 1.0809 -0.8603c 0.5662,-0.3456 1.3162,-0.3456 1.3162 -0.3456c 1.1324,0.0000 1.6544,0.7059 1.6544 0.7059c 0.5221,0.7059 0.5221,2.0882 0.5221 2.0882v 4.5294 h -1.2059 v -4.3676 c 0.0000,-1.0147 -0.3235,-1.4632 -0.3235 -1.4632c -0.3235,-0.4485 -1.0294,-0.4485 -1.0294 -0.4485c -0.5588,-0.0000 -0.9853,0.2794 -0.9853 0.2794c -0.4265,0.2794 -0.9706,0.8235 -0.9706 0.8235v 5.1765 h -1.2059 v -7.1471 ZM 104.1912,561.2500 ZM 106.7353,557.5147 l -2.1618,-3.4118 h 1.3088 l 0.9559,1.5735 c 0.1618,0.2941 0.3382,0.5956 0.3382 0.5956c 0.1765,0.3015 0.3676,0.5956 0.3676 0.5956h 0.0588 c 0.1618,-0.2941 0.3235,-0.5956 0.3235 -0.5956c 0.1618,-0.3015 0.3235,-0.5956 0.3235 -0.5956l 0.8676,-1.5735 h 1.2647 l -2.1618,3.5441 l 2.3235,3.6029 h -1.3088 l -1.0441,-1.6618 l -0.3824,-0.6471 c 0.0000,0.0000 -0.3971,-0.6324 -0.3971 -0.6324h -0.0588 c -0.1912,0.3088 -0.3676,0.6250 -0.3676 0.6250c -0.1765,0.3162 -0.3529,0.6544 -0.3529 0.6544l -0.9706,1.6618 h -1.2647 ZM 113.7206,561.2500 ZM 118.1912,557.6912 v -2.7206 c 0.0000,-0.3824 0.0221,-0.9044 0.0221 -0.9044c 0.0221,-0.5221 0.0515,-0.9044 0.0515 -0.9044h -0.0588 c -0.1765,0.3382 -0.3676,0.6618 -0.3676 0.6618c -0.1912,0.3235 -0.3971,0.6618 -0.3971 0.6618l -2.1912,3.2059 h 2.9412 ZM 118.1912,557.6912 ZM 120.6176,558.6618 h -1.2794 v 2.5882 h -1.1471 v -2.5882 h -4.2206 v -0.7941 l 4.0147,-6.0000 h 1.3529 v 5.8235 h 1.2794 v 0.9706 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,128,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 139.9265,552.0000 v 14.0000 h 22.0000 v -14.0000 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 169.0294,561.2500 ZM 169.7206,557.6912 c 0.0000,-0.8676 0.2574,-1.5662 0.2574 -1.5662c 0.2574,-0.6985 0.6838,-1.1838 0.6838 -1.1838c 0.4265,-0.4853 0.9853,-0.7500 0.9853 -0.7500c 0.5588,-0.2647 1.1765,-0.2647 1.1765 -0.2647c 0.6176,0.0000 1.0735,0.2206 1.0735 0.2206c 0.4559,0.2206 0.9265,0.6029 0.9265 0.6029l -0.0588,-1.2206 v -2.7500 h 1.2206 v 10.4706 h -1.0000 l -0.1029,-0.8382 h -0.0441 c -0.4265,0.4118 -0.9779,0.7132 -0.9779 0.7132c -0.5515,0.3015 -1.1838,0.3015 -1.1838 0.3015c -1.3529,-0.0000 -2.1544,-0.9706 -2.1544 -0.9706c -0.8015,-0.9706 -0.8015,-2.7647 -0.8015 -2.7647ZM 169.7206,557.6912 ZM 170.9706,557.6765 c 0.0000,1.2941 0.5147,2.0147 0.5147 2.0147c 0.5147,0.7206 1.4559,0.7206 1.4559 0.7206c 0.5000,0.0000 0.9412,-0.2426 0.9412 -0.2426c 0.4412,-0.2426 0.8824,-0.7426 0.8824 -0.7426v -3.7353 c -0.4559,-0.4118 -0.8750,-0.5809 -0.8750 -0.5809c -0.4191,-0.1691 -0.8603,-0.1691 -0.8603 -0.1691c -0.4265,-0.0000 -0.8015,0.1985 -0.8015 0.1985c -0.3750,0.1985 -0.6544,0.5588 -0.6544 0.5588c -0.2794,0.3603 -0.4412,0.8603 -0.4412 0.8603c -0.1618,0.5000 -0.1618,1.1176 -0.1618 1.1176ZM 177.1912,561.2500 ZM 178.3971,554.1029 h 1.0000 l 0.1029,1.2941 h 0.0441 c 0.3676,-0.6765 0.8897,-1.0735 0.8897 -1.0735c 0.5221,-0.3971 1.1397,-0.3971 1.1397 -0.3971c 0.4265,0.0000 0.7647,0.1471 0.7647 0.1471l -0.2353,1.0588 c -0.1765,-0.0588 -0.3235,-0.0882 -0.3235 -0.0882c -0.1471,-0.0294 -0.3676,-0.0294 -0.3676 -0.0294c -0.4559,-0.0000 -0.9485,0.3676 -0.9485 0.3676c -0.4926,0.3676 -0.8603,1.2794 -0.8603 1.2794v 4.5882 h -1.2059 v -7.1471 ZM 182.1471,561.2500 ZM 182.8235,557.6912 c 0.0000,-0.8971 0.2721,-1.5956 0.2721 -1.5956c 0.2721,-0.6985 0.7279,-1.1838 0.7279 -1.1838c 0.4559,-0.4853 1.0515,-0.7353 1.0515 -0.7353c 0.5956,-0.2500 1.2574,-0.2500 1.2574 -0.2500c 0.6618,0.0000 1.2574,0.2500 1.2574 0.2500c 0.5956,0.2500 1.0515,0.7353 1.0515 0.7353c 0.4559,0.4853 0.7279,1.1838 0.7279 1.1838c 0.2721,0.6985 0.2721,1.5956 0.2721 1.5956c 0.0000,0.8824 -0.2721,1.5809 -0.2721 1.5809c -0.2721,0.6985 -0.7279,1.1765 -0.7279 1.1765c -0.4559,0.4779 -1.0515,0.7279 -1.0515 0.7279c -0.5956,0.2500 -1.2574,0.2500 -1.2574 0.2500c -0.6618,-0.0000 -1.2574,-0.2500 -1.2574 -0.2500c -0.5956,-0.2500 -1.0515,-0.7279 -1.0515 -0.7279c -0.4559,-0.4779 -0.7279,-1.1765 -0.7279 -1.1765c -0.2721,-0.6985 -0.2721,-1.5809 -0.2721 -1.5809ZM 182.8235,557.6912 ZM 184.0735,557.6912 c 0.0000,0.6176 0.1471,1.1176 0.1471 1.1176c 0.1471,0.5000 0.4191,0.8603 0.4191 0.8603c 0.2721,0.3603 0.6544,0.5588 0.6544 0.5588c 0.3824,0.1985 0.8382,0.1985 0.8382 0.1985c 0.4559,0.0000 0.8382,-0.1985 0.8382 -0.1985c 0.3824,-0.1985 0.6544,-0.5588 0.6544 -0.5588c 0.2721,-0.3603 0.4191,-0.8603 0.4191 -0.8603c 0.1471,-0.5000 0.1471,-1.1176 0.1471 -1.1176c 0.0000,-0.6176 -0.1471,-1.1250 -0.1471 -1.1250c -0.1471,-0.5074 -0.4191,-0.8750 -0.4191 -0.8750c -0.2721,-0.3676 -0.6544,-0.5662 -0.6544 -0.5662c -0.3824,-0.1985 -0.8382,-0.1985 -0.8382 -0.1985c -0.4559,-0.0000 -0.8382,0.1985 -0.8382 0.1985c -0.3824,0.1985 -0.6544,0.5662 -0.6544 0.5662c -0.2721,0.3676 -0.4191,0.8750 -0.4191 0.8750c -0.1471,0.5074 -0.1471,1.1250 -0.1471 1.1250ZM 190.1176,561.2500 ZM 192.5294,561.8529 v 2.4118 h -1.2059 v -10.1618 h 1.0000 l 0.1029,0.8235 h 0.0441 c 0.4853,-0.4118 1.0662,-0.7059 1.0662 -0.7059c 0.5809,-0.2941 1.2132,-0.2941 1.2132 -0.2941c 0.6912,0.0000 1.2206,0.2574 1.2206 0.2574c 0.5294,0.2574 0.8824,0.7353 0.8824 0.7353c 0.3529,0.4779 0.5368,1.1471 0.5368 1.1471c 0.1838,0.6691 0.1838,1.5074 0.1838 1.5074c 0.0000,0.9118 -0.2500,1.6250 -0.2500 1.6250c -0.2500,0.7132 -0.6765,1.2132 -0.6765 1.2132c -0.4265,0.5000 -0.9853,0.7574 -0.9853 0.7574c -0.5588,0.2574 -1.1765,0.2574 -1.1765 0.2574c -0.5000,-0.0000 -0.9926,-0.2206 -0.9926 -0.2206c -0.4926,-0.2206 -0.9926,-0.6029 -0.9926 -0.6029ZM 192.5294,561.8529 ZM 192.5294,559.6618 c 0.4853,0.4118 0.9412,0.5809 0.9412 0.5809c 0.4559,0.1691 0.8088,0.1691 0.8088 0.1691c 0.4412,0.0000 0.8162,-0.1985 0.8162 -0.1985c 0.3750,-0.1985 0.6471,-0.5588 0.6471 -0.5588c 0.2721,-0.3603 0.4265,-0.8897 0.4265 -0.8897c 0.1544,-0.5294 0.1544,-1.1912 0.1544 -1.1912c 0.0000,-0.5882 -0.1029,-1.0735 -0.1029 -1.0735c -0.1029,-0.4853 -0.3309,-0.8309 -0.3309 -0.8309c -0.2279,-0.3456 -0.5882,-0.5368 -0.5882 -0.5368c -0.3603,-0.1912 -0.8603,-0.1912 -0.8603 -0.1912c -0.4559,-0.0000 -0.9191,0.2500 -0.9191 0.2500c -0.4632,0.2500 -0.9926,0.7206 -0.9926 0.7206v 3.7500 ZM 198.2794,561.2500 ZM 198.8824,557.1029 h 3.3824 v 0.9265 h -3.3824 v -0.9265 ZM 202.8529,561.2500 ZM 203.7059,559.3971 c 0.0000,-1.1765 1.0515,-1.8015 1.0515 -1.8015c 1.0515,-0.6250 3.3456,-0.8750 3.3456 -0.8750c 0.0000,-0.3382 -0.0662,-0.6618 -0.0662 -0.6618c -0.0662,-0.3235 -0.2353,-0.5735 -0.2353 -0.5735c -0.1691,-0.2500 -0.4485,-0.4044 -0.4485 -0.4044c -0.2794,-0.1544 -0.7206,-0.1544 -0.7206 -0.1544c -0.6324,-0.0000 -1.1691,0.2353 -1.1691 0.2353c -0.5368,0.2353 -0.9632,0.5294 -0.9632 0.5294l -0.4853,-0.8382 c 0.5000,-0.3235 1.2206,-0.6250 1.2206 -0.6250c 0.7206,-0.3015 1.5882,-0.3015 1.5882 -0.3015c 1.3088,0.0000 1.8971,0.8015 1.8971 0.8015c 0.5882,0.8015 0.5882,2.1397 0.5882 2.1397v 4.3824 h -1.0000 l -0.1029,-0.8529 h -0.0294 c -0.5147,0.4265 -1.1103,0.7279 -1.1103 0.7279c -0.5956,0.3015 -1.2574,0.3015 -1.2574 0.3015c -0.9118,-0.0000 -1.5074,-0.5294 -1.5074 -0.5294c -0.5956,-0.5294 -0.5956,-1.5000 -0.5956 -1.5000ZM 203.7059,559.3971 ZM 204.8971,559.3088 c 0.0000,0.6176 0.3603,0.8824 0.3603 0.8824c 0.3603,0.2647 0.8897,0.2647 0.8897 0.2647c 0.5147,0.0000 0.9779,-0.2426 0.9779 -0.2426c 0.4632,-0.2426 0.9779,-0.7132 0.9779 -0.7132v -1.9853 c -0.8971,0.1176 -1.5147,0.2794 -1.5147 0.2794c -0.6176,0.1618 -0.9926,0.3824 -0.9926 0.3824c -0.3750,0.2206 -0.5368,0.5074 -0.5368 0.5074c -0.1618,0.2868 -0.1618,0.6250 -0.1618 0.6250ZM 210.3824,561.2500 ZM 211.5882,550.7794 h 1.2059 v 9.1176 c 0.0000,0.2941 0.1029,0.4118 0.1029 0.4118c 0.1029,0.1176 0.2353,0.1176 0.2353 0.1176h 0.1103 c 0.0000,0.0000 0.1544,-0.0294 0.1544 -0.0294l 0.1618,0.9118 c -0.1176,0.0588 -0.2794,0.0882 -0.2794 0.0882c -0.1618,0.0294 -0.4118,0.0294 -0.4118 0.0294c -0.6912,-0.0000 -0.9853,-0.4118 -0.9853 -0.4118c -0.2941,-0.4118 -0.2941,-1.2059 -0.2941 -1.2059v -9.0294 ZM 214.1324,561.2500 ZM 215.3382,550.7794 h 1.2059 v 9.1176 c 0.0000,0.2941 0.1029,0.4118 0.1029 0.4118c 0.1029,0.1176 0.2353,0.1176 0.2353 0.1176h 0.1103 c 0.0000,0.0000 0.1544,-0.0294 0.1544 -0.0294l 0.1618,0.9118 c -0.1176,0.0588 -0.2794,0.0882 -0.2794 0.0882c -0.1618,0.0294 -0.4118,0.0294 -0.4118 0.0294c -0.6912,-0.0000 -0.9853,-0.4118 -0.9853 -0.4118c -0.2941,-0.4118 -0.2941,-1.2059 -0.2941 -1.2059v -9.0294 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(255,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 288.1471,552.0000 v 14.0000 h 22.0000 v -14.0000 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 317.2500,561.2500 ZM 318.6618,555.0882 h -1.0588 v -0.9118 l 1.1176,-0.0735 l 0.1471,-2.0000 h 1.0147 v 2.0000 h 1.9265 v 0.9853 h -1.9265 v 3.9706 c 0.0000,0.6618 0.2426,1.0221 0.2426 1.0221c 0.2426,0.3603 0.8603,0.3603 0.8603 0.3603c 0.1912,0.0000 0.4118,-0.0588 0.4118 -0.0588c 0.2206,-0.0588 0.3971,-0.1324 0.3971 -0.1324l 0.2353,0.9118 c -0.2941,0.1029 -0.6397,0.1838 -0.6397 0.1838c -0.3456,0.0809 -0.6838,0.0809 -0.6838 0.0809c -0.5735,-0.0000 -0.9632,-0.1765 -0.9632 -0.1765c -0.3897,-0.1765 -0.6324,-0.4853 -0.6324 -0.4853c -0.2426,-0.3088 -0.3456,-0.7500 -0.3456 -0.7500c -0.1029,-0.4412 -0.1029,-0.9706 -0.1029 -0.9706v -3.9559 ZM 321.9559,561.2500 ZM 322.8088,559.3971 c 0.0000,-1.1765 1.0515,-1.8015 1.0515 -1.8015c 1.0515,-0.6250 3.3456,-0.8750 3.3456 -0.8750c 0.0000,-0.3382 -0.0662,-0.6618 -0.0662 -0.6618c -0.0662,-0.3235 -0.2353,-0.5735 -0.2353 -0.5735c -0.1691,-0.2500 -0.4485,-0.4044 -0.4485 -0.4044c -0.2794,-0.1544 -0.7206,-0.1544 -0.7206 -0.1544c -0.6324,-0.0000 -1.1691,0.2353 -1.1691 0.2353c -0.5368,0.2353 -0.9632,0.5294 -0.9632 0.5294l -0.4853,-0.8382 c 0.5000,-0.3235 1.2206,-0.6250 1.2206 -0.6250c 0.7206,-0.3015 1.5882,-0.3015 1.5882 -0.3015c 1.3088,0.0000 1.8971,0.8015 1.8971 0.8015c 0.5882,0.8015 0.5882,2.1397 0.5882 2.1397v 4.3824 h -1.0000 l -0.1029,-0.8529 h -0.0294 c -0.5147,0.4265 -1.1103,0.7279 -1.1103 0.7279c -0.5956,0.3015 -1.2574,0.3015 -1.2574 0.3015c -0.9118,-0.0000 -1.5074,-0.5294 -1.5074 -0.5294c -0.5956,-0.5294 -0.5956,-1.5000 -0.5956 -1.5000ZM 322.8088,559.3971 ZM 324.0000,559.3088 c 0.0000,0.6176 0.3603,0.8824 0.3603 0.8824c 0.3603,0.2647 0.8897,0.2647 0.8897 0.2647c 0.5147,0.0000 0.9779,-0.2426 0.9779 -0.2426c 0.4632,-0.2426 0.9779,-0.7132 0.9779 -0.7132v -1.9853 c -0.8971,0.1176 -1.5147,0.2794 -1.5147 0.2794c -0.6176,0.1618 -0.9926,0.3824 -0.9926 0.3824c -0.3750,0.2206 -0.5368,0.5074 -0.5368 0.5074c -0.1618,0.2868 -0.1618,0.6250 -0.1618 0.6250ZM 329.4853,561.2500 ZM 330.6912,550.7794 h 1.1912 v 7.0882 h 0.0441 l 3.0441,-3.7647 h 1.3382 l -2.3971,2.8676 l 2.7206,4.2794 h -1.3235 l -2.0882,-3.4412 l -1.3382,1.5588 v 1.8824 h -1.1912 v -10.4706 ZM 336.5000,561.2500 ZM 337.1765,557.6912 c 0.0000,-0.8824 0.2721,-1.5809 0.2721 -1.5809c 0.2721,-0.6985 0.7206,-1.1838 0.7206 -1.1838c 0.4485,-0.4853 1.0221,-0.7426 1.0221 -0.7426c 0.5735,-0.2574 1.1912,-0.2574 1.1912 -0.2574c 0.6765,0.0000 1.2132,0.2353 1.2132 0.2353c 0.5368,0.2353 0.8971,0.6765 0.8971 0.6765c 0.3603,0.4412 0.5515,1.0588 0.5515 1.0588c 0.1912,0.6176 0.1912,1.3824 0.1912 1.3824c 0.0000,0.3971 -0.0441,0.6618 -0.0441 0.6618h -4.8235 c 0.0735,1.1618 0.7132,1.8382 0.7132 1.8382c 0.6397,0.6765 1.6691,0.6765 1.6691 0.6765c 0.5147,0.0000 0.9485,-0.1544 0.9485 -0.1544c 0.4338,-0.1544 0.8309,-0.4044 0.8309 -0.4044l 0.4265,0.7941 c -0.4706,0.2941 -1.0441,0.5147 -1.0441 0.5147c -0.5735,0.2206 -1.3088,0.2206 -1.3088 0.2206c -0.7206,-0.0000 -1.3456,-0.2574 -1.3456 -0.2574c -0.6250,-0.2574 -1.0882,-0.7353 -1.0882 -0.7353c -0.4632,-0.4779 -0.7279,-1.1691 -0.7279 -1.1691c -0.2647,-0.6912 -0.2647,-1.5735 -0.2647 -1.5735ZM 337.1765,557.6912 ZM 342.1765,557.1471 c 0.0000,-1.1029 -0.4632,-1.6838 -0.4632 -1.6838c -0.4632,-0.5809 -1.3015,-0.5809 -1.3015 -0.5809c -0.3824,-0.0000 -0.7279,0.1544 -0.7279 0.1544c -0.3456,0.1544 -0.6250,0.4412 -0.6250 0.4412c -0.2794,0.2868 -0.4632,0.7059 -0.4632 0.7059c -0.1838,0.4191 -0.2426,0.9632 -0.2426 0.9632h 3.8235 ZM 343.7941,561.2500 ZM 344.3971,557.1029 h 3.3824 v 0.9265 h -3.3824 v -0.9265 ZM 348.3676,561.2500 ZM 349.0588,557.6912 c 0.0000,-0.8676 0.2574,-1.5662 0.2574 -1.5662c 0.2574,-0.6985 0.6838,-1.1838 0.6838 -1.1838c 0.4265,-0.4853 0.9853,-0.7500 0.9853 -0.7500c 0.5588,-0.2647 1.1765,-0.2647 1.1765 -0.2647c 0.6176,0.0000 1.0735,0.2206 1.0735 0.2206c 0.4559,0.2206 0.9265,0.6029 0.9265 0.6029l -0.0588,-1.2206 v -2.7500 h 1.2206 v 10.4706 h -1.0000 l -0.1029,-0.8382 h -0.0441 c -0.4265,0.4118 -0.9779,0.7132 -0.9779 0.7132c -0.5515,0.3015 -1.1838,0.3015 -1.1838 0.3015c -1.3529,-0.0000 -2.1544,-0.9706 -2.1544 -0.9706c -0.8015,-0.9706 -0.8015,-2.7647 -0.8015 -2.7647ZM 349.0588,557.6912 ZM 350.3088,557.6765 c 0.0000,1.2941 0.5147,2.0147 0.5147 2.0147c 0.5147,0.7206 1.4559,0.7206 1.4559 0.7206c 0.5000,0.0000 0.9412,-0.2426 0.9412 -0.2426c 0.4412,-0.2426 0.8824,-0.7426 0.8824 -0.7426v -3.7353 c -0.4559,-0.4118 -0.8750,-0.5809 -0.8750 -0.5809c -0.4191,-0.1691 -0.8603,-0.1691 -0.8603 -0.1691c -0.4265,-0.0000 -0.8015,0.1985 -0.8015 0.1985c -0.3750,0.1985 -0.6544,0.5588 -0.6544 0.5588c -0.2794,0.3603 -0.4412,0.8603 -0.4412 0.8603c -0.1618,0.5000 -0.1618,1.1176 -0.1618 1.1176ZM 356.5294,561.2500 ZM 357.7353,554.1029 h 1.0000 l 0.1029,1.2941 h 0.0441 c 0.3676,-0.6765 0.8897,-1.0735 0.8897 -1.0735c 0.5221,-0.3971 1.1397,-0.3971 1.1397 -0.3971c 0.4265,0.0000 0.7647,0.1471 0.7647 0.1471l -0.2353,1.0588 c -0.1765,-0.0588 -0.3235,-0.0882 -0.3235 -0.0882c -0.1471,-0.0294 -0.3676,-0.0294 -0.3676 -0.0294c -0.4559,-0.0000 -0.9485,0.3676 -0.9485 0.3676c -0.4926,0.3676 -0.8603,1.2794 -0.8603 1.2794v 4.5882 h -1.2059 v -7.1471 ZM 361.4853,561.2500 ZM 362.1618,557.6912 c 0.0000,-0.8971 0.2721,-1.5956 0.2721 -1.5956c 0.2721,-0.6985 0.7279,-1.1838 0.7279 -1.1838c 0.4559,-0.4853 1.0515,-0.7353 1.0515 -0.7353c 0.5956,-0.2500 1.2574,-0.2500 1.2574 -0.2500c 0.6618,0.0000 1.2574,0.2500 1.2574 0.2500c 0.5956,0.2500 1.0515,0.7353 1.0515 0.7353c 0.4559,0.4853 0.7279,1.1838 0.7279 1.1838c 0.2721,0.6985 0.2721,1.5956 0.2721 1.5956c 0.0000,0.8824 -0.2721,1.5809 -0.2721 1.5809c -0.2721,0.6985 -0.7279,1.1765 -0.7279 1.1765c -0.4559,0.4779 -1.0515,0.7279 -1.0515 0.7279c -0.5956,0.2500 -1.2574,0.2500 -1.2574 0.2500c -0.6618,-0.0000 -1.2574,-0.2500 -1.2574 -0.2500c -0.5956,-0.2500 -1.0515,-0.7279 -1.0515 -0.7279c -0.4559,-0.4779 -0.7279,-1.1765 -0.7279 -1.1765c -0.2721,-0.6985 -0.2721,-1.5809 -0.2721 -1.5809ZM 362.1618,557.6912 ZM 363.4118,557.6912 c 0.0000,0.6176 0.1471,1.1176 0.1471 1.1176c 0.1471,0.5000 0.4191,0.8603 0.4191 0.8603c 0.2721,0.3603 0.6544,0.5588 0.6544 0.5588c 0.3824,0.1985 0.8382,0.1985 0.8382 0.1985c 0.4559,0.0000 0.8382,-0.1985 0.8382 -0.1985c 0.3824,-0.1985 0.6544,-0.5588 0.6544 -0.5588c 0.2721,-0.3603 0.4191,-0.8603 0.4191 -0.8603c 0.1471,-0.5000 0.1471,-1.1176 0.1471 -1.1176c 0.0000,-0.6176 -0.1471,-1.1250 -0.1471 -1.1250c -0.1471,-0.5074 -0.4191,-0.8750 -0.4191 -0.8750c -0.2721,-0.3676 -0.6544,-0.5662 -0.6544 -0.5662c -0.3824,-0.1985 -0.8382,-0.1985 -0.8382 -0.1985c -0.4559,-0.0000 -0.8382,0.1985 -0.8382 0.1985c -0.3824,0.1985 -0.6544,0.5662 -0.6544 0.5662c -0.2721,0.3676 -0.4191,0.8750 -0.4191 0.8750c -0.1471,0.5074 -0.1471,1.1250 -0.1471 1.1250ZM 369.4559,561.2500 ZM 371.8676,561.8529 v 2.4118 h -1.2059 v -10.1618 h 1.0000 l 0.1029,0.8235 h 0.0441 c 0.4853,-0.4118 1.0662,-0.7059 1.0662 -0.7059c 0.5809,-0.2941 1.2132,-0.2941 1.2132 -0.2941c 0.6912,0.0000 1.2206,0.2574 1.2206 0.2574c 0.5294,0.2574 0.8824,0.7353 0.8824 0.7353c 0.3529,0.4779 0.5368,1.1471 0.5368 1.1471c 0.1838,0.6691 0.1838,1.5074 0.1838 1.5074c 0.0000,0.9118 -0.2500,1.6250 -0.2500 1.6250c -0.2500,0.7132 -0.6765,1.2132 -0.6765 1.2132c -0.4265,0.5000 -0.9853,0.7574 -0.9853 0.7574c -0.5588,0.2574 -1.1765,0.2574 -1.1765 0.2574c -0.5000,-0.0000 -0.9926,-0.2206 -0.9926 -0.2206c -0.4926,-0.2206 -0.9926,-0.6029 -0.9926 -0.6029ZM 371.8676,561.8529 ZM 371.8676,559.6618 c 0.4853,0.4118 0.9412,0.5809 0.9412 0.5809c 0.4559,0.1691 0.8088,0.1691 0.8088 0.1691c 0.4412,0.0000 0.8162,-0.1985 0.8162 -0.1985c 0.3750,-0.1985 0.6471,-0.5588 0.6471 -0.5588c 0.2721,-0.3603 0.4265,-0.8897 0.4265 -0.8897c 0.1544,-0.5294 0.1544,-1.1912 0.1544 -1.1912c 0.0000,-0.5882 -0.1029,-1.0735 -0.1029 -1.0735c -0.1029,-0.4853 -0.3309,-0.8309 -0.3309 -0.8309c -0.2279,-0.3456 -0.5882,-0.5368 -0.5882 -0.5368c -0.3603,-0.1912 -0.8603,-0.1912 -0.8603 -0.1912c -0.4559,-0.0000 -0.9191,0.2500 -0.9191 0.2500c -0.4632,0.2500 -0.9926,0.7206 -0.9926 0.7206v 3.7500 ZM 380.5882,561.2500 ZM 383.1324,557.5147 l -2.1618,-3.4118 h 1.3088 l 0.9559,1.5735 c 0.1618,0.2941 0.3382,0.5956 0.3382 0.5956c 0.1765,0.3015 0.3676,0.5956 0.3676 0.5956h 0.0588 c 0.1618,-0.2941 0.3235,-0.5956 0.3235 -0.5956c 0.1618,-0.3015 0.3235,-0.5956 0.3235 -0.5956l 0.8676,-1.5735 h 1.2647 l -2.1618,3.5441 l 2.3235,3.6029 h -1.3088 l -1.0441,-1.6618 l -0.3824,-0.6471 c 0.0000,0.0000 -0.3971,-0.6324 -0.3971 -0.6324h -0.0588 c -0.1912,0.3088 -0.3676,0.6250 -0.3676 0.6250c -0.1765,0.3162 -0.3529,0.6544 -0.3529 0.6544l -0.9706,1.6618 h -1.2647 ZM 390.1176,561.2500 ZM 394.5882,557.6912 v -2.7206 c 0.0000,-0.3824 0.0221,-0.9044 0.0221 -0.9044c 0.0221,-0.5221 0.0515,-0.9044 0.0515 -0.9044h -0.0588 c -0.1765,0.3382 -0.3676,0.6618 -0.3676 0.6618c -0.1912,0.3235 -0.3971,0.6618 -0.3971 0.6618l -2.1912,3.2059 h 2.9412 ZM 394.5882,557.6912 ZM 397.0147,558.6618 h -1.2794 v 2.5882 h -1.1471 v -2.5882 h -4.2206 v -0.7941 l 4.0147,-6.0000 h 1.3529 v 5.8235 h 1.2794 v 0.9706 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(255,165,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 417.9559,552.0000 v 14.0000 h 22.0000 v -14.0000 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 447.0588,561.2500 ZM 447.7500,557.6912 c 0.0000,-0.8676 0.2574,-1.5662 0.2574 -1.5662c 0.2574,-0.6985 0.6838,-1.1838 0.6838 -1.1838c 0.4265,-0.4853 0.9853,-0.7500 0.9853 -0.7500c 0.5588,-0.2647 1.1765,-0.2647 1.1765 -0.2647c 0.6176,0.0000 1.0735,0.2206 1.0735 0.2206c 0.4559,0.2206 0.9265,0.6029 0.9265 0.6029l -0.0588,-1.2206 v -2.7500 h 1.2206 v 10.4706 h -1.0000 l -0.1029,-0.8382 h -0.0441 c -0.4265,0.4118 -0.9779,0.7132 -0.9779 0.7132c -0.5515,0.3015 -1.1838,0.3015 -1.1838 0.3015c -1.3529,-0.0000 -2.1544,-0.9706 -2.1544 -0.9706c -0.8015,-0.9706 -0.8015,-2.7647 -0.8015 -2.7647ZM 447.7500,557.6912 ZM 449.0000,557.6765 c 0.0000,1.2941 0.5147,2.0147 0.5147 2.0147c 0.5147,0.7206 1.4559,0.7206 1.4559 0.7206c 0.5000,0.0000 0.9412,-0.2426 0.9412 -0.2426c 0.4412,-0.2426 0.8824,-0.7426 0.8824 -0.7426v -3.7353 c -0.4559,-0.4118 -0.8750,-0.5809 -0.8750 -0.5809c -0.4191,-0.1691 -0.8603,-0.1691 -0.8603 -0.1691c -0.4265,-0.0000 -0.8015,0.1985 -0.8015 0.1985c -0.3750,0.1985 -0.6544,0.5588 -0.6544 0.5588c -0.2794,0.3603 -0.4412,0.8603 -0.4412 0.8603c -0.1618,0.5000 -0.1618,1.1176 -0.1618 1.1176ZM 455.2206,561.2500 ZM 456.4265,554.1029 h 1.0000 l 0.1029,1.2941 h 0.0441 c 0.3676,-0.6765 0.8897,-1.0735 0.8897 -1.0735c 0.5221,-0.3971 1.1397,-0.3971 1.1397 -0.3971c 0.4265,0.0000 0.7647,0.1471 0.7647 0.1471l -0.2353,1.0588 c -0.1765,-0.0588 -0.3235,-0.0882 -0.3235 -0.0882c -0.1471,-0.0294 -0.3676,-0.0294 -0.3676 -0.0294c -0.4559,-0.0000 -0.9485,0.3676 -0.9485 0.3676c -0.4926,0.3676 -0.8603,1.2794 -0.8603 1.2794v 4.5882 h -1.2059 v -7.1471 ZM 460.1765,561.2500 ZM 460.8529,557.6912 c 0.0000,-0.8971 0.2721,-1.5956 0.2721 -1.5956c 0.2721,-0.6985 0.7279,-1.1838 0.7279 -1.1838c 0.4559,-0.4853 1.0515,-0.7353 1.0515 -0.7353c 0.5956,-0.2500 1.2574,-0.2500 1.2574 -0.2500c 0.6618,0.0000 1.2574,0.2500 1.2574 0.2500c 0.5956,0.2500 1.0515,0.7353 1.0515 0.7353c 0.4559,0.4853 0.7279,1.1838 0.7279 1.1838c 0.2721,0.6985 0.2721,1.5956 0.2721 1.5956c 0.0000,0.8824 -0.2721,1.5809 -0.2721 1.5809c -0.2721,0.6985 -0.7279,1.1765 -0.7279 1.1765c -0.4559,0.4779 -1.0515,0.7279 -1.0515 0.7279c -0.5956,0.2500 -1.2574,0.2500 -1.2574 0.2500c -0.6618,-0.0000 -1.2574,-0.2500 -1.2574 -0.2500c -0.5956,-0.2500 -1.0515,-0.7279 -1.0515 -0.7279c -0.4559,-0.4779 -0.7279,-1.1765 -0.7279 -1.1765c -0.2721,-0.6985 -0.2721,-1.5809 -0.2721 -1.5809ZM 460.8529,557.6912 ZM 462.1029,557.6912 c 0.0000,0.6176 0.1471,1.1176 0.1471 1.1176c 0.1471,0.5000 0.4191,0.8603 0.4191 0.8603c 0.2721,0.3603 0.6544,0.5588 0.6544 0.5588c 0.3824,0.1985 0.8382,0.1985 0.8382 0.1985c 0.4559,0.0000 0.8382,-0.1985 0.8382 -0.1985c 0.3824,-0.1985 0.6544,-0.5588 0.6544 -0.5588c 0.2721,-0.3603 0.4191,-0.8603 0.4191 -0.8603c 0.1471,-0.5000 0.1471,-1.1176 0.1471 -1.1176c 0.0000,-0.6176 -0.1471,-1.1250 -0.1471 -1.1250c -0.1471,-0.5074 -0.4191,-0.8750 -0.4191 -0.8750c -0.2721,-0.3676 -0.6544,-0.5662 -0.6544 -0.5662c -0.3824,-0.1985 -0.8382,-0.1985 -0.8382 -0.1985c -0.4559,-0.0000 -0.8382,0.1985 -0.8382 0.1985c -0.3824,0.1985 -0.6544,0.5662 -0.6544 0.5662c -0.2721,0.3676 -0.4191,0.8750 -0.4191 0.8750c -0.1471,0.5074 -0.1471,1.1250 -0.1471 1.1250ZM 468.1471,561.2500 ZM 470.5588,561.8529 v 2.4118 h -1.2059 v -10.1618 h 1.0000 l 0.1029,0.8235 h 0.0441 c 0.4853,-0.4118 1.0662,-0.7059 1.0662 -0.7059c 0.5809,-0.2941 1.2132,-0.2941 1.2132 -0.2941c 0.6912,0.0000 1.2206,0.2574 1.2206 0.2574c 0.5294,0.2574 0.8824,0.7353 0.8824 0.7353c 0.3529,0.4779 0.5368,1.1471 0.5368 1.1471c 0.1838,0.6691 0.1838,1.5074 0.1838 1.5074c 0.0000,0.9118 -0.2500,1.6250 -0.2500 1.6250c -0.2500,0.7132 -0.6765,1.2132 -0.6765 1.2132c -0.4265,0.5000 -0.9853,0.7574 -0.9853 0.7574c -0.5588,0.2574 -1.1765,0.2574 -1.1765 0.2574c -0.5000,-0.0000 -0.9926,-0.2206 -0.9926 -0.2206c -0.4926,-0.2206 -0.9926,-0.6029 -0.9926 -0.6029ZM 470.5588,561.8529 ZM 470.5588,559.6618 c 0.4853,0.4118 0.9412,0.5809 0.9412 0.5809c 0.4559,0.1691 0.8088,0.1691 0.8088 0.1691c 0.4412,0.0000 0.8162,-0.1985 0.8162 -0.1985c 0.3750,-0.1985 0.6471,-0.5588 0.6471 -0.5588c 0.2721,-0.3603 0.4265,-0.8897 0.4265 -0.8897c 0.1544,-0.5294 0.1544,-1.1912 0.1544 -1.1912c 0.0000,-0.5882 -0.1029,-1.0735 -0.1029 -1.0735c -0.1029,-0.4853 -0.3309,-0.8309 -0.3309 -0.8309c -0.2279,-0.3456 -0.5882,-0.5368 -0.5882 -0.5368c -0.3603,-0.1912 -0.8603,-0.1912 -0.8603 -0.1912c -0.4559,-0.0000 -0.9191,0.2500 -0.9191 0.2500c -0.4632,0.2500 -0.9926,0.7206 -0.9926 0.7206v 3.7500 ZM 476.3088,561.2500 ZM 476.6471,551.6029 h 1.2647 l 1.0147,5.2500 c 0.1324,0.7941 0.2794,1.5588 0.2794 1.5588c 0.1471,0.7647 0.2794,1.5588 0.2794 1.5588h 0.0588 c 0.1618,-0.7941 0.3382,-1.5662 0.3382 -1.5662c 0.1765,-0.7721 0.3382,-1.5515 0.3382 -1.5515l 1.3382,-5.2500 h 1.1176 l 1.3382,5.2500 c 0.1765,0.7647 0.3529,1.5441 0.3529 1.5441c 0.1765,0.7794 0.3529,1.5735 0.3529 1.5735h 0.0588 c 0.1324,-0.7941 0.2647,-1.5662 0.2647 -1.5662c 0.1324,-0.7721 0.2794,-1.5515 0.2794 -1.5515l 1.0147,-5.2500 h 1.1765 l -2.0000,9.6471 h -1.4706 l -1.4559,-5.8088 c -0.1324,-0.5588 -0.2426,-1.0956 -0.2426 -1.0956c -0.1103,-0.5368 -0.2279,-1.0956 -0.2279 -1.0956h -0.0588 c -0.1176,0.5588 -0.2426,1.0956 -0.2426 1.0956c -0.1250,0.5368 -0.2426,1.0956 -0.2426 1.0956l -1.4265,5.8088 h -1.4559 ZM 487.8676,561.2500 ZM 489.0735,550.7794 h 1.2059 v 2.8529 l -0.0441,1.4706 c 0.5147,-0.4853 1.0735,-0.8309 1.0735 -0.8309c 0.5588,-0.3456 1.3088,-0.3456 1.3088 -0.3456c 1.1324,0.0000 1.6544,0.7059 1.6544 0.7059c 0.5221,0.7059 0.5221,2.0882 0.5221 2.0882v 4.5294 h -1.2059 v -4.3676 c 0.0000,-1.0147 -0.3235,-1.4632 -0.3235 -1.4632c -0.3235,-0.4485 -1.0294,-0.4485 -1.0294 -0.4485c -0.5588,-0.0000 -0.9853,0.2794 -0.9853 0.2794c -0.4265,0.2794 -0.9706,0.8235 -0.9706 0.8235v 5.1765 h -1.2059 v -10.4706 ZM 495.8676,561.2500 ZM 497.6912,552.6324 c -0.3529,-0.0000 -0.5956,-0.2206 -0.5956 -0.2206c -0.2426,-0.2206 -0.2426,-0.5588 -0.2426 -0.5588c 0.0000,-0.3529 0.2426,-0.5662 0.2426 -0.5662c 0.2426,-0.2132 0.5956,-0.2132 0.5956 -0.2132c 0.3529,0.0000 0.5956,0.2132 0.5956 0.2132c 0.2426,0.2132 0.2426,0.5662 0.2426 0.5662c 0.0000,0.3382 -0.2426,0.5588 -0.2426 0.5588c -0.2426,0.2206 -0.5956,0.2206 -0.5956 0.2206ZM 497.6912,552.6324 ZM 497.0735,554.1029 h 1.2059 v 7.1471 h -1.2059 v -7.1471 ZM 499.4853,561.2500 ZM 500.6912,550.7794 h 1.2059 v 9.1176 c 0.0000,0.2941 0.1029,0.4118 0.1029 0.4118c 0.1029,0.1176 0.2353,0.1176 0.2353 0.1176h 0.1103 c 0.0000,0.0000 0.1544,-0.0294 0.1544 -0.0294l 0.1618,0.9118 c -0.1176,0.0588 -0.2794,0.0882 -0.2794 0.0882c -0.1618,0.0294 -0.4118,0.0294 -0.4118 0.0294c -0.6912,-0.0000 -0.9853,-0.4118 -0.9853 -0.4118c -0.2941,-0.4118 -0.2941,-1.2059 -0.2941 -1.2059v -9.0294 ZM 503.2353,561.2500 ZM 503.9118,557.6912 c 0.0000,-0.8824 0.2721,-1.5809 0.2721 -1.5809c 0.2721,-0.6985 0.7206,-1.1838 0.7206 -1.1838c 0.4485,-0.4853 1.0221,-0.7426 1.0221 -0.7426c 0.5735,-0.2574 1.1912,-0.2574 1.1912 -0.2574c 0.6765,0.0000 1.2132,0.2353 1.2132 0.2353c 0.5368,0.2353 0.8971,0.6765 0.8971 0.6765c 0.3603,0.4412 0.5515,1.0588 0.5515 1.0588c 0.1912,0.6176 0.1912,1.3824 0.1912 1.3824c 0.0000,0.3971 -0.0441,0.6618 -0.0441 0.6618h -4.8235 c 0.0735,1.1618 0.7132,1.8382 0.7132 1.8382c 0.6397,0.6765 1.6691,0.6765 1.6691 0.6765c 0.5147,0.0000 0.9485,-0.1544 0.9485 -0.1544c 0.4338,-0.1544 0.8309,-0.4044 0.8309 -0.4044l 0.4265,0.7941 c -0.4706,0.2941 -1.0441,0.5147 -1.0441 0.5147c -0.5735,0.2206 -1.3088,0.2206 -1.3088 0.2206c -0.7206,-0.0000 -1.3456,-0.2574 -1.3456 -0.2574c -0.6250,-0.2574 -1.0882,-0.7353 -1.0882 -0.7353c -0.4632,-0.4779 -0.7279,-1.1691 -0.7279 -1.1691c -0.2647,-0.6912 -0.2647,-1.5735 -0.2647 -1.5735ZM 503.9118,557.6912 ZM 508.9118,557.1471 c 0.0000,-1.1029 -0.4632,-1.6838 -0.4632 -1.6838c -0.4632,-0.5809 -1.3015,-0.5809 -1.3015 -0.5809c -0.3824,-0.0000 -0.7279,0.1544 -0.7279 0.1544c -0.3456,0.1544 -0.6250,0.4412 -0.6250 0.4412c -0.2794,0.2868 -0.4632,0.7059 -0.4632 0.7059c -0.1838,0.4191 -0.2426,0.9632 -0.2426 0.9632h 3.8235 ZM 510.5294,561.2500 ZM 511.1324,557.1029 h 3.3824 v 0.9265 h -3.3824 v -0.9265 ZM 515.1029,561.2500 ZM 519.5294,551.7647 c -0.3971,-0.1765 -0.8088,-0.1765 -0.8088 -0.1765c -1.0000,-0.0000 -1.0000,1.3824 -1.0000 1.3824v 1.1324 h 1.5147 v 0.9853 h -1.5147 v 6.1618 h -1.2059 v -6.1618 h -0.9706 v -0.9118 l 0.9706,-0.0735 v -1.1324 c 0.0000,-1.1029 0.5074,-1.7353 0.5074 -1.7353c 0.5074,-0.6324 1.5809,-0.6324 1.5809 -0.6324c 0.3382,0.0000 0.6397,0.0662 0.6397 0.0662c 0.3015,0.0662 0.5515,0.1691 0.5515 0.1691ZM 519.1029,561.2500 ZM 519.9559,559.3971 c 0.0000,-1.1765 1.0515,-1.8015 1.0515 -1.8015c 1.0515,-0.6250 3.3456,-0.8750 3.3456 -0.8750c 0.0000,-0.3382 -0.0662,-0.6618 -0.0662 -0.6618c -0.0662,-0.3235 -0.2353,-0.5735 -0.2353 -0.5735c -0.1691,-0.2500 -0.4485,-0.4044 -0.4485 -0.4044c -0.2794,-0.1544 -0.7206,-0.1544 -0.7206 -0.1544c -0.6324,-0.0000 -1.1691,0.2353 -1.1691 0.2353c -0.5368,0.2353 -0.9632,0.5294 -0.9632 0.5294l -0.4853,-0.8382 c 0.5000,-0.3235 1.2206,-0.6250 1.2206 -0.6250c 0.7206,-0.3015 1.5882,-0.3015 1.5882 -0.3015c 1.3088,0.0000 1.8971,0.8015 1.8971 0.8015c 0.5882,0.8015 0.5882,2.1397 0.5882 2.1397v 4.3824 h -1.0000 l -0.1029,-0.8529 h -0.0294 c -0.5147,0.4265 -1.1103,0.7279 -1.1103 0.7279c -0.5956,0.3015 -1.2574,0.3015 -1.2574 0.3015c -0.9118,-0.0000 -1.5074,-0.5294 -1.5074 -0.5294c -0.5956,-0.5294 -0.5956,-1.5000 -0.5956 -1.5000ZM 519.9559,559.3971 ZM 521.1471,559.3088 c 0.0000,0.6176 0.3603,0.8824 0.3603 0.8824c 0.3603,0.2647 0.8897,0.2647 0.8897 0.2647c 0.5147,0.0000 0.9779,-0.2426 0.9779 -0.2426c 0.4632,-0.2426 0.9779,-0.7132 0.9779 -0.7132v -1.9853 c -0.8971,0.1176 -1.5147,0.2794 -1.5147 0.2794c -0.6176,0.1618 -0.9926,0.3824 -0.9926 0.3824c -0.3750,0.2206 -0.5368,0.5074 -0.5368 0.5074c -0.1618,0.2868 -0.1618,0.6250 -0.1618 0.6250ZM 526.6324,561.2500 ZM 527.8382,550.7794 h 1.2059 v 9.1176 c 0.0000,0.2941 0.1029,0.4118 0.1029 0.4118c 0.1029,0.1176 0.2353,0.1176 0.2353 0.1176h 0.1103 c 0.0000,0.0000 0.1544,-0.0294 0.1544 -0.0294l 0.1618,0.9118 c -0.1176,0.0588 -0.2794,0.0882 -0.2794 0.0882c -0.1618,0.0294 -0.4118,0.0294 -0.4118 0.0294c -0.6912,-0.0000 -0.9853,-0.4118 -0.9853 -0.4118c -0.2941,-0.4118 -0.2941,-1.2059 -0.2941 -1.2059v -9.0294 ZM 530.3824,561.2500 ZM 531.3971,559.6324 c 0.4706,0.3824 0.9632,0.6176 0.9632 0.6176c 0.4926,0.2353 1.1397,0.2353 1.1397 0.2353c 0.7059,0.0000 1.0588,-0.3235 1.0588 -0.3235c 0.3529,-0.3235 0.3529,-0.7941 0.3529 -0.7941c 0.0000,-0.2794 -0.1471,-0.4853 -0.1471 -0.4853c -0.1471,-0.2059 -0.3750,-0.3603 -0.3750 -0.3603c -0.2279,-0.1544 -0.5221,-0.2721 -0.5221 -0.2721l -0.5882,-0.2353 c -0.3824,-0.1324 -0.7647,-0.3015 -0.7647 -0.3015c -0.3824,-0.1691 -0.6838,-0.4118 -0.6838 -0.4118c -0.3015,-0.2426 -0.4926,-0.5662 -0.4926 -0.5662c -0.1912,-0.3235 -0.1912,-0.7794 -0.1912 -0.7794c 0.0000,-0.4265 0.1691,-0.8015 0.1691 -0.8015c 0.1691,-0.3750 0.4853,-0.6471 0.4853 -0.6471c 0.3162,-0.2721 0.7721,-0.4265 0.7721 -0.4265c 0.4559,-0.1544 1.0294,-0.1544 1.0294 -0.1544c 0.6765,0.0000 1.2426,0.2353 1.2426 0.2353c 0.5662,0.2353 0.9779,0.5735 0.9779 0.5735l -0.5735,0.7647 c -0.3676,-0.2794 -0.7647,-0.4559 -0.7647 -0.4559c -0.3971,-0.1765 -0.8676,-0.1765 -0.8676 -0.1765c -0.6765,-0.0000 -0.9926,0.3088 -0.9926 0.3088c -0.3162,0.3088 -0.3162,0.7206 -0.3162 0.7206c 0.0000,0.2500 0.1324,0.4338 0.1324 0.4338c 0.1324,0.1838 0.3529,0.3235 0.3529 0.3235c 0.2206,0.1397 0.5074,0.2500 0.5074 0.2500c 0.2868,0.1103 0.5956,0.2279 0.5956 0.2279c 0.3824,0.1471 0.7721,0.3088 0.7721 0.3088c 0.3897,0.1618 0.6985,0.4044 0.6985 0.4044c 0.3088,0.2426 0.5074,0.5956 0.5074 0.5956c 0.1985,0.3529 0.1985,0.8529 0.1985 0.8529c 0.0000,0.4412 -0.1691,0.8235 -0.1691 0.8235c -0.1691,0.3824 -0.5000,0.6765 -0.5000 0.6765c -0.3309,0.2941 -0.8235,0.4632 -0.8235 0.4632c -0.4926,0.1691 -1.1250,0.1691 -1.1250 0.1691c -0.7647,-0.0000 -1.4559,-0.2794 -1.4559 -0.2794c -0.6912,-0.2794 -1.2059,-0.7059 -1.2059 -0.7059ZM 536.5441,561.2500 ZM 537.2206,557.6912 c 0.0000,-0.8824 0.2721,-1.5809 0.2721 -1.5809c 0.2721,-0.6985 0.7206,-1.1838 0.7206 -1.1838c 0.4485,-0.4853 1.0221,-0.7426 1.0221 -0.7426c 0.5735,-0.2574 1.1912,-0.2574 1.1912 -0.2574c 0.6765,0.0000 1.2132,0.2353 1.2132 0.2353c 0.5368,0.2353 0.8971,0.6765 0.8971 0.6765c 0.3603,0.4412 0.5515,1.0588 0.5515 1.0588c 0.1912,0.6176 0.1912,1.3824 0.1912 1.3824c 0.0000,0.3971 -0.0441,0.6618 -0.0441 0.6618h -4.8235 c 0.0735,1.1618 0.7132,1.8382 0.7132 1.8382c 0.6397,0.6765 1.6691,0.6765 1.6691 0.6765c 0.5147,0.0000 0.9485,-0.1544 0.9485 -0.1544c 0.4338,-0.1544 0.8309,-0.4044 0.8309 -0.4044l 0.4265,0.7941 c -0.4706,0.2941 -1.0441,0.5147 -1.0441 0.5147c -0.5735,0.2206 -1.3088,0.2206 -1.3088 0.2206c -0.7206,-0.0000 -1.3456,-0.2574 -1.3456 -0.2574c -0.6250,-0.2574 -1.0882,-0.7353 -1.0882 -0.7353c -0.4632,-0.4779 -0.7279,-1.1691 -0.7279 -1.1691c -0.2647,-0.6912 -0.2647,-1.5735 -0.2647 -1.5735ZM 537.2206,557.6912 ZM 542.2206,557.1471 c 0.0000,-1.1029 -0.4632,-1.6838 -0.4632 -1.6838c -0.4632,-0.5809 -1.3015,-0.5809 -1.3015 -0.5809c -0.3824,-0.0000 -0.7279,0.1544 -0.7279 0.1544c -0.3456,0.1544 -0.6250,0.4412 -0.6250 0.4412c -0.2794,0.2868 -0.4632,0.7059 -0.4632 0.7059c -0.1838,0.4191 -0.2426,0.9632 -0.2426 0.9632h 3.8235 ZM 546.8088,561.2500 ZM 549.3529,557.5147 l -2.1618,-3.4118 h 1.3088 l 0.9559,1.5735 c 0.1618,0.2941 0.3382,0.5956 0.3382 0.5956c 0.1765,0.3015 0.3676,0.5956 0.3676 0.5956h 0.0588 c 0.1618,-0.2941 0.3235,-0.5956 0.3235 -0.5956c 0.1618,-0.3015 0.3235,-0.5956 0.3235 -0.5956l 0.8676,-1.5735 h 1.2647 l -2.1618,3.5441 l 2.3235,3.6029 h -1.3088 l -1.0441,-1.6618 l -0.3824,-0.6471 c 0.0000,0.0000 -0.3971,-0.6324 -0.3971 -0.6324h -0.0588 c -0.1912,0.3088 -0.3676,0.6250 -0.3676 0.6250c -0.1765,0.3162 -0.3529,0.6544 -0.3529 0.6544l -0.9706,1.6618 h -1.2647 ZM 556.3382,561.2500 ZM 560.8088,557.6912 v -2.7206 c 0.0000,-0.3824 0.0221,-0.9044 0.0221 -0.9044c 0.0221,-0.5221 0.0515,-0.9044 0.0515 -0.9044h -0.0588 c -0.1765,0.3382 -0.3676,0.6618 -0.3676 0.6618c -0.1912,0.3235 -0.3971,0.6618 -0.3971 0.6618l -2.1912,3.2059 h 2.9412 ZM 560.8088,557.6912 ZM 563.2353,558.6618 h -1.2794 v 2.5882 h -1.1471 v -2.5882 h -4.2206 v -0.7941 l 4.0147,-6.0000 h 1.3529 v 5.8235 h 1.2794 v 0.9706 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(255,255,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 10.0000,576.0000 v 14.0000 h 22.0000 v -14.0000 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 39.1029,585.2500 ZM 40.3088,574.7794 h 1.2059 v 9.1176 c 0.0000,0.2941 0.1029,0.4118 0.1029 0.4118c 0.1029,0.1176 0.2353,0.1176 0.2353 0.1176h 0.1103 c 0.0000,0.0000 0.1544,-0.0294 0.1544 -0.0294l 0.1618,0.9118 c -0.1176,0.0588 -0.2794,0.0882 -0.2794 0.0882c -0.1618,0.0294 -0.4118,0.0294 -0.4118 0.0294c -0.6912,-0.0000 -0.9853,-0.4118 -0.9853 -0.4118c -0.2941,-0.4118 -0.2941,-1.2059 -0.2941 -1.2059v -9.0294 ZM 42.8529,585.2500 ZM 43.7059,583.3971 c 0.0000,-1.1765 1.0515,-1.8015 1.0515 -1.8015c 1.0515,-0.6250 3.3456,-0.8750 3.3456 -0.8750c 0.0000,-0.3382 -0.0662,-0.6618 -0.0662 -0.6618c -0.0662,-0.3235 -0.2353,-0.5735 -0.2353 -0.5735c -0.1691,-0.2500 -0.4485,-0.4044 -0.4485 -0.4044c -0.2794,-0.1544 -0.7206,-0.1544 -0.7206 -0.1544c -0.6324,-0.0000 -1.1691,0.2353 -1.1691 0.2353c -0.5368,0.2353 -0.9632,0.5294 -0.9632 0.5294l -0.4853,-0.8382 c 0.5000,-0.3235 1.2206,-0.6250 1.2206 -0.6250c 0.7206,-0.3015 1.5882,-0.3015 1.5882 -0.3015c 1.3088,0.0000 1.8971,0.8015 1.8971 0.8015c 0.5882,0.8015 0.5882,2.1397 0.5882 2.1397v 4.3824 h -1.0000 l -0.1029,-0.8529 h -0.0294 c -0.5147,0.4265 -1.1103,0.7279 -1.1103 0.7279c -0.5956,0.3015 -1.2574,0.3015 -1.2574 0.3015c -0.9118,-0.0000 -1.5074,-0.5294 -1.5074 -0.5294c -0.5956,-0.5294 -0.5956,-1.5000 -0.5956 -1.5000ZM 43.7059,583.3971 ZM 44.8971,583.3088 c 0.0000,0.6176 0.3603,0.8824 0.3603 0.8824c 0.3603,0.2647 0.8897,0.2647 0.8897 0.2647c 0.5147,0.0000 0.9779,-0.2426 0.9779 -0.2426c 0.4632,-0.2426 0.9779,-0.7132 0.9779 -0.7132v -1.9853 c -0.8971,0.1176 -1.5147,0.2794 -1.5147 0.2794c -0.6176,0.1618 -0.9926,0.3824 -0.9926 0.3824c -0.3750,0.2206 -0.5368,0.5074 -0.5368 0.5074c -0.1618,0.2868 -0.1618,0.6250 -0.1618 0.6250ZM 50.3824,585.2500 ZM 51.3971,583.6324 c 0.4706,0.3824 0.9632,0.6176 0.9632 0.6176c 0.4926,0.2353 1.1397,0.2353 1.1397 0.2353c 0.7059,0.0000 1.0588,-0.3235 1.0588 -0.3235c 0.3529,-0.3235 0.3529,-0.7941 0.3529 -0.7941c 0.0000,-0.2794 -0.1471,-0.4853 -0.1471 -0.4853c -0.1471,-0.2059 -0.3750,-0.3603 -0.3750 -0.3603c -0.2279,-0.1544 -0.5221,-0.2721 -0.5221 -0.2721l -0.5882,-0.2353 c -0.3824,-0.1324 -0.7647,-0.3015 -0.7647 -0.3015c -0.3824,-0.1691 -0.6838,-0.4118 -0.6838 -0.4118c -0.3015,-0.2426 -0.4926,-0.5662 -0.4926 -0.5662c -0.1912,-0.3235 -0.1912,-0.7794 -0.1912 -0.7794c 0.0000,-0.4265 0.1691,-0.8015 0.1691 -0.8015c 0.1691,-0.3750 0.4853,-0.6471 0.4853 -0.6471c 0.3162,-0.2721 0.7721,-0.4265 0.7721 -0.4265c 0.4559,-0.1544 1.0294,-0.1544 1.0294 -0.1544c 0.6765,0.0000 1.2426,0.2353 1.2426 0.2353c 0.5662,0.2353 0.9779,0.5735 0.9779 0.5735l -0.5735,0.7647 c -0.3676,-0.2794 -0.7647,-0.4559 -0.7647 -0.4559c -0.3971,-0.1765 -0.8676,-0.1765 -0.8676 -0.1765c -0.6765,-0.0000 -0.9926,0.3088 -0.9926 0.3088c -0.3162,0.3088 -0.3162,0.7206 -0.3162 0.7206c 0.0000,0.2500 0.1324,0.4338 0.1324 0.4338c 0.1324,0.1838 0.3529,0.3235 0.3529 0.3235c 0.2206,0.1397 0.5074,0.2500 0.5074 0.2500c 0.2868,0.1103 0.5956,0.2279 0.5956 0.2279c 0.3824,0.1471 0.7721,0.3088 0.7721 0.3088c 0.3897,0.1618 0.6985,0.4044 0.6985 0.4044c 0.3088,0.2426 0.5074,0.5956 0.5074 0.5956c 0.1985,0.3529 0.1985,0.8529 0.1985 0.8529c 0.0000,0.4412 -0.1691,0.8235 -0.1691 0.8235c -0.1691,0.3824 -0.5000,0.6765 -0.5000 0.6765c -0.3309,0.2941 -0.8235,0.4632 -0.8235 0.4632c -0.4926,0.1691 -1.1250,0.1691 -1.1250 0.1691c -0.7647,-0.0000 -1.4559,-0.2794 -1.4559 -0.2794c -0.6912,-0.2794 -1.2059,-0.7059 -1.2059 -0.7059ZM 56.5441,585.2500 ZM 57.9559,579.0882 h -1.0588 v -0.9118 l 1.1176,-0.0735 l 0.1471,-2.0000 h 1.0147 v 2.0000 h 1.9265 v 0.9853 h -1.9265 v 3.9706 c 0.0000,0.6618 0.2426,1.0221 0.2426 1.0221c 0.2426,0.3603 0.8603,0.3603 0.8603 0.3603c 0.1912,0.0000 0.4118,-0.0588 0.4118 -0.0588c 0.2206,-0.0588 0.3971,-0.1324 0.3971 -0.1324l 0.2353,0.9118 c -0.2941,0.1029 -0.6397,0.1838 -0.6397 0.1838c -0.3456,0.0809 -0.6838,0.0809 -0.6838 0.0809c -0.5735,-0.0000 -0.9632,-0.1765 -0.9632 -0.1765c -0.3897,-0.1765 -0.6324,-0.4853 -0.6324 -0.4853c -0.2426,-0.3088 -0.3456,-0.7500 -0.3456 -0.7500c -0.1029,-0.4412 -0.1029,-0.9706 -0.1029 -0.9706v -3.9559 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(238,130,238)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 139.9265,576.0000 v 14.0000 h 22.0000 v -14.0000 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 169.0294,585.2500 ZM 169.8824,583.3971 c 0.0000,-1.1765 1.0515,-1.8015 1.0515 -1.8015c 1.0515,-0.6250 3.3456,-0.8750 3.3456 -0.8750c 0.0000,-0.3382 -0.0662,-0.6618 -0.0662 -0.6618c -0.0662,-0.3235 -0.2353,-0.5735 -0.2353 -0.5735c -0.1691,-0.2500 -0.4485,-0.4044 -0.4485 -0.4044c -0.2794,-0.1544 -0.7206,-0.1544 -0.7206 -0.1544c -0.6324,-0.0000 -1.1691,0.2353 -1.1691 0.2353c -0.5368,0.2353 -0.9632,0.5294 -0.9632 0.5294l -0.4853,-0.8382 c 0.5000,-0.3235 1.2206,-0.6250 1.2206 -0.6250c 0.7206,-0.3015 1.5882,-0.3015 1.5882 -0.3015c 1.3088,0.0000 1.8971,0.8015 1.8971 0.8015c 0.5882,0.8015 0.5882,2.1397 0.5882 2.1397v 4.3824 h -1.0000 l -0.1029,-0.8529 h -0.0294 c -0.5147,0.4265 -1.1103,0.7279 -1.1103 0.7279c -0.5956,0.3015 -1.2574,0.3015 -1.2574 0.3015c -0.9118,-0.0000 -1.5074,-0.5294 -1.5074 -0.5294c -0.5956,-0.5294 -0.5956,-1.5000 -0.5956 -1.5000ZM 169.8824,583.3971 ZM 171.0735,583.3088 c 0.0000,0.6176 0.3603,0.8824 0.3603 0.8824c 0.3603,0.2647 0.8897,0.2647 0.8897 0.2647c 0.5147,0.0000 0.9779,-0.2426 0.9779 -0.2426c 0.4632,-0.2426 0.9779,-0.7132 0.9779 -0.7132v -1.9853 c -0.8971,0.1176 -1.5147,0.2794 -1.5147 0.2794c -0.6176,0.1618 -0.9926,0.3824 -0.9926 0.3824c -0.3750,0.2206 -0.5368,0.5074 -0.5368 0.5074c -0.1618,0.2868 -0.1618,0.6250 -0.1618 0.6250ZM 176.5588,585.2500 ZM 178.9706,585.8529 v 2.4118 h -1.2059 v -10.1618 h 1.0000 l 0.1029,0.8235 h 0.0441 c 0.4853,-0.4118 1.0662,-0.7059 1.0662 -0.7059c 0.5809,-0.2941 1.2132,-0.2941 1.2132 -0.2941c 0.6912,0.0000 1.2206,0.2574 1.2206 0.2574c 0.5294,0.2574 0.8824,0.7353 0.8824 0.7353c 0.3529,0.4779 0.5368,1.1471 0.5368 1.1471c 0.1838,0.6691 0.1838,1.5074 0.1838 1.5074c 0.0000,0.9118 -0.2500,1.6250 -0.2500 1.6250c -0.2500,0.7132 -0.6765,1.2132 -0.6765 1.2132c -0.4265,0.5000 -0.9853,0.7574 -0.9853 0.7574c -0.5588,0.2574 -1.1765,0.2574 -1.1765 0.2574c -0.5000,-0.0000 -0.9926,-0.2206 -0.9926 -0.2206c -0.4926,-0.2206 -0.9926,-0.6029 -0.9926 -0.6029ZM 178.9706,585.8529 ZM 178.9706,583.6618 c 0.4853,0.4118 0.9412,0.5809 0.9412 0.5809c 0.4559,0.1691 0.8088,0.1691 0.8088 0.1691c 0.4412,0.0000 0.8162,-0.1985 0.8162 -0.1985c 0.3750,-0.1985 0.6471,-0.5588 0.6471 -0.5588c 0.2721,-0.3603 0.4265,-0.8897 0.4265 -0.8897c 0.1544,-0.5294 0.1544,-1.1912 0.1544 -1.1912c 0.0000,-0.5882 -0.1029,-1.0735 -0.1029 -1.0735c -0.1029,-0.4853 -0.3309,-0.8309 -0.3309 -0.8309c -0.2279,-0.3456 -0.5882,-0.5368 -0.5882 -0.5368c -0.3603,-0.1912 -0.8603,-0.1912 -0.8603 -0.1912c -0.4559,-0.0000 -0.9191,0.2500 -0.9191 0.2500c -0.4632,0.2500 -0.9926,0.7206 -0.9926 0.7206v 3.7500 ZM 184.7206,585.2500 ZM 187.1324,585.8529 v 2.4118 h -1.2059 v -10.1618 h 1.0000 l 0.1029,0.8235 h 0.0441 c 0.4853,-0.4118 1.0662,-0.7059 1.0662 -0.7059c 0.5809,-0.2941 1.2132,-0.2941 1.2132 -0.2941c 0.6912,0.0000 1.2206,0.2574 1.2206 0.2574c 0.5294,0.2574 0.8824,0.7353 0.8824 0.7353c 0.3529,0.4779 0.5368,1.1471 0.5368 1.1471c 0.1838,0.6691 0.1838,1.5074 0.1838 1.5074c 0.0000,0.9118 -0.2500,1.6250 -0.2500 1.6250c -0.2500,0.7132 -0.6765,1.2132 -0.6765 1.2132c -0.4265,0.5000 -0.9853,0.7574 -0.9853 0.7574c -0.5588,0.2574 -1.1765,0.2574 -1.1765 0.2574c -0.5000,-0.0000 -0.9926,-0.2206 -0.9926 -0.2206c -0.4926,-0.2206 -0.9926,-0.6029 -0.9926 -0.6029ZM 187.1324,585.8529 ZM 187.1324,583.6618 c 0.4853,0.4118 0.9412,0.5809 0.9412 0.5809c 0.4559,0.1691 0.8088,0.1691 0.8088 0.1691c 0.4412,0.0000 0.8162,-0.1985 0.8162 -0.1985c 0.3750,-0.1985 0.6471,-0.5588 0.6471 -0.5588c 0.2721,-0.3603 0.4265,-0.8897 0.4265 -0.8897c 0.1544,-0.5294 0.1544,-1.1912 0.1544 -1.1912c 0.0000,-0.5882 -0.1029,-1.0735 -0.1029 -1.0735c -0.1029,-0.4853 -0.3309,-0.8309 -0.3309 -0.8309c -0.2279,-0.3456 -0.5882,-0.5368 -0.5882 -0.5368c -0.3603,-0.1912 -0.8603,-0.1912 -0.8603 -0.1912c -0.4559,-0.0000 -0.9191,0.2500 -0.9191 0.2500c -0.4632,0.2500 -0.9926,0.7206 -0.9926 0.7206v 3.7500 ZM 192.8824,585.2500 ZM 193.5588,581.6912 c 0.0000,-0.8824 0.2721,-1.5809 0.2721 -1.5809c 0.2721,-0.6985 0.7206,-1.1838 0.7206 -1.1838c 0.4485,-0.4853 1.0221,-0.7426 1.0221 -0.7426c 0.5735,-0.2574 1.1912,-0.2574 1.1912 -0.2574c 0.6765,0.0000 1.2132,0.2353 1.2132 0.2353c 0.5368,0.2353 0.8971,0.6765 0.8971 0.6765c 0.3603,0.4412 0.5515,1.0588 0.5515 1.0588c 0.1912,0.6176 0.1912,1.3824 0.1912 1.3824c 0.0000,0.3971 -0.0441,0.6618 -0.0441 0.6618h -4.8235 c 0.0735,1.1618 0.7132,1.8382 0.7132 1.8382c 0.6397,0.6765 1.6691,0.6765 1.6691 0.6765c 0.5147,0.0000 0.9485,-0.1544 0.9485 -0.1544c 0.4338,-0.1544 0.8309,-0.4044 0.8309 -0.4044l 0.4265,0.7941 c -0.4706,0.2941 -1.0441,0.5147 -1.0441 0.5147c -0.5735,0.2206 -1.3088,0.2206 -1.3088 0.2206c -0.7206,-0.0000 -1.3456,-0.2574 -1.3456 -0.2574c -0.6250,-0.2574 -1.0882,-0.7353 -1.0882 -0.7353c -0.4632,-0.4779 -0.7279,-1.1691 -0.7279 -1.1691c -0.2647,-0.6912 -0.2647,-1.5735 -0.2647 -1.5735ZM 193.5588,581.6912 ZM 198.5588,581.1471 c 0.0000,-1.1029 -0.4632,-1.6838 -0.4632 -1.6838c -0.4632,-0.5809 -1.3015,-0.5809 -1.3015 -0.5809c -0.3824,-0.0000 -0.7279,0.1544 -0.7279 0.1544c -0.3456,0.1544 -0.6250,0.4412 -0.6250 0.4412c -0.2794,0.2868 -0.4632,0.7059 -0.4632 0.7059c -0.1838,0.4191 -0.2426,0.9632 -0.2426 0.9632h 3.8235 ZM 200.1765,585.2500 ZM 201.3824,578.1029 h 1.0000 l 0.1029,1.0294 h 0.0441 c 0.5147,-0.5147 1.0809,-0.8603 1.0809 -0.8603c 0.5662,-0.3456 1.3162,-0.3456 1.3162 -0.3456c 1.1324,0.0000 1.6544,0.7059 1.6544 0.7059c 0.5221,0.7059 0.5221,2.0882 0.5221 2.0882v 4.5294 h -1.2059 v -4.3676 c 0.0000,-1.0147 -0.3235,-1.4632 -0.3235 -1.4632c -0.3235,-0.4485 -1.0294,-0.4485 -1.0294 -0.4485c -0.5588,-0.0000 -0.9853,0.2794 -0.9853 0.2794c -0.4265,0.2794 -0.9706,0.8235 -0.9706 0.8235v 5.1765 h -1.2059 v -7.1471 ZM 208.2206,585.2500 ZM 208.9118,581.6912 c 0.0000,-0.8676 0.2574,-1.5662 0.2574 -1.5662c 0.2574,-0.6985 0.6838,-1.1838 0.6838 -1.1838c 0.4265,-0.4853 0.9853,-0.7500 0.9853 -0.7500c 0.5588,-0.2647 1.1765,-0.2647 1.1765 -0.2647c 0.6176,0.0000 1.0735,0.2206 1.0735 0.2206c 0.4559,0.2206 0.9265,0.6029 0.9265 0.6029l -0.0588,-1.2206 v -2.7500 h 1.2206 v 10.4706 h -1.0000 l -0.1029,-0.8382 h -0.0441 c -0.4265,0.4118 -0.9779,0.7132 -0.9779 0.7132c -0.5515,0.3015 -1.1838,0.3015 -1.1838 0.3015c -1.3529,-0.0000 -2.1544,-0.9706 -2.1544 -0.9706c -0.8015,-0.9706 -0.8015,-2.7647 -0.8015 -2.7647ZM 208.9118,581.6912 ZM 210.1618,581.6765 c 0.0000,1.2941 0.5147,2.0147 0.5147 2.0147c 0.5147,0.7206 1.4559,0.7206 1.4559 0.7206c 0.5000,0.0000 0.9412,-0.2426 0.9412 -0.2426c 0.4412,-0.2426 0.8824,-0.7426 0.8824 -0.7426v -3.7353 c -0.4559,-0.4118 -0.8750,-0.5809 -0.8750 -0.5809c -0.4191,-0.1691 -0.8603,-0.1691 -0.8603 -0.1691c -0.4265,-0.0000 -0.8015,0.1985 -0.8015 0.1985c -0.3750,0.1985 -0.6544,0.5588 -0.6544 0.5588c -0.2794,0.3603 -0.4412,0.8603 -0.4412 0.8603c -0.1618,0.5000 -0.1618,1.1176 -0.1618 1.1176ZM 216.3824,585.2500 ZM 218.9265,580.1765 h 1.6176 c 1.1324,0.0000 1.7353,-0.4632 1.7353 -0.4632c 0.6029,-0.4632 0.6029,-1.4044 0.6029 -1.4044c 0.0000,-0.9559 -0.6029,-1.3382 -0.6029 -1.3382c -0.6029,-0.3824 -1.7353,-0.3824 -1.7353 -0.3824h -1.6176 v 3.5882 ZM 218.9265,580.1765 ZM 223.0000,585.2500 l -2.3235,-4.0735 h -1.7500 v 4.0735 h -1.2206 v -9.6471 h 3.0147 c 0.7353,0.0000 1.3603,0.1397 1.3603 0.1397c 0.6250,0.1397 1.0735,0.4632 1.0735 0.4632c 0.4485,0.3235 0.6985,0.8382 0.6985 0.8382c 0.2500,0.5147 0.2500,1.2647 0.2500 1.2647c 0.0000,1.1324 -0.5882,1.8088 -0.5882 1.8088c -0.5882,0.6765 -1.5735,0.9265 -1.5735 0.9265l 2.4412,4.2059 h -1.3824 ZM 224.9265,585.2500 ZM 226.3088,574.8382 h 2.6324 v 0.6912 h -1.7206 v 11.2647 h 1.7206 v 0.6912 h -2.6324 v -12.6471 ZM 229.3824,585.2500 ZM 230.5441,584.2500 h 2.1471 v -6.9118 h -1.7059 v -0.7794 c 0.6471,-0.1176 1.1250,-0.2868 1.1250 -0.2868c 0.4779,-0.1691 0.8603,-0.4044 0.8603 -0.4044h 0.9265 v 8.3824 h 1.9412 v 1.0000 h -5.2941 v -1.0000 ZM 236.6912,585.2500 ZM 240.3529,585.4265 c -1.4265,-0.0000 -2.2206,-1.2647 -2.2206 -1.2647c -0.7941,-1.2647 -0.7941,-3.6324 -0.7941 -3.6324c 0.0000,-2.3676 0.7941,-3.6029 0.7941 -3.6029c 0.7941,-1.2353 2.2206,-1.2353 2.2206 -1.2353c 1.4118,0.0000 2.2059,1.2353 2.2059 1.2353c 0.7941,1.2353 0.7941,3.6029 0.7941 3.6029c 0.0000,2.3676 -0.7941,3.6324 -0.7941 3.6324c -0.7941,1.2647 -2.2059,1.2647 -2.2059 1.2647ZM 240.3529,585.4265 ZM 240.3529,584.4559 c 0.4118,0.0000 0.7426,-0.2279 0.7426 -0.2279c 0.3309,-0.2279 0.5735,-0.7059 0.5735 -0.7059c 0.2426,-0.4779 0.3750,-1.2206 0.3750 -1.2206c 0.1324,-0.7426 0.1324,-1.7721 0.1324 -1.7721c 0.0000,-1.0294 -0.1324,-1.7647 -0.1324 -1.7647c -0.1324,-0.7353 -0.3750,-1.1985 -0.3750 -1.1985c -0.2426,-0.4632 -0.5735,-0.6838 -0.5735 -0.6838c -0.3309,-0.2206 -0.7426,-0.2206 -0.7426 -0.2206c -0.4118,-0.0000 -0.7500,0.2206 -0.7500 0.2206c -0.3382,0.2206 -0.5809,0.6838 -0.5809 0.6838c -0.2426,0.4632 -0.3750,1.1985 -0.3750 1.1985c -0.1324,0.7353 -0.1324,1.7647 -0.1324 1.7647c 0.0000,2.0588 0.5074,2.9926 0.5074 2.9926c 0.5074,0.9338 1.3309,0.9338 1.3309 0.9338ZM 244.0000,585.2500 ZM 247.6618,585.4265 c -1.4265,-0.0000 -2.2206,-1.2647 -2.2206 -1.2647c -0.7941,-1.2647 -0.7941,-3.6324 -0.7941 -3.6324c 0.0000,-2.3676 0.7941,-3.6029 0.7941 -3.6029c 0.7941,-1.2353 2.2206,-1.2353 2.2206 -1.2353c 1.4118,0.0000 2.2059,1.2353 2.2059 1.2353c 0.7941,1.2353 0.7941,3.6029 0.7941 3.6029c 0.0000,2.3676 -0.7941,3.6324 -0.7941 3.6324c -0.7941,1.2647 -2.2059,1.2647 -2.2059 1.2647ZM 247.6618,585.4265 ZM 247.6618,584.4559 c 0.4118,0.0000 0.7426,-0.2279 0.7426 -0.2279c 0.3309,-0.2279 0.5735,-0.7059 0.5735 -0.7059c 0.2426,-0.4779 0.3750,-1.2206 0.3750 -1.2206c 0.1324,-0.7426 0.1324,-1.7721 0.1324 -1.7721c 0.0000,-1.0294 -0.1324,-1.7647 -0.1324 -1.7647c -0.1324,-0.7353 -0.3750,-1.1985 -0.3750 -1.1985c -0.2426,-0.4632 -0.5735,-0.6838 -0.5735 -0.6838c -0.3309,-0.2206 -0.7426,-0.2206 -0.7426 -0.2206c -0.4118,-0.0000 -0.7500,0.2206 -0.7500 0.2206c -0.3382,0.2206 -0.5809,0.6838 -0.5809 0.6838c -0.2426,0.4632 -0.3750,1.1985 -0.3750 1.1985c -0.1324,0.7353 -0.1324,1.7647 -0.1324 1.7647c 0.0000,2.0588 0.5074,2.9926 0.5074 2.9926c 0.5074,0.9338 1.3309,0.9338 1.3309 0.9338ZM 251.3088,585.2500 ZM 254.9706,585.4265 c -1.4265,-0.0000 -2.2206,-1.2647 -2.2206 -1.2647c -0.7941,-1.2647 -0.7941,-3.6324 -0.7941 -3.6324c 0.0000,-2.3676 0.7941,-3.6029 0.7941 -3.6029c 0.7941,-1.2353 2.2206,-1.2353 2.2206 -1.2353c 1.4118,0.0000 2.2059,1.2353 2.2059 1.2353c 0.7941,1.2353 0.7941,3.6029 0.7941 3.6029c 0.0000,2.3676 -0.7941,3.6324 -0.7941 3.6324c -0.7941,1.2647 -2.2059,1.2647 -2.2059 1.2647ZM 254.9706,585.4265 ZM 254.9706,584.4559 c 0.4118,0.0000 0.7426,-0.2279 0.7426 -0.2279c 0.3309,-0.2279 0.5735,-0.7059 0.5735 -0.7059c 0.2426,-0.4779 0.3750,-1.2206 0.3750 -1.2206c 0.1324,-0.7426 0.1324,-1.7721 0.1324 -1.7721c 0.0000,-1.0294 -0.1324,-1.7647 -0.1324 -1.7647c -0.1324,-0.7353 -0.3750,-1.1985 -0.3750 -1.1985c -0.2426,-0.4632 -0.5735,-0.6838 -0.5735 -0.6838c -0.3309,-0.2206 -0.7426,-0.2206 -0.7426 -0.2206c -0.4118,-0.0000 -0.7500,0.2206 -0.7500 0.2206c -0.3382,0.2206 -0.5809,0.6838 -0.5809 0.6838c -0.2426,0.4632 -0.3750,1.1985 -0.3750 1.1985c -0.1324,0.7353 -0.1324,1.7647 -0.1324 1.7647c 0.0000,2.0588 0.5074,2.9926 0.5074 2.9926c 0.5074,0.9338 1.3309,0.9338 1.3309 0.9338ZM 258.6176,585.2500 ZM 262.2794,585.4265 c -1.4265,-0.0000 -2.2206,-1.2647 -2.2206 -1.2647c -0.7941,-1.2647 -0.7941,-3.6324 -0.7941 -3.6324c 0.0000,-2.3676 0.7941,-3.6029 0.7941 -3.6029c 0.7941,-1.2353 2.2206,-1.2353 2.2206 -1.2353c 1.4118,0.0000 2.2059,1.2353 2.2059 1.2353c 0.7941,1.2353 0.7941,3.6029 0.7941 3.6029c 0.0000,2.3676 -0.7941,3.6324 -0.7941 3.6324c -0.7941,1.2647 -2.2059,1.2647 -2.2059 1.2647ZM 262.2794,585.4265 ZM 262.2794,584.4559 c 0.4118,0.0000 0.7426,-0.2279 0.7426 -0.2279c 0.3309,-0.2279 0.5735,-0.7059 0.5735 -0.7059c 0.2426,-0.4779 0.3750,-1.2206 0.3750 -1.2206c 0.1324,-0.7426 0.1324,-1.7721 0.1324 -1.7721c 0.0000,-1.0294 -0.1324,-1.7647 -0.1324 -1.7647c -0.1324,-0.7353 -0.3750,-1.1985 -0.3750 -1.1985c -0.2426,-0.4632 -0.5735,-0.6838 -0.5735 -0.6838c -0.3309,-0.2206 -0.7426,-0.2206 -0.7426 -0.2206c -0.4118,-0.0000 -0.7500,0.2206 -0.7500 0.2206c -0.3382,0.2206 -0.5809,0.6838 -0.5809 0.6838c -0.2426,0.4632 -0.3750,1.1985 -0.3750 1.1985c -0.1324,0.7353 -0.1324,1.7647 -0.1324 1.7647c 0.0000,2.0588 0.5074,2.9926 0.5074 2.9926c 0.5074,0.9338 1.3309,0.9338 1.3309 0.9338ZM 265.9265,585.2500 ZM 268.0882,586.7941 v -11.2647 h -1.7059 v -0.6912 h 2.6176 v 12.6471 h -2.6176 v -0.6912 h 1.7059 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,255)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 288.1471,576.0000 v 14.0000 h 22.0000 v -14.0000 Z"/></g><g stroke-linejoin="bevel" stroke-opacity="0.0" fill-opacity="1.0" stroke="rgb(0,0,0)" stroke-width="0.0" fill="rgb(0,0,0)" stroke-linecap="butt" stroke-miterlimit="10.0"><path d="M 317.2500,585.2500 ZM 317.9265,581.6912 c 0.0000,-0.8971 0.2794,-1.5956 0.2794 -1.5956c 0.2794,-0.6985 0.7500,-1.1838 0.7500 -1.1838c 0.4706,-0.4853 1.0956,-0.7353 1.0956 -0.7353c 0.6250,-0.2500 1.3162,-0.2500 1.3162 -0.2500c 0.7059,0.0000 1.2132,0.2574 1.2132 0.2574c 0.5074,0.2574 0.8750,0.5956 0.8750 0.5956l -0.6029,0.7794 c -0.3235,-0.2794 -0.6691,-0.4559 -0.6691 -0.4559c -0.3456,-0.1765 -0.7721,-0.1765 -0.7721 -0.1765c -0.4853,-0.0000 -0.8971,0.1985 -0.8971 0.1985c -0.4118,0.1985 -0.7059,0.5662 -0.7059 0.5662c -0.2941,0.3676 -0.4632,0.8750 -0.4632 0.8750c -0.1691,0.5074 -0.1691,1.1250 -0.1691 1.1250c 0.0000,0.6176 0.1618,1.1176 0.1618 1.1176c 0.1618,0.5000 0.4485,0.8603 0.4485 0.8603c 0.2868,0.3603 0.6985,0.5588 0.6985 0.5588c 0.4118,0.1985 0.8971,0.1985 0.8971 0.1985c 0.5147,0.0000 0.9338,-0.2132 0.9338 -0.2132c 0.4191,-0.2132 0.7426,-0.5074 0.7426 -0.5074l 0.5441,0.7941 c -0.4853,0.4265 -1.0809,0.6765 -1.0809 0.6765c -0.5956,0.2500 -1.2426,0.2500 -1.2426 0.2500c -0.7059,-0.0000 -1.3235,-0.2500 -1.3235 -0.2500c -0.6176,-0.2500 -1.0662,-0.7279 -1.0662 -0.7279c -0.4485,-0.4779 -0.7059,-1.1765 -0.7059 -1.1765c -0.2574,-0.6985 -0.2574,-1.5809 -0.2574 -1.5809ZM 323.6471,585.2500 ZM 324.3235,581.6912 c 0.0000,-0.8971 0.2721,-1.5956 0.2721 -1.5956c 0.2721,-0.6985 0.7279,-1.1838 0.7279 -1.1838c 0.4559,-0.4853 1.0515,-0.7353 1.0515 -0.7353c 0.5956,-0.2500 1.2574,-0.2500 1.2574 -0.2500c 0.6618,0.0000 1.2574,0.2500 1.2574 0.2500c 0.5956,0.2500 1.0515,0.7353 1.0515 0.7353c 0.4559,0.4853 0.7279,1.1838 0.7279 1.1838c 0.2721,0.6985 0.2721,1.5956 0.2721 1.5956c 0.0000,0.8824 -0.2721,1.5809 -0.2721 1.5809c -0.2721,0.6985 -0.7279,1.1765 -0.7279 1.1765c -0.4559,0.4779 -1.0515,0.7279 -1.0515 0.7279c -0.5956,0.2500 -1.2574,0.2500 -1.2574 0.2500c -0.6618,-0.0000 -1.2574,-0.2500 -1.2574 -0.2500c -0.5956,-0.2500 -1.0515,-0.7279 -1.0515 -0.7279c -0.4559,-0.4779 -0.7279,-1.1765 -0.7279 -1.1765c -0.2721,-0.6985 -0.2721,-1.5809 -0.2721 -1.5809ZM 324.3235,581.6912 ZM 325.5735,581.6912 c 0.0000,0.6176 0.1471,1.1176 0.1471 1.1176c 0.1471,0.5000 0.4191,0.8603 0.4191 0.8603c 0.2721,0.3603 0.6544,0.5588 0.6544 0.5588c 0.3824,0.1985 0.8382,0.1985 0.8382 0.1985c 0.4559,0.0000 0.8382,-0.1985 0.8382 -0.1985c 0.3824,-0.1985 0.6544,-0.5588 0.6544 -0.5588c 0.2721,-0.3603 0.4191,-0.8603 0.4191 -0.8603c 0.1471,-0.5000 0.1471,-1.1176 0.1471 -1.1176c 0.0000,-0.6176 -0.1471,-1.1250 -0.1471 -1.1250c -0.1471,-0.5074 -0.4191,-0.8750 -0.4191 -0.8750c -0.2721,-0.3676 -0.6544,-0.5662 -0.6544 -0.5662c -0.3824,-0.1985 -0.8382,-0.1985 -0.8382 -0.1985c -0.4559,-0.0000 -0.8382,0.1985 -0.8382 0.1985c -0.3824,0.1985 -0.6544,0.5662 -0.6544 0.5662c -0.2721,0.3676 -0.4191,0.8750 -0.4191 0.8750c -0.1471,0.5074 -0.1471,1.1250 -0.1471 1.1250ZM 331.6176,585.2500 ZM 332.8235,578.1029 h 1.0000 l 0.1029,1.0294 h 0.0441 c 0.5147,-0.5147 1.0809,-0.8603 1.0809 -0.8603c 0.5662,-0.3456 1.3162,-0.3456 1.3162 -0.3456c 1.1324,0.0000 1.6544,0.7059 1.6544 0.7059c 0.5221,0.7059 0.5221,2.0882 0.5221 2.0882v 4.5294 h -1.2059 v -4.3676 c 0.0000,-1.0147 -0.3235,-1.4632 -0.3235 -1.4632c -0.3235,-0.4485 -1.0294,-0.4485 -1.0294 -0.4485c -0.5588,-0.0000 -0.9853,0.2794 -0.9853 0.2794c -0.4265,0.2794 -0.9706,0.8235 -0.9706 0.8235v 5.1765 h -1.2059 v -7.1471 ZM 339.6618,585.2500 ZM 340.3382,581.6912 c 0.0000,-0.8971 0.2794,-1.5956 0.2794 -1.5956c 0.2794,-0.6985 0.7500,-1.1838 0.7500 -1.1838c 0.4706,-0.4853 1.0956,-0.7353 1.0956 -0.7353c 0.6250,-0.2500 1.3162,-0.2500 1.3162 -0.2500c 0.7059,0.0000 1.2132,0.2574 1.2132 0.2574c 0.5074,0.2574 0.8750,0.5956 0.8750 0.5956l -0.6029,0.7794 c -0.3235,-0.2794 -0.6691,-0.4559 -0.6691 -0.4559c -0.3456,-0.1765 -0.7721,-0.1765 -0.7721 -0.1765c -0.4853,-0.0000 -0.8971,0.1985 -0.8971 0.1985c -0.4118,0.1985 -0.7059,0.5662 -0.7059 0.5662c -0.2941,0.3676 -0.4632,0.8750 -0.4632 0.8750c -0.1691,0.5074 -0.1691,1.1250 -0.1691 1.1250c 0.0000,0.6176 0.1618,1.1176 0.1618 1.1176c 0.1618,0.5000 0.4485,0.8603 0.4485 0.8603c 0.2868,0.3603 0.6985,0.5588 0.6985 0.5588c 0.4118,0.1985 0.8971,0.1985 0.8971 0.1985c 0.5147,0.0000 0.9338,-0.2132 0.9338 -0.2132c 0.4191,-0.2132 0.7426,-0.5074 0.7426 -0.5074l 0.5441,0.7941 c -0.4853,0.4265 -1.0809,0.6765 -1.0809 0.6765c -0.5956,0.2500 -1.2426,0.2500 -1.2426 0.2500c -0.7059,-0.0000 -1.3235,-0.2500 -1.3235 -0.2500c -0.6176,-0.2500 -1.0662,-0.7279 -1.0662 -0.7279c -0.4485,-0.4779 -0.7059,-1.1765 -0.7059 -1.1765c -0.2574,-0.6985 -0.2574,-1.5809 -0.2574 -1.5809ZM 346.2206,585.2500 ZM 347.0735,583.3971 c 0.0000,-1.1765 1.0515,-1.8015 1.0515 -1.8015c 1.0515,-0.6250 3.3456,-0.8750 3.3456 -0.8750c 0.0000,-0.3382 -0.0662,-0.6618 -0.0662 -0.6618c -0.0662,-0.3235 -0.2353,-0.5735 -0.2353 -0.5735c -0.1691,-0.2500 -0.4485,-0.4044 -0.4485 -0.4044c -0.2794,-0.1544 -0.7206,-0.1544 -0.7206 -0.1544c -0.6324,-0.0000 -1.1691,0.2353 -1.1691 0.2353c -0.5368,0.2353 -0.9632,0.5294 -0.9632 0.5294l -0.4853,-0.8382 c 0.5000,-0.3235 1.2206,-0.6250 1.2206 -0.6250c 0.7206,-0.3015 1.5882,-0.3015 1.5882 -0.3015c 1.3088,0.0000 1.8971,0.8015 1.8971 0.8015c 0.5882,0.8015 0.5882,2.1397 0.5882 2.1397v 4.3824 h -1.0000 l -0.1029,-0.8529 h -0.0294 c -0.5147,0.4265 -1.1103,0.7279 -1.1103 0.7279c -0.5956,0.3015 -1.2574,0.3015 -1.2574 0.3015c -0.9118,-0.0000 -1.5074,-0.5294 -1.5074 -0.5294c -0.5956,-0.5294 -0.5956,-1.5000 -0.5956 -1.5000ZM 347.0735,583.3971 ZM 348.2647,583.3088 c 0.0000,0.6176 0.3603,0.8824 0.3603 0.8824c 0.3603,0.2647 0.8897,0.2647 0.8897 0.2647c 0.5147,0.0000 0.9779,-0.2426 0.9779 -0.2426c 0.4632,-0.2426 0.9779,-0.7132 0.9779 -0.7132v -1.9853 c -0.8971,0.1176 -1.5147,0.2794 -1.5147 0.2794c -0.6176,0.1618 -0.9926,0.3824 -0.9926 0.3824c -0.3750,0.2206 -0.5368,0.5074 -0.5368 0.5074c -0.1618,0.2868 -0.1618,0.6250 -0.1618 0.6250ZM 353.7500,585.2500 ZM 355.1618,579.0882 h -1.0588 v -0.9118 l 1.1176,-0.0735 l 0.1471,-2.0000 h 1.0147 v 2.0000 h 1.9265 v 0.9853 h -1.9265 v 3.9706 c 0.0000,0.6618 0.2426,1.0221 0.2426 1.0221c 0.2426,0.3603 0.8603,0.3603 0.8603 0.3603c 0.1912,0.0000 0.4118,-0.0588 0.4118 -0.0588c 0.2206,-0.0588 0.3971,-0.1324 0.3971 -0.1324l 0.2353,0.9118 c -0.2941,0.1029 -0.6397,0.1838 -0.6397 0.1838c -0.3456,0.0809 -0.6838,0.0809 -0.6838 0.0809c -0.5735,-0.0000 -0.9632,-0.1765 -0.9632 -0.1765c -0.3897,-0.1765 -0.6324,-0.4853 -0.6324 -0.4853c -0.2426,-0.3088 -0.3456,-0.7500 -0.3456 -0.7500c -0.1029,-0.4412 -0.1029,-0.9706 -0.1029 -0.9706v -3.9559 ZM 358.7206,585.2500 ZM 360.0441,575.6029 h 1.4412 l 1.8676,5.1765 l 0.7059,1.9706 h 0.0588 l 0.6765,-1.9706 l 1.8529,-5.1765 h 1.4412 v 9.6471 h -1.1618 v -5.3088 c 0.0000,-0.6471 0.0515,-1.4265 0.0515 -1.4265c 0.0515,-0.7794 0.1103,-1.4265 0.1103 -1.4265h -0.0588 l -0.7794,2.1471 l -1.8529,5.0441 h -0.6912 l -1.8676,-5.0441 l -0.7647,-2.1471 h -0.0588 c 0.0441,0.6471 0.1029,1.4265 0.1029 1.4265c 0.0588,0.7794 0.0588,1.4265 0.0588 1.4265v 5.3088 h -1.1324 v -9.6471 ZM 369.4118,585.2500 ZM 370.2647,583.3971 c 0.0000,-1.1765 1.0515,-1.8015 1.0515 -1.8015c 1.0515,-0.6250 3.3456,-0.8750 3.3456 -0.8750c 0.0000,-0.3382 -0.0662,-0.6618 -0.0662 -0.6618c -0.0662,-0.3235 -0.2353,-0.5735 -0.2353 -0.5735c -0.1691,-0.2500 -0.4485,-0.4044 -0.4485 -0.4044c -0.2794,-0.1544 -0.7206,-0.1544 -0.7206 -0.1544c -0.6324,-0.0000 -1.1691,0.2353 -1.1691 0.2353c -0.5368,0.2353 -0.9632,0.5294 -0.9632 0.5294l -0.4853,-0.8382 c 0.5000,-0.3235 1.2206,-0.6250 1.2206 -0.6250c 0.7206,-0.3015 1.5882,-0.3015 1.5882 -0.3015c 1.3088,0.0000 1.8971,0.8015 1.8971 0.8015c 0.5882,0.8015 0.5882,2.1397 0.5882 2.1397v 4.3824 h -1.0000 l -0.1029,-0.8529 h -0.0294 c -0.5147,0.4265 -1.1103,0.7279 -1.1103 0.7279c -0.5956,0.3015 -1.2574,0.3015 -1.2574 0.3015c -0.9118,-0.0000 -1.5074,-0.5294 -1.5074 -0.5294c -0.5956,-0.5294 -0.5956,-1.5000 -0.5956 -1.5000ZM 370.2647,583.3971 ZM 371.4559,583.3088 c 0.0000,0.6176 0.3603,0.8824 0.3603 0.8824c 0.3603,0.2647 0.8897,0.2647 0.8897 0.2647c 0.5147,0.0000 0.9779,-0.2426 0.9779 -0.2426c 0.4632,-0.2426 0.9779,-0.7132 0.9779 -0.7132v -1.9853 c -0.8971,0.1176 -1.5147,0.2794 -1.5147 0.2794c -0.6176,0.1618 -0.9926,0.3824 -0.9926 0.3824c -0.3750,0.2206 -0.5368,0.5074 -0.5368 0.5074c -0.1618,0.2868 -0.1618,0.6250 -0.1618 0.6250ZM 376.9412,585.2500 ZM 379.3529,585.8529 v 2.4118 h -1.2059 v -10.1618 h 1.0000 l 0.1029,0.8235 h 0.0441 c 0.4853,-0.4118 1.0662,-0.7059 1.0662 -0.7059c 0.5809,-0.2941 1.2132,-0.2941 1.2132 -0.2941c 0.6912,0.0000 1.2206,0.2574 1.2206 0.2574c 0.5294,0.2574 0.8824,0.7353 0.8824 0.7353c 0.3529,0.4779 0.5368,1.1471 0.5368 1.1471c 0.1838,0.6691 0.1838,1.5074 0.1838 1.5074c 0.0000,0.9118 -0.2500,1.6250 -0.2500 1.6250c -0.2500,0.7132 -0.6765,1.2132 -0.6765 1.2132c -0.4265,0.5000 -0.9853,0.7574 -0.9853 0.7574c -0.5588,0.2574 -1.1765,0.2574 -1.1765 0.2574c -0.5000,-0.0000 -0.9926,-0.2206 -0.9926 -0.2206c -0.4926,-0.2206 -0.9926,-0.6029 -0.9926 -0.6029ZM 379.3529,585.8529 ZM 379.3529,583.6618 c 0.4853,0.4118 0.9412,0.5809 0.9412 0.5809c 0.4559,0.1691 0.8088,0.1691 0.8088 0.1691c 0.4412,0.0000 0.8162,-0.1985 0.8162 -0.1985c 0.3750,-0.1985 0.6471,-0.5588 0.6471 -0.5588c 0.2721,-0.3603 0.4265,-0.8897 0.4265 -0.8897c 0.1544,-0.5294 0.1544,-1.1912 0.1544 -1.1912c 0.0000,-0.5882 -0.1029,-1.0735 -0.1029 -1.0735c -0.1029,-0.4853 -0.3309,-0.8309 -0.3309 -0.8309c -0.2279,-0.3456 -0.5882,-0.5368 -0.5882 -0.5368c -0.3603,-0.1912 -0.8603,-0.1912 -0.8603 -0.1912c -0.4559,-0.0000 -0.9191,0.2500 -0.9191 0.2500c -0.4632,0.2500 -0.9926,0.7206 -0.9926 0.7206v 3.7500 Z"/></g></svg>
docs/streamly-vs-lists.md view
@@ -206,10 +206,10 @@ main = runStream func ``` -To run it concurrently, just run the same code with `asyncly` combinator:+To run it concurrently, just run the same code with `fromAsync` combinator:  ```haskell-main = runStream $ asyncly func+main = runStream $ fromAsync func ```  The `mapM` combinator now maps the monadic delay action concurrently on all the@@ -217,7 +217,7 @@ the delay actions run concurrently. Alternatively we can write:  ```-func = S.mapM $ asyncly $ S.replicateM (threadDelay 1000000 >> print 1)+func = S.mapM $ fromAsync $ S.replicateM (threadDelay 1000000 >> print 1) main = runStream func ``` @@ -237,7 +237,7 @@ shown in a sorted order, from list's worst performing ones on the left to its best ones on the right. -![Streamly vs Lists (time) comparison](../charts-0/streamly-vs-list-time.svg)+![Streamly vs Lists (time) comparison](streamly-vs-list-time.svg)  ## Why use streams instead of lists?
− docs/transformers.md 
@@ -1,32 +0,0 @@-## Using Monad Transformers--Common monad transformers can be used with streamly serial streams, without any-issues. `ReaderT` can be used with concurrent streams as well without any-issues.--The semantics of monads other than `ReaderT` with concurrent streams are-not yet finalized and will change in future, therefore as of now they are not-recommended to be used with concurrent streams.--## Ordering of Monad Transformers--In most cases it is a good idea to keep streamly as the top level monad.--## State Sharing-### Serial Applications--Read only global state can always be shared using the `Reader` monad.-Read-write global state can be shared either using an `IORef` in the `Reader`-monad or using the `State` monad.--See `AcidRain.hs` example for a usage of `StateT` in the serially executing-portion of the program.--### Concurrent Applications--The current recommended method for sharing modifiable global state across-concurrent tasks is to put the shared state inside an `IORef` in a `Reader`-monad or just share the `IORef` by passing it to the required functions. The-`IORef` can be updated atomically using `atomicModifyIORef`.--The `CirclingSquare.hs` example shares an `IORef` across parallel tasks.
+ docs/unified-abstractions.md view
@@ -0,0 +1,272 @@+# Unified Functional Abstractions in Streamly++The goal of Streamly is to provide unified abstractions with high+performance.  The basic abstractions in Streamly are streams and arrays+and yet it provides the functionality of many packages in the Haskell+ecosystem.++This document discusses the related packages in the Haskell ecosystem+and how streamly unifies, overlaps, or compares with those. We provide+simple code snippets for illustrations, for a better overview of the+library please see the [Streamly Quick Overview](../README.md) document.++## Existing Haskell Libraries++In the Haskell ecosystem effectful streaming functionality is provided+by several streaming libraries e.g. `streaming`, nested looping by list+transformers e.g. `list-t`, interleaved scheduling by `logict`,+concurrency by `async`, time-domain programming by FRP libraries like+`Yampa` and `reflex`, and array functionality by `bytestring`, `text`,+`vector`, and `arrays` packages.++For basic programming needs, one needs to discover and learn all of+these or roll something on their own. These libraries have evolved+independently for specialized needs. They are not designed with a big+picture in mind to eliminate duplicate functionality and to come up with+the most optimal abstractions on the whole. For example, there is no+reason why streaming, list-t, and logict cannot be provided by the same+implementation. Concurrency and reactive programming also naturally fit+with the streaming model and can be unified. `Bytestring`, `text`,+`vector`, and `arrays` all provide the same functionality which can+be unified under one umbrella of arrays. Moreover, there are many+of flavors some of these packages like lazy bytestring, Char8 bytestrings,+lazy text which can be eliminated by using streams instead.++On the performance side, existing streaming libraries lack stream fusion+leading to a function call overhead in each iteration of the loop,+therefore, providing orders of magnitude lower performance in tight+loops compared to writing a monolithic loop by hand. Similarly, `logict`+shows quadratic performance characteristics in some basic use cases.+These problems are solved by Streamly.++## How Streamly Unifies them?++Streamly unifies streaming, nested looping, scheduling, concurrency,+time, and array functionality using two basic constructs, namely streams+and arrays. Streams provide efficient, immutable, composable serial+processing capabilities for in-flight data, whereas arrays provide+efficient storage, mutability, and random access for data at rest.++Streamly builds all the functionality on top of these two building+blocks. It takes a big picture view of programming in general and+provides well-integrated APIs with the same look and feel. Moreover,+performance is a primary goal of streamly, all the functionality is+built for performance comparable to C.++Streamly streams are like lists and provide non-determinism just like+lists.  Streamly also adds asynchronicity and concurrency to+streaming composition.  This seemingly simple change unifies several+disparate abstractions into one powerful, concise, and elegant+abstraction.  A wide variety of programming problems can be solved+elegantly with this abstraction. In particular, it unifies three major+programming domains namely non-deterministic (logic) programming,+concurrent programming, and functional Reactive programming.++## Streaming++The basic, bare-bones functionality of Streamly is processing streams of+data.  In simple terms, stream processing is the functional equivalent+of loops in imperative programming.++Like Haskell lists, `vector`, and `streaming` packages, Streamly composes+streams of data rather than stream processor functions as in other+streaming libraries like `pipes` and `machines`. This makes the types+and API very simple and is very similar to Haskell lists which is+familiar to everyone. The fundamental difference is that Streamly adds+concurrency support but the good thing is that it does not change the+API.++This simple console echo program shows the simplicity of Streamly API+and its similarity with the list API:++```haskell+echo =+      Stream.repeatM getLine+    & Stream.mapM putStrLn+    & Stream.drain+```++Streamly uses dual representation for streams. On top it uses Scott+encoded CPS streams which provide a way to incrementally construct and+append streams efficiently. Under the good, for tight loops, Streamly+uses a vector-like stream representation which is amenable to+`case-of-case` and `SPEC constructor` optimizations by GHC resulting in+low-level code having performance comparable to C.++To further understand the similarity with list API, please see [Streamly vs.+lists](streamly-vs-lists.md).+For comparison of Streamly performance with other libraries see+[streaming benchmarks](https://github.com/composewell/streaming-benchmarks).++## Non-determinism++Roughly speaking, non-determinism is a fancy term that functional+programmers use for what you call nested loops in imperative+programming. List transformers are the basic implementations for+non-determinism.++The stream monad in Streamly is a list-transformer with behavior similar+to the list monad. It provides the functionality provided by `list-t` or+`logict` packages for free.  Here is an example of nested looping using+the serial stream monad:++``` haskell+import qualified Streamly.Prelude as S++loops = do+    x <- Stream.fromFoldable [1,2]+    y <- Stream.fromFoldable [3,4]+    Stream.fromEffect $ print (x, y)+```++Moreover, the list transformer in Streamly can be concurrent. The Scott+encoding of streams also avoids the quadratic performance issue of+`logict`.++## Scheduling Behaviors++When we execute a stream or combine two streams, the actions in the+stream need to be scheduled for execution.  Existing streaming libraries+are limited to just one form of scheduling of actions in the stream+which is serial execution. Streamly provides several ways of scheduling+the actions in the stream. The good thing is the API does not change, we+just need to use a combinator or a different type to change the+scheduling behavior.++In a single stream, the actions in the stream can be executed+concurrently with different concurrent scheduling behaviors.  Two or+more streams can be combined in several ways. For example, the actions+from two streams being combined can be interleaved.  Similarly, streams+can be interleaved with concurrent execution providing a fair,+concurrent round-robin scheduling of streams.++The monad instance provides a convenient way to combine streams in+different ways. It is just non-determinism with different flavors of+scheduling behavior.  The example from the previous section can be run+with interleaved scheduling behavior as follows, without changing the+code at all:++```haskell+main = Stream.drain $ Stream.fromWserial loops+```++Scheduling is fundamental to expressing many common programming problems+in an idiomatic functional manner.  One example application of+interleaving is breadth-first search mechanism for logic programming.+Please see [mini kanren implementation using streamly](https://github.com/composewell/ds-kanren).++## Declarative Concurrency++The same combinators that are used for serial streams e.g. 'unfoldrM',+'replicateM', 'repeatM' work concurrently when used at the appropriate type.+It allows concurrent programs to be written declaratively and composed+idiomatically. They are not much different than serial programs.  See+[Streamly vs async](streamly-vs-async.md)+for a comparison of Streamly with the `async` package.++Streamly provides concurrent scheduling and looping similar to to+[OpenMP](https://en.wikipedia.org/wiki/OpenMP) and+[Cilk](https://en.wikipedia.org/wiki/Cilk) but with a more declarative+style.  The list transformer example can be run with concurrent+execution of loop iterations as follows, without changing the code at+all:++```haskell+main = Stream.drain $ Stream.fromAhead loops+```++And interleaving with concurrent execution of the loop iterations can be+written like this:++```haskell+main = Stream.drain $ Stream.fromWAsync loops+```++All this comes with no change in the streaming APIs.++## Reactive Programming++The combination of non-determinism, concurrency, and streaming makes+Streamly a strong reactive programming library as well. Reactive+programming fundamentally deals with streams of events that can be+processed concurrently. The+[https://github.com/composewell/streamly-examples/tree/master/AcidRain.hs](Acid+Rain) and [Circling+Square](https://github.com/composewell/streamly-examples/tree/master/CirclingSquare.hs)+examples demonstrate the basic reactive capability of Streamly.++In core concepts, Streamly is strikingly similar to `dunai`.  `dunai` was+designed from a FRP perspective and Streamly was originally designed+from a concurrency perspective. However, both have similarities at the+core.++## Arrays++Streamly provides immutable, mutable, pinned, unpinned, boxed, and+unboxed arrays with streaming interfaces.  The combination of efficient+streaming and polymorphic arrays lets it express the functionality of+`bytestring` and `text` packages as special cases of arrays with no loss+of performance. Since we can use explicit streaming, the lazy versions+of `bytestring` and `text` are not required.++## Conclusion++Streamly, provides effectful streams, with a simple API, almost+identical to standard lists, and in-built support for concurrency.+By using stream-style combinators on stream composition, streams can be+generated, merged, chained, mapped, zipped, and consumed concurrently –+providing a generalized high-level programming framework unifying+streaming and concurrency. Controlled concurrency allows even infinite+streams to be evaluated concurrently.  Concurrency is auto-scaled based+on feedback from the stream consumer.++Streamly is a programmer-first library, designed to be useful and+friendly to programmers for solving practical problems in a simple and+concise manner. Some key points that Streamly stresses are:++* _Simplicity_: Simple list like streaming API, if you know how to use lists+  then you know how to use Streamly. This library is built with simplicity+  and ease of use as a design goal.+* _Concurrency_: Simple, powerful, and scalable concurrency.  Concurrency is+  built-in, and not intrusive, concurrent programs are written exactly +  as non-concurrent ones.+* _Generality_: Unifies functionality provided by several disparate packages+  (streaming, concurrency, list transformer, logic programming, reactive+  programming) in a concise API.+* _Performance_: Streamly is designed for high performance. It employs stream+  fusion optimizations for the best possible performance. Serial performance is+  equivalent to the venerable `vector` library in most cases and even better+  in some cases.  Concurrent performance is unbeatable.  See+  [streaming-benchmarks](https://github.com/composewell/streaming-benchmarks)+  for a comparison of popular streaming libraries on micro-benchmarks.++## Appendix++Streamly unifies the functionality overlapping the following Haskell+libraries:++### Streaming++* [vector](https://hackage.haskell.org/package/vector)+* [streaming](https://hackage.haskell.org/package/streaming)+* [pipes](https://hackage.haskell.org/package/pipes)+* [conduit](https://hackage.haskell.org/package/conduit)++### List Transformers and Logic Programming++* [pipes](https://hackage.haskell.org/package/pipes)+* [list-t](https://hackage.haskell.org/package/list-t)+* [logict](https://hackage.haskell.org/package/logict)++### Concurrency++* [async](https://hackage.haskell.org/package/async)++### Reactive Programming++* [Yampa](https://hackage.haskell.org/package/Yampa)+* [reflex](https://hackage.haskell.org/package/reflex)++### Arrays++* [vector](https://hackage.haskell.org/package/vector)
− examples/AcidRain.hs 
@@ -1,58 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}---- Copyright   : (c) 2017 Harendra Kumar---               (c) 2013, 2014 Gabriel Gonzalez------ This example is adapted from Gabriel Gonzalez's pipes-concurrency package.--- https://hackage.haskell.org/package/pipes-concurrency-2.0.8/docs/Pipes-Concurrent-Tutorial.html--import Streamly-import Streamly.Prelude as S-import Control.Monad (void)-import Control.Monad.IO.Class (MonadIO(liftIO))-import Control.Monad.State (MonadState, get, modify, runStateT)--data Event = Quit | Harm Int | Heal Int deriving (Show)--userAction :: MonadAsync m => SerialT m Event-userAction = S.repeatM $ liftIO askUser-    where-    askUser = do-        command <- getLine-        case command of-            "potion" -> return (Heal 10)-            "harm"   -> return (Harm 10)-            "quit"   -> return Quit-            _        -> putStrLn "Type potion or harm or quit" >> askUser--acidRain :: MonadAsync m => SerialT m Event-acidRain = asyncly $ constRate 1 $ S.repeatM $ liftIO $ return $ Harm 1--data Result = Check | Done--runEvents :: (MonadAsync m, MonadState Int m) => SerialT m Result-runEvents = do-    event <- userAction `parallel` acidRain-    case event of-        Harm n -> modify (\h -> h - n) >> return Check-        Heal n -> modify (\h -> h + n) >> return Check-        Quit -> return Done--data Status = Alive | GameOver deriving Eq--getStatus :: (MonadAsync m, MonadState Int m) => Result -> m Status-getStatus result =-    case result of-        Done  -> liftIO $ putStrLn "You quit!" >> return GameOver-        Check -> do-            h <- get-            liftIO $ if (h <= 0)-                     then putStrLn "You die!" >> return GameOver-                     else putStrLn ("Health = " <> show h) >> return Alive--main :: IO ()-main = do-    putStrLn "Your health is deteriorating due to acid rain,\-             \ type \"potion\" or \"quit\""-    let runGame = S.drainWhile (== Alive) $ S.mapM getStatus runEvents-    void $ runStateT runGame 60
− examples/CamelCase.hs 
@@ -1,33 +0,0 @@--- ghc -O2  -fspec-constr-recursive=10 -fmax-worker-args=16--- Convert the input file to camel case and write to stdout--import Data.Maybe (fromJust, isJust)-import System.Environment (getArgs)-import System.IO (Handle, IOMode(..), openFile, stdout)--import qualified Streamly.Prelude as S-import qualified Streamly.Internal.FileSystem.Handle as FH--camelCase :: Handle -> Handle -> IO ()-camelCase src dst =-      FH.fromBytes dst-    $ S.map fromJust-    $ S.filter isJust-    $ S.map snd-    $ S.scanl' step (True, Nothing)-    $ FH.toBytes src--    where--    step (wasSpace, _) x =-        if x == 0x0a || x >= 0x41 && x <= 0x5a-        then (False, Just x)-        else if x >= 0x61 && x <= 0x7a-             then (False, Just $ if wasSpace then x - 32 else x)-             else (True, Nothing)--main :: IO ()-main = do-    name <- fmap head getArgs-    src <- openFile name ReadMode-    camelCase src stdout
− examples/CirclingSquare.hs 
@@ -1,83 +0,0 @@--- Adapted from the Yampa package.--- Displays a square moving in a circle. To move the position drag it with the--- mouse.------ Requires the SDL package, assuming streamly has already been built, you can--- compile it like this:--- stack ghc --package SDL CirclingSquare.hs--import Data.IORef-import Graphics.UI.SDL as SDL-import Streamly-import Streamly.Prelude as S----------------------------------------------------------------------------------- SDL Graphics Init---------------------------------------------------------------------------------sdlInit :: IO ()-sdlInit = do-  SDL.init [InitVideo]--  let width  = 640-      height = 480-  _ <- SDL.setVideoMode width height 16 [SWSurface]-  SDL.setCaption "Test" ""----------------------------------------------------------------------------------- Display a box at a given coordinates---------------------------------------------------------------------------------display :: (Double, Double) -> IO ()-display (playerX, playerY) = do-  screen <- getVideoSurface--  -- Paint screen green-  let format = surfaceGetPixelFormat screen-  bgColor <- mapRGB format 55 60 64-  _ <- fillRect screen Nothing bgColor--  -- Paint small red square, at an angle 'angle' with respect to the center-  foreC <- mapRGB format 212 108 73-  let side = 20-      x = round playerX-      y = round playerY-  _ <- fillRect screen (Just (Rect x y side side)) foreC--  -- Double buffering-  SDL.flip screen----------------------------------------------------------------------------------- Wait and update Controller Position if it changes---------------------------------------------------------------------------------updateController :: IORef (Double, Double) -> IO ()-updateController ref = do-    e <- pollEvent-    case e of-        MouseMotion x y _ _ -> writeIORef ref (fromIntegral x, fromIntegral y)-        _ -> return ()----------------------------------------------------------------------------------- Periodically refresh the output display---------------------------------------------------------------------------------updateDisplay :: IORef (Double, Double) -> IO ()-updateDisplay cref = do-    time <- SDL.getTicks-    (x, y) <- readIORef cref-    let t = fromIntegral time * speed / 1000-     in display (x + cos t * radius, y + sin t * radius)--    where--    speed  = 6-    radius = 60--main :: IO ()-main = do-    sdlInit-    cref <- newIORef (0,0)-    S.drain $ asyncly $ constRate 40-        $ S.repeatM (updateController cref)-              `parallel` S.repeatM (updateDisplay cref)
− examples/ControlFlow.hs 
@@ -1,303 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}------------------------------------------------------------------------------------ Combining control flow manipulating monad transformers (MaybeT, exceptT,--- ContT) with Streamly-------------------------------------------------------------------------------------- Streamly streams are non-determinism (nested looping) monads. We can use a--- control flow monad on top or streamly on top depending on whether we want to--- superimpose control flow manipulation on top of non-deterministic--- composition or vice-versa.------ This file provides an example where we enter a sequence of characters "x",--- and "y" on separate lines, on the command line. When any other sequence is--- entered the control flow short circuits at the first non-matching char and--- exits.--import Control.Concurrent (threadDelay)-import Control.Exception (catch, SomeException)-import Control.Monad-import Control.Monad.Catch (MonadThrow, throwM, Exception)-import Control.Monad.IO.Class-import Control.Monad.Trans.Class-import Control.Monad.Trans.Maybe-import Control.Monad.Trans.Except-import Control.Monad.Trans.Cont-import Streamly-import qualified Streamly.Prelude as S------------------------------------------------------------------------------------ Using MaybeT below streamly-------------------------------------------------------------------------------------- When streamly is on top MaybeT would terminate all iterations of--- non-determinism.----getSequenceMaybeBelow-    :: ( IsStream t-       , Monad m-       , MonadTrans t-       , MonadIO (t (MaybeT m))-       )-    => t (MaybeT m) ()-getSequenceMaybeBelow = do-    liftIO $ putStrLn "MaybeT below streamly: Enter one char per line: "--    i <- S.fromFoldable [1..2 :: Int]-    liftIO $ putStrLn $ "iteration = " <> show i--    r1 <- liftIO getLine-    when (r1 /= "x") $ lift mzero--    r2 <- liftIO getLine-    when (r2 /= "y") $ lift mzero--mainMaybeBelow :: IO ()-mainMaybeBelow = do-    r <- runMaybeT (S.drain getSequenceMaybeBelow)-    case r of-        Just _ -> putStrLn "Bingo"-        Nothing -> putStrLn "Wrong"------------------------------------------------------------------------------------ Using MaybeT above streamly-------------------------------------------------------------------------------------- When MaybeT is on top a Nothing would terminate only the current iteration--- of non-determinism below.------ Note that this is redundant configuration as the same behavior can be--- achieved with just streamly, using mzero.----getSequenceMaybeAbove :: (IsStream t, MonadIO (t m)) => MaybeT (t m) ()-getSequenceMaybeAbove = do-    liftIO $ putStrLn "MaybeT above streamly: Enter one char per line: "--    i <- lift $ S.fromFoldable [1..2 :: Int]-    liftIO $ putStrLn $ "iteration = " <> show i--    r1 <- liftIO getLine-    when (r1 /= "x") mzero--    r2 <- liftIO getLine-    when (r2 /= "y") mzero--mainMaybeAbove :: (IsStream t, MonadIO (t m)) => MaybeT (t m) ()-mainMaybeAbove = do-    getSequenceMaybeAbove-    liftIO $ putStrLn "Bingo"------------------------------------------------------------------------------------ Using ExceptT below streamly-------------------------------------------------------------------------------------- XXX need to have a specialized liftCatch to lift catchE------ Note that throwE would terminate all iterations of non-determinism--- altogether.-getSequenceEitherBelow-    :: ( IsStream t-       , MonadTrans t-       , Monad m-       , MonadIO (t (ExceptT String m))-       )-    => t (ExceptT String m) ()-getSequenceEitherBelow = do-    liftIO $ putStrLn "ExceptT below streamly: Enter one char per line: "--    i <- S.fromFoldable [1..2 :: Int]-    liftIO $ putStrLn $ "iteration = " <> show i--    r1 <- liftIO getLine-    when (r1 /= "x") $ lift $ throwE $ "Expecting x got: " <> r1--    r2 <- liftIO getLine-    when (r2 /= "y") $ lift $ throwE $ "Expecting y got: " <> r2--mainEitherBelow :: IO ()-mainEitherBelow = do-    -- XXX Cannot lift catchE-    r <- runExceptT (S.drain getSequenceEitherBelow)-    case r of-        Right _ -> liftIO $ putStrLn "Bingo"-        Left s  -> liftIO $ putStrLn s------------------------------------------------------------------------------------ Using ExceptT below concurrent streamly-------------------------------------------------------------------------------------- XXX does not work correctly yet----getSequenceEitherAsyncBelow-    :: ( IsStream t-       , MonadTrans t-       , MonadIO m-       , MonadIO (t (ExceptT String m))-       , Semigroup (t (ExceptT String m) Integer)-       )-    => t (ExceptT String m) ()-getSequenceEitherAsyncBelow = do-    liftIO $ putStrLn "ExceptT below concurrent streamly: "--    i <- (liftIO (threadDelay 1000)-            >> lift (throwE "First task")-            >> return 1)-            <> (lift (throwE "Second task") >> return 2)-            <> S.yield (3 :: Integer)-    liftIO $ putStrLn $ "iteration = " <> show i--mainEitherAsyncBelow :: IO ()-mainEitherAsyncBelow = do-    r <- runExceptT (S.drain $ asyncly getSequenceEitherAsyncBelow)-    case r of-        Right _ -> liftIO $ putStrLn "Bingo"-        Left s  -> liftIO $ putStrLn s------------------------------------------------------------------------------------ Using ExceptT above streamly-------------------------------------------------------------------------------------- When ExceptT is on top, we can lift the non-determinism of stream from--- below.------ Note that throwE would terminate/break only current iteration of--- non-determinism and not all of them altogether.------ Here we can use catchE directly but will have to use monad-control to lift--- stream operations with stream arguments.-getSequenceEitherAbove :: (IsStream t, MonadIO (t m))-    => ExceptT String (t m) ()-getSequenceEitherAbove = do-    liftIO $ putStrLn "ExceptT above streamly: Enter one char per line: "--    i <- lift $ S.fromFoldable [1..2 :: Int]-    liftIO $ putStrLn $ "iteration = " <> show i--    r1 <- liftIO getLine-    when (r1 /= "x") $ throwE $ "Expecting x got: " <> r1--    r2 <- liftIO getLine-    when (r2 /= "y") $ throwE $ "Expecting y got: " <> r2--mainEitherAbove :: (IsStream t, MonadIO (t m)) => ExceptT String (t m) ()-mainEitherAbove =-    catchE (getSequenceEitherAbove >> liftIO (putStrLn "Bingo"))-           (liftIO . putStrLn)------------------------------------------------------------------------------------ Using MonadThrow to throw exceptions in streamly------------------------------------------------------------------------------------newtype Unexpected = Unexpected String deriving Show--instance Exception Unexpected---- Note that unlike when ExceptT is used on top, MonadThrow terminates all--- iterations of non-determinism rather then just the current iteration.----getSequenceMonadThrow :: (IsStream t, MonadIO (t m), MonadThrow (t m))-    => t m ()-getSequenceMonadThrow = do-    liftIO $ putStrLn "MonadThrow in streamly: Enter one char per line: "--    i <- S.fromFoldable [1..2 :: Int]-    liftIO $ putStrLn $ "iteration = " <> show i--    r1 <- liftIO getLine-    when (r1 /= "x") $ throwM $ Unexpected $ "Expecting x got: " <> r1--    r2 <- liftIO getLine-    when (r2 /= "y") $ throwM $ Unexpected $ "Expecting y got: " <> r2--mainMonadThrow :: IO ()-mainMonadThrow =-    catch (S.drain getSequenceMonadThrow >> liftIO (putStrLn "Bingo"))-          (\(e :: SomeException) -> liftIO $ print e)------------------------------------------------------------------------------------ Using ContT below streamly-------------------------------------------------------------------------------------- CallCC is the goto/setjmp/longjmp equivalent--- Allows us to manipulate the control flow in arbitrary ways------ XXX need to have a specialized liftCallCC to actually lift callCC----getSequenceContBelow-    :: (IsStream t, MonadTrans t, MonadIO m, MonadIO (t (ContT r m)))-    => t (ContT r m) (Either String ())-getSequenceContBelow = do-    liftIO $ putStrLn "ContT below streamly: Enter one char per line: "--    i <- S.fromFoldable [1..2 :: Int]-    liftIO $ putStrLn $ "iteration = " <> show i--    r <- lift $ callCC $ \exit -> do-        r1 <- liftIO getLine-        _ <- if r1 /= "x"-             then exit $ Left $ "Expecting x got: " <> r1-             else return $ Right ()--        r2 <- liftIO getLine-        if r2 /= "y"-        then exit $ Left $ "Expecting y got: " <> r2-        else return $ Right ()-    liftIO $ putStrLn $ "done iteration = " <> show i-    return r--mainContBelow-    :: (IsStream t, MonadIO m, MonadTrans t, MonadIO (t (ContT r m)))-    => t (ContT r m) ()-mainContBelow = do-    r <- getSequenceContBelow-    case r of-        Right _ -> liftIO $ putStrLn "Bingo"-        Left s  -> liftIO $ putStrLn s------------------------------------------------------------------------------------ Using ContT above streamly------------------------------------------------------------------------------------getSequenceContAbove :: (IsStream t, MonadIO (t m))-    => ContT r (t m) (Either String ())-getSequenceContAbove = do-    liftIO $ putStrLn "ContT above streamly: Enter one char per line: "--    i <- lift $ S.fromFoldable [1..2 :: Int]-    liftIO $ putStrLn $ "iteration = " <> show i--    callCC $ \exit -> do-        r1 <- liftIO getLine-        _ <- if r1 /= "x"-             then exit $ Left $ "Expecting x got: " <> r1-             else return $ Right ()--        r2 <- liftIO getLine-        if r2 /= "y"-        then exit $ Left $ "Expecting y got: " <> r2-        else return $ Right ()--mainContAbove :: (IsStream t, MonadIO (t m)) => ContT r (t m) ()-mainContAbove = do-    r <- getSequenceContAbove-    case r of-        Right _ -> liftIO $ putStrLn "Bingo"-        Left s  -> liftIO $ putStrLn s------------------------------------------------------------------------------------ Combining control flow manipulating monad transformers (MaybeT, exceptT,--- ContT) with Streamly----------------------------------------------------------------------------------main :: IO ()-main = do-    mainMaybeBelow-    S.drain $ runMaybeT mainMaybeAbove-    runContT (S.drain mainContBelow) return-    S.drain (runContT mainContAbove return)-    mainEitherBelow-    S.drain (runExceptT mainEitherAbove)-    mainMonadThrow-    mainEitherAsyncBelow
− examples/EchoServer.hs 
@@ -1,22 +0,0 @@--- A concurrent TCP server that echoes everything that it receives.--import Data.Function ((&))--import Streamly-import Streamly.Internal.Network.Socket (handleWithM)-import Streamly.Network.Socket--import qualified Streamly.Network.Inet.TCP as TCP-import qualified Streamly.Prelude as S--main :: IO ()-main =-      serially (S.unfold TCP.acceptOnPort 8091)-    & parallely . S.mapM (handleWithM echo)-    & S.drain--    where--    echo sk =-          S.unfold readChunksWithBufferOf (32768, sk) -- SerialT IO Socket-        & S.fold (writeChunks sk)                     -- IO ()
− examples/FileIOExamples.hs 
@@ -1,65 +0,0 @@-import qualified Streamly.Prelude as S-import qualified Streamly.Data.Fold as FL-import qualified Streamly.Memory.Array as A--import qualified Streamly.Internal.Data.Fold as FL-import qualified Streamly.Internal.Prelude as IP-import qualified Streamly.Internal.FileSystem.File as File--import Data.Char (ord)-import System.Environment (getArgs)--cat :: FilePath -> IO ()-cat src =-      File.fromChunks "/dev/stdout"-    $ File.toChunksWithBufferOf (256*1024) src--cp :: FilePath -> FilePath -> IO ()-cp src dst =-      File.fromChunks dst-    $ File.toChunksWithBufferOf (256*1024) src--append :: FilePath -> FilePath -> IO ()-append src dst =-      File.appendChunks dst-    $ File.toChunksWithBufferOf (256*1024) src--ord' :: Num a => Char -> a-ord' = (fromIntegral . ord)--wcl :: FilePath -> IO ()-wcl src = print =<< (S.length-    $ S.splitOnSuffix (== ord' '\n') FL.drain-    $ File.toBytes src)--grepc :: String -> FilePath -> IO ()-grepc pat src = print . (subtract 1) =<< (S.length-    $ IP.splitOnSeq (A.fromList (map ord' pat)) FL.drain-    $ File.toBytes src)--avgll :: FilePath -> IO ()-avgll src = print =<< (S.fold avg-    $ S.splitOnSuffix (== ord' '\n') FL.length-    $ File.toBytes src)-    where avg = (/) <$> toDouble FL.sum <*> toDouble FL.length-          toDouble = fmap (fromIntegral :: Int -> Double)--llhisto :: FilePath -> IO ()-llhisto src = print =<< (S.fold (FL.classify FL.length)-    $ S.map bucket-    $ S.splitOnSuffix (== ord' '\n') FL.length-    $ File.toBytes src)-    where-    bucket n = let i = n `mod` 10 in if i > 9 then (9,n) else (i,n)--main :: IO ()-main = do-    src <- fmap head getArgs--    putStrLn "cat"    >> cat src              -- Unix cat program-    putStr "wcl "     >> wcl src              -- Unix wc -l program-    putStr "grepc "   >> grepc "aaaa" src     -- Unix grep -c program-    putStr "avgll "   >> avgll src            -- get average line length-    putStr "llhisto " >> llhisto src          -- get line length histogram-    putStr "cp "      >> cp src "dst-xyz.txt" -- Unix cp program-    putStr "append "  >> append src "dst-xyz.txt" -- Appending to file
− examples/FileSinkServer.hs 
@@ -1,38 +0,0 @@--- A concurrent TCP server that:------ * receives connections from clients--- * splits the incoming data into lines--- * lines from concurrent connections are merged into a single srteam--- * writes the line stream to an output file--import Control.Monad.IO.Class (liftIO)-import Network.Socket (close)-import System.Environment (getArgs)--import Streamly-import Streamly.Data.Unicode.Stream-import qualified Streamly.FileSystem.Handle as FH-import qualified Streamly.Memory.Array as A-import qualified Streamly.Network.Socket as NS-import qualified Streamly.Network.Inet.TCP as TCP-import qualified Streamly.Prelude as S--import System.IO (withFile, IOMode(..))--main :: IO ()-main = do-    file <- fmap head getArgs-    withFile file AppendMode-        (\src -> S.fold (FH.write src)-        $ encodeLatin1Lax-        $ S.concatUnfold A.read-        $ S.concatMapWith parallel use-        $ S.unfold TCP.acceptOnPort 8090)--    where--    use sk = S.finally (liftIO $ close sk) (recv sk)-    recv =-          S.splitWithSuffix (== '\n') A.write-        . decodeLatin1-        . S.unfold NS.read
− examples/FromFileClient.hs 
@@ -1,21 +0,0 @@--- A TCP client that does the following:--- * Reads multiple filenames passed on the command line--- * Opens as many concurrent connections to the server--- * Sends all the files concurrently to the server--import System.Environment (getArgs)--import Streamly-import qualified Streamly.Prelude as S-import qualified Streamly.Internal.FileSystem.Handle as IFH-import qualified Streamly.Internal.Network.Inet.TCP as TCP--import System.IO (withFile, IOMode(..))--main :: IO ()-main =-    let sendFile file =-            withFile file ReadMode $ \src ->-                  S.fold (TCP.writeChunks (127, 0, 0, 1) 8090)-                $ IFH.toChunks src-     in getArgs >>= S.drain . parallely . S.mapM sendFile . S.fromList
− examples/HandleIO.hs 
@@ -1,107 +0,0 @@-import Data.Char (ord)-import System.Environment (getArgs)-import System.IO (IOMode(..), hSeek, SeekMode(..))--import qualified Streamly.Data.Fold as FL-import qualified Streamly.FileSystem.Handle as FH-import qualified System.IO as FH-import qualified Streamly.Memory.Array as A-import qualified Streamly.Prelude as S--- import qualified Streamly.FileSystem.FD as FH--import qualified Streamly.Internal.Data.Fold as FL-import qualified Streamly.Internal.Data.Unicode.Stream as US-import qualified Streamly.Internal.Memory.ArrayStream as AS-import qualified Streamly.Internal.Prelude as S---- Read the contents of a file to stdout.------ FH.read reads the file in 32KB chunks and converts the chunks into a byte--- stream. FH.write takes the byte stream as input, converts it into chunks of--- 32KB and writes those chunks to stdout.----_cat :: FH.Handle -> IO ()-_cat src = S.fold (FH.write FH.stdout) $ S.unfold FH.read src---- Chunked version, more efficient than the byte stream version above. Reads--- the file in 256KB chunks and writes those chunks to stdout.-cat :: FH.Handle -> IO ()-cat src =-      S.fold (FH.writeChunks FH.stdout)-    $ S.unfold FH.readChunksWithBufferOf ((256*1024), src)---- Copy a source file to a destination file.------ FH.read reads the file in 32KB chunks and converts the chunks into a byte--- stream. FH.write takes the byte stream as input, converts it into chunks of--- 32KB and writes those chunks to the destination file.-_cp :: FH.Handle -> FH.Handle -> IO ()-_cp src dst = S.fold (FH.write dst) $ S.unfold FH.read src---- Chunked version, more efficient than the byte stream version above. Reads--- the file in 256KB chunks and writes those chunks to stdout.-cp :: FH.Handle -> FH.Handle -> IO ()-cp src dst =-      S.fold (FH.writeChunks dst)-    $ S.unfold FH.readChunksWithBufferOf ((256*1024), src)--ord' :: Num a => Char -> a-ord' = (fromIntegral . ord)---- Count lines like wc -l.------ Char stream version. Reads the input as a byte stream, splits it into lines--- and counts the lines..-_wcl :: FH.Handle -> IO ()-_wcl src = print =<< (S.length-    $ US.lines FL.drain-    $ US.decodeLatin1-    $ S.unfold FH.read src)---- More efficient chunked version. Reads chunks from the input handles and--- splits the chunks directly instead of converting them into byte stream--- first.-wcl :: FH.Handle -> IO ()-wcl src = print =<< (S.length-    $ AS.splitOn 10-    $ S.unfold FH.readChunks src)---- grep -c------ count the occurrences of a pattern in a file.-grepc :: String -> FH.Handle -> IO ()-grepc pat src = print . (subtract 1) =<< (S.length-    $ S.splitOnSeq (A.fromList (map ord' pat)) FL.drain-    $ S.unfold FH.read src)---- Compute the average line length in a file.-avgll :: FH.Handle -> IO ()-avgll src = print =<< (S.fold avg-    $ S.splitWithSuffix (== ord' '\n') FL.length-    $ S.unfold FH.read src)-    where avg = (/) <$> toDouble FL.sum <*> toDouble FL.length-          toDouble = fmap (fromIntegral :: Int -> Double)---- histogram of line lengths in a file-llhisto :: FH.Handle -> IO ()-llhisto src = print =<< (S.fold (FL.classify FL.length)-    $ S.map bucket-    $ S.splitWithSuffix (== ord' '\n') FL.length-    $ S.unfold FH.read src)-    where-    bucket n = let i = n `mod` 10 in if i > 9 then (9,n) else (i,n)--main :: IO ()-main = do-    name <- fmap head getArgs-    src <- FH.openFile name ReadMode-    let rewind = hSeek src AbsoluteSeek 0--    rewind >> putStrLn "cat"    >> cat src          -- Unix cat program-    rewind >> putStr "wcl "     >> wcl src          -- Unix wc -l program-    rewind >> putStr "grepc "   >> grepc "aaaa" src -- Unix grep -c program-    rewind >> putStr "avgll "   >> avgll src        -- get average line length-    rewind >> putStr "llhisto " >> llhisto src      -- get line length histogram--    dst <- FH.openFile "dst-xyz.txt" WriteMode-    rewind >> putStr "cp " >> cp src dst       -- Unix cp program
− examples/ListDir.hs 
@@ -1,25 +0,0 @@-module Main (main) where--import Data.Bifunctor (bimap)-import Data.Function ((&))-import System.IO (stdout, hSetBuffering, BufferMode(LineBuffering))-import Streamly (ahead)--import qualified Streamly.Prelude as S-import qualified Streamly.Internal.Prelude as S-import qualified Streamly.Internal.FileSystem.Dir as Dir---- | List the current directory recursively using concurrent processing----main :: IO ()-main = do-    hSetBuffering stdout LineBuffering-    S.mapM_ print $ S.concatMapTreeWith ahead listDir-        (S.yieldM $ return (Left "."))--    where--    listDir dir =-          Dir.toEither dir            -- SerialT IO (Either String String)-        & S.map (bimap prefix prefix) -- SerialT IO (Either String String)-        where prefix x = dir ++ "/" ++ x
− examples/MergeSort.hs 
@@ -1,24 +0,0 @@-{-# LANGUAGE FlexibleContexts    #-}---- | This example generates two streams sorted in ascending order and merges--- them in ascending order, concurrently.------ Compile with '-threaded -with-rtsopts "-N"' GHC options to use the--- parallelism.--import Data.Word-import System.Random (getStdGen, randoms)-import Data.List (sort)-import Data.Ord (compare)--import Streamly-import qualified Streamly.Prelude as S--getSorted :: Serial Word16-getSorted = do-    g <- S.yieldM getStdGen-    let ls = take 100000 (randoms g) :: [Word16]-    foldMap return (sort ls)--main :: IO ()-main = S.last (S.mergeAsyncBy compare getSorted getSorted) >>= print
+ examples/README.md view
@@ -0,0 +1,3 @@+# Examples++Examples are available in [streamly-examples](https://github.com/composewell/streamly-examples) repo.
− examples/SearchQuery.hs 
@@ -1,29 +0,0 @@-import Streamly-import Streamly.Prelude (drain, nil, yieldM, (|:))-import Network.HTTP.Simple---- | Runs three search engine queries in parallel and prints the search engine--- names in the fastest first order.------ Does it twice using two different ways.----main :: IO ()-main = do-    putStrLn "Using parallel stream construction"-    drain . parallely $ google |: bing |: duckduckgo |: nil--    putStrLn "\nUsing parallel semigroup composition"-    drain . parallely $ yieldM google <> yieldM bing <> yieldM duckduckgo--    putStrLn "\nUsing parallel applicative zip"-    drain . zipAsyncly $-        (,,) <$> yieldM google <*> yieldM bing <*> yieldM duckduckgo--    where-        get :: String -> IO ()-        get s = httpNoBody (parseRequest_ s) >> print s--        google, bing, duckduckgo :: IO ()-        google     = get "https://www.google.com/search?q=haskell"-        bing       = get "https://www.bing.com/search?q=haskell"-        duckduckgo = get "https://www.duckduckgo.com/?q=haskell"
− examples/WordClassifier.hs 
@@ -1,75 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-#if __GLASGOW_HASKELL__ >= 800-{-# OPTIONS_GHC -Wno-orphans #-}-#endif--- compile with:--- ghc -O2 -fspec-constr-recursive=10 -fmax-worker-args=16 word-classifier.hs----import qualified Data.Char as Char-import           Data.Foldable-import           Data.Function ((&))-import           Data.Functor.Identity (Identity(..))-import qualified Data.HashMap.Strict as Map-import           Data.Hashable-import           Data.IORef-import qualified Data.List as List-import qualified Data.Ord as Ord-import           Foreign.Storable (Storable(..))-import qualified Streamly.Data.Unicode.Stream as S-import qualified Streamly.Internal.Data.Unicode.Stream as S-import qualified Streamly.Data.Fold as FL-import qualified Streamly.Internal.Data.Fold as IFL-import qualified Streamly.Internal.Data.Unfold as IUF-import qualified Streamly.Internal.FileSystem.File as File-import qualified Streamly.Memory.Array as A-import qualified Streamly.Prelude as S-import           System.Environment (getArgs)--instance (Enum a, Storable a) => Hashable (A.Array a) where-    hash arr = fromIntegral $ runIdentity $ IUF.fold A.read IFL.rollingHash arr-    hashWithSalt salt arr = fromIntegral $ runIdentity $-        IUF.fold A.read (IFL.rollingHashWithSalt $ fromIntegral salt) arr--{-# INLINE toLower #-}-toLower :: Char -> Char-toLower c-  | uc >= 0x61 && uc <= 0x7a = c-  | otherwise = Char.toLower c-  where-    uc = fromIntegral (Char.ord c) :: Word--{-# INLINE isAlpha #-}-isAlpha :: Char -> Bool-isAlpha c-  | uc >= 0x61 && uc <= 0x7a = True-  | otherwise = Char.isAlpha c-  where-    uc = fromIntegral (Char.ord c) :: Word--main :: IO ()-main = do-    inFile <- fmap head getArgs--    -- Write the stream to a hashmap consisting of word counts-    mp <--        let-            alter Nothing    = fmap Just $ newIORef (1 :: Int)-            alter (Just ref) = modifyIORef' ref (+ 1) >> return (Just ref)-        in File.toBytes inFile    -- SerialT IO Word8-         & S.decodeLatin1         -- SerialT IO Char-         & S.map toLower          -- SerialT IO Char-         & S.words FL.toList      -- SerialT IO String-         & S.filter (all isAlpha) -- SerialT IO String-         & S.foldlM' (flip (Map.alterF alter)) Map.empty -- IO (Map String (IORef Int))--    -- Print the top hashmap entries-    counts <--        let readRef (w, ref) = do-                cnt <- readIORef ref-                return (w, cnt)-         in Map.toList mp-          & mapM readRef--    traverse_ print $ List.sortOn (Ord.Down . snd) counts-                    & List.take 25
− examples/WordCount.hs 
@@ -1,630 +0,0 @@----------------------------------------------------------------------------------- Fast, streaming and parallel word counting (wc) program.----------------------------------------------------------------------------------- 1) On utf8 inputs the serial version is around 3x faster than MacOS wc--- 2) It can run parallely on multiple cores providing further speedup--- 3) Parallel version works efficiently on stdin/streaming input as well--- 4) Parallel version handles utf8 input correctly (including multi-byte space---    chars) and gives the same output as the serial version on all inputs.--- 5) There may be differences in word/char counts when there are invalid utf8---    byte sequences present in the input because of different styles of error---    handling.------------------------------------------------------------------------------------ Build with the following options:----------------------------------------------------------------------------------- streamly optimization plugin is required for best performance--- ghc -O2 -fplugin Plugin -fspec-constr-recursive=10 -fmax-worker-args=16--- For concurrent version add: -threaded -with-rtsopts "-N"------------------------------------------------------------------------------------ Comparing with "wc -mwl" command:-------------------------------------------------------------------------------------- 1) To enable UTF8 with wc: export LANG=en_US.UTF-8; export LC_ALL=$LANG--- 2) To test whether it is acutally using utf8, copy and paste this string--- "U+1680 U+2000 U+2001 U+2002" and run "wc -mwl" on this. Without proper UTF8--- handling word count would be 1, with proper UTF8 handling word count would--- be 4. Note that the spaces in this string are not regular space chars they--- are different unicode space chars.--{-# LANGUAGE CPP #-}--import Control.Monad (when)-import Data.Char (isSpace)-import Data.Word (Word8)-import GHC.Conc (numCapabilities)-import System.Environment (getArgs)-import System.IO (Handle, openFile, IOMode(..))-import Streamly.Internal.Data.Unicode.Stream-       (DecodeState, DecodeError(..), CodePoint, decodeUtf8Either,-       resumeDecodeUtf8Either)--import qualified Streamly as S-import qualified Streamly.Data.Unicode.Stream as S-import qualified Streamly.FileSystem.Handle as FH-import qualified Streamly.Memory.Array as A-import qualified Streamly.Prelude as S-import qualified Data.Vector.Storable.Mutable as V------------------------------------------------------------------------------------ Parallel char, line and word counting------------------------------------------------------------------------------------ We process individual chunks in the stream independently and parallely and--- the combine the chunks to combine what they have counted.-------------------------------------------------------------------------------------- Char counting------------------------------------------------------------------------------------ To count chars each block needs the following:------ -- | header | char counts | trailer |------ header and trailer are incomplete utf8 byte sequences that may be combined--- with the previous or the next block to complete them later.------ The trailer may have one or more bytes in a valid utf8 sequence and is--- expecting more bytes to complete the sequence. The header stores any--- possible continuation from the previous block. It contains a maximum of 3--- bytes which all must be non-starter bytes.------ When two blocks are combined, the trailer of the first block is combined--- with the header of the next block and then utf8 decoded. The combined--- header+trailer may yield:------ * Nothing - when there is no trailer and header--- * All errors - when there is no trailer in the previous block, and there is--- a header in the next block. In this case there is no starting char which--- means all header bytes are errors.--- * It can yield at most one valid character followed by 0, 1 or 2 errors.------ We count an incomplete utf8 sequence of 2 or more bytes starting with a--- valid starter byte as a single codepoint. Bytes not following a valid--- starter byte are treated as individual codepoints for counting.-------------------------------------------------------------------------------------- Word counting------------------------------------------------------------------------------------ For word counting we need the following in each block:------ -- | header | startsWithSpace | word counts | endsWithSpace | trailer |------ The word counts in individual blocks are performed assuming that the--- previous char before the block is a space.--- When combining two blocks, after combining the trailer of previous blocks--- with the header of the next we determine if the resulting char is a space or--- not.------ 1) If there is no new char joining the two blocks then we use endsWithSpace--- of the previous block and startsWithSpace of the next block to determine if--- the word counts are to be adjusted. If the previous block ends with--- non-space and the next block starts with non-space we need to decrement the--- word count by one if it is non-zero in the next block.------ 2) If the new joining char is a space then we combine it with--- startsWithSpace and endsWithSpace to determine the--- startsWithSpace/endsWithSpace of the combined block and adjust the word--- counts appropriately.-------------------------------------------------------------------------------------- Line counting------------------------------------------------------------------------------------ Line counting is performed by counting "\n" in the stream. No new "\n" can--- result from patching the trailer and header as it is always a single byte.------------------------------------------------------------------------------------ Counting state------------------------------------------------------------------------------------ We use a mutable vector for the counting state. A fold using an immutable--- structure for such a large state does not perform well.  However, mutability--- is confined to just the accumulator.------ XXX we need convenient mutable records (like C structs) to handle things--- like this. It may be possible to achieve the same performance with an--- immutable accumulator, but that will require more research. Since we are--- always discarding the previous state, we can perhaps make use of that memory--- using safe in-place modifications, without having to allocate new memory.---- XXX we can also count the number of decoding errors separately-data Field =-    -- The number of "\n" characters found in the block.-      LineCount-    -- Number of full words found in the block, words are counted on a-    -- transition from space char to a non-space char. We always assume the-    -- char before the first starter char in a block is a space. If this is-    -- found to be incorrect when joining two blocks then we fix the counts-    -- accordingly.-    | WordCount-    -- The number of successfully decoded characters plus the number of-    -- decoding failures in the block. Each byte or sequence of bytes on which-    -- decoding fails is also counted as one char. The header and trailer bytes-    -- are not accounted in this, they are accounted only when we join two-    -- blocks.-    | CharCount-    -- whether the last counted char in this block was a space char-    | WasSpace-    -- whether the first successfully decoded char in this block is a space. A-    -- decoding failure, after the trailing bytes from the previous block are-    -- accounted, is also considered as space.-    | FirstIsSpace-    -- If no starter byte is found in the first three bytes in the block then-    -- store those bytes to possibly combine them with the trailing incomplete-    -- byte sequence in the previous block. We mark it done when either we have-    -- stored three bytes or we have found a starter byte.-    ---    -- XXX This is ugly to manipulate, we can implement a statically max sized-    -- mutable ring structure within this record.-    | HeaderDone-    | HeaderWordCount-    | HeaderWord1-    | HeaderWord2-    | HeaderWord3-    -- If a byte sequence at the end of the block is not complete then store-    -- the current state of the utf8 decoder to continue it later using the-    -- incomplete leading byte sequence in the next block.-    | TrailerPresent-    | TrailerState-    | TrailerCodePoint-    deriving (Show, Enum, Bounded)------------------------------------------------------------------------------------ Default/initial state of the block----------------------------------------------------------------------------------readField :: V.IOVector Int -> Field -> IO Int-readField v fld = V.read v (fromEnum fld)--writeField :: V.IOVector Int -> Field -> Int -> IO ()-writeField v fld val = V.write v (fromEnum fld) val--modifyField :: V.IOVector Int -> Field -> (Int -> Int) -> IO ()-modifyField v fld f = V.modify v f (fromEnum fld)--newCounts :: IO (V.IOVector Int)-newCounts = do-    counts <- V.new (fromEnum (maxBound :: Field) + 1)-    writeField counts LineCount 0-    writeField counts WordCount 0-    writeField counts CharCount 0-    writeField counts WasSpace 1-    writeField counts FirstIsSpace 0-    writeField counts HeaderDone 0-    writeField counts HeaderWordCount 0-    writeField counts TrailerPresent 0-    return counts------------------------------------------------------------------------------------ Counting chars----------------------------------------------------------------------------------accountChar :: V.IOVector Int -> Bool -> IO ()-accountChar counts isSp = do-    c <- readField counts CharCount-    let space = if isSp then 1 else 0-    when (c == 0) $ writeField counts FirstIsSpace space-    writeField counts CharCount (c + 1)-    writeField counts WasSpace space------------------------------------------------------------------------------------ Manipulating the header bytes----------------------------------------------------------------------------------addToHeader :: V.IOVector Int -> Int -> IO Bool-addToHeader counts cp = do-    cnt <- readField counts HeaderWordCount-    case cnt of-        0 -> do-            writeField counts HeaderWord1 cp-            writeField counts HeaderWordCount 1-            return True-        1 -> do-            writeField counts HeaderWord2 cp-            writeField counts HeaderWordCount 2-            return True-        2 -> do-            writeField counts HeaderWord3 cp-            writeField counts HeaderWordCount 3-            writeField counts HeaderDone 1-            return True-        _ -> return False--resetHeaderOnNewChar :: V.IOVector Int -> IO ()-resetHeaderOnNewChar counts = do-    hdone <- readField counts HeaderDone-    when (hdone == 0) $ writeField counts HeaderDone 1------------------------------------------------------------------------------------ Manipulating the trailer----------------------------------------------------------------------------------setTrailer :: V.IOVector Int -> DecodeState -> CodePoint -> IO ()-setTrailer counts st cp = do-    writeField counts TrailerState (fromIntegral st)-    writeField counts TrailerCodePoint cp-    writeField counts TrailerPresent 1--resetTrailerOnNewChar :: V.IOVector Int -> IO ()-resetTrailerOnNewChar counts = do-    trailer <- readField counts TrailerPresent-    when (trailer /= 0) $ do-        writeField counts TrailerPresent 0-        accountChar counts True------------------------------------------------------------------------------------ Counting the stream----------------------------------------------------------------------------------{-# INLINE countChar #-}-countChar :: V.IOVector Int -> Either DecodeError Char -> IO ()-countChar counts inp =-    case inp of-        Right ch -> do-            resetHeaderOnNewChar counts-            -- account the last stored error as whitespace and clear it-            resetTrailerOnNewChar counts--            when (ch == '\n') $ modifyField counts LineCount (+ 1)-            if isSpace ch-            then accountChar counts True-            else do-                wasSpace <- readField counts WasSpace-                when (wasSpace /= 0) $ modifyField counts WordCount (+ 1)-                accountChar counts False-        Left (DecodeError st cp) -> do-            hdone <- readField counts HeaderDone-            if hdone == 0-            then do-                if st == 0-                then do-                    -- We got a non-starter in initial decoder state, there may-                    -- be something that comes before this to complete it.-                    r <- addToHeader counts cp-                    when (not r) $ error "countChar: Bug addToHeader failed"-                else do-                    -- We got an error in a non-initial decoder state, it may-                    -- be an input underflow error, keep it as incomplete in-                    -- the trailer.-                    writeField counts HeaderDone 1-                    setTrailer counts st cp-            else do-                    resetTrailerOnNewChar counts-                    if st == 0-                    then accountChar counts True-                    else setTrailer counts st cp--printCounts :: V.IOVector Int -> IO ()-printCounts v = do-    l <- readField v LineCount-    w <- readField v WordCount-    c <- readField v CharCount-    putStrLn $ show l ++ " " ++ show w ++  " " ++ show c------------------------------------------------------------------------------------ Serial counting using parallel version of countChar----------------------------------------------------------------------------------_wc_mwl_parserial :: Handle -> IO (V.IOVector Int)-_wc_mwl_parserial src = do-    counts <- newCounts-    S.mapM_ (countChar counts)-        $ decodeUtf8Either-        $ S.unfold FH.read src-    return counts------------------------------------------------------------------------------------ Serial word counting with UTF-8 handling----------------------------------------------------------------------------------data Counts = Counts !Int !Int !Int !Bool deriving Show--{-# INLINE countCharSerial #-}-countCharSerial :: Counts -> Char -> Counts-countCharSerial (Counts l w c wasSpace) ch =-    let l1 = if (ch == '\n') then l + 1 else l-        (w1, wasSpace1) =-            if (isSpace ch)-            then (w, True)-            else (if wasSpace then w + 1 else w, False)-    in (Counts l1 w1 (c + 1) wasSpace1)---- Note: This counts invalid byte sequences are non-space chars-_wc_mwl_serial :: Handle -> IO ()-_wc_mwl_serial src = print =<< (-      S.foldl' countCharSerial (Counts 0 0 0 True)-    $ S.decodeUtf8Lax-    $ S.unfold FH.read src)------------------------------------------------------------------------------------ Parallel counting------------------------------------------------------------------------------------ XXX we need a better data structure to store the header bytes to make these--- routines simpler.------ combine trailing bytes in preceding block with leading bytes in the next--- block and decode them into a codepoint-reconstructChar :: Int-                -> V.IOVector Int-                -> V.IOVector Int-                -> IO (S.SerialT IO (Either DecodeError Char))-reconstructChar hdrCnt v1 v2 = do-    when (hdrCnt > 3 || hdrCnt < 0) $ error "reconstructChar: hdrCnt > 3"-    stream1 <--        if (hdrCnt > 2)-        then do-            x <- readField v2 HeaderWord3-            return $ (fromIntegral x :: Word8) `S.cons` S.nil-        else return S.nil-    stream2 <--        if (hdrCnt > 1)-        then do-            x <- readField v2 HeaderWord2-            return $ fromIntegral x `S.cons` stream1-        else return stream1-    stream3 <--        if (hdrCnt > 0)-        then do-            x <- readField v2 HeaderWord1-            return $ fromIntegral x `S.cons` stream2-        else return stream2--    state <- readField v1 TrailerState-    cp <- readField v1 TrailerCodePoint-    return $ resumeDecodeUtf8Either (fromIntegral state) cp stream3--getHdrChar :: V.IOVector Int -> IO (Maybe Int)-getHdrChar v = do-    hdrCnt <- readField v HeaderWordCount-    case hdrCnt of-        0 -> return Nothing-        1 -> do-            writeField v HeaderWordCount 0-            fmap Just $ readField v HeaderWord1-        2 -> do-            x1 <- readField v HeaderWord1-            x2 <- readField v HeaderWord2-            writeField v HeaderWord1 x2-            writeField v HeaderWordCount 1-            return $ Just x1-        3 -> do-            x1 <- readField v HeaderWord1-            x2 <- readField v HeaderWord2-            x3 <- readField v HeaderWord3-            writeField v HeaderWord1 x2-            writeField v HeaderWord2 x3-            writeField v HeaderWordCount 2-            return $ Just x1-        _ -> error "getHdrChar: Bug, hdrCnt not in range 0-3"---- If the header of the first block is not done then combine the header--- with the header of the next block.-combineHeaders :: V.IOVector Int -> V.IOVector Int -> IO ()-combineHeaders v1 v2 = do-    hdone1 <- readField v1 HeaderDone-    if hdone1 == 0-    then do-        res <- getHdrChar v2-        case res of-            Nothing -> return ()-            Just x -> do-                r <- addToHeader v1 x-                when (not r) $ error "combineHeaders: Bug, addToHeader failed"-    else return ()---- We combine the contents of the second vector into the first vector, mutating--- the first vector and returning it.--- XXX This is a quick hack and can be refactored to reduce the size--- and understandability considerably.-addCounts :: V.IOVector Int -> V.IOVector Int -> IO (V.IOVector Int)-addCounts v1 v2 = do-    hdone1 <- readField v1 HeaderDone-    hdone2 <- readField v2 HeaderDone-    hdrCnt2_0 <- readField v2 HeaderWordCount-    if hdone1 == 0 && (hdrCnt2_0 /= 0 || hdone2 /= 0)-    then do-        combineHeaders v1 v2-        if hdone2 == 0-        then return v1-        else do-            writeField v1 HeaderDone 1-            addCounts v1 v2-    else do-        trailerPresent2 <- readField v2 TrailerPresent-        trailerState2 <- readField v2 TrailerState-        trailerCodePoint2 <- readField v2 TrailerCodePoint-        if hdone1 == 0-        then error "addCounts: Bug, trying to add completely empty second block"-        else do-            l1 <- readField v1 LineCount-            w1 <- readField v1 WordCount-            c1 <- readField v1 CharCount-            wasSpace1 <- readField v1 WasSpace--            l2 <- readField v2 LineCount-            w2 <- readField v2 WordCount-            c2 <- readField v2 CharCount-            wasSpace2 <- readField v2 WasSpace-            firstIsSpace2 <- readField v2 FirstIsSpace-            hdrCnt2 <- readField v2 HeaderWordCount--            trailer1 <- readField v1 TrailerPresent-            if trailer1 == 0 -- no trailer in the first block-            then do-                -- header2, if any, complete or incomplete, is just invalid-                -- bytes, count them as whitespace-                let firstIsSpace2' = firstIsSpace2 /= 0 || hdrCnt2 /= 0-                w <--                        if w2 /= 0 && wasSpace1 == 0 && not firstIsSpace2'-                        then return $ w1 + w2 - 1-                        else return $ w1 + w2-                writeField v1 LineCount (l1 + l2)-                writeField v1 WordCount w-                writeField v1 CharCount (c1 + c2 + hdrCnt2)--                when (c1 == 0) $ do-                    if c2 == 0 && hdrCnt2 /= 0-                    then writeField v1 FirstIsSpace 1-                    else writeField v1 FirstIsSpace firstIsSpace2--                if c2 == 0 && hdrCnt2 /= 0-                then writeField v1 WasSpace 1-                else writeField v1 WasSpace wasSpace2--                writeField v1 TrailerPresent trailerPresent2-                writeField v1 TrailerState trailerState2-                writeField v1 TrailerCodePoint trailerCodePoint2-                return v1-            else do-                if hdrCnt2 == 0-                then do-                    when (hdone2 /= 0) $ do -- empty and Done header-                        -- count trailer as whitespace, its counted as one char-                        -- Note: hdrCnt2 == 0 means either header is not done-                        -- or c2 /= 0-                        writeField v1 LineCount (l1 + l2)-                        writeField v1 WordCount (w1 + w2)-                        writeField v1 CharCount (c1 + c2 + 1)--                        when (c1 == 0) $ writeField v1 FirstIsSpace 1-                        if (c2 == 0)-                        then writeField v1 WasSpace 1-                        else writeField v1 WasSpace wasSpace2--                        writeField v1 TrailerPresent trailerPresent2-                        writeField v1 TrailerState trailerState2-                        writeField v1 TrailerCodePoint trailerCodePoint2-                    -- If header of the next block is not done we continue the-                    -- trailer from the previous block instead of treating it-                    -- as whitespace-                    return v1-                else do-                    -- join the trailing part of the first block with the-                    -- header of the next-                    decoded <- reconstructChar hdrCnt2 v1 v2-                    res <- S.uncons decoded-                    case res of-                        Nothing -> error "addCounts: Bug. empty reconstructed char"-                        Just (h, t) -> do-                            tlength <- S.length t-                            case h of-                                Right ch -> do-                                    -- If we have an error case after this-                                    -- char then that would be treated-                                    -- as whitespace-                                    let lcount = l1 + l2-                                        lcount1 = if (ch == '\n') then lcount + 1 else lcount-                                        wcount = w1 + w2-                                        firstSpace = isSpace ch-                                        wasSpace = firstSpace || tlength /= 0-                                        wcount1 =-                                            if wasSpace-                                            then wcount-                                            else if w2 == 0 || firstIsSpace2 /= 0-                                                 then wcount-                                                 else wcount - 1-                                    writeField v1 LineCount lcount1-                                    writeField v1 WordCount wcount1-                                    writeField v1 CharCount (c1 + c2 + 1 + tlength)--                                    when (c1 == 0) $-                                        writeField v1 FirstIsSpace-                                                   (if firstSpace then 1 else 0)--                                    if c2 == 0-                                    then do-                                        if wasSpace-                                        then writeField v1 WasSpace 1-                                        else writeField v1 WasSpace 0-                                    else writeField v1 WasSpace wasSpace2--                                    writeField v1 TrailerPresent trailerPresent2-                                    writeField v1 TrailerState trailerState2-                                    writeField v1 TrailerCodePoint trailerCodePoint2-                                    return v1-                                Left (DecodeError st cp) -> do-                                    -- if header was incomplete it may result-                                    -- in partially decoded char to be written-                                    -- as trailer. Check if the last error is-                                    -- an incomplete decode.-                                    r <- S.last t-                                    let (st', cp') =-                                            case r of-                                                Nothing -> (st, cp)-                                                Just lst -> case lst of-                                                    Right _ -> error "addCounts: Bug"-                                                    Left (DecodeError st1 cp1) -> (st1, cp1)-                                    if hdone2 == 0 && st' /= 12-                                    then do-                                        -- all elements before the last one must be errors-                                        writeField v1 CharCount (c1 + tlength)--                                        when (c1 == 0) $-                                            writeField v1 FirstIsSpace 1--                                        writeField v1 WasSpace 1--                                        writeField v1 TrailerState (fromIntegral st')-                                        writeField v1 TrailerCodePoint cp'-                                    else do-                                        -- all elements must be errors-                                        -- treat them as whitespace-                                        writeField v1 LineCount (l1 + l2)-                                        writeField v1 WordCount (w1 + w2)-                                        writeField v1 CharCount (c1 + c2 + tlength + 1)--                                        when (c1 == 0) $-                                            writeField v1 FirstIsSpace 1--                                        if c2 == 0-                                        then writeField v1 WasSpace 1-                                        else writeField v1 WasSpace wasSpace2--                                        writeField v1 TrailerPresent trailerPresent2-                                        writeField v1 TrailerState trailerState2-                                        writeField v1 TrailerCodePoint trailerCodePoint2-                                    return v1---- Individual array processing is an isolated loop, fusing it with the bigger--- loop may be counter productive.-{-# NOINLINE countArray #-}-countArray :: A.Array Word8 -> IO (V.IOVector Int)-countArray src = do-    counts <- newCounts-    S.mapM_ (countChar counts)-        $ decodeUtf8Either-        $ S.unfold A.read src-    return counts--{-# INLINE wc_mwl_parallel #-}-wc_mwl_parallel :: Handle -> Int -> IO (V.IOVector Int)-wc_mwl_parallel src n = do-    counts <- newCounts-    S.foldlM' addCounts counts-        $ S.aheadly-        $ S.maxThreads numCapabilities-        $ S.mapM (countArray)-        $ S.unfold FH.readChunksWithBufferOf (n, src)------------------------------------------------------------------------------------ Main----------------------------------------------------------------------------------main :: IO ()-main = do-    name <- fmap head getArgs-    src <- openFile name ReadMode-    -- _wc_mwl_serial src -- Unix wc -l program-    -- printCounts =<< _wc_mwl_parserial src -- Unix wc -l program-    -- Using different sizes of chunks (1,2,3,4,5,10,128,256) is a good testing-    -- mechanism for parallel counting code.-    {--    args <- getArgs-    let chunkSize = read $ args !! 1-    -}-    let chunkSize = 32 * 1024-    printCounts =<< wc_mwl_parallel src chunkSize  -- Unix wc -l program
src/Streamly.hs view
@@ -1,6 +1,6 @@ -- | -- Module      : Streamly--- Copyright   : (c) 2017 Harendra Kumar+-- Copyright   : (c) 2017 Composewell Technologies -- -- License     : BSD3 -- Maintainer  : streamly@composewell.com@@ -51,17 +51,12 @@ -- please see the "Streamly.Tutorial" module and the examples directory in this -- package. -{-# LANGUAGE CPP                       #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE MultiParamTypeClasses     #-}--#if __GLASGOW_HASKELL__ >= 800+{-# LANGUAGE NoMonomorphismRestriction #-} {-# OPTIONS_GHC -Wno-orphans #-}-#endif  #include "inline.hs" -module Streamly+module Streamly {-# DEPRECATED "Please use \"Streamly.Prelude\" instead." #-}     (     -- -- * Concepts Overview     -- -- ** Streams@@ -187,13 +182,12 @@     -- finite container of streams. Note that these are just special cases of     -- the more general 'concatMapWith' operation.     ---    , IP.foldWith-    , IP.foldMapWith-    , IP.forEachWith+    , foldWith+    , foldMapWith+    , forEachWith      -- * Re-exports     , Semigroup (..)-     -- * Deprecated     , Streaming     , runStream@@ -212,14 +206,6 @@     , zippingAsync     , (<=>)     , (<|)--    {--    -- * Deprecated/Moved-    -- | These APIs have been moved to other modules-    , foldWith-    , foldMapWith-    , forEachWith-    -}     ) where @@ -227,14 +213,14 @@ import Streamly.Internal.Data.SVar (MonadAsync, Rate(..)) import Streamly.Internal.Data.Stream.Ahead import Streamly.Internal.Data.Stream.Async hiding (mkAsync)-import Streamly.Internal.Data.Stream.Combinators+import Streamly.Internal.Data.Stream.IsStream.Combinators import Streamly.Internal.Data.Stream.Parallel import Streamly.Internal.Data.Stream.Serial import Streamly.Internal.Data.Stream.StreamK hiding (serial) import Streamly.Internal.Data.Stream.Zip  import qualified Streamly.Prelude as P-import qualified Streamly.Internal.Prelude as IP+import qualified Streamly.Internal.Data.Stream.IsStream as IP import qualified Streamly.Internal.Data.Stream.StreamK as K import qualified Streamly.Internal.Data.Stream.Async as Async @@ -258,7 +244,7 @@ -- > S.length $ S.splitOnSuffix FL.drain 10 $ FH.read fh -- -- The following example folds the lines to arrays of 'Word8' using the--- 'Streamly.Memory.Array.writeF' fold and then wraps the lines in square+-- 'Streamly.Data.Array.Foreign.writeF' fold and then wraps the lines in square -- brackets before writing them to standard output using -- 'Streamly.FileSystem.Handle.write': --@@ -286,7 +272,7 @@ -- reducers of streams. Reducers can be combined to consume a stream source in -- many ways. The simplest is to reduce a stream source using a fold e.g.: ----- > S.runFold FL.length $ S.enumerateTo 100+-- > S.fold FL.length $ S.enumerateTo 100 -- -- Folds are consumers of streams and can be used to split a stream into -- multiple independent flows. Grouping transforms a stream by applying a fold@@ -309,7 +295,7 @@  -- $arrays ----- Streamly arrays (See "Streamly.Memory.Array") complement streams to provide an+-- Streamly arrays (See "Streamly.Data.Array.Foreign") complement streams to provide an -- efficient computing paradigm.  Streams are suitable for immutable -- transformations of /potentially infinite/ data using /sequential access/ and -- pipelined transformations whereas arrays are suitable for in-place@@ -392,38 +378,38 @@ runStream :: Monad m => SerialT m a -> m () runStream = P.drain --- | Same as @runStream . wSerially@.+-- | Same as @drain . fromWSerial@. -- -- @since 0.1.0-{-# DEPRECATED runInterleavedT "Please use 'runStream . interleaving' instead." #-}+{-# DEPRECATED runInterleavedT "Please use 'drain . interleaving' instead." #-} runInterleavedT :: Monad m => WSerialT m a -> m () runInterleavedT = P.drain . K.adapt --- | Same as @runStream . parallely@.+-- | Same as @drain . fromParallel@. -- -- @since 0.1.0-{-# DEPRECATED runParallelT "Please use 'runStream . parallely' instead." #-}+{-# DEPRECATED runParallelT "Please use 'drain . fromParallel' instead." #-} runParallelT :: Monad m => ParallelT m a -> m () runParallelT = P.drain . K.adapt --- | Same as @runStream . asyncly@.+-- | Same as @drain . fromAsync@. -- -- @since 0.1.0-{-# DEPRECATED runAsyncT "Please use 'runStream . asyncly' instead." #-}+{-# DEPRECATED runAsyncT "Please use 'drain . fromAsync' instead." #-} runAsyncT :: Monad m => AsyncT m a -> m () runAsyncT = P.drain . K.adapt --- | Same as @runStream . zipping@.+-- | Same as @drain . zipping@. -- -- @since 0.1.0-{-# DEPRECATED runZipStream "Please use 'runStream . zipSerially instead." #-}+{-# DEPRECATED runZipStream "Please use 'drain . fromZipSerial instead." #-} runZipStream :: Monad m => ZipSerialM m a -> m () runZipStream = P.drain . K.adapt --- | Same as @runStream . zippingAsync@.+-- | Same as @drain . zippingAsync@. -- -- @since 0.1.0-{-# DEPRECATED runZipAsync "Please use 'runStream . zipAsyncly instead." #-}+{-# DEPRECATED runZipAsync "Please use 'drain . fromZipAsync instead." #-} runZipAsync :: Monad m => ZipAsyncM m a -> m () runZipAsync = P.drain . K.adapt @@ -641,8 +627,64 @@ -- To adapt from one monomorphic type (e.g. 'AsyncT') to another monomorphic -- type (e.g. 'SerialT') use the 'adapt' combinator. To give a polymorphic code -- a specific interpretation or to adapt a specific type to a polymorphic type--- use the type specific combinators e.g. 'asyncly' or 'wSerially'. You+-- use the type specific combinators e.g. 'fromAsync' or 'fromWSerial'. You -- cannot adapt polymorphic code to polymorphic code, as the compiler would not know -- which specific type you are converting from or to. If you see a an -- @ambiguous type variable@ error then most likely you are using 'adapt' -- unnecessarily on polymorphic code.++-- | Same as 'Streamly.Prelude.concatFoldableWith'+--+-- @since 0.1.0+{-# DEPRECATED foldWith "Please use 'Streamly.Prelude.concatFoldableWith' instead." #-}+{-# INLINEABLE foldWith #-}+foldWith :: (IsStream t, Foldable f) => (t m a -> t m a -> t m a) -> f (t m a) -> t m a+foldWith = P.concatFoldableWith++-- | Same as 'Streamly.Prelude.concatMapFoldableWith'+--+-- @since 0.1.0+{-# DEPRECATED foldMapWith "Please use 'Streamly.Prelude.concatMapFoldableWith' instead." #-}+{-# INLINEABLE foldMapWith #-}+foldMapWith :: (IsStream t, Foldable f) => (t m b -> t m b -> t m b) -> (a -> t m b) -> f a -> t m b+foldMapWith = P.concatMapFoldableWith++-- | Same as 'Streamly.Prelude.concatForFoldableWith'+--+-- @since 0.1.0+{-# DEPRECATED forEachWith "Please use 'Streamly.Prelude.concatForFoldableWith' instead." #-}+{-# INLINEABLE forEachWith #-}+forEachWith :: (IsStream t, Foldable f) => (t m b -> t m b -> t m b) -> f a -> (a -> t m b) -> t m b+forEachWith = P.concatForFoldableWith++{-# DEPRECATED serially "Please use 'Streamly.Prelude.fromSerial' instead." #-}+serially :: IsStream t => SerialT m a -> t m a+serially = fromSerial++{-# DEPRECATED wSerially "Please use 'Streamly.Prelude.fromWSerial' instead." #-}+wSerially :: IsStream t => WSerialT m a -> t m a+wSerially = fromWSerial++{-# DEPRECATED asyncly "Please use 'Streamly.Prelude.fromAsync' instead." #-}+asyncly :: IsStream t => AsyncT m a -> t m a+asyncly = fromAsync++{-# DEPRECATED aheadly "Please use 'Streamly.Prelude.fromAhead' instead." #-}+aheadly :: IsStream t => AheadT m a -> t m a+aheadly = fromAhead++{-# DEPRECATED wAsyncly "Please use 'Streamly.Prelude.fromWAsync' instead." #-}+wAsyncly :: IsStream t => WAsyncT m a -> t m a+wAsyncly = fromWAsync++{-# DEPRECATED parallely "Please use 'Streamly.Prelude.fromParallel' instead." #-}+parallely :: IsStream t => ParallelT m a -> t m a+parallely = fromParallel++{-# DEPRECATED zipSerially "Please use 'Streamly.Prelude.fromZipSerial' instead." #-}+zipSerially :: IsStream t => ZipSerialM m a -> t m a+zipSerially = fromZipSerial++{-# DEPRECATED zipAsyncly "Please use 'Streamly.Prelude.fromZipAsync' instead." #-}+zipAsyncly :: IsStream t => ZipAsyncM m a -> t m a+zipAsyncly = fromZipAsync
+ src/Streamly/Console/Stdio.hs view
@@ -0,0 +1,31 @@+-- |+-- 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+    (+    -- * Read (stdin)+      read+    , readChunks++    -- * Write (stdout)+    , write+    , writeChunks++    -- * Write (stderr)+    , writeErr+    , writeErrChunks+    )+where++import Streamly.Internal.Console.Stdio+import Prelude hiding (read)
+ src/Streamly/Data/Array/Foreign.hs view
@@ -0,0 +1,78 @@+#include "inline.hs"++-- |+-- Module      : Streamly.Data.Array.Foreign+-- Copyright   : (c) 2019 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : released+-- Portability : GHC+--+-- This module provides immutable arrays in pinned memory (non GC memory)+-- suitable for long lived data storage, random access and for interfacing with+-- the operating system.+--+-- Arrays in this module are chunks of pinned memory that hold a sequence of+-- 'Storable' values of a given type, they cannot store non-serializable data+-- like functions.  Once created an array cannot be modified.  Pinned memory+-- allows efficient buffering of long lived data without adding any impact to+-- GC. One array is just one pointer visible to GC and it does not have to be+-- copied across generations.  Moreover, pinned memory allows communication+-- with foreign consumers and producers (e.g. file or network IO) without+-- copying the data.+--+-- = Programmer Notes+--+-- To apply a transformation to an array use 'read' to unfold the array into a+-- stream, apply a transformation on the stream and then use 'write' to fold it+-- back to an array.+--+-- This module is designed to be imported qualified:+--+-- > import qualified Streamly.Data.Array.Foreign as Array+--+-- For experimental APIs see "Streamly.Internal.Data.Array.Foreign".++module Streamly.Data.Array.Foreign+    (+      A.Array++    -- * Arrays+    -- ** 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)++    -- ** Elimination+    -- 'GHC.Exts.toList' from "GHC.Exts" can be used to convert an array to a+    -- list.++    , A.toList+    , A.read+    , A.readRev++    -- ** Casting+    , cast+    , asBytes++    -- ** Random Access+    , A.length+    -- , (!!)+    , A.getIndex+    )+where++import Streamly.Internal.Data.Array.Foreign as A
src/Streamly/Data/Fold.hs view
@@ -1,76 +1,142 @@ -- | -- Module      : Streamly.Data.Fold -- Copyright   : (c) 2019 Composewell Technologies--- License     : BSD3+-- License     : BSD-3-Clause -- Maintainer  : streamly@composewell.com--- Stability   : experimental+-- Stability   : released -- Portability : GHC ----- 'Fold' type represents an effectful action that consumes a value from an--- input stream and combines it with a single final value often called an--- accumulator, returning the resulting output accumulator.  Values from a--- stream can be /pushed/ to the fold and consumed one at a time. It can also--- be called a consumer of stream or a sink.  It is a data representation of--- the standard 'Streamly.Prelude.foldl'' function.  A 'Fold' can be turned--- into an effect (@m b@) using 'Streamly.Prelude.fold' by supplying it the--- input stream.+-- A 'Fold' is a sink or a consumer of a stream of values.  The 'Fold' type+-- consists of an accumulator and an effectful action that absorbs a value into+-- the accumulator. ----- Using this representation multiple folds can be combined efficiently using--- combinators; a stream can then be supplied to the combined fold and it would--- distribute the input to constituent folds according to the composition.  For--- example, an applicative composition distributes the same input to the--- constituent folds and then combines the resulting fold outputs.  Similarly,--- a partitioning combinator divides the input among constituent folds.+-- >>> import qualified Streamly.Data.Fold as Fold+-- >>> import qualified Streamly.Prelude as Stream ----- = Performance Notes+-- For example, a 'sum' Fold represents adding the input to the accumulated+-- sum.  A fold driver e.g. 'Streamly.Prelude.fold' pushes values from a stream+-- to the 'Fold' one at a time, reducing the stream to a single value. ----- 'Fold' representation is more efficient than using streams when splitting--- streams.  @Fold m a b@ can be considered roughly equivalent to a fold action--- @m b -> t m a -> m b@ (where @t@ is a stream type and @m@ is a 'Monad').--- Instead of using a 'Fold' type one could just use a fold action of the shape--- @m b -> t m a -> m b@ for folding streams. However, multiple such actions--- cannot be composed into a single fold function in an efficient manner.--- Using the 'Fold' type we can efficiently split the stream across mutliple--- folds because it allows the compiler to perform stream fusion optimizations.+-- >>> Stream.fold Fold.sum $ Stream.fromList [1..100]+-- 5050 ----- On the other hand, transformation operations (e.g. 'Streamly.Prelude.map')--- on stream types can be as efficient as transformations on 'Fold' (e.g.--- 'Streamly.Internal.Data.Fold.lmap').+-- Conceptually, a 'Fold' is a data type that can mimic a strict left fold+-- ('Data.List.foldl') as well as lazy right fold ('Prelude.foldr').  The above+-- example is similar to a left fold using @(+)@ as the step and @0@ as the+-- initial value of the accumulator: ----- = Left folds vs Right Folds+-- >>> Data.List.foldl' (+) 0 [1..100]+-- 5050 ----- The folds in this module are left folds, therefore, even partial folds, e.g.--- @head@ in this module, would drain the whole stream. On the other hand, the--- partial folds in "Streamly.Prelude" module are lazy right folds and would--- terminate as soon as the result is determined. However, the folds in this--- module can be composed but the folds in "Streamly.Prelude" cannot be--- composed.+-- 'Fold's have an early termination capability e.g. the 'head' fold would+-- terminate on an infinite stream: ----- = Programmer Notes+-- >>> Stream.fold Fold.head $ Stream.fromList [1..]+-- Just 1 ----- > import qualified Streamly.Data.Fold as FL+-- The above example is similar to the following right fold: ----- More, not yet exposed, fold combinators can be found in--- "Streamly.Internal.Data.Fold".---- IMPORTANT: keep the signatures consistent with the folds in Streamly.Prelude+-- >>> 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 = Stream.map 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.serialWith (,) (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.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"]+--+-- Please see "Streamly.Internal.Data.Fold" for additional @Pre-release@+-- functions.+--+-- = Folds vs. Streams+--+-- We can often use streams or folds to achieve the same goal. However, streams+-- allow efficient composition of producers (e.g. 'Streamly.Prelude.serial' or+-- 'Streamly.Prelude.mergeBy') whereas folds allow efficient composition of+-- consumers (e.g.  'serialWith', 'partition' or 'teeWith').+--+-- Streams are producers, transformations on streams happen on the output side:+--+-- >>> f = Stream.sum . Stream.map (+1) . Stream.filter odd+-- >>> f $ Stream.fromList [1..100]+-- 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]+-- 2550+--+-- Notice the composition by @.@ vs @$@ and the order of operations in the+-- above examples, the difference is due to output vs input side+-- transformations.  module Streamly.Data.Fold     (     -- * Fold Type-    -- |-    -- A 'Fold' can be run over a stream using the 'Streamly.Prelude.fold'-    -- combinator:-    ---    -- >>> S.fold FL.sum (S.enumerateFromTo 1 100)-    -- 5050        Fold -- (..) -    -- , tail-    -- , init+    -- * Constructors+    , foldl'+    , foldlM'+    , foldr -    -- ** Full Folds+    -- * 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     , drainBy     , last@@ -81,32 +147,21 @@     , maximum     , minimumBy     , minimum-    -- , the     , mean     , variance     , stdDev--    -- ** Full Folds (Monoidal)-    , mconcat-    , foldMap-    , foldMapM--    -- ** Full Folds (To Containers)-    -- | 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.+    , rollingHash+    , rollingHashWithSalt +    -- Collectors     , toList+    , toListRev -    -- ** Partial Folds-    -- , drainN-    -- , drainWhile-    -- , lastN-    -- , (!!)-    -- , genericIndex+    -- ** Terminating Folds+    -- | These are much like lazy right folds.+     , index     , head-    -- , findM     , find     , lookup     , findIndex@@ -114,148 +169,87 @@     , null     , elem     , notElem-    -- XXX these are slower than right folds even when full input is used     , all     , any     , and     , or -    -- * Transformations-    -- | Unlike stream producer types (e.g. @SerialT m a@) which have only-    -- output side, folds have an input side as well as an output side.  In the-    -- type @Fold m a b@, the input type is @a@ and the output type is @b@.-    -- Transformations can be applied either on the input side or on the output-    -- side. The 'Functor' instance of a fold maps on the output of the fold:+    -- * 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 or on the output side.  Therefore,+    -- combinators are of one of the following general shapes:     ---    -- >>> S.fold (fmap show FL.sum) (S.enumerateFromTo 1 100)-    -- "5050"+    -- * @... -> Fold m a b -> Fold m c b@ (input transformation)+    -- * @... -> Fold m a b -> Fold m a c@ (output transformation)     ---    -- However, the input side or contravariant transformations are more-    -- interesting for folds.  The following sections describe the input-    -- transformation operations on a fold.  The names of the operations are-    -- consistent with their covariant counterparts in "Streamly.Prelude", the-    -- only difference is that they are prefixed with 'l' which stands for-    -- 'left' assuming left side is the input side, notice that in @Fold m a b@-    -- the type variable @a@ is on the left side.--    -- ** Covariant Operations-    , sequence-    , mapM--    {--    -- ** Mapping-    --, transform-    -- , lmap-    --, lsequence-    -- , lmapM--    -- -- ** Filtering-    -- , lfilter-    -- , lfilterM-    -- , ldeleteBy-    -- , luniq--    -- ** Mapping Filters-    , lmapMaybe-    , lmapMaybeM+    -- Output transformations are also known as covariant transformations, and+    -- input transformations are also known as contravariant transformations.+    -- The input side transformations are more interesting for folds.  Most of+    -- the following sections describe the input transformation operations on a+    -- fold.  The names and signatures of the operations are consistent with+    -- corresponding operations in "Streamly.Prelude". 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. -    -- ** Scanning Filters-    , lfindIndices-    , lelemIndices+    -- ** 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 -    -- ** Insertion-    -- | Insertion adds more elements to the stream.+    -- ** Mapping on Input+    , lmap+    , lmapM -    , linsertBy-    , lintersperseM+    -- ** Filtering+    , filter+    , filterM -    -- ** Reordering-    , lreverse-    -}+    -- -- ** Mapping Filters+    , catMaybes+    , mapMaybe -    {--    -- * Parsing     -- ** Trimming-    , ltake-    -- , lrunFor -- time-    , ltakeWhile-    , ltakeWhileM-    , ldrop-    , ldropWhile-    , ldropWhileM-    -}+    , take+    -- , takeInterval+    , takeEndBy_+    , takeEndBy -    -- * 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-    -- >>> S.fold 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)-    -- >>> S.fold (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.+    -- ** Serial Append+    , serialWith +    -- ** Parallel Distribution+    -- | For applicative composition using distribution see+    -- "Streamly.Internal.Data.Fold.Tee".++    , teeWith     , tee     , distribute -    -- * Partitioning-    -- |-    -- Direct items in the input stream to different folds using a binary+    -- ** Partitioning+    -- | Direct items in the input stream to different folds using a binary     -- fold selector. -    -- , partitionByM-    -- , partitionBy     , partition -    {--    -- * Demultiplexing-    -- | Direct values in the input stream to different folds using an n-ary-    -- fold selector.--    , demux-    -- , demuxWith-    , demux_-    -- , demuxWith_--    -- * Classifying-    -- | In an input stream of key value pairs fold values for different keys-    -- in individual output buckets using the given fold.+    -- ** Unzipping+    , unzip -    , classify-    -- , classifyWith-    -}+    -- ** Splitting+    , many+    , chunksOf+    -- , intervalsOf -    -- * Unzipping-    , unzip-    -- These can be expressed using lmap/lmapM and unzip-    -- , unzipWith-    -- , unzipWithM+    -- ** Nesting+    , concatMap -    -- -- * Nested Folds-    -- , concatMap-    -- , chunksOf-    -- , duplicate  -- experimental+    -- * Deprecated+    , sequence+    , mapM     ) where @@ -268,3 +262,7 @@                span, splitAt, break, mapM)  import Streamly.Internal.Data.Fold++-- $setup+-- >>> import qualified Streamly.Data.Fold as Fold+-- >>> import qualified Streamly.Prelude as Stream
+ src/Streamly/Data/Fold/Tee.hs view
@@ -0,0 +1,41 @@+-- |+-- Module      : Streamly.Data.Fold.Tee+-- Copyright   : (c) 2021 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : released+-- Portability : GHC+--+-- The 'Tee' type is a newtype wrapper over the 'Streamly.Data.Fold.Fold' type providing+-- distributive 'Applicative', 'Semigroup', 'Monoid', 'Num', 'Floating' and+-- 'Fractional' instances. The input received by the composed 'Tee' is+-- replicated and distributed to both the constituent Tees.+--+-- For example, to compute the average of numbers in a stream without going+-- through the stream twice:+--+-- >>> import Streamly.Data.Fold.Tee (Tee(..))+-- >>> import qualified Streamly.Prelude as Stream+-- >>> import qualified Streamly.Data.Fold as Fold+--+-- >>> avg = (/) <$> (Tee Fold.sum) <*> (Tee $ fmap fromIntegral Fold.length)+-- >>> Stream.fold (toFold 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.head <> Tee Fold.last+-- >>> Stream.fold (toFold 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.+--+module Streamly.Data.Fold.Tee+    ( Tee(..)+    )+where++import Streamly.Internal.Data.Fold.Tee
src/Streamly/Data/Prim/Array.hs view
@@ -8,8 +8,7 @@ -- Portability : GHC -- module Streamly.Data.Prim.Array-    ( PrimArray-    , Prim+    ( Array      -- * Construction     , A.fromListN@@ -39,6 +38,6 @@     ) where -import Streamly.Internal.Data.Prim.Array (PrimArray, Prim)+import Streamly.Internal.Data.Array.Prim (Array) -import qualified Streamly.Internal.Data.Prim.Array as A+import qualified Streamly.Internal.Data.Array.Prim as A
src/Streamly/Data/Unfold.hs view
@@ -1,10 +1,3 @@-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE PatternSynonyms           #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}- #include "inline.hs"  -- |@@ -12,58 +5,148 @@ -- Copyright   : (c) 2019 Composewell Technologies -- License     : BSD3 -- Maintainer  : streamly@composewell.com--- Stability   : experimental+-- Stability   : released -- Portability : GHC ----- 'Unfold' type represents an effectful action that generates a stream of--- values from a single starting value often called a seed value. Values can be--- generated and /pulled/ from the 'Unfold' one at a time. It can also be--- called a producer or a source of stream.  It is a data representation of the--- standard 'Streamly.Prelude.unfoldr' function.  An 'Unfold' can be converted--- into a stream type using 'Streamly.Prelude.unfold' by supplying the seed.+-- 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. ----- = Performance Notes+-- >>> import qualified Streamly.Data.Fold as Fold+-- >>> import qualified Streamly.Data.Unfold as Unfold+-- >>> import qualified Streamly.Prelude as Stream ----- '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.Prelude.concatMap' combinator which uses @a -> t m b@--- (where @t@ is a stream type) to generate streams is much less efficient--- compared to 'Streamly.Prelude.concatUnfold'.+-- For example, the 'fromList' Unfold generates a stream of values from a+-- supplied list.  Unfolds can be converted to 'Streamly.Prelude.SerialT'+-- stream using the Stream.unfold operation. ----- On the other hand, transformation operations on stream types are as--- efficient as transformations on 'Unfold'.+-- >>> stream = Stream.unfold Unfold.fromList [1..100]+-- >>> Stream.sum stream+-- 5050 ----- 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.+-- All the serial stream generation operations in "Streamly.Prelude"+-- can be expressed using unfolds: ----- = Programmer Notes+-- > Stream.fromList = Stream.unfold Unfold.fromList [1..100] ----- > import qualified Streamly.Data.Unfold as UF+-- Conceptually, an 'Unfold' is just like "Data.List.unfoldr". Let us write a+-- step function to unfold a list using "Data.List.unfoldr": ----- More, not yet exposed, unfold combinators can be found in--- "Streamly.Internal.Data.Unfold".---- The stream types (e.g. t'Streamly.SerialT') can be considered as a special--- case of 'Unfold' with no starting seed.+-- >>> :{+--  f [] = Nothing+--  f (x:xs) = Just (x, xs)+-- :} --+-- >>> Data.List.unfoldr f [1,2,3]+-- [1,2,3]+--+-- Unfold.unfoldr is just the same, it uses the same step function:+--+-- >>> Stream.toList $ Stream.unfold (Unfold.unfoldr f) [1,2,3]+-- [1,2,3]+--+-- The input of an unfold can be transformed using 'lmap':+--+-- >>> u = Unfold.lmap (fmap (+1)) Unfold.fromList+-- >>> Stream.toList $ Stream.unfold u [1..5]+-- [2,3,4,5,6]+--+-- 'Unfold' streams 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.toList $ Stream.unfold u [1..100]+-- [1,2]+--+-- Multiple unfolds can be combined in several interesting ways. For example,+-- to generate nested looping as in imperative languages (also known as cross+-- product of the two streams):+--+-- >>> u1 = Unfold.lmap fst Unfold.fromList+-- >>> u2 = Unfold.lmap snd Unfold.fromList+-- >>> u = Unfold.crossWith (,) u1 u2+-- >>> Stream.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)]+--+-- Nested loops using unfolds provide C like performance due to complete stream+-- fusion.+--+-- Please see "Streamly.Internal.Data.Unfold" for additional @Pre-release@+-- functions.+--+-- = Unfolds vs. Streams+--+-- Unfolds' raison d'etre is their efficiency in nested stream operations due+-- to complete stream fusion.  'Streamly.Prelude.concatMap' or the 'Monad'+-- instance of streams use stream generation operations of the shape @a -> t m+-- b@ and then flatten the resulting stream.  This implementation is more+-- powerful but does not allow for complete stream fusion.  Unfolds provide+-- less powerful but more efficient 'Streamly.Prelude.unfoldMany', 'many' and+-- 'crossWith' operations as an alternative to a subset of use cases of+-- 'concatMap' and 'Applicative' stream operations.+--+-- "Streamly.Prelude" exports polymorphic stream generation operations that+-- provide the same functionality as unfolds in this module.  Since unfolds can+-- be easily converted to streams, several modules in streamly provide only+-- unfolds for serial stream generation.  We cannot use unfolds exclusively for+-- stream generation as they do not support concurrency.+ module Streamly.Data.Unfold     (     -- * Unfold Type       Unfold++    -- * Unfolds+    -- One to one correspondence with+    -- "Streamly.Internal.Data.Stream.IsStream.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, takeWhile, take, filter, const)+import Prelude hiding+    ( concat, map, mapM, takeWhile, take, filter, const, drop, dropWhile+    , zipWith+    ) import Streamly.Internal.Data.Unfold
src/Streamly/Data/Unicode/Stream.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE FlexibleContexts #-} -- | -- Module      : Streamly.Data.Unicode.Stream -- Copyright   : (c) 2018 Composewell Technologies@@ -13,11 +12,11 @@ -- 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.Memory.Array.Array' in memory can be decoded into a 'Char' stream+-- 'Streamly.Data.Array.Foreign.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.Prelude.fromList'.  An @Array -- Char@ can be 'Streamly.Prelude.unfold'ed into a stream using the array--- 'Streamly.Memory.Array.read' unfold.+-- 'Streamly.Data.Array.Foreign.read' unfold. -- -- = Storing Unicode Strings --@@ -31,10 +30,10 @@ -- than pinned arrays for short and short lived strings. -- -- For longer or long lived streams you can 'Streamly.Prelude.fold' the 'Char'--- stream as @Array Char@ using the array 'Streamly.Memory.Array.write' fold.+-- stream as @Array Char@ using the array 'Streamly.Data.Array.Foreign.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+-- 'encodeUtf8'' on the 'Char' stream before writing it to an 'Array' providing -- an even more compact representation. -- -- = String Literals@@ -66,15 +65,14 @@ -- lived strings in memory. -- module Streamly.Data.Unicode.Stream+    {-# DEPRECATED "Use \"Streamly.Unicode.Stream\" instead" #-}     (     -- * Construction (Decoding)       decodeLatin1     , decodeUtf8-    , decodeUtf8Lax      -- * Elimination (Encoding)     , encodeLatin1-    , encodeLatin1Lax     , encodeUtf8     {-     -- * Operations on character strings@@ -89,8 +87,13 @@     -- , words     -- , unlines     -- , unwords++    -- * Deprecations+    , decodeUtf8Lax+    , encodeLatin1Lax+    , encodeUtf8Lax     ) where -import Streamly.Internal.Data.Unicode.Stream+import Streamly.Internal.Unicode.Stream import Prelude hiding (lines, words, unlines, unwords)
− src/Streamly/FileSystem/FD.hs 
@@ -1,570 +0,0 @@-{-# LANGUAGE CPP #-}--#include "inline.hs"---- |--- Module      : Streamly.FileSystem.FD--- Copyright   : (c) 2019 Composewell Technologies------ License     : BSD3--- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC------ This module is a an experimental replacement for--- "Streamly.FileSystem.Handle". The former module provides IO facilities based--- on the GHC Handle type. The APIs in this module avoid the GHC handle layer--- and provide more explicit control over buffering.------ Read and write data as streams and arrays to and from files.------ This module provides read and write APIs based on handles. Before reading or--- writing, a file must be opened first using 'openFile'. The 'Handle' returned--- by 'openFile' is then used to access the file. A 'Handle' is backed by an--- operating system file descriptor. When the 'Handle' is garbage collected the--- underlying file descriptor is automatically closed. A handle can be--- explicitly closed using 'closeFile'.------ Reading and writing APIs are divided into two categories, sequential--- streaming APIs and random or seekable access APIs.  File IO APIs are quite--- similar to "Streamly.Memory.Array" read write APIs. In that regard, arrays can--- be considered as in-memory files or files can be considered as on-disk--- arrays.------ > import qualified Streamly.FileSystem.FD as FD-----module Streamly.FileSystem.FD-    (-    -- * File Handles-      Handle-    , stdin-    , stdout-    , stderr-    , openFile--    -- TODO file path based APIs-    -- , readFile-    -- , writeFile--    -- * Streaming IO-    -- | Streaming APIs read or write data to or from a file or device-    -- sequentially, they never perform a seek to a random location.  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-    -- 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.--    -- ** Read File to Stream-    , read-    -- , readUtf8-    -- , readLines-    -- , readFrames-    , readInChunksOf--    -- -- * Array Read-    -- , readArrayUpto-    -- , readArrayOf--    , readArrays-    , readArraysOfUpto-    -- , readArraysOf--    -- ** Write File from Stream-    , write-    -- , writeUtf8-    -- , writeUtf8Lines-    -- , writeFrames-    , writeInChunksOf--    -- -- * Array Write-    -- , writeArray-    , writeArrays-    , writeArraysPackedUpto--    -- XXX these are incomplete-    -- , writev-    -- , writevArraysPackedUpto--    -- -- * 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.-    ---    -- , readIndex-    -- , readSlice-    -- , readSliceRev-    -- , readAt -- read from a given position to th end of file-    -- , readSliceArrayUpto-    -- , readSliceArrayOf--    -- , writeIndex-    -- , writeSlice-    -- , writeSliceRev-    -- , writeAt -- start writing at the given position-    -- , writeSliceArray-    )-where--import Control.Monad.IO.Class (MonadIO(..))-import Data.Word (Word8)-import Foreign.ForeignPtr (withForeignPtr)--- import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)-import Foreign.Ptr (plusPtr, castPtr)-import Foreign.Storable (Storable(..))-import GHC.ForeignPtr (mallocPlainForeignPtrBytes)--- import System.IO (Handle, hGetBufSome, hPutBuf)-import System.IO (IOMode)-import Prelude hiding (read)--import qualified GHC.IO.FD as FD-import qualified GHC.IO.Device as RawIO--import Streamly.Internal.Memory.Array.Types (Array(..), byteLength, defaultChunkSize)-import Streamly.Internal.Data.Stream.Serial (SerialT)-import Streamly.Internal.Data.Stream.StreamK.Type (IsStream, mkStream)--#if !defined(mingw32_HOST_OS)-import Streamly.Internal.Memory.Array.Types (groupIOVecsOf)-import Streamly.Internal.Data.Stream.StreamD (toStreamD)-import Streamly.Internal.Data.Stream.StreamD.Type (fromStreamD)-import qualified Streamly.FileSystem.FDIO as RawIO hiding (write)-#endif--- import Streamly.Data.Fold (Fold)--- import Streamly.String (encodeUtf8, decodeUtf8, foldLines)--import qualified Streamly.Memory.Array as A-import qualified Streamly.Internal.Memory.ArrayStream as AS-import qualified Streamly.Prelude as S-import qualified Streamly.Internal.Data.Stream.StreamD.Type as D------------------------------------------------------------------------------------ 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.------------------------------------------------------------------------------------ Handles------------------------------------------------------------------------------------ XXX attach a finalizer--- | A 'Handle' is returned by 'openFile' and is subsequently used to perform--- read and write operations on a file.----newtype Handle = Handle FD.FD---- | File handle for standard input-stdin :: Handle-stdin = Handle FD.stdin---- | File handle for standard output-stdout :: Handle-stdout = Handle FD.stdout---- | File handle for standard error-stderr :: Handle-stderr = Handle FD.stderr---- XXX we can support all the flags that the "open" system call supports.--- Instead of using RTS locking mechanism can we use system provided locking--- instead?------ | Open a file that is not a directory and return a file handle.--- 'openFile' enforces a multiple-reader single-writer locking on files. That--- is, there may either be many handles on the same file which manage input, or--- just one handle on the file which manages output. If any open handle is--- managing a file for output, no new handle can be allocated for that file. If--- any open handle is managing a file for input, new handles can only be--- allocated if they do not manage output. Whether two files are the same is--- implementation-dependent, but they should normally be the same if they have--- the same absolute path name and neither has been renamed, for example.----openFile :: FilePath -> IOMode -> IO Handle-openFile path mode = Handle . fst <$> FD.openFile path mode True------------------------------------------------------------------------------------ Array IO (Input)------------------------------------------------------------------------------------ | Read a 'ByteArray' from a file handle. If no data is available on the--- handle it blocks until some data becomes available. If data is available--- then it immediately returns that data without blocking. It reads a maximum--- of up to the size requested.-{-# INLINABLE readArrayUpto #-}-readArrayUpto :: Int -> Handle -> IO (Array Word8)-readArrayUpto size (Handle fd) = do-    ptr <- mallocPlainForeignPtrBytes size-    -- ptr <- mallocPlainForeignPtrAlignedBytes size (alignment (undefined :: Word8))-    withForeignPtr ptr $ \p -> do-        -- n <- hGetBufSome h p size-        n <- RawIO.read fd p size-        let v = Array-                { aStart = ptr-                , aEnd   = p `plusPtr` n-                , aBound = p `plusPtr` size-                }-        -- XXX shrink only if the diff is significant-        -- A.shrinkToFit v-        return v------------------------------------------------------------------------------------ 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 (Handle fd) arr = withForeignPtr (aStart arr) $ \p ->-    -- RawIO.writeAll fd (castPtr p) aLen-    RawIO.write fd (castPtr p) aLen-    {--    -- Experiment to compare "writev" based IO with "write" based IO.-    iov <- A.newArray 1-    let iov' = iov {aEnd = aBound iov}-    A.writeIndex iov' 0 (RawIO.IOVec (castPtr p) (fromIntegral aLen))-    RawIO.writevAll fd (unsafeForeignPtrToPtr (aStart iov')) 1-    -}-    where-    aLen = byteLength arr--#if !defined(mingw32_HOST_OS)--- | Write an array of 'IOVec' to a file handle.------ @since 0.7.0-{-# INLINABLE writeIOVec #-}-writeIOVec :: Handle -> Array RawIO.IOVec -> IO ()-writeIOVec _ iov | A.length iov == 0 = return ()-writeIOVec (Handle fd) iov =-    withForeignPtr (aStart iov) $ \p ->-        RawIO.writevAll fd p (A.length iov)-#endif------------------------------------------------------------------------------------ Stream of Arrays IO------------------------------------------------------------------------------------ | @readArraysOfUpto 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@.-{-# INLINABLE _readArraysOfUpto #-}-_readArraysOfUpto :: (IsStream t, MonadIO m)-    => Int -> Handle -> t m (Array Word8)-_readArraysOfUpto 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--{-# INLINE_NORMAL readArraysOfUpto #-}-readArraysOfUpto :: (IsStream t, MonadIO m)-    => Int -> Handle -> t m (Array Word8)-readArraysOfUpto 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 ()---- XXX read 'Array a' instead of Word8------ | @readArrays h@ reads a stream of arrays from file handle @h@.--- The maximum size of a single array is limited to @defaultChunkSize@.--- 'readArrays' ignores the prevailing 'TextEncoding' and 'NewlineMode'--- on the 'Handle'.------ > readArrays = readArraysOfUpto defaultChunkSize------ @since 0.7.0-{-# INLINE readArrays #-}-readArrays :: (IsStream t, MonadIO m) => Handle -> t m (Array Word8)-readArrays = readArraysOfUpto defaultChunkSize------------------------------------------------------------------------------------ Read File to Stream------------------------------------------------------------------------------------ TODO for concurrent streams implement readahead IO. We can send multiple--- read requests at the same time. For serial case we can use async IO. We can--- also control the read throughput in mbps or IOPS.---- | @readInChunksOf chunkSize handle@ reads a byte stream from a file handle,--- reads are performed in chunks of up to @chunkSize@.  The stream ends as soon--- as EOF is encountered.----{-# INLINE readInChunksOf #-}-readInChunksOf :: (IsStream t, MonadIO m) => Int -> Handle -> t m Word8-readInChunksOf chunkSize h = AS.concat $ readArraysOfUpto chunkSize h---- TODO--- read :: (IsStream t, MonadIO m, Storable a) => Handle -> t m a------ > read = 'readByChunks' A.defaultChunkSize--- | Generate a stream of elements of the given type from a file 'Handle'. The--- stream ends when EOF is encountered.------ @since 0.7.0-{-# INLINE read #-}-read :: (IsStream t, MonadIO m) => Handle -> t m Word8-read = AS.concat . readArrays------------------------------------------------------------------------------------ Writing------------------------------------------------------------------------------------ | Write a stream of arrays to a handle.------ @since 0.7.0-{-# INLINE writeArrays #-}-writeArrays :: (MonadIO m, Storable a) => Handle -> SerialT m (Array a) -> m ()-writeArrays h = S.mapM_ (liftIO . writeArray h)---- | Write a stream of arrays to a handle after coalescing them in chunks of--- specified size. The chunk size is only a maximum and the actual writes could--- be smaller than that as we do not split the arrays to fit them to the--- specified size.------ @since 0.7.0-{-# INLINE writeArraysPackedUpto #-}-writeArraysPackedUpto :: (MonadIO m, Storable a)-    => Int -> Handle -> SerialT m (Array a) -> m ()-writeArraysPackedUpto n h xs = writeArrays h $ AS.compact n xs--#if !defined(mingw32_HOST_OS)--- XXX this is incomplete--- | Write a stream of 'IOVec' arrays to a handle.------ @since 0.7.0-{-# INLINE writev #-}-writev :: MonadIO m => Handle -> SerialT m (Array RawIO.IOVec) -> m ()-writev h = S.mapM_ (liftIO . writeIOVec h)---- XXX this is incomplete--- | Write a stream of arrays to a handle after grouping them in 'IOVec' arrays--- of up to a maximum total size. Writes are performed using gather IO via--- @writev@ system call. The maximum number of entries in each 'IOVec' group--- limited to 512.------ @since 0.7.0-{-# INLINE _writevArraysPackedUpto #-}-_writevArraysPackedUpto :: MonadIO m-    => Int -> Handle -> SerialT m (Array a) -> m ()-_writevArraysPackedUpto n h xs =-    writev h $ fromStreamD $ groupIOVecsOf n 512 (toStreamD xs)-#endif---- 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.------ @since 0.7.0-{-# INLINE writeInChunksOf #-}-writeInChunksOf :: MonadIO m => Int -> Handle -> SerialT m Word8 -> m ()-writeInChunksOf n h m = writeArrays h $ AS.arraysOf n m---- > write = 'writeInChunksOf' A.defaultChunkSize------ | Write a byte stream to a file handle. Combines the bytes in chunks of size--- up to 'A.defaultChunkSize' before writing.  Note that the write behavior--- depends on the 'IOMode' and the current seek position of the handle.------ @since 0.7.0-{-# INLINE write #-}-write :: MonadIO m => Handle -> SerialT m Word8 -> m ()-write = writeInChunksOf defaultChunkSize--{--{-# INLINE write #-}-write :: (MonadIO m, Storable a) => Handle -> SerialT m a -> m ()-write = toHandleWith A.defaultChunkSize--}------------------------------------------------------------------------------------ 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 :: (IsStream t, MonadIO m) => Handle -> t 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 -> SerialT 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 :: (IsStream t, MonadIO m) => Handle -> t 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 :: (IsStream t, MonadIO m) => Handle -> Fold m Char b -> t 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 :: (IsStream t, MonadIO m, Storable a)-    => Array a -> Handle -> Fold m a b -> t 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 :: (IsStream t, MonadIO m, Storable a)-    => Array a -> Handle -> t 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 :: (IsStream t, MonadIO m, Storable a)-    => Int -> Handle -> Int -> Int -> t 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 :: (IsStream t, MonadIO m, Storable a)-    => Handle -> Int -> Int -> t 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 :: (IsStream t, MonadIO m, Storable a)-    => Handle -> Int -> Int -> t 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 :: (IsStream t, Monad m, Storable a)-    => Handle -> Int -> Int -> t 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 :: (IsStream t, Monad m, Storable a)-    => Handle -> Int -> Int -> t m a -> m ()-writeSliceRev arr i len s = undefined--}
− src/Streamly/FileSystem/FDIO.hs 
@@ -1,229 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}--#include "inline.hs"---- |--- Module      : Streamly.FileSystem.FDIO--- Copyright   : (c) 2019 Composewell Technologies--- Copyright   : (c) 1994-2008 The University of Glasgow------ License     : BSD3--- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC------ Low level IO routines interfacing the operating system.-----module Streamly.FileSystem.FDIO-    ( write-    , writeAll-    , IOVec (..)-    , writev-    , writevAll-    )-where--#if !defined(mingw32_HOST_OS)-import Control.Concurrent (threadWaitWrite)-import Control.Monad (when)-import Data.Int (Int64)-import Foreign.C.Error (throwErrnoIfMinus1RetryMayBlock)-#if __GLASGOW_HASKELL__ >= 802-import Foreign.C.Types (CBool(..))-#endif-import System.Posix.Internals (c_write, c_safe_write)-import Streamly.FileSystem.IOVec (c_writev, c_safe_writev)-#endif--import Foreign.C.Types (CSize(..), CInt(..))-import Data.Word (Word8)-import Foreign.Ptr (plusPtr, Ptr)--import GHC.IO.FD (FD(..))--import Streamly.FileSystem.IOVec (IOVec(..))------------------------------------------------------------------------------------ IO Routines------------------------------------------------------------------------------------ See System.POSIX.Internals in GHC base package------------------------------------------------------------------------------------ Write without blocking the underlying OS thread----------------------------------------------------------------------------------#if !defined(mingw32_HOST_OS)--foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool--isNonBlocking :: FD -> Bool-isNonBlocking fd = fdIsNonBlocking fd /= 0---- "poll"s the fd for data to become available or timeout--- See cbits/inputReady.c in base package-#if __GLASGOW_HASKELL__ >= 804-foreign import ccall unsafe "fdReady"-    unsafe_fdReady :: CInt -> CBool -> Int64 -> CBool -> IO CInt-#else-foreign import ccall safe "fdReady"-    unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt-#endif--writeNonBlocking :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt-writeNonBlocking loc !fd !buf !off !len-    | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block-    | otherwise   = do-        let isWrite = 1-            isSocket = 0-            msecs = 0-        r <- unsafe_fdReady (fdFD fd) isWrite msecs isSocket-        when (r == 0) $ threadWaitWrite (fromIntegral (fdFD fd))-        if threaded then safe_write else unsafe_write--    where--    do_write call = fromIntegral `fmap`-                      throwErrnoIfMinus1RetryMayBlock loc call-                        (threadWaitWrite (fromIntegral (fdFD fd)))-    unsafe_write  = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)-    safe_write    = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)--writevNonBlocking :: String -> FD -> Ptr IOVec -> Int -> IO CInt-writevNonBlocking loc !fd !iov !cnt-    | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block-    | otherwise   = do-        let isWrite = 1-            isSocket = 0-            msecs = 0-        r <- unsafe_fdReady (fdFD fd) isWrite msecs isSocket-        when (r == 0) $ threadWaitWrite (fromIntegral (fdFD fd))-        if threaded then safe_write else unsafe_write--    where--    do_write call = fromIntegral `fmap`-                      throwErrnoIfMinus1RetryMayBlock loc call-                        (threadWaitWrite (fromIntegral (fdFD fd)))-    unsafe_write  = do_write (c_writev (fdFD fd) iov (fromIntegral cnt))-    safe_write    = do_write (c_safe_writev (fdFD fd) iov (fromIntegral cnt))--#else-writeNonBlocking :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt-writeNonBlocking = undefined--writevNonBlocking :: String -> FD -> Ptr IOVec -> Int -> IO CInt-writevNonBlocking = undefined-#endif---- Windows code is disabled for now-#if 0--#if defined(mingw32_HOST_OS)-# if defined(i386_HOST_ARCH)-#  define WINDOWS_CCONV stdcall-# elif defined(x86_64_HOST_ARCH)-#  define WINDOWS_CCONV ccall-# else-#  error Unknown mingw32 arch-# endif-#endif--foreign import WINDOWS_CCONV safe "recv"-   c_safe_recv :: CInt -> Ptr Word8 -> CInt -> CInt{-flags-} -> IO CInt--foreign import WINDOWS_CCONV safe "send"-   c_safe_send :: CInt -> Ptr Word8 -> CInt -> CInt{-flags-} -> IO CInt--blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CSize -> IO CInt-blockingWriteRawBufferPtr loc !fd !buf !off !len-  = throwErrnoIfMinus1Retry loc $ do-        let start_ptr = buf `plusPtr` off-            send_ret = c_safe_send  (fdFD fd) start_ptr (fromIntegral len) 0-            write_ret = c_safe_write (fdFD fd) start_ptr (fromIntegral len)-        r <- bool write_ret send_ret (fdIsSocket fd)-        when (r == -1) c_maperrno-        return r-      -- We don't trust write() to give us the correct errno, and-      -- instead do the errno conversion from GetLastError()-      -- ourselves. The main reason is that we treat ERROR_NO_DATA-      -- (pipe is closing) as EPIPE, whereas write() returns EINVAL-      -- for this case. We need to detect EPIPE correctly, because it-      -- shouldn't be reported as an error when it happens on stdout.-      -- As for send()'s case, Winsock functions don't do errno-      -- conversion in any case so we have to do it ourselves.-      -- That means we're doing the errno conversion no matter if the-      -- fd is from a socket or not.---- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.--- These calls may block, but that's ok.--asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt-asyncWriteRawBufferPtr loc !fd !buf !off !len = do-    (l, rc) <- asyncWrite (fromIntegral (fdFD fd)) (fdIsSocket_ fd)-                  (fromIntegral len) (buf `plusPtr` off)-    if l == (-1)-      then let sock_errno = c_maperrno_func (fromIntegral rc)-               non_sock_errno = Errno (fromIntegral rc)-               errno = bool non_sock_errno sock_errno (fdIsSocket fd)-           in  ioError (errnoToIOError loc errno Nothing Nothing)-      else return (fromIntegral l)--writeNonBlocking :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt-writeNonBlocking loc !fd !buf !off !len-    | threaded  = blockingWriteRawBufferPtr loc fd buf off len-    | otherwise = asyncWriteRawBufferPtr    loc fd buf off len--#endif---- | @write FD buffer offset length@ tries to write data on the given--- filesystem fd (cannot be a socket) up to sepcified length starting from the--- given offset in the buffer. The write will not block the OS thread, it may--- suspend the Haskell thread until write can proceed.  Returns the actual--- amount of data written.-write :: FD -> Ptr Word8 -> Int -> CSize -> IO CInt-write = writeNonBlocking "Streamly.FileSystem.FDIO"---- XXX sendAll for sockets has a similar code, we can deduplicate the two.--- XXX we need to check the errno to determine if the loop should continue. For--- example, write may return without writing all data if the process file-size--- limit has reached, in that case keep writing in a loop is fruitless.------ | Keep writing in a loop until all data in the buffer has been written.-writeAll :: FD -> Ptr Word8 -> Int -> IO ()-writeAll fd ptr bytes = do-    res <- write fd ptr 0 (fromIntegral bytes)-    let res' = fromIntegral res-    if res' < bytes-    then writeAll fd (ptr `plusPtr` res') (bytes - res')-    else return ()------------------------------------------------------------------------------------ Vector IO------------------------------------------------------------------------------------ | @write FD iovec count@ tries to write data on the given filesystem fd--- (cannot be a socket) from an iovec with specified number of entries.  The--- write will not block the OS thread, it may suspend the Haskell thread until--- write can proceed.  Returns the actual amount of data written.-writev :: FD -> Ptr IOVec -> Int -> IO CInt-writev = writevNonBlocking "Streamly.FileSystem.FDIO"---- XXX incomplete--- | Keep writing an iovec in a loop until all the iovec entries are written.-writevAll :: FD -> Ptr IOVec -> Int -> IO ()-writevAll fd iovec count = do-    _res <- writev fd iovec count-    {--    let res' = fromIntegral res-    totalBytes = countIOVecBytes-    if res' < totalBytes-     then do-        let iovec' = createModifiedIOVec-            count' = ...-        writeAll fd iovec' count'-     else return ()-    -}-    return ()
src/Streamly/FileSystem/Handle.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}- #include "inline.hs"  -- |@@ -8,11 +6,11 @@ -- -- License     : BSD3 -- Maintainer  : streamly@composewell.com--- Stability   : experimental+-- Stability   : released -- Portability : GHC -- -- Read and write streams and arrays to and from file handles. File handle IO--- APIs are quite similar to "Streamly.Memory.Array" read write APIs. In that+-- APIs are quite similar to "Streamly.Data.Array.Foreign" read write APIs. In that -- regard, arrays can be considered as in-memory files or files can be -- considered as on-disk arrays. --@@ -23,7 +21,7 @@ -- -- = Programmer Notes ----- > import qualified Streamly.FileSystem.Handle as FH+-- > import qualified Streamly.FileSystem.Handle as Handle -- -- For additional, experimental APIs take a look at -- "Streamly.Internal.FileSystem.Handle" module.@@ -46,12 +44,12 @@     -- 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-    -- 'Streamly.Internal.Memory.Array.Types.defaultChunkSize' in the+    -- 'Streamly.Internal.Data.Array.Foreign.Type.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 'Streamly.Internal.Memory.Array.Types.defaultChunkSize' before they+    -- of 'Streamly.Internal.Data.Array.Foreign.Type.defaultChunkSize' before they     -- are written to the IO device.      -- Streaming APIs work for all kind of devices, seekable or non-seekable;
− src/Streamly/FileSystem/IOVec.hsc 
@@ -1,91 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CApiFFI #-}-{-# LANGUAGE ScopedTypeVariables #-}--#include "MachDeps.h"---- |--- Module      : Streamly.FileSystem.IOVec--- Copyright   : (c) 2019 Composewell Technologies------ License     : BSD3--- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC------ Low level IO routines interfacing the operating system.-----module Streamly.FileSystem.IOVec-    ( IOVec(..)-    , c_writev-    , c_safe_writev-    )-where--import Data.Word (Word8)-#if (WORD_SIZE_IN_BITS == 32)-import Data.Word (Word32)-#else-import Data.Word (Word64)-#endif-import Foreign.C.Types (CInt(..))-import Foreign.Ptr (Ptr)-import System.Posix.Types (CSsize(..))-#if !defined(mingw32_HOST_OS)-import Foreign.Storable (Storable(..))-#endif------------------------------------------------------------------------------------ IOVec----------------------------------------------------------------------------------data IOVec = IOVec-  { iovBase :: {-# UNPACK #-} !(Ptr Word8)-#if (WORD_SIZE_IN_BITS == 32)-  , iovLen  :: {-# UNPACK #-} !Word32-#else-  , iovLen  :: {-# UNPACK #-} !Word64-#endif-  } deriving (Eq, Show)--#if !defined(mingw32_HOST_OS)--#include <sys/uio.h>--#if __GLASGOW_HASKELL__ < 800-#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)-#endif--instance Storable IOVec where-  sizeOf _ = #{size struct iovec}-  alignment _ = #{alignment struct iovec}-  peek ptr = do-      base <- #{peek struct iovec, iov_base} ptr-      len  :: #{type size_t} <- #{peek struct iovec, iov_len}  ptr-      return $ IOVec base len-  poke ptr vec = do-      let base = iovBase vec-          len  :: #{type size_t} = iovLen vec-      #{poke struct iovec, iov_base} ptr base-      #{poke struct iovec, iov_len}  ptr len-#endif---- capi calling convention does not work without -fobject-code option with GHCi--- so using this in DEVBUILD only for now.----#if !defined(mingw32_HOST_OS) && defined DEVBUILD-foreign import capi unsafe "sys/uio.h writev"-   c_writev :: CInt -> Ptr IOVec -> CInt -> IO CSsize--foreign import capi safe "sys/uio.h writev"-   c_safe_writev :: CInt -> Ptr IOVec -> CInt -> IO CSsize--#else-c_writev :: CInt -> Ptr IOVec -> CInt -> IO CSsize-c_writev = error "writev not implemented"--c_safe_writev :: CInt -> Ptr IOVec -> CInt -> IO CSsize-c_safe_writev = error "writev not implemented"-#endif
src/Streamly/Internal/BaseCompat.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP                       #-}- -- | -- Module      : Streamly.Internal.BaseCompat -- License     : BSD3@@ -13,10 +11,25 @@     (       (#.)     , errorWithoutStackTrace+    , fromLeft+    , fromRight+    , unsafeWithForeignPtr+    , oneShot     ) where  import Data.Coerce (Coercible, coerce)+#if MIN_VERSION_base(4,10,0)+import Data.Either (fromRight, fromLeft)+import qualified GHC.Exts as GHCExt+#endif+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)@@ -24,6 +37,30 @@  #if !(MIN_VERSION_base(4,9,0)) {-# NOINLINE errorWithoutStackTrace #-}-errorWithoutStackTrace :: [Char] -> a-errorWithoutStackTrace s = error s+errorWithoutStackTrace :: String -> a+errorWithoutStackTrace = error+#endif++#if !(MIN_VERSION_base(4,10,0))+fromLeft :: a -> Either a b -> a+fromLeft _ (Left a) = a+fromLeft a _        = a++fromRight :: b -> Either a b -> b+fromRight _ (Right b) = b+fromRight b _         = b+#endif++unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b+#if MIN_VERSION_base(4,15,0)+unsafeWithForeignPtr = GHCForeignPtr.unsafeWithForeignPtr+#else+unsafeWithForeignPtr = withForeignPtr+#endif++oneShot :: (a -> b) -> a -> b+#if MIN_VERSION_base(4,10,0)+oneShot = GHCExt.oneShot+#else+oneShot = id #endif
+ src/Streamly/Internal/Console/Stdio.hs view
@@ -0,0 +1,229 @@+-- |+-- 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+    (+    -- * Read+      read+    , getBytes+    , getChars+    , readChunks+    , getChunks+    -- , 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++    -- * Write+    , write+    , writeErr+    , putBytes  -- Buffered (32K)+    , putChars+    , writeChunks+    , writeErrChunks+    , 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.Foreign.Type (Array(..))+import Streamly.Internal.Data.Stream.Serial (SerialT)+import Streamly.Internal.Data.Unfold (Unfold)+import Streamly.Internal.Data.Fold (Fold)++import qualified Streamly.Internal.Data.Array.Foreign as Array+import qualified Streamly.Internal.Data.Stream.IsStream as Stream+import qualified Streamly.Internal.Data.Unfold as Unfold+import qualified Streamly.Internal.FileSystem.Handle as Handle+import qualified Streamly.Internal.Unicode.Stream as Unicode++-------------------------------------------------------------------------------+-- Reads+-------------------------------------------------------------------------------++-- | Unfold standard input into a stream of 'Word8'.+--+-- @since 0.8.0+{-# INLINE read #-}+read :: MonadIO m => Unfold m () Word8+read = Unfold.lmap (\() -> stdin) Handle.read++-- | Read a byte stream from standard input.+--+-- > getBytes = Handle.toBytes stdin+-- > getBytes = Stream.unfold Stdio.read ()+--+-- /Pre-release/+--+{-# INLINE getBytes #-}+getBytes :: MonadIO m => SerialT m Word8+getBytes = Handle.toBytes stdin++-- | Read a character stream from Utf8 encoded standard input.+--+-- > getChars = Unicode.decodeUtf8 Stdio.getBytes+--+-- /Pre-release/+--+{-# INLINE getChars #-}+getChars :: MonadIO m => SerialT m Char+getChars = Unicode.decodeUtf8 getBytes++-- | Unfolds standard input into a stream of 'Word8' arrays.+--+-- @since 0.8.0+{-# INLINE readChunks #-}+readChunks :: MonadIO m => Unfold m () (Array Word8)+readChunks = Unfold.lmap (\() -> stdin) Handle.readChunks++-- | 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@.+--+-- > getChunks = Handle.toChunks stdin+-- > getChunks = Stream.unfold Stdio.readChunks ()+--+-- /Pre-release/+--+{-# INLINE getChunks #-}+getChunks :: MonadIO m => SerialT m (Array Word8)+getChunks = Handle.toChunks 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 => SerialT 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.+--+-- @since 0.8.0+{-# INLINE write #-}+write :: MonadIO m => Fold m Word8 ()+write = Handle.write stdout++-- | Fold a stream of 'Word8' to standard error.+--+-- @since 0.8.0+{-# 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 => SerialT 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 => SerialT m Char -> m ()+putChars = putBytes . Unicode.encodeUtf8++-- | Fold a stream of @Array Word8@ to standard output.+--+-- @since 0.8.0+{-# INLINE writeChunks #-}+writeChunks :: MonadIO m => Fold m (Array Word8) ()+writeChunks = Handle.writeChunks stdout++-- | Fold a stream of @Array Word8@ to standard error.+--+-- @since 0.8.0+{-# 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 => SerialT 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+    => (SerialT m Char -> SerialT m Word8) -> SerialT 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 => SerialT 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 => SerialT m String -> m ()+putStringsLn =+      putChunks+    . Stream.intersperseSuffix (return $ Array.fromList [10])+    . Unicode.encodeStrings Unicode.encodeUtf8
+ src/Streamly/Internal/Control/Concurrent.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE UnboxedTuples #-}++-- |+-- Module      : Streamly.Internal.Control.Concurrent+-- Copyright   : (c) 2017 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Internal.Control.Concurrent+    (+      MonadAsync+    , RunInIO(..)+    , doFork+    , fork+    , forkManaged+    )+where++import Control.Concurrent (ThreadId, forkIO, killThread)+import Control.Exception (SomeException(..), catch, mask)+import Control.Monad.Catch (MonadThrow)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.Control+       (MonadBaseControl, control, StM, liftBaseDiscard)+import Data.Functor (void)+import GHC.Conc (ThreadId(..))+import GHC.Exts+import GHC.IO (IO(..))+import System.Mem.Weak (addFinalizer)++-- /Since: 0.8.0 ("Streamly.Prelude")/+--+-- | A monad that can perform concurrent or parallel IO operations. Streams+-- that can be composed concurrently require the underlying monad to be+-- 'MonadAsync'.+--+-- /Since: 0.1.0 ("Streamly")/+--+-- @since 0.8.0+type MonadAsync m = (MonadIO m, MonadBaseControl IO m, MonadThrow m)++newtype RunInIO m = RunInIO { runInIO :: forall b. m b -> IO (StM m b) }++-- 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 action = IO $ \ s ->+   case fork# action s of (# s1, tid #) -> (# s1, ThreadId tid #)++-- | Fork a thread to run the given computation, installing the provided+-- exception handler. Lifted to any monad with 'MonadBaseControl IO m'+-- capability.+--+-- TODO: the RunInIO argument can be removed, we can directly pass the action+-- as "mrun action" instead.+{-# INLINE doFork #-}+doFork :: MonadBaseControl IO m+    => m ()+    -> RunInIO m+    -> (SomeException -> IO ())+    -> m ThreadId+doFork action (RunInIO mrun) exHandler =+    control $ \run ->+        mask $ \restore -> do+                tid <- rawForkIO $ catch (restore $ void $ mrun action)+                                         exHandler+                run (return tid)++-- | 'fork' lifted to any monad with 'MonadBaseControl IO m' capability.+--+{-# INLINABLE fork #-}+fork :: MonadBaseControl IO m => m () -> m ThreadId+fork = liftBaseDiscard forkIO++-- | Fork a thread that is automatically killed as soon as the reference to the+-- returned threadId is garbage collected.+--+{-# INLINABLE forkManaged #-}+forkManaged :: (MonadIO m, MonadBaseControl IO m) => m () -> m ThreadId+forkManaged action = do+    tid <- fork action+    liftIO $ addFinalizer tid (killThread tid)+    return tid
+ src/Streamly/Internal/Control/Exception.hs view
@@ -0,0 +1,50 @@+-- |+-- 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+    ( assertM+    , verify+    , verifyM+    )+where++import Control.Exception (assert)++-- Like 'assert' but returns @()@ in an 'Applicative' context so that it can be+-- used as an independent statement in a @do@ block.+--+-- /Pre-release/+--+{-# INLINE assertM #-}+assertM :: Applicative f => Bool -> f ()+assertM predicate = assert predicate (pure ())++-- | 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 ())
src/Streamly/Internal/Control/Monad.hs view
@@ -9,8 +9,6 @@ -- -- Additional "Control.Monad" utilities. -{-# LANGUAGE ScopedTypeVariables #-}- module Streamly.Internal.Control.Monad     ( discard     )@@ -21,8 +19,8 @@  -- | Discard any exceptions or value returned by an effectful action. ----- /Internal/+-- /Pre-release/ -- {-# INLINE discard #-} discard :: MonadCatch m => m b -> m ()-discard action = (void $ action) `catch` (\(_ :: SomeException) -> return ())+discard action = void action `catch` (\(_ :: SomeException) -> return ())
src/Streamly/Internal/Data/Array.hs view
@@ -1,9 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE CPP           #-}-{-# LANGUAGE MagicHash     #-} {-# LANGUAGE UnboxedTuples #-}- #include "inline.hs"  -- |@@ -12,7 +9,7 @@ -- -- License     : BSD-3-Clause -- Maintainer  : streamly@composewell.com--- Stability   : experimental+-- Stability   : pre-release -- Portability : GHC -- module Streamly.Internal.Data.Array@@ -52,17 +49,19 @@ #endif import Control.Monad (when) import Control.Monad.IO.Class (liftIO, MonadIO)-import GHC.IO (unsafePerformIO)-import GHC.Base (Int(..)) import Data.Functor.Identity (runIdentity) import Data.Primitive.Array hiding (fromList, fromListN)+import GHC.Base (Int(..))+import GHC.IO (unsafePerformIO) import qualified GHC.Exts as Exts -import Streamly.Internal.Data.Unfold.Types (Unfold(..))-import Streamly.Internal.Data.Fold.Types (Fold(..))+import Streamly.Internal.Data.Fold.Type (Fold(..)) import Streamly.Internal.Data.Stream.StreamK.Type (IsStream) import Streamly.Internal.Data.Stream.Serial (SerialT)+import Streamly.Internal.Data.Tuple.Strict (Tuple'(..), Tuple3'(..))+import Streamly.Internal.Data.Unfold.Type (Unfold(..)) +import qualified Streamly.Internal.Data.Fold.Type as FL import qualified Streamly.Internal.Data.Stream.StreamD as D  {-# NOINLINE bottomElement #-}@@ -79,11 +78,11 @@     step _ (I# i) =         return $         case Exts.indexArray# (array# arr) i of-            (# x #) -> D.Yield x ((I# i) + 1)+            (# x #) -> D.Yield x (I# i + 1)  {-# INLINE length #-} length :: Array a -> Int-length arr = sizeofArray arr+length = sizeofArray  {-# INLINE_NORMAL toStreamDRev #-} toStreamDRev :: Monad m => Array a -> D.Stream m a@@ -95,7 +94,7 @@     step _ (I# i) =         return $         case Exts.indexArray# (array# arr) i of-            (# x #) -> D.Yield x ((I# i) - 1)+            (# x #) -> D.Yield x (I# i - 1)  {-# INLINE_NORMAL foldl' #-} foldl' :: (b -> a -> b) -> b -> Array a -> b@@ -112,13 +111,13 @@   where     initial = do         marr <- liftIO $ newArray limit bottomElement-        return (marr, 0)-    step (marr, i) x-        | i == limit = return (marr, i)+        return $ FL.Partial (Tuple' marr 0)+    step st@(Tuple' marr i) x+        | i == limit = fmap FL.Done $ extract st         | otherwise = do             liftIO $ writeArray marr i x-            return (marr, i + 1)-    extract (marr, len) = liftIO $ freezeArray marr 0 len+            return $ FL.Partial $ Tuple' marr (i + 1)+    extract (Tuple' marr len) = liftIO $ freezeArray marr 0 len  {-# INLINE_NORMAL write #-} write :: MonadIO m => Fold m a (Array a)@@ -126,18 +125,18 @@   where     initial = do         marr <- liftIO $ newArray 0 bottomElement-        return (marr, 0, 0)-    step (marr, i, capacity) x+        return $ FL.Partial (Tuple3' marr 0 0)+    step (Tuple3' marr i capacity) x         | i == capacity =             let newCapacity = max (capacity * 2) 1              in do newMarr <- liftIO $ newArray newCapacity bottomElement                    liftIO $ copyMutableArray newMarr 0 marr 0 i                    liftIO $ writeArray newMarr i x-                   return (newMarr, i + 1, newCapacity)+                   return $ FL.Partial $ Tuple3' newMarr (i + 1) newCapacity         | otherwise = do             liftIO $ writeArray marr i x-            return (marr, i + 1, capacity)-    extract (marr, len, _) = liftIO $ freezeArray marr 0 len+            return $ FL.Partial $ Tuple3' marr (i + 1) capacity+    extract (Tuple3' marr len _) = liftIO $ freezeArray marr 0 len  {-# INLINE_NORMAL fromStreamDN #-} fromStreamDN :: MonadIO m => Int -> D.Stream m a -> m (Array a)@@ -145,14 +144,14 @@     marr <- liftIO $ newArray (max limit 0) bottomElement     i <-         D.foldlM'-            (\i x -> i `seq` (liftIO $ writeArray marr i x) >> return (i + 1))-            0 $+            (\i x -> i `seq` liftIO $ writeArray marr i x >> return (i + 1))+            (return 0) $         D.take limit str     liftIO $ freezeArray marr 0 i  {-# INLINE fromStreamD #-} fromStreamD :: MonadIO m => D.Stream m a -> m (Array a)-fromStreamD str = D.runFold write str+fromStreamD = D.fold write  {-# INLINABLE fromListN #-} fromListN :: Int -> [a] -> Array a@@ -188,7 +187,7 @@  {-# INLINE fold #-} fold :: Monad m => Fold m a b -> Array a -> m b-fold f arr = D.runFold f (toStreamD arr)+fold f arr = D.fold f (toStreamD arr)  {-# INLINE streamFold #-} streamFold :: Monad m => (SerialT m a -> m b) -> Array a -> m b@@ -201,7 +200,7 @@     inject arr = return (arr, 0)     step (arr, i)         | i == length arr = return D.Stop-    step (arr, (I# i)) =+    step (arr, I# i) =         return $         case Exts.indexArray# (array# arr) i of             (# x #) -> D.Yield x (arr, I# i + 1)
+ src/Streamly/Internal/Data/Array/Foreign.hs view
@@ -0,0 +1,615 @@+{-# LANGUAGE UnboxedTuples #-}++#include "inline.hs"++-- |+-- Module      : Streamly.Internal.Data.Array.Foreign+-- Copyright   : (c) 2019 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- 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.Array.Stream.Foreign.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.++module Streamly.Internal.Data.Array.Foreign+    (+      Array++    -- , defaultChunkSize++    -- * Construction++    -- Pure, From Static Memory (Unsafe)+    -- We can use fromPtrM#, fromCStringM# and fromAddrM# to create arrays from+    -- a dynamic memory address which requires a finalizer.+    , A.fromPtr+    , A.fromAddr#+    , A.fromCString#++    -- Pure List APIs+    , A.fromListN+    , A.fromList++    -- Stream Folds+    , fromStreamN+    , fromStream++    -- Monadic APIs+    -- , newArray+    , A.writeN      -- drop new+    , A.writeNAligned+    , A.write       -- full buffer+    , writeLastN++    -- * Elimination++    , A.toList+    , A.toStream+    , A.toStreamRev+    , read+    , producer+    , unsafeRead+    , A.readRev+    -- , readChunksOf++    -- * Random Access+    , length+    , null+    , last+    -- , (!!)+    , getIndex+    , A.unsafeIndex+    -- , readIndices+    -- , readRanges++    -- , readFrom    -- read from a given position to the end of file+    -- , readFromRev -- read from a given position to 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++    -- , readChunksOfFrom+    -- , ...++    -- , writeIndex+    -- , writeFrom -- start writing at the given position+    -- , writeFromRev+    -- , writeTo   -- write from beginning up to the given position+    -- , writeToRev+    -- , writeFromTo+    -- , writeFromThenTo+    --+    -- , writeChunksOfFrom+    -- , ...++    , writeIndex+    --, writeIndices+    --, writeRanges++    -- -- * Search+    -- , bsearch+    -- , bsearchIndex+    -- , find+    -- , findIndex+    -- , findIndices++    -- -- * In-pace mutation (for Mutable Array type)+    -- , partitionBy+    -- , shuffleBy+    -- , foldtWith+    -- , foldbWith++    , unsafeSlice++    -- * Immutable Transformations+    , streamTransform++    -- * Casting+    , cast+    , unsafeCast+    , unsafeAsPtr+    , asBytes+    , unsafeAsCString++    -- * Folding Arrays+    , streamFold+    , fold+    )+where++import Control.Monad (when)+import Control.Monad.IO.Class (MonadIO(..))+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup ((<>))+#endif+import Data.Word (Word8)+-- import Data.Functor.Identity (Identity)+import Foreign.C.String (CString)+import Foreign.ForeignPtr (castForeignPtr)+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)+import Foreign.Ptr (plusPtr, castPtr)+import Foreign.Storable (Storable(..))+import Prelude hiding (length, null, last, map, (!!), read, concat)++import GHC.ForeignPtr (ForeignPtr(..))+import GHC.Ptr (Ptr(..))+import GHC.Prim (touch#)+import GHC.IO (IO(..))++import Streamly.Internal.BaseCompat+import Streamly.Internal.Data.Array.Foreign.Type (Array(..), length)+import Streamly.Internal.Data.Fold.Type (Fold(..))+import Streamly.Internal.Data.Producer.Type (Producer)+import Streamly.Internal.Data.Stream.Serial (SerialT)+import Streamly.Internal.Data.Tuple.Strict (Tuple3'(..))+import Streamly.Internal.Data.Unfold.Type (Unfold(..))++import qualified Streamly.Internal.Data.Array.Foreign.Mut.Type as MA+import qualified Streamly.Internal.Data.Array.Foreign.Type as A+import qualified Streamly.Internal.Data.Fold as FL+import qualified Streamly.Internal.Data.Stream.Prelude as P+import qualified Streamly.Internal.Data.Stream.Serial as Serial+import qualified Streamly.Internal.Data.Stream.StreamD as D+import qualified Streamly.Internal.Data.Unfold as Unfold+import qualified Streamly.Internal.Data.Producer.Type as Producer+import qualified Streamly.Internal.Ring.Foreign as RB++#if MIN_VERSION_base(4,10,0)+import Foreign.ForeignPtr (plusForeignPtr)+#else+import GHC.Base (Int(..), plusAddr#)+import GHC.ForeignPtr (ForeignPtr(..))+plusForeignPtr :: ForeignPtr a -> Int -> ForeignPtr b+plusForeignPtr (ForeignPtr addr c) (I# d) = ForeignPtr (plusAddr# addr d) c+#endif++-------------------------------------------------------------------------------+-- 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, Storable a) => Int -> SerialT m a -> m (Array a)+fromStreamN n m = do+    when (n < 0) $ error "writeN: negative write count specified"+    A.fromStreamDN n $ D.toStreamD 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, `arraysOf` followed by+-- processing of indvidual arrays in the resulting stream should be preferred.+--+-- /Pre-release/+{-# INLINE fromStream #-}+fromStream :: (MonadIO m, Storable a) => SerialT m a -> m (Array a)+fromStream = P.fold A.write+-- write m = A.fromStreamD $ D.toStreamD m++-------------------------------------------------------------------------------+-- Elimination+-------------------------------------------------------------------------------++-- | Unfold an array into a stream.+--+-- /Since 0.7.0 (Streamly.Memory.Array)/+--+-- @since 0.8.0+{-# INLINE_NORMAL read #-}+read :: forall m a. (Monad m, Storable a) => Unfold m (Array a) a+read = Unfold.lmap A.unsafeThaw MA.read++{-# INLINE_NORMAL producer #-}+producer :: forall m a. (Monad m, Storable a) => Producer m (Array a) a+producer = Producer.translate A.unsafeThaw A.unsafeFreeze MA.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 unsafeRead #-}+unsafeRead :: forall m a. (Monad m, Storable a) => Unfold m (Array a) a+unsafeRead = Unfold step inject+    where++    inject (Array fp _) = return fp++    {-# INLINE_LATE step #-}+    step (ForeignPtr p contents) = 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 = A.unsafeInlineIO $ do+                        r <- peek (Ptr p)+                        touch contents+                        return r+            let !(Ptr p1) = Ptr p `plusPtr` sizeOf (undefined :: a)+            return $ D.Yield x (ForeignPtr p1 contents)++    touch r = IO $ \s -> case touch# r s of s' -> (# s', () #)++-- | > null arr = length arr == 0+--+-- /Pre-release/+{-# INLINE null #-}+null :: Storable a => Array a -> Bool+null arr = length arr == 0++-- | > last arr = getIndex arr (length arr - 1)+--+-- /Pre-release/+{-# INLINE last #-}+last :: Storable a => Array a -> Maybe a+last arr = getIndex arr (length arr - 1)++-------------------------------------------------------------------------------+-- Folds with Array as the container+-------------------------------------------------------------------------------++-- | @writeLastN n@ folds a maximum of @n@ elements from the end of the input+-- stream to an 'Array'.+--+-- @since 0.8.0+{-# INLINE writeLastN #-}+writeLastN :: (Storable 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 (Tuple3' rb rh i) a = do+        rh1 <- liftIO $ RB.unsafeInsert rb rh a+        return $ FL.Partial $ Tuple3' rb rh1 (i + 1)++    initial =+        let f (a, b) = FL.Partial $ Tuple3' a b (0 :: Int)+         in fmap f $ liftIO $ RB.new n++    done (Tuple3' rb rh i) = do+        arr <- liftIO $ MA.newArray n+        foldFunc i rh snoc' arr rb++    snoc' b a = liftIO $ MA.unsafeSnoc b a++    foldFunc i+        | i < n = RB.unsafeFoldRingM+        | otherwise = RB.unsafeFoldRingFullM++-------------------------------------------------------------------------------+-- Random Access+-------------------------------------------------------------------------------++-------------------------------------------------------------------------------+-- Searching+-------------------------------------------------------------------------------++{-+-- | Perform a binary search in the array to find an element.+bsearch :: a -> Array a -> Maybe Bool+bsearch = undefined++-- | Perform a binary search in the array to find an element index.+{-# INLINE elemIndex #-}+bsearchIndex :: a -> Array a -> Maybe Int+bsearchIndex elem arr = undefined++-- find/findIndex etc can potentially be implemented more efficiently on arrays+-- compared to streams by using SIMD instructions.++find :: (a -> Bool) -> Array a -> Bool+find = undefined++findIndex :: (a -> Bool) -> Array a -> Maybe Int+findIndex = undefined++findIndices :: (a -> Bool) -> Array a -> Array Int+findIndices = undefined+-}++-------------------------------------------------------------------------------+-- Folds+-------------------------------------------------------------------------------++-- XXX We can potentially use SIMD instructions on arrays to fold faster.++-------------------------------------------------------------------------------+-- Slice and splice+-------------------------------------------------------------------------------++-- | /O(1)/ Slice an array in constant time.+--+-- Caution: The bounds of the slice are not checked.+--+-- /Unsafe/+--+-- /Pre-release/+{-# INLINE unsafeSlice #-}+unsafeSlice ::+       forall a. Storable a+    => Int -- ^ starting index+    -> Int -- ^ length of the slice+    -> Array a+    -> Array a+unsafeSlice start len (Array fp _) =+    let size = sizeOf (undefined :: a)+        fp1 = fp `plusForeignPtr` (start * size)+        end = unsafeForeignPtrToPtr fp1 `plusPtr` (len * size)+     in Array fp1 end++{-++splitAt :: Int -> Array a -> (Array a, Array a)+splitAt i arr = undefined++-- XXX This operation can be performed efficiently via streams.+-- | Append two arrays together to create a single array.+splice :: Array a -> Array a -> Array a+splice arr1 arr2 = undefined++-------------------------------------------------------------------------------+-- In-place mutation APIs+-------------------------------------------------------------------------------++-- | 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'.+{-# INLINE partitionBy #-}+partitionBy :: (a -> Bool) -> Array a -> (Array a, Array a)+partitionBy f arr = undefined++-- | 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.+shuffleBy :: (a -> a -> m Bool) -> Array a -> Array a -> m (Array a)+shuffleBy f arr1 arr2 = undefined++-- XXX we can also make the folds partial by stopping at a certain level.+--+-- | Perform a top down hierarchical recursive partitioning fold of items in+-- the container using the given function as the partition function.+--+-- This will perform a quick sort if the partition function is+-- 'partitionBy (< pivot)'.+--+-- @since 0.7.0+{-# INLINABLE foldtWith #-}+foldtWith :: Int -> (Array a -> Array a -> m (Array a)) -> Array a -> m (Array a)+foldtWith level f = undefined++-- | Perform a pairwise bottom up fold recursively merging the pairs. Level+-- indicates the level in the tree where the fold would stop.+--+-- This will perform a random shuffle if the shuffle function is random.+-- If we stop at level 0 and repeatedly apply the function then we can do a+-- bubble sort.+foldbWith :: Int -> (Array a -> Array a -> m (Array a)) -> Array a -> m (Array a)+foldbWith level f = undefined+-}++-- XXX consider the bulk update/accumulation/permutation APIs from vector.++-------------------------------------------------------------------------------+-- Random reads and writes+-------------------------------------------------------------------------------++-- | /O(1)/ Lookup the element at the given index, starting from 0.+--+-- @since 0.8.0+{-# INLINE getIndex #-}+getIndex :: Storable a => Array a -> Int -> Maybe a+getIndex arr i =+    if i < 0 || i > length arr - 1+        then Nothing+        else A.unsafeInlineIO $+            unsafeWithForeignPtr (aStart arr) $ \p -> Just <$> peekElemOff p i++{-+-- | @readSlice arr i count@ streams a slice of the array @arr@ 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 :: (IsStream t, Monad m, Storable a)+    => Array a -> Int -> Int -> t m a+readSlice arr i len = undefined++-- | @readSliceRev arr i count@ streams a slice of the array @arr@ 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 :: (IsStream t, Monad m, Storable a)+    => Array a -> Int -> Int -> t m a+readSliceRev arr i len = undefined+-}++-- | /O(1)/ Write the given element at the given index in the array.+-- Performs in-place mutation of the array.+--+-- /Pre-release/+{-# INLINE writeIndex #-}+writeIndex :: (MonadIO m, Storable a) => Array a -> Int -> a -> m ()+writeIndex arr i a = do+    let maxIndex = length arr - 1+    if i < 0+    then error "writeIndex: negative array index"+    else if i > maxIndex+         then error $ "writeIndex: specified array index " ++ show i+                    ++ " is beyond the maximum index " ++ show maxIndex+         else+            liftIO $ unsafeWithForeignPtr (aStart arr) $ \p ->+                pokeElemOff p i a++{-+-- | @writeSlice arr i count stream@ writes a stream to the array @arr@+-- 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 :: (IsStream t, Monad m, Storable a)+    => Array a -> Int -> Int -> t m a -> m (Array a)+writeSlice arr i len s = undefined++-- | @writeSliceRev arr i count stream@ writes a stream to the array @arr@+-- 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 :: (IsStream t, Monad m, Storable a)+    => Array a -> Int -> Int -> t m a -> m (Array a)+writeSliceRev arr i len s = 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.+--+-- @since 0.7.0+{-# INLINE runPipe #-}+runPipe :: (MonadIO m, Storable a, Storable b)+    => Pipe m a b -> Array a -> m (Array b)+runPipe f arr = P.runPipe (toArrayMinChunk (length arr)) $ f (A.read arr)+-}++-- | Transform an array into another array using a stream transformation+-- operation.+--+-- /Pre-release/+{-# INLINE streamTransform #-}+streamTransform :: forall m a b. (MonadIO m, Storable a, Storable b)+    => (SerialT m a -> SerialT m b) -> Array a -> m (Array b)+streamTransform f arr =+    P.fold (A.toArrayMinChunk (alignment (undefined :: a)) (length arr))+        $ f (A.toStream arr)++-------------------------------------------------------------------------------+-- Casts+-------------------------------------------------------------------------------++-- | Cast an array having elements of type @a@ into an array having elements of+-- type @b@. The array size must be a multiple of the size of type @b@+-- otherwise accessing the last element of the array may result into a crash or+-- a random value.+--+-- /Pre-release/+--+unsafeCast ::+#ifdef DEVBUILD+    Storable b =>+#endif+    Array a -> Array b+unsafeCast (Array start end) = Array (castForeignPtr start) (castPtr end)++-- | Cast an @Array a@ into an @Array Word8@.+--+-- @since 0.8.0+--+asBytes :: Array a -> Array Word8+asBytes = unsafeCast++-- | Cast an array having elements of type @a@ into an array having elements of+-- type @b@. The length of the array should be a multiple of the size of the+-- target element otherwise 'Nothing' is returned.+--+-- @since 0.8.0+--+cast :: forall a b. (Storable b) => Array a -> Maybe (Array b)+cast arr =+    let len = A.byteLength arr+        r = len `mod` sizeOf (undefined :: b)+     in if r /= 0+        then Nothing+        else Just $ unsafeCast arr++-- | Use an @Array a@ as @Ptr b@.+--+-- /Unsafe/+--+-- /Pre-release/+--+unsafeAsPtr :: Array a -> (Ptr b -> IO c) -> IO c+unsafeAsPtr Array{..} act = do+    unsafeWithForeignPtr aStart $ \ptr -> act (castPtr ptr)++-- | Convert an array of any type into a null terminated CString Ptr.+--+-- /Unsafe/+--+-- /O(n) Time: (creates a copy of the array)/+--+-- /Pre-release/+--+unsafeAsCString :: Array a -> (CString -> IO b) -> IO b+unsafeAsCString arr act = do+    let Array{..} = asBytes arr <> A.fromList [0]+    unsafeWithForeignPtr aStart $ \ptr -> act (castPtr ptr)++-------------------------------------------------------------------------------+-- Folds+-------------------------------------------------------------------------------++-- | Fold an array using a 'Fold'.+--+-- /Pre-release/+{-# INLINE fold #-}+fold :: forall m a b. (MonadIO m, Storable a) => Fold m a b -> Array a -> m b+fold f arr = P.fold f (A.toStream arr :: Serial.SerialT m a)++-- | Fold an array using a stream fold operation.+--+-- /Pre-release/+{-# INLINE streamFold #-}+streamFold :: (MonadIO m, Storable a) => (SerialT m a -> m b) -> Array a -> m b+streamFold f arr = f (A.toStream arr)
+ src/Streamly/Internal/Data/Array/Foreign/Mut/Type.hs view
@@ -0,0 +1,1267 @@+{-# LANGUAGE UnboxedTuples #-}++-- |+-- Module      : Streamly.Internal.Data.Array.Foreign.Mut.Type+-- Copyright   : (c) 2020 Composewell Technologies+-- License     : BSD3-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- Unboxed pinned mutable array type for 'Storable' types with an option to use+-- foreign (non-GHC) memory allocators. 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)+-- * Fragmentation control (foreign allocators)+--+-- Stream and Fold APIs allow easy, efficient and convenient operations on+-- arrays.++module Streamly.Internal.Data.Array.Foreign.Mut.Type+    (+    -- * Type+    -- $arrayNotes+      Array (..)++    -- * Construction+    , mutableArray+    , unsafeWithNewArray+    , newArray+    , newArrayAligned+    , newArrayAlignedUnmanaged+    , newArrayAlignedAllocWith++    -- * From containers+    , fromList+    , fromListN+    , fromStreamDN+    , fromStreamD++    -- * Resizing+    , realloc+    , shrinkToFit++    -- * Size+    , length+    , byteLength+    , byteCapacity++    -- * Random access+    , unsafeIndexIO+    , unsafeIndex++    -- * Mutation+    , unsafeWriteIndex+    , unsafeSnoc+    , snoc++    -- * Folding+    , foldl'+    , foldr++    -- * Composable Folds+    , toArrayMinChunk+    , writeNAllocWith+    , writeN+    , writeNUnsafe+    , ArrayUnsafe (..)+    , writeNAligned+    , writeNAlignedUnmanaged+    , write+    , writeAligned++    -- * Unfolds+    , ReadUState+    , read+    , readRev+    , producer+    , flattenArrays+    , flattenArraysRev++    -- * To containers+    , toStreamD+    , toStreamDRev+    , toStreamK+    , toStreamKRev+    , toList++    -- * Combining+    , spliceWith+    , spliceWithDoubling+    , spliceTwo++    -- * Splitting+    , breakOn+    , splitAt++    -- * Stream of arrays+    , arraysOf+    , bufferChunks+    , writeChunks++    -- * Utilities+    , defaultChunkSize+    , mkChunkSize+    , mkChunkSizeKB+    , bytesToElemCount+    , unsafeInlineIO+    , memcpy+    , memcmp+    )+where++#include "inline.hs"++import Control.Exception (assert)+import Control.DeepSeq (NFData(..))+import Control.Monad (when, void)+import Control.Monad.IO.Class (MonadIO(..))+import Data.Functor.Identity (runIdentity)+#if __GLASGOW_HASKELL__ < 808+import Data.Semigroup (Semigroup(..))+#endif+import Data.Word (Word8)+import Foreign.C.Types (CSize(..), CInt(..))+import Foreign.ForeignPtr (touchForeignPtr)+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)+import Foreign.Ptr (plusPtr, minusPtr, castPtr, nullPtr)+import Foreign.Storable (Storable(..))+import GHC.Base (nullAddr#, realWorld#, build)+import GHC.Exts (IsList, IsString(..))+import GHC.ForeignPtr (ForeignPtr(..))+import GHC.IO (IO(IO), unsafePerformIO)+import GHC.Ptr (Ptr(..))++import Streamly.Internal.BaseCompat+import Streamly.Internal.Data.Fold.Type (Fold(..))+import Streamly.Internal.Data.Producer.Type (Producer (..))+import Streamly.Internal.Data.SVar (adaptState)+import Streamly.Internal.Data.Unfold.Type (Unfold(..))+import Text.Read (readPrec, readListPrec, readListPrecDefault)++#ifdef DEVBUILD+import qualified Data.Foldable as F+#endif+import qualified GHC.Exts as Exts+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.Foreign.Malloc as Malloc++import Prelude hiding (length, foldr, read, unlines, splitAt)++#if MIN_VERSION_base(4,10,0)+import Foreign.ForeignPtr (plusForeignPtr)+#else+import GHC.Base (Int(..), plusAddr#)+import GHC.ForeignPtr (ForeignPtr(..))+plusForeignPtr :: ForeignPtr a -> Int -> ForeignPtr b+plusForeignPtr (ForeignPtr addr c) (I# d) = ForeignPtr (plusAddr# addr d) c+#endif++-------------------------------------------------------------------------------+-- Array Data Type+-------------------------------------------------------------------------------++-- $arrayNotes+--+-- We can use a 'Storable' 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.+--+-- XXX Rename the fields to better names.+--+data Array a =+#ifdef DEVBUILD+    Storable a =>+#endif+    Array+    { aStart :: {-# UNPACK #-} !(ForeignPtr a) -- ^ first address+    , aEnd   :: {-# UNPACK #-} !(Ptr a)        -- ^ first unused address+    , aBound :: {-# UNPACK #-} !(Ptr a)        -- ^ first address beyond allocated memory+    }++{-# INLINE mutableArray #-}+mutableArray ::+#ifdef DEVBUILD+    Storable a =>+#endif+    ForeignPtr a -> Ptr a -> Ptr a -> Array a+mutableArray = Array++-------------------------------------------------------------------------------+-- Utility functions+-------------------------------------------------------------------------------++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)++-- 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))++foreign import ccall unsafe "string.h memcmp" c_memcmp+    :: Ptr Word8 -> Ptr Word8 -> CSize -> IO CInt++-- 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++{-# INLINE unsafeInlineIO #-}+unsafeInlineIO :: IO a -> a+unsafeInlineIO (IO m) = case m realWorld# of (# _, r #) -> r++{-# INLINE bytesToElemCount #-}+bytesToElemCount :: Storable a => a -> Int -> Int+bytesToElemCount x n =+    let elemSize = sizeOf x+    in n + elemSize - 1 `div` elemSize+++-- | GHC memory management allocation header overhead+allocOverhead :: Int+allocOverhead = 2 * sizeOf (undefined :: Int)++mkChunkSize :: Int -> Int+mkChunkSize n = let size = n - allocOverhead in max size 0++mkChunkSizeKB :: Int -> Int+mkChunkSizeKB n = mkChunkSize (n * k)+   where k = 1024++-- | 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 = mkChunkSizeKB 32++-- | Remove the free space from an Array.+shrinkToFit :: forall a. Storable a => Array a -> IO (Array a)+shrinkToFit arr@Array{..} = do+    assert (aEnd <= aBound) (return ())+    let start = unsafeForeignPtrToPtr aStart+    let used = aEnd `minusPtr` start+        waste = aBound `minusPtr` aEnd+    -- if used == waste == 0 then do not realloc+    -- if the wastage is more than 25% of the array then realloc+    if used < 3 * waste+    then realloc used arr+    else return arr++-------------------------------------------------------------------------------+-- Construction+-------------------------------------------------------------------------------++-- | allocate a new array using the provided allocator function.+{-# INLINE newArrayAlignedAllocWith #-}+newArrayAlignedAllocWith :: forall a. Storable a+    => (Int -> Int -> IO (ForeignPtr a)) -> Int -> Int -> IO (Array a)+newArrayAlignedAllocWith alloc alignSize count = do+    let size = count * sizeOf (undefined :: a)+    fptr <- alloc size alignSize+    let p = unsafeForeignPtrToPtr fptr+    return $ Array+        { aStart = fptr+        , aEnd   = p+        , aBound = p `plusPtr` size+        }++-- | Allocate a new array aligned to the specified alignmend and using+-- unmanaged pinned memory. The memory will not be automatically freed by GHC.+-- This could be useful in allocate once global data structures. Use carefully+-- as incorrect use can lead to memory leak.+{-# INLINE newArrayAlignedUnmanaged #-}+newArrayAlignedUnmanaged :: forall a. Storable a => Int -> Int -> IO (Array a)+newArrayAlignedUnmanaged =+    newArrayAlignedAllocWith Malloc.mallocForeignPtrAlignedUnmanagedBytes++{-# INLINE newArrayAligned #-}+newArrayAligned :: forall a. Storable a => Int -> Int -> IO (Array a)+newArrayAligned = newArrayAlignedAllocWith Malloc.mallocForeignPtrAlignedBytes++-- XXX can unaligned allocation be more efficient when alignment is not needed?+--+-- | Allocate an array that can hold 'count' items.  The memory of the array is+-- uninitialized.+--+-- Note that this is internal routine, the reference to this array cannot be+-- given out until the array has been written to and frozen.+{-# INLINE newArray #-}+newArray :: forall a. Storable a => Int -> IO (Array a)+newArray = newArrayAligned (alignment (undefined :: a))++-- | Allocate an Array of the given size and run an IO action passing the array+-- start pointer.+{-# INLINE unsafeWithNewArray #-}+unsafeWithNewArray :: forall a. Storable a => Int -> (Ptr a -> IO ()) -> IO (Array a)+unsafeWithNewArray count f = do+    arr <- newArray count+    unsafeWithForeignPtr (aStart arr) $ \p -> f p >> return arr++-------------------------------------------------------------------------------+-- snoc+-------------------------------------------------------------------------------++{-# INLINE unsafeWriteIndex #-}+unsafeWriteIndex :: forall a. Storable a => Array a -> Int -> a -> IO (Array a)+unsafeWriteIndex arr@Array {..} i x =+    unsafeWithForeignPtr aStart+        $ \begin -> do+              poke (begin `plusPtr` (i * sizeOf (undefined :: a))) x+              return arr++-- XXX grow the array when we are beyond bound.+--+-- Internal routine for when the array is being created. Appends one item at+-- the end of the array. Useful when sequentially writing a stream to the+-- array.+{-# INLINE unsafeSnoc #-}+unsafeSnoc :: forall a. Storable a => Array a -> a -> IO (Array a)+unsafeSnoc arr@Array {..} x = do+    when (aEnd == aBound) $ error "BUG: unsafeSnoc: writing beyond array bounds"+    poke aEnd x+    touchForeignPtr aStart+    return $ arr {aEnd = aEnd `plusPtr` sizeOf (undefined :: a)}++{-# INLINE snoc #-}+snoc :: forall a. Storable a => Array a -> a -> IO (Array a)+snoc arr@Array {..} x =+    if aEnd == aBound+    then do+        let oldStart = unsafeForeignPtrToPtr aStart+            size = aEnd `minusPtr` oldStart+            newSize = size + sizeOf (undefined :: a)+        newPtr <-+            Malloc.mallocForeignPtrAlignedBytes+                newSize+                (alignment (undefined :: a))+        unsafeWithForeignPtr newPtr $ \pNew -> do+            memcpy (castPtr pNew) (castPtr oldStart) size+            poke (pNew `plusPtr` size) x+            touchForeignPtr aStart+            return $+                Array+                    { aStart = newPtr+                    , aEnd = pNew `plusPtr` (size + sizeOf (undefined :: a))+                    , aBound = pNew `plusPtr` newSize+                    }+    else do+        poke aEnd x+        touchForeignPtr aStart+        return $ arr {aEnd = aEnd `plusPtr` sizeOf (undefined :: a)}++-------------------------------------------------------------------------------+-- re-allocate+-------------------------------------------------------------------------------++-- | Reallocate the array to the specified size in bytes. If the size is less+-- than the original array the array gets truncated.+{-# NOINLINE reallocAligned #-}+reallocAligned :: Int -> Int -> Array a -> IO (Array a)+reallocAligned alignSize newSize Array{..} = do+    assert (aEnd <= aBound) (return ())+    let oldStart = unsafeForeignPtrToPtr aStart+    let size = aEnd `minusPtr` oldStart+    newPtr <- Malloc.mallocForeignPtrAlignedBytes newSize alignSize+    unsafeWithForeignPtr newPtr $ \pNew -> do+        memcpy (castPtr pNew) (castPtr oldStart) size+        touchForeignPtr aStart+        return $ Array+            { aStart = newPtr+            , aEnd   = pNew `plusPtr` size+            , aBound = pNew `plusPtr` newSize+            }++-- XXX can unaligned allocation be more efficient when alignment is not needed?+{-# INLINABLE realloc #-}+realloc :: forall a. Storable a => Int -> Array a -> IO (Array a)+realloc = reallocAligned (alignment (undefined :: a))++-------------------------------------------------------------------------------+-- 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. Storable a => Array a -> Int -> IO a+unsafeIndexIO Array {..} i =+        unsafeWithForeignPtr aStart $ \p -> do+        let elemSize = sizeOf (undefined :: a)+            elemOff = p `plusPtr` (elemSize * i)+        assert (i >= 0 && elemOff `plusPtr` elemSize <= aEnd)+               (return ())+        peek elemOff++-- | Return element at the specified index without checking the bounds.+{-# INLINE_NORMAL unsafeIndex #-}+unsafeIndex :: forall a. Storable a => Array a -> Int -> a+unsafeIndex arr i = let !r = unsafeInlineIO $ unsafeIndexIO arr i in r++-- | /O(1)/ Get the byte length of the array.+--+-- @since 0.7.0+{-# INLINE byteLength #-}+byteLength :: Array a -> Int+byteLength Array{..} =+    let p = unsafeForeignPtrToPtr aStart+        len = aEnd `minusPtr` p+    in assert (len >= 0) len++-- | /O(1)/ Get the length of the array i.e. the number of elements in the+-- array.+--+-- @since 0.7.0+{-# INLINE length #-}+length :: forall a. Storable a => Array a -> Int+length arr = byteLength arr `div` sizeOf (undefined :: a)++-- | 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 :: Array a -> Int+byteCapacity Array{..} =+    let p = unsafeForeignPtrToPtr aStart+        len = aBound `minusPtr` p+    in assert (len >= 0) len++-------------------------------------------------------------------------------+-- Streams of arrays - Creation+-------------------------------------------------------------------------------++data GroupState s start end bound+    = GroupStart s+    | GroupBuffer s start end bound+    | GroupYield start end bound (GroupState s start end bound)+    | GroupFinish++-- | @arraysOf n stream@ groups the input stream into a stream of+-- arrays of size n.+--+-- @arraysOf n = StreamD.foldMany (Array.writeN n)@+--+-- /Pre-release/+{-# INLINE_NORMAL arraysOf #-}+arraysOf :: forall m a. (MonadIO m, Storable a)+    => Int -> D.Stream m a -> D.Stream m (Array 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.+-- arraysOf n = D.foldMany (writeN n)+arraysOf 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.Array.Foreign.Mut.Type.fromStreamDArraysOf: the size of "+                 ++ "arrays [" ++ show n ++ "] must be a natural number"+        Array start end bound <- liftIO $ newArray n+        return $ D.Skip (GroupBuffer st start end bound)++    step' gst (GroupBuffer st start end bound) = do+        r <- step (adaptState gst) st+        case r of+            D.Yield x s -> do+                liftIO $ poke end x+                let end' = end `plusPtr` sizeOf (undefined :: a)+                return $+                    if end' >= bound+                    then D.Skip (GroupYield start end' bound (GroupStart s))+                    else D.Skip (GroupBuffer s start end' bound)+            D.Skip s -> return $ D.Skip (GroupBuffer s start end bound)+            D.Stop -> return $ D.Skip (GroupYield start end bound GroupFinish)++    step' _ (GroupYield start end bound next) =+        return $ D.Yield (Array start end bound) next++    step' _ GroupFinish = return D.Stop++-- XXX buffer to a list instead?+-- | Buffer the stream into arrays in memory.+{-# INLINE bufferChunks #-}+bufferChunks :: (MonadIO m, Storable a) =>+    D.Stream m a -> m (K.Stream m (Array a))+bufferChunks m = D.foldr K.cons K.nil $ arraysOf defaultChunkSize m++-------------------------------------------------------------------------------+-- Streams of arrays - flatten+-------------------------------------------------------------------------------++data ReadUState a = ReadUState+    {-# UNPACK #-} !(ForeignPtr a)  -- foreign ptr with end of array pointer+    {-# UNPACK #-} !(Ptr a)         -- current pointer++-- | Resumable unfold of an array.+--+{-# INLINE_NORMAL producer #-}+producer :: forall m a. (Monad m, Storable a) => Producer m (Array a) a+producer = Producer step inject extract+    where++    inject (Array (ForeignPtr start contents) (Ptr end) _) =+        return $ ReadUState (ForeignPtr end contents) (Ptr start)++    {-# INLINE_LATE step #-}+    step (ReadUState fp@(ForeignPtr end _) p) | p == Ptr end =+        let x = unsafeInlineIO $ touchForeignPtr fp+        in x `seq` return D.Stop+    step (ReadUState fp 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 $ peek p+            return $ D.Yield x+                (ReadUState fp (p `plusPtr` sizeOf (undefined :: a)))++    extract (ReadUState (ForeignPtr end contents) (Ptr p)) =+        return $ Array (ForeignPtr p contents) (Ptr end) (Ptr end)++-- | Unfold an array into a stream.+--+-- @since 0.7.0+{-# INLINE_NORMAL read #-}+read :: forall m a. (Monad m, Storable a) => Unfold m (Array a) a+read = Producer.simplify producer++-- | Unfold an array into a stream in reverse order.+--+-- /Pre-release/+{-# INLINE_NORMAL readRev #-}+readRev :: forall m a. (Monad m, Storable a) => Unfold m (Array a) a+readRev = Unfold step inject+    where++    inject (Array fp end _) =+        let p = end `plusPtr` negate (sizeOf (undefined :: a))+         in return $ ReadUState fp p++    {-# INLINE_LATE step #-}+    step (ReadUState fp@(ForeignPtr start _) p) | p < Ptr start =+        let x = unsafeInlineIO $ touchForeignPtr fp+        in x `seq` return D.Stop+    step (ReadUState fp 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 $ peek p+            return $ D.Yield x+                (ReadUState fp (p `plusPtr` negate (sizeOf (undefined :: a))))++data FlattenState s a =+      OuterLoop s+    | InnerLoop s !(ForeignPtr a) !(Ptr a) !(Ptr a)++-- | 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, Storable a)+    => D.Stream m (Array 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 Array{..} s ->+                let p = unsafeForeignPtrToPtr aStart+                in D.Skip (InnerLoop s aStart p aEnd)+            D.Skip s -> D.Skip (OuterLoop s)+            D.Stop -> D.Stop++    step' _ (InnerLoop st _ p end) | p == end =+        return $ D.Skip $ OuterLoop st++    step' _ (InnerLoop st startf p end) = do+        x <- liftIO $ do+                    r <- peek p+                    touchForeignPtr startf+                    return r+        return $ D.Yield x (InnerLoop st startf+                            (p `plusPtr` sizeOf (undefined :: a)) end)++-- | 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, Storable a)+    => D.Stream m (Array 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 Array{..} s ->+                let p = aEnd `plusPtr` negate (sizeOf (undefined :: a))+                -- XXX we do not need aEnd+                in D.Skip (InnerLoop s aStart p aEnd)+            D.Skip s -> D.Skip (OuterLoop s)+            D.Stop -> D.Stop++    step' _ (InnerLoop st start p _) | p < unsafeForeignPtrToPtr start =+        return $ D.Skip $ OuterLoop st++    step' _ (InnerLoop st startf p end) = do+        x <- liftIO $ do+                    r <- peek p+                    touchForeignPtr startf+                    return r+        return $ D.Yield x (InnerLoop st startf+                            (p `plusPtr` negate (sizeOf (undefined :: a))) end)++-------------------------------------------------------------------------------+-- 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. Storable a => (a -> b -> b) -> b -> Array a -> b+toListFB c n Array{..} = go (unsafeForeignPtrToPtr aStart)+    where++    go p | p == aEnd = 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.+        let !x = unsafeInlineIO $ do+                    r <- peek p+                    touchForeignPtr aStart+                    return r+        in c x (go (p `plusPtr` sizeOf (undefined :: a)))++-- | Convert an 'Array' into a list.+--+-- @since 0.7.0+{-# INLINE toList #-}+toList :: Storable a => Array a -> [a]+toList s = build (\c n -> toListFB c n s)++-- | Use the 'read' unfold instead.+--+-- @toStreamD = D.unfold read@+--+-- We can try this if the unfold has any performance issues.+{-# INLINE_NORMAL toStreamD #-}+toStreamD :: forall m a. (Monad m, Storable a) => Array a -> D.Stream m a+toStreamD Array{..} =+    let p = unsafeForeignPtrToPtr aStart+    in D.Stream step p++    where++    {-# INLINE_LATE step #-}+    step _ p | p == aEnd = return D.Stop+    step _ 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 $ do+                    r <- peek p+                    touchForeignPtr aStart+                    return r+        return $ D.Yield x (p `plusPtr` sizeOf (undefined :: a))++{-# INLINE toStreamK #-}+toStreamK :: forall t m a. (K.IsStream t, Storable a) => Array a -> t m a+toStreamK Array{..} =+    let p = unsafeForeignPtrToPtr aStart+    in go p++    where++    go p | p == aEnd = K.nil+         | otherwise =+        -- See Note in toStreamD.+        let !x = unsafeInlineIO $ do+                    r <- peek p+                    touchForeignPtr aStart+                    return r+        in x `K.cons` go (p `plusPtr` sizeOf (undefined :: a))++-- | Use the 'readRev' unfold instead.+--+-- @toStreamDRev = D.unfold readRev@+--+-- We can try this if the unfold has any perf issues.+{-# INLINE_NORMAL toStreamDRev #-}+toStreamDRev :: forall m a. (Monad m, Storable a) => Array a -> D.Stream m a+toStreamDRev Array{..} =+    let p = aEnd `plusPtr` negate (sizeOf (undefined :: a))+    in D.Stream step p++    where++    {-# INLINE_LATE step #-}+    step _ p | p < unsafeForeignPtrToPtr aStart = return D.Stop+    step _ p = do+        -- See comments in toStreamD for why we use unsafeInlineIO+        let !x = unsafeInlineIO $ do+                    r <- peek p+                    touchForeignPtr aStart+                    return r+        return $ D.Yield x (p `plusPtr` negate (sizeOf (undefined :: a)))++{-# INLINE toStreamKRev #-}+toStreamKRev :: forall t m a. (K.IsStream t, Storable a) => Array a -> t m a+toStreamKRev Array {..} =+    let p = aEnd `plusPtr` negate (sizeOf (undefined :: a))+    in go p++    where++    go p | p < unsafeForeignPtrToPtr aStart = K.nil+         | otherwise =+        let !x = unsafeInlineIO $ do+                    r <- peek p+                    touchForeignPtr aStart+                    return r+        in x `K.cons` go (p `plusPtr` negate (sizeOf (undefined :: a)))++-------------------------------------------------------------------------------+-- Folding+-------------------------------------------------------------------------------++-- | Strict left fold of an array.+{-# INLINE_NORMAL foldl' #-}+foldl' :: forall a b. Storable a => (b -> a -> b) -> b -> Array a -> b+foldl' f z arr = runIdentity $ D.foldl' f z $ toStreamD arr++-- | Right fold of an array.+{-# INLINE_NORMAL foldr #-}+foldr :: Storable a => (a -> b -> b) -> b -> Array a -> b+foldr f z arr = runIdentity $ D.foldr f z $ toStreamD arr++-------------------------------------------------------------------------------+-- Write Folds to fold streams into arrays+-------------------------------------------------------------------------------++{-# INLINE_NORMAL writeNAllocWith #-}+writeNAllocWith :: forall m a. (MonadIO m, Storable a)+    => (Int -> IO (Array a)) -> Int -> Fold m a (Array a)+writeNAllocWith alloc n = Fold step initial extract++    where++    initial = FL.Partial <$> liftIO (alloc (max n 0))+    step arr@(Array _ end bound) _ | end == bound = return $ FL.Done arr+    step (Array start end bound) x = do+        liftIO $ poke end x+        return $ FL.Partial $ Array start (end `plusPtr` sizeOf (undefined :: a)) bound+    -- XXX note that shirkToFit does not maintain alignment, in case we are+    -- using aligned allocation.+    extract = return -- liftIO . shrinkToFit++-- | @writeN n@ folds a maximum of @n@ elements from the input stream to an+-- 'Array'.+--+-- @writeN n = Fold.take n writeNUnsafe@+--+-- @since 0.7.0+{-# INLINE_NORMAL writeN #-}+writeN :: forall m a. (MonadIO m, Storable a) => Int -> Fold m a (Array a)+writeN = writeNAllocWith newArray++-- | @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, Storable a)+    => Int -> Int -> Fold m a (Array a)+writeNAligned alignSize = writeNAllocWith (newArrayAligned alignSize)++-- | @writeNAlignedUnmanaged n@ folds a maximum of @n@ elements from the input+-- stream to an 'Array' aligned to the given size and using unmanaged memory.+-- This could be useful to allocate memory that we need to allocate only once+-- in the lifetime of the program.+--+-- /Pre-release/+--+{-# INLINE_NORMAL writeNAlignedUnmanaged #-}+writeNAlignedUnmanaged :: forall m a. (MonadIO m, Storable a)+    => Int -> Int -> Fold m a (Array a)+writeNAlignedUnmanaged alignSize =+    writeNAllocWith (newArrayAlignedUnmanaged alignSize)++data ArrayUnsafe a = ArrayUnsafe+    {-# UNPACK #-} !(ForeignPtr a) -- first address+    {-# UNPACK #-} !(Ptr a)        -- first unused address++-- | 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.+--+-- @since 0.7.0+{-# INLINE_NORMAL writeNUnsafe #-}+writeNUnsafe :: forall m a. (MonadIO m, Storable a)+    => Int -> Fold m a (Array a)+writeNUnsafe n = Fold step initial extract++    where++    initial = do+        (Array start end _) <- liftIO $ newArray (max n 0)+        return $ FL.Partial $ ArrayUnsafe start end++    step (ArrayUnsafe start end) x = do+        liftIO $ poke end x+        return+          $ FL.Partial+          $ ArrayUnsafe start (end `plusPtr` sizeOf (undefined :: a))++    extract (ArrayUnsafe start end) = return $ Array start end end -- liftIO . shrinkToFit++-- XXX Buffer to a list instead?+--+-- | Buffer a stream into a stream of arrays.+--+-- @writeChunks = Fold.many Fold.toStream (Array.writeN n)@+--+-- See 'bufferChunks'.+--+-- /Unimplemented/+--+{-# INLINE_NORMAL writeChunks #-}+writeChunks :: -- (MonadIO m, Storable a) =>+    Int -> Fold m a (D.Stream m (Array a))+writeChunks = undefined -- Fold.many Fold.toStream (Array.writeN n)++-- XXX Compare toArrayMinChunk with fromStreamD which uses an array of streams+-- implementation. We can write this using writeChunks above if that is faster.+-- If toArrayMinChunk 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 seems 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.++{-# INLINE_NORMAL toArrayMinChunk #-}+toArrayMinChunk :: forall m a. (MonadIO m, Storable a)+    => Int -> Int -> Fold m a (Array a)+-- toArrayMinChunk n = FL.rmapM spliceArrays $ toArraysOf n+toArrayMinChunk alignSize elemCount =+    FL.rmapM extract $ FL.foldlM' step initial++    where++    insertElem (Array start end bound) x = do+        liftIO $ poke end x+        return $ Array start (end `plusPtr` sizeOf (undefined :: a)) bound++    initial = do+        when (elemCount < 0) $ error "toArrayMinChunk: elemCount is negative"+        liftIO $ newArrayAligned alignSize elemCount+    step arr@(Array start end bound) x | end == bound = do+        let p = unsafeForeignPtrToPtr start+            oldSize = end `minusPtr` p+            newSize = max (oldSize * 2) 1+        arr1 <- liftIO $ reallocAligned alignSize newSize arr+        insertElem arr1 x+    step arr x = insertElem arr x+    extract = liftIO . shrinkToFit++-- | Fold the whole input to a single array.+--+-- /Caution! Do not use this on infinite streams./+--+-- @since 0.7.0+{-# INLINE write #-}+write :: forall m a. (MonadIO m, Storable a) => Fold m a (Array a)+write = toArrayMinChunk (alignment (undefined :: a))+                        (bytesToElemCount (undefined :: a)+                        (mkChunkSize 1024))++-- | Like 'write' but the array memory is aligned according to the specified+-- alignment size. This could be useful when we have specific alignment, for+-- example, cache aligned arrays for lookup table etc.+--+-- /Caution! Do not use this on infinite streams./+--+-- @since 0.7.0+{-# INLINE writeAligned #-}+writeAligned :: forall m a. (MonadIO m, Storable a)+    => Int -> Fold m a (Array a)+writeAligned alignSize =+    toArrayMinChunk alignSize+                    (bytesToElemCount (undefined :: a)+                    (mkChunkSize 1024))++-------------------------------------------------------------------------------+-- construct from streams, known size+-------------------------------------------------------------------------------++-- | Use the 'writeN' fold instead.+--+-- @fromStreamDN n = D.fold (writeN n)@+--+{-# INLINE_NORMAL fromStreamDN #-}+fromStreamDN :: forall m a. (MonadIO m, Storable a)+    => Int -> D.Stream m a -> m (Array a)+fromStreamDN limit str = do+    arr <- liftIO $ newArray limit+    end <- D.foldlM' fwrite (return $ aEnd arr) $ D.take limit str+    return $ arr {aEnd = end}++    where++    fwrite ptr x = do+        liftIO $ poke ptr x+        return $ ptr `plusPtr` sizeOf (undefined :: a)++-- | 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.+--+-- @since 0.7.0+{-# INLINABLE fromListN #-}+fromListN :: Storable a => Int -> [a] -> Array a+fromListN n xs = unsafePerformIO $ fromStreamDN n $ D.fromList xs++-------------------------------------------------------------------------------+-- convert stream to a single array+-------------------------------------------------------------------------------++-- 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 Array.write+-- @+--+{-# INLINE fromStreamD #-}+fromStreamD :: (MonadIO m, Storable a) => D.Stream m a -> m (Array a)+fromStreamD m = do+    buffered <- bufferChunks m+    len <- K.foldl' (+) 0 (K.map length buffered)+    fromStreamDN len $ D.unfoldMany read $ D.fromStreamK buffered++-- | Create an 'Array' from a list. The list must be of finite size.+--+-- @since 0.7.0+{-# INLINABLE fromList #-}+fromList :: Storable a => [a] -> Array a+fromList xs = unsafePerformIO $ fromStreamD $ D.fromList xs++-------------------------------------------------------------------------------+-- Combining+-------------------------------------------------------------------------------++-- | Copy two arrays into a newly allocated array.+{-# INLINE spliceTwo #-}+spliceTwo :: (MonadIO m, Storable a) => Array a -> Array a -> m (Array a)+spliceTwo arr1 arr2 = do+    let src1 = unsafeForeignPtrToPtr (aStart arr1)+        src2 = unsafeForeignPtrToPtr (aStart arr2)+        len1 = aEnd arr1 `minusPtr` src1+        len2 = aEnd arr2 `minusPtr` src2++    arr <- liftIO $ newArray (len1 + len2)+    let dst = unsafeForeignPtrToPtr (aStart arr)++    -- XXX Should we use copyMutableByteArray# instead? Is there an overhead to+    -- ccall?+    liftIO $ do+        memcpy (castPtr dst) (castPtr src1) len1+        touchForeignPtr (aStart arr1)+        memcpy (castPtr (dst `plusPtr` len1)) (castPtr src2) len2+        touchForeignPtr (aStart arr2)+    return arr { aEnd = dst `plusPtr` (len1 + len2) }++-- | Splice an array into a pre-reserved mutable array.  The user must ensure+-- that there is enough space in the mutable array, otherwise the splicing+-- fails.+{-# INLINE spliceWith #-}+spliceWith :: (MonadIO m) => Array a -> Array a -> m (Array a)+spliceWith dst@(Array _ end bound) src =+    liftIO $ do+        let srcLen = byteLength src+        if end `plusPtr` srcLen > bound+        then error+                 "Bug: spliceWith: Not enough space in the target array"+        else unsafeWithForeignPtr (aStart dst) $ \_ ->+                unsafeWithForeignPtr (aStart src) $ \psrc -> do+                     let pdst = aEnd dst+                     memcpy (castPtr pdst) (castPtr psrc) srcLen+                     return $ dst {aEnd = pdst `plusPtr` srcLen}++-- | Splice a new array into a preallocated mutable array, doubling the space+-- if there is no space in the target array.+{-# INLINE spliceWithDoubling #-}+spliceWithDoubling :: (MonadIO m, Storable a)+    => Array a -> Array a -> m (Array a)+spliceWithDoubling dst@(Array start end bound) src  = do+    assert (end <= bound) (return ())+    let srcLen = aEnd src `minusPtr` unsafeForeignPtrToPtr (aStart src)++    dst1 <-+        if end `plusPtr` srcLen >= bound+        then do+            let oldStart = unsafeForeignPtrToPtr start+                oldSize = end `minusPtr` oldStart+                newSize = max (oldSize * 2) (oldSize + srcLen)+            liftIO $ realloc newSize dst+        else return dst+    spliceWith dst1 src++-------------------------------------------------------------------------------+-- Splitting+-------------------------------------------------------------------------------++-- | Drops the separator byte+{-# INLINE breakOn #-}+breakOn :: MonadIO m+    => Word8 -> Array Word8 -> m (Array Word8, Maybe (Array Word8))+breakOn sep arr@Array{..} = liftIO $ do+    let p = unsafeForeignPtrToPtr aStart+    loc <- c_memchr p sep (fromIntegral $ aEnd `minusPtr` p)+    return $+        if loc == nullPtr+        then (arr, Nothing)+        else+            ( Array+                { aStart = aStart+                , aEnd = loc+                , aBound = loc+                }+            , Just $ Array+                    { aStart = aStart `plusForeignPtr` (loc `minusPtr` p + 1)+                    , aEnd = aEnd+                    , aBound = aBound+                    }+            )++-- | Create two slices of an array without copying the original array. The+-- specified index @i@ is the first index of the second slice.+--+-- @since 0.7.0+splitAt :: forall a. Storable a => Int -> Array a -> (Array a, Array a)+splitAt i arr@Array{..} =+    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 * sizeOf (undefined :: a)+                      p = unsafeForeignPtrToPtr aStart `plusPtr` off+                in ( Array+                  { aStart = aStart+                  , aEnd = p+                  , aBound = p+                  }+                , Array+                  { aStart = aStart `plusForeignPtr` off+                  , aEnd = aEnd+                  , aBound = aBound+                  }+                )++-------------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------------++instance (Show a, Storable a) => Show (Array a) where+    {-# INLINE showsPrec #-}+    showsPrec _ = shows . toList++instance (Storable a, Read a, Show a) => Read (Array a) where+    {-# INLINE readPrec #-}+    readPrec = do+          xs <- readPrec+          return (fromList xs)+    readListPrec = readListPrecDefault++instance (a ~ Char) => IsString (Array a) where+    {-# INLINE fromString #-}+    fromString = fromList++-- GHC versions 8.0 and below cannot derive IsList+instance Storable a => IsList (Array a) where+    type (Item (Array a)) = a+    {-# INLINE fromList #-}+    fromList = fromList+    {-# INLINE fromListN #-}+    fromListN = fromListN+    {-# INLINE toList #-}+    toList = toList++{-# INLINE arrcmp #-}+arrcmp :: Array a -> Array a -> Bool+arrcmp arr1 arr2 =+    let !res = unsafeInlineIO $ do+            let ptr1 = unsafeForeignPtrToPtr $ aStart arr1+            let ptr2 = unsafeForeignPtrToPtr $ aStart arr2+            let len1 = aEnd arr1 `minusPtr` ptr1+            let len2 = aEnd arr2 `minusPtr` ptr2++            if len1 == len2+            then do+                r <- memcmp (castPtr ptr1) (castPtr ptr2) len1+                touchForeignPtr $ aStart arr1+                touchForeignPtr $ aStart arr2+                return r+            else return False+    in res++-- XXX we are assuming that Storable equality means element equality. This may+-- or may not be correct? arrcmp is 40% faster compared to stream equality.+instance (Storable a, Eq a) => Eq (Array a) where+    {-# INLINE (==) #-}+    (==) = arrcmp+    -- arr1 == arr2 = runIdentity $ D.eqBy (==) (toStreamD arr1) (toStreamD arr2)++instance (Storable a, NFData a) => NFData (Array a) where+    {-# INLINE rnf #-}+    rnf = foldl' (\_ x -> rnf x) ()++instance (Storable a, Ord a) => Ord (Array a) where+    {-# INLINE compare #-}+    compare arr1 arr2 = unsafePerformIO $+        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 Storable 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{..} =+    let p = unsafeForeignPtrToPtr aStart+    in D.Stream step p++    where++    {-# INLINE_LATE step #-}+    step _ p | p == aEnd = return D.Stop+    step _ p = do+        x <- liftIO $ do+                    r <- peek p+                    touchForeignPtr aStart+                    return r+        return $ D.Yield x (p `plusPtr` size)++{-# INLINE_NORMAL _foldr #-}+_foldr :: forall a b. (a -> b -> b) -> b -> Array a -> b+_foldr f z arr@Array {..} =+    let !n = sizeOf (undefined :: 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+-------------------------------------------------------------------------------++-- Note: we cannot splice the second array into the free space of the first+-- array because that would require a monadic API due to mutation.+-- | Copies the two arrays into a newly allocated array.+instance Storable a => Semigroup (Array a) where+    {-# INLINE (<>) #-}+    arr1 <> arr2 = unsafePerformIO $ spliceTwo arr1 arr2++nullForeignPtr :: ForeignPtr a+nullForeignPtr = ForeignPtr nullAddr# (error "nullForeignPtr")++nil ::+#ifdef DEVBUILD+    Storable a =>+#endif+    Array a+nil = Array nullForeignPtr (Ptr nullAddr#) (Ptr nullAddr#)++instance Storable a => Monoid (Array a) where+    {-# INLINE mempty #-}+    mempty = nil+    {-# INLINE mappend #-}+    mappend = (<>)
+ src/Streamly/Internal/Data/Array/Foreign/Type.hs view
@@ -0,0 +1,680 @@+#include "inline.hs"++-- |+-- Module      : Streamly.Internal.Data.Array.Foreign.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.Foreign.Mut.Type"+--+module Streamly.Internal.Data.Array.Foreign.Type+    (+    -- $arrayNotes+      Array (..)++    -- * Freezing and Thawing+    , unsafeFreeze+    , unsafeFreezeWithShrink+    , unsafeThaw++    -- * Construction+    , spliceTwo++    , fromPtr+    , fromAddr#+    , fromCString#+    , fromList+    , fromListN+    , fromStreamDN+    , fromStreamD++    -- * Split+    , breakOn++    -- * Elimination+    , unsafeIndexIO+    , unsafeIndex+    , byteLength+    , length++    , foldl'+    , foldr+    , splitAt++    , readRev+    , toStreamD+    , toStreamDRev+    , toStreamK+    , toStreamKRev+    , toStream+    , toStreamRev+    , toList++    -- * Folds+    , toArrayMinChunk+    , writeN+    , writeNUnsafe+    , MA.ArrayUnsafe (..)+    , writeNAligned+    , writeNAlignedUnmanaged+    , write+    , writeAligned++    -- * Streams of arrays+    , arraysOf+    , bufferChunks+    , flattenArrays+    , flattenArraysRev++    -- * Utilities+    , MA.defaultChunkSize+    , MA.mkChunkSize+    , MA.mkChunkSizeKB+    , MA.unsafeInlineIO++    , MA.memcpy+    , MA.memcmp+    , MA.bytesToElemCount+    )+where++import Control.DeepSeq (NFData(..))+import Control.Monad.IO.Class (MonadIO(..))+import Data.Word (Word8)+import Foreign.C.String (CString)+import Foreign.C.Types (CSize(..))+import Foreign.Ptr (plusPtr, castPtr)+import Foreign.Storable (Storable(..))+import GHC.Base (Addr#, nullAddr#)+import GHC.Exts (IsList, IsString(..))+import GHC.ForeignPtr (ForeignPtr(..), newForeignPtr_)+#ifdef DEVBUILD+import GHC.ForeignPtr (touchForeignPtr, unsafeForeignPtrToPtr)+#endif+import GHC.IO (unsafePerformIO)+import GHC.Ptr (Ptr(..))+import Streamly.Internal.Data.Fold.Type (Fold(..))+import Streamly.Internal.Data.Unfold.Type (Unfold(..))+import Text.Read (readPrec, readListPrec, readListPrecDefault)++import Prelude hiding (length, foldr, read, unlines, splitAt)++import qualified Streamly.Internal.Data.Array.Foreign.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.Unfold.Type as Unfold+import qualified GHC.Exts as Exts++#if __GLASGOW_HASKELL__ < 808+import Data.Semigroup (Semigroup(..))+#endif++#ifdef DEVBUILD+import qualified Data.Foldable as F+#endif++--+-- $setup+-- >>> :m+-- >>> :set -XMagicHash+-- >>> import Prelude hiding (length, foldr, read, unlines, splitAt)+-- >>> import Streamly.Internal.Data.Array.Foreign as Array++-------------------------------------------------------------------------------+-- Array Data Type+-------------------------------------------------------------------------------++-- $arrayNotes+--+-- We can use a 'Storable' 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.+--+-- XXX Rename the fields to better names.+--+data Array a =+#ifdef DEVBUILD+    Storable a =>+#endif+    Array+    { aStart :: {-# UNPACK #-} !(ForeignPtr a) -- first address+    , aEnd   :: {-# UNPACK #-} !(Ptr a)        -- first unused addres+    }++-------------------------------------------------------------------------------+-- Utility functions+-------------------------------------------------------------------------------++foreign import ccall unsafe "string.h strlen" c_strlen+    :: CString -> IO CSize++-------------------------------------------------------------------------------+-- Freezing and Thawing+-------------------------------------------------------------------------------++-- | Returns an immutable array using the same underlying pointers of the+-- mutable array. If the underlying array is mutated, the immutable promise is+-- lost. Please make sure that the mutable array is never used after freezing it+-- using /unsafeFreeze/.+{-# INLINE unsafeFreeze #-}+unsafeFreeze :: MA.Array a -> Array a+unsafeFreeze (MA.Array as ae _) = Array as ae++-- | Similar to 'unsafeFreeze' but uses 'MA.shrinkToFit' on the mutable array+-- first.+{-# INLINE unsafeFreezeWithShrink #-}+unsafeFreezeWithShrink :: Storable a => MA.Array a -> Array a+unsafeFreezeWithShrink arr = unsafePerformIO $ do+  MA.Array as ae _ <- MA.shrinkToFit arr+  return $ Array as ae++-- | Returns a mutable array using the same underlying pointers of the immutable+-- array. If the resulting array is mutated, the older immutable array is+-- mutated as well. Please make sure that the immutable array is never used+-- after thawing it using /unsafeThaw/.+{-# INLINE unsafeThaw #-}+unsafeThaw :: Array a -> MA.Array a+unsafeThaw (Array as ae) = MA.Array as ae ae++-------------------------------------------------------------------------------+-- Construction+-------------------------------------------------------------------------------++-- Splice two immutable arrays creating a new array.+{-# INLINE spliceTwo #-}+spliceTwo :: (MonadIO m, Storable a) => Array a -> Array a -> m (Array a)+spliceTwo arr1 arr2 =+    unsafeFreeze <$> MA.spliceTwo (unsafeThaw arr1) (unsafeThaw arr2)++-- | Create an 'Array' of the given number of elements of type @a@ from a read+-- only pointer @Ptr a@.  The pointer is not freed when the array is garbage+-- collected. This API is unsafe for the following reasons:+--+-- 1. The pointer must point to static pinned memory or foreign memory that+-- does not require freeing..+-- 2. The pointer must be legally accessible upto the given length.+-- 3. To guarantee that the array is immutable, the contents of the address+-- must be guaranteed to not change.+--+-- /Unsafe/+--+-- /Pre-release/+--+{-# INLINE fromPtr #-}+fromPtr ::+#ifdef DEVBUILD+    Storable a =>+#endif+    Int -> Ptr a -> Array a+fromPtr n ptr = MA.unsafeInlineIO $ do+    fptr <- newForeignPtr_ ptr+    let end = ptr `plusPtr` n+    return $ Array+        { aStart = fptr+        , aEnd   = end+        }++-- XXX when converting an array of Word8 from a literal string we can simply+-- refer to the literal string. Is it possible to write rules such that+-- fromList Word8 can be rewritten so that GHC does not first convert the+-- literal to [Char] and then we convert it back to an Array Word8?+--+-- TBD: We can also add template haskell quasiquotes to specify arrays of other+-- literal types. TH will encode them into a string literal and we read that as+-- an array of the required type. With template Haskell we can provide a safe+-- version of fromString#.+--+-- | Create an @Array Word8@ of the given length from a static, read only+-- machine address 'Addr#'. See 'fromPtr' for safety caveats.+--+-- A common use case for this API is to create an array from a static unboxed+-- string literal. GHC string literals are of type 'Addr#', and must contain+-- characters that can be encoded in a byte i.e. characters or literal bytes in+-- the range from 0-255.+--+-- >>> import Data.Word (Word8)+-- >>> Array.fromAddr# 5 "hello world!"# :: Array Word8+-- [104,101,108,108,111]+--+-- >>> Array.fromAddr# 3 "\255\NUL\255"# :: Array Word8+-- [255,0,255]+--+-- /See also: 'fromString#'/+--+-- /Unsafe/+--+-- /Time complexity: O(1)/+--+-- /Pre-release/+--+{-# INLINE fromAddr# #-}+fromAddr# ::+#ifdef DEVBUILD+    Storable a =>+#endif+    Int -> Addr# -> Array a+fromAddr# n addr# = fromPtr n (castPtr $ Ptr addr#)++-- | Generate a byte array from an 'Addr#' that contains a sequence of NUL+-- (@0@) terminated bytes. The array would not include the NUL byte. The+-- address must be in static read-only memory and must be legally accessible up+-- to and including the first NUL byte.+--+-- An unboxed string literal (e.g. @"hello"#@) is a common example of an+-- 'Addr#' in static read only memory. It represents the UTF8 encoded sequence+-- of bytes terminated by a NUL byte (a 'CString') corresponding to the+-- given unicode string.+--+-- >>> Array.fromCString# "hello world!"#+-- [104,101,108,108,111,32,119,111,114,108,100,33]+--+-- >>> Array.fromCString# "\255\NUL\255"#+-- [255]+--+-- /See also: 'fromAddr#'/+--+-- /Unsafe/+--+-- /Time complexity: O(n) (computes the length of the string)/+--+-- /Pre-release/+--+{-# INLINE fromCString# #-}+fromCString# :: Addr# -> Array Word8+fromCString# addr# = do+    let cstr = Ptr addr#+        len = MA.unsafeInlineIO $ c_strlen cstr+    fromPtr (fromIntegral len) (castPtr cstr)++-- | 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.+--+-- /Since 0.7.0 (Streamly.Memory.Array)/+--+-- @since 0.8.0+{-# INLINABLE fromListN #-}+fromListN :: Storable a => Int -> [a] -> Array a+fromListN n xs = unsafeFreeze $ MA.fromListN n xs++-- | Create an 'Array' from a list. The list must be of finite size.+--+-- /Since 0.7.0 (Streamly.Memory.Array)/+--+-- @since 0.8.0+{-# INLINABLE fromList #-}+fromList :: Storable a => [a] -> Array a+fromList xs = unsafeFreeze $ MA.fromList xs++{-# INLINE_NORMAL fromStreamDN #-}+fromStreamDN :: forall m a. (MonadIO m, Storable 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, Storable a)+    => D.Stream m a -> m (Array a)+fromStreamD str = unsafeFreeze <$> MA.fromStreamD str++-------------------------------------------------------------------------------+-- Streams of arrays+-------------------------------------------------------------------------------++{-# INLINE bufferChunks #-}+bufferChunks :: (MonadIO m, Storable a) =>+    D.Stream m a -> m (K.Stream m (Array a))+bufferChunks m = D.foldr K.cons K.nil $ arraysOf MA.defaultChunkSize m++-- | @arraysOf n stream@ groups the input stream into a stream of+-- arrays of size n.+{-# INLINE_NORMAL arraysOf #-}+arraysOf :: forall m a. (MonadIO m, Storable a)+    => Int -> D.Stream m a -> D.Stream m (Array a)+arraysOf n str = D.map unsafeFreeze $ MA.arraysOf 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, Storable 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, Storable 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. Storable a => Array a -> Int -> IO a+unsafeIndexIO arr = MA.unsafeIndexIO (unsafeThaw arr)++-- | Return element at the specified index without checking the bounds.+{-# INLINE_NORMAL unsafeIndex #-}+unsafeIndex :: forall a. Storable a => Array a -> Int -> a+unsafeIndex arr = MA.unsafeIndex (unsafeThaw arr)++-- | /O(1)/ Get the byte length of the array.+--+-- @since 0.7.0+{-# 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.+--+-- /Since 0.7.0 (Streamly.Memory.Array)/+--+-- @since 0.8.0+{-# INLINE length #-}+length :: forall a. Storable a => Array a -> Int+length arr =  MA.length (unsafeThaw arr)++-- | Unfold an array into a stream in reverse order.+--+-- @since 0.8.0+{-# INLINE_NORMAL readRev #-}+readRev :: forall m a. (Monad m, Storable a) => Unfold m (Array a) a+readRev = Unfold.lmap unsafeThaw MA.readRev++{-# INLINE_NORMAL toStreamD #-}+toStreamD :: forall m a. (Monad m, Storable a) => Array a -> D.Stream m a+toStreamD arr = MA.toStreamD (unsafeThaw arr)++{-# INLINE toStreamK #-}+toStreamK :: forall t m a. (K.IsStream t, Storable a) => Array a -> t m a+toStreamK arr = MA.toStreamK (unsafeThaw arr)++{-# INLINE_NORMAL toStreamDRev #-}+toStreamDRev :: forall m a. (Monad m, Storable a) => Array a -> D.Stream m a+toStreamDRev arr = MA.toStreamDRev (unsafeThaw arr)++{-# INLINE toStreamKRev #-}+toStreamKRev :: forall t m a. (K.IsStream t, Storable a) => Array a -> t m a+toStreamKRev arr = MA.toStreamKRev (unsafeThaw arr)++-- | Convert an 'Array' into a stream.+--+-- /Pre-release/+{-# INLINE_EARLY toStream #-}+toStream :: (Monad m, K.IsStream t, Storable a) => Array a -> t m a+toStream = D.fromStreamD . toStreamD+-- 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 toStreamRev #-}+toStreamRev :: (Monad m, K.IsStream t, Storable a) => Array a -> t m a+toStreamRev = D.fromStreamD . toStreamDRev++-- 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. Storable a => (b -> a -> b) -> b -> Array a -> b+foldl' f z arr = MA.foldl' f z (unsafeThaw arr)++{-# INLINE_NORMAL foldr #-}+foldr :: Storable a => (a -> b -> b) -> b -> Array a -> b+foldr f z arr = MA.foldr f z (unsafeThaw arr)++-- | Create two slices of an array without copying the original array. The+-- specified index @i@ is the first index of the second slice.+--+-- @since 0.7.0+splitAt :: forall a. Storable a => Int -> Array a -> (Array a, Array a)+splitAt i arr = (unsafeFreeze a, unsafeFreeze b)+  where+    (a, b) = MA.splitAt i (unsafeThaw arr)++-- | Convert an 'Array' into a list.+--+-- /Since 0.7.0 (Streamly.Memory.Array)/+--+-- @since 0.8.0+{-# INLINE toList #-}+toList :: Storable a => Array a -> [a]+toList = MA.toList . unsafeThaw++-------------------------------------------------------------------------------+-- Folds+-------------------------------------------------------------------------------++-- | @writeN n@ folds a maximum of @n@ elements from the input stream to an+-- 'Array'.+--+-- /Since 0.7.0 (Streamly.Memory.Array)/+--+-- @since 0.8.0+{-# INLINE_NORMAL writeN #-}+writeN :: forall m a. (MonadIO m, Storable 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, Storable a)+    => Int -> Int -> Fold m a (Array a)+writeNAligned alignSize = fmap unsafeFreeze . MA.writeNAligned alignSize++-- | @writeNAlignedUnmanaged n@ folds a maximum of @n@ elements from the input+-- stream to an 'Array' aligned to the given size and using unmanaged memory.+-- This could be useful to allocate memory that we need to allocate only once+-- in the lifetime of the program.+--+-- /Pre-release/+--+{-# INLINE_NORMAL writeNAlignedUnmanaged #-}+writeNAlignedUnmanaged :: forall m a. (MonadIO m, Storable a)+    => Int -> Int -> Fold m a (Array a)+writeNAlignedUnmanaged alignSize =+    fmap unsafeFreeze . MA.writeNAlignedUnmanaged 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.+--+-- @since 0.7.0+{-# INLINE_NORMAL writeNUnsafe #-}+writeNUnsafe :: forall m a. (MonadIO m, Storable a)+    => Int -> Fold m a (Array a)+writeNUnsafe n = unsafeFreeze <$> MA.writeNUnsafe n++-- 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 seems 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.++{-# INLINE_NORMAL toArrayMinChunk #-}+toArrayMinChunk :: forall m a. (MonadIO m, Storable a)+    => Int -> Int -> Fold m a (Array a)+-- toArrayMinChunk n = FL.rmapM spliceArrays $ toArraysOf n+toArrayMinChunk alignSize elemCount =+    unsafeFreeze <$> MA.toArrayMinChunk alignSize elemCount++-- | Fold the whole input to a single array.+--+-- /Caution! Do not use this on infinite streams./+--+-- /Since 0.7.0 (Streamly.Memory.Array)/+--+-- @since 0.8.0+{-# INLINE write #-}+write :: forall m a. (MonadIO m, Storable a) => Fold m a (Array a)+write = fmap unsafeFreeze MA.write++-- | Like 'write' but the array memory is aligned according to the specified+-- alignment size. This could be useful when we have specific alignment, for+-- example, cache aligned arrays for lookup table etc.+--+-- /Caution! Do not use this on infinite streams./+--+-- @since 0.7.0+{-# INLINE writeAligned #-}+writeAligned :: forall m a. (MonadIO m, Storable a)+    => Int -> Fold m a (Array a)+writeAligned = fmap unsafeFreeze . MA.writeAligned++-------------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------------++instance (Show a, Storable a) => Show (Array a) where+    {-# INLINE showsPrec #-}+    showsPrec _ = shows . toList++instance (Storable a, Read a, Show a) => Read (Array a) where+    {-# INLINE readPrec #-}+    readPrec = fromList <$> readPrec+    readListPrec = readListPrecDefault++instance (a ~ Char) => IsString (Array a) where+    {-# INLINE fromString #-}+    fromString = fromList++-- GHC versions 8.0 and below cannot derive IsList+instance Storable 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 Storable equality means element equality. This may+-- or may not be correct? arrcmp is 40% faster compared to stream equality.+instance (Storable a, Eq a) => Eq (Array a) where+    {-# INLINE (==) #-}+    a == b = unsafeThaw a == unsafeThaw b+    -- arr1 == arr2 = runIdentity $ D.eqBy (==) (toStreamD arr1) (toStreamD arr2)++instance (Storable a, NFData a) => NFData (Array a) where+    {-# INLINE rnf #-}+    rnf = foldl' (\_ x -> rnf x) ()++instance (Storable a, Ord a) => Ord (Array a) where+    {-# INLINE compare #-}+    compare a b = compare (unsafeThaw a) (unsafeThaw b)++    -- 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 Storable 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{..} =+    let p = unsafeForeignPtrToPtr aStart+    in D.Stream step p++    where++    {-# INLINE_LATE step #-}+    step _ p | p == aEnd = return D.Stop+    step _ p = do+        x <- liftIO $ do+                    r <- peek p+                    touchForeignPtr aStart+                    return r+        return $ D.Yield x (p `plusPtr` size)++{-# INLINE_NORMAL _foldr #-}+_foldr :: forall a b. (a -> b -> b) -> b -> Array a -> b+_foldr f z arr@Array {..} =+    let !n = sizeOf (undefined :: 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 Storable a => Semigroup (Array a) where+    arr1 <> arr2 = unsafePerformIO $ spliceTwo arr1 arr2++nullForeignPtr :: ForeignPtr a+nullForeignPtr = ForeignPtr nullAddr# (error "nullForeignPtr")++nil ::+#ifdef DEVBUILD+    Storable a =>+#endif+    Array a+nil = Array nullForeignPtr (Ptr nullAddr#)++instance Storable a => Monoid (Array a) where+    mempty = nil+    mappend = (<>)
+ src/Streamly/Internal/Data/Array/Prim.hs view
@@ -0,0 +1,110 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++#include "inline.hs"++-- |+-- Module      : Streamly.Internal.Data.Array.Prim+-- Copyright   : (c) 2020 Composewell Technologies+--+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+module Streamly.Internal.Data.Array.Prim+    (+      Array++    -- * Construction++    -- Pure List APIs+    , A.fromListN+    , A.fromList++    -- Stream Folds+    , fromStreamN+    , fromStream++    -- Monadic APIs+    -- , newArray+    , A.writeN      -- drop new+    , A.write       -- full buffer++    -- * Elimination++    , A.toList+    , toStream+    , toStreamRev+    , read+    , unsafeRead++    -- * Random Access+    , length+    , null+    , last+    -- , (!!)+    , readIndex+    , A.unsafeIndex+    -- , readIndices+    -- , readRanges++    -- , readFrom    -- read from a given position to the end of file+    -- , readFromRev -- read from a given position to 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++    -- , readChunksOfFrom+    -- , ...++    -- , writeIndex+    -- , writeFrom -- start writing at the given position+    -- , writeFromRev+    -- , writeTo   -- write from beginning up to the given position+    -- , writeToRev+    -- , writeFromTo+    -- , writeFromThenTo+    --+    -- , writeChunksOfFrom+    -- , ...++    -- , writeIndex+    -- , writeIndices+    -- , writeRanges++    -- -- * Search+    -- , bsearch+    -- , bsearchIndex+    -- , find+    -- , findIndex+    -- , findIndices++    -- -- * In-pace mutation (for Mutable Array type)+    -- , partitionBy+    -- , shuffleBy+    -- , foldtWith+    -- , foldbWith++    -- * Immutable Transformations+--    , streamTransform++    -- * Folding Arrays+    , streamFold+    , fold++    -- * Folds with Array as the container+--    , D.lastN++    -- * Streaming array operations++    , concat+    , compact++    )+where++import Streamly.Internal.Data.Array.Prim.Type (Array(..), length)+import qualified Streamly.Internal.Data.Array.Prim.Type as A++#include "Streamly/Internal/Data/Array/PrimInclude.hs"
+ src/Streamly/Internal/Data/Array/Prim/Mut/Type.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE UnboxedTuples #-}++#include "inline.hs"++-- |+-- Module      : Streamly.Internal.Data.Array.Prim.Mut.Type+-- Copyright   : (c) 2020 Composewell Technologies+--+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+module Streamly.Internal.Data.Array.Prim.Mut.Type+    (+      Array (..)++    -- * Construction+    , newArray+    , unsafeWriteIndex++    , spliceTwo+    , unsafeCopy++    , fromListM+    , fromListNM+    , fromStreamDN+    , fromStreamD++    -- * Streams of arrays+    , fromStreamDArraysOf++    , packArraysChunksOf+    , lpackArraysChunksOf++#if !defined(mingw32_HOST_OS)+--    , groupIOVecsOf+#endif++    -- * Elimination+    , unsafeReadIndex+    , length+    , byteLength++    , writeN+    , ArrayUnsafe(..)+    , writeNUnsafe+    , write++    -- * Utilities+    , resizeArray+    , shrinkArray+    )+where++#include "Streamly/Internal/Data/Array/Prim/MutTypesInclude.hs"++-------------------------------------------------------------------------------+-- Allocation (Unpinned)+-------------------------------------------------------------------------------++-- | Allocate an array that is unpinned and can hold 'count' items.  The memory+-- of the array is uninitialized.+--+-- Note that this is internal routine, the reference to this array cannot be+-- given out until the array has been written to and frozen.+{-# INLINE newArray #-}+newArray ::+       forall m a. (MonadIO m, Prim a)+    => Int+    -> m (Array a)+newArray (I# n#) =+    liftIO $ do+        let bytes = n# *# sizeOf# (undefined :: a)+        primitive $ \s# ->+            case newByteArray# bytes s# of+                (# s1#, arr# #) -> (# s1#, Array arr# #)++-- | Resize (unpinned) mutable byte array to new specified size (in elem+-- count). The returned array is either the original array resized in-place or,+-- if not possible, a newly allocated (unpinned) array (with the original+-- content copied over).+{-# INLINE resizeArray #-}+resizeArray ::+       forall m a. (MonadIO m, Prim a)+    => Array a+    -> Int -- ^ new size in elem count+    -> m (Array a)+resizeArray (Array arr#) (I# n#) =+    liftIO $ do+        let bytes = n# *# sizeOf# (undefined :: a)+        primitive $ \s# ->+            case resizeMutableByteArray# arr# bytes s# of+                (# s1#, arr1# #) -> (# s1#, Array arr1# #)
+ src/Streamly/Internal/Data/Array/Prim/MutTypesInclude.hs view
@@ -0,0 +1,407 @@+-- Copyright   : (c) 2020 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++import Control.Monad (when)+import Control.Monad.IO.Class (MonadIO(..))+import Data.Bifunctor (first)+import Data.Primitive.Types (Prim(..), sizeOf)+import Streamly.Internal.Data.Fold.Type (Fold(..))+import Streamly.Internal.Data.SVar (adaptState)+import Streamly.Internal.Data.Tuple.Strict (Tuple'(..), Tuple3'(..))++import qualified Streamly.Internal.Data.Fold as FL+import qualified Streamly.Internal.Data.Stream.StreamD as D++import GHC.Exts+import Control.Monad.Primitive+import Prelude hiding (length, unlines)++-------------------------------------------------------------------------------+-- Array Data Type+-------------------------------------------------------------------------------++data Array a = Array (MutableByteArray# RealWorld)++-------------------------------------------------------------------------------+-- Utilities+-------------------------------------------------------------------------------++-- | Copy a range of the first array to the specified region in the second+-- array. Both arrays must fully contain the specified ranges, but this is not+-- checked. The regions are allowed to overlap, although this is only possible+-- when the same array is provided as both the source and the destination.+{-# INLINE unsafeCopy #-}+unsafeCopy ::+       forall m a. (MonadIO m, Prim a)+    => Array a -- ^ destination array+    -> Int -- ^ offset into destination array+    -> Array a -- ^ source array+    -> Int -- ^ offset into source array+    -> Int -- ^ number of elements to copy+    -> m ()+unsafeCopy (Array dst#) (I# doff#) (Array src#) (I# soff#) (I# n#) =+    liftIO $ do+        let toBytes cnt# = cnt# *# (sizeOf# (undefined :: a))+        primitive_ $+            copyMutableByteArray#+                src#+                (toBytes soff#)+                dst#+                (toBytes doff#)+                (toBytes n#)++-------------------------------------------------------------------------------+-- Length+-------------------------------------------------------------------------------++-- XXX rename to byteCount?+{-# INLINE byteLength #-}+byteLength :: MonadIO m => Array a -> m Int+byteLength (Array arr#) =+    liftIO $+    primitive+        (\s0# ->+             case getSizeofMutableByteArray# arr# s0# of+                 (# s1#, blen# #) -> (# s1#, I# blen# #))+++-- XXX Rename length to elemCount so that there is no confusion bout what it+-- means.+--+-- XXX Since size of 'a' is statically known, we can replace `quot` with shift+-- when it is power of 2. Though it may not matter unless length is used too+-- often.+--+{-# INLINE length #-}+length ::+       forall m a. (MonadIO m, Prim a)+    => Array a+    -> m Int+length arr =+    liftIO $ do+        blen <- byteLength arr+        return $ blen `quot` (sizeOf (undefined :: a))++-------------------------------------------------------------------------------+-- Random Access+-------------------------------------------------------------------------------++{-# INLINE unsafeReadIndex #-}+unsafeReadIndex :: (MonadIO m, Prim a) => Array a -> Int -> m a+unsafeReadIndex (Array arr#) (I# i#) =+    liftIO $ primitive (readByteArray# arr# i#)++{-# INLINE unsafeWriteIndex #-}+unsafeWriteIndex ::+       (MonadIO m, Prim a)+    => Array a -- ^ array+    -> Int -- ^ index+    -> a -- ^ element+    -> m ()+unsafeWriteIndex (Array arr#) (I# i#) x =+    liftIO $ primitive_ (writeByteArray# arr# i# x)++-------------------------------------------------------------------------------+-- Construction+-------------------------------------------------------------------------------++-- Note: We do not store the actual length of the array in the Array+-- constructor. Therefore, for "length" API to work correctly we need to match+-- the ByteArray length with the used length by shrinking it.+--+-- However, it may be expensive to always shrink the array. We may want to+-- shrink only if significant space is being wasted. If we want to do that then+-- we will have to store the used length separately. Or does GHC take care of+-- that?+-- Although the docs are not explicit about it, given how the signature is,+-- the shrinking must me inplace. "resizeMutableByteArray#" shrinks the+-- array inplace.+{-# INLINE shrinkArray #-}+shrinkArray ::+       forall m a. (MonadIO m, Prim a)+    => Array a+    -> Int -- ^ new size+    -> m ()+shrinkArray (Array arr#) (I# n#) =+    liftIO $ do+        let bytes = n# *# (sizeOf# (undefined :: a))+        primitive_ (shrinkMutableByteArray# arr# bytes)++-- | Fold the whole input to a single array.+--+-- /Caution! Do not use this on infinite streams./+--+-- /Pre-release/+{-# INLINE_NORMAL write #-}+write :: (MonadIO m, Prim a) => Fold m a (Array a)+write = FL.rmapM extract $ FL.foldlM' step initial++    where++    initial = do+        marr <- newArray 0+        return $ Tuple3' marr 0 0++    step (Tuple3' marr i capacity) x+        | i == capacity = do+            let newCapacity = max (capacity * 2) 1+            newMarr <- resizeArray marr newCapacity+            unsafeWriteIndex newMarr i x+            return $ Tuple3' newMarr (i + 1) newCapacity+        | otherwise = do+            unsafeWriteIndex marr i x+            return $ Tuple3' marr (i + 1) capacity++    extract (Tuple3' marr len _) = shrinkArray marr len >> return marr++-- | @writeN n@ folds a maximum of @n@ elements from the input stream to an+-- 'Array'.+--+-- /Pre-release/+{-# INLINE_NORMAL writeN #-}+writeN :: (MonadIO m, Prim a) => Int -> Fold m a (Array a)+writeN limit = Fold step initial extract++    where++    initial = do+        marr <- newArray limit+        return $ FL.Partial $ Tuple' marr 0++    extract (Tuple' marr len) = shrinkArray marr len >> return marr++    step s@(Tuple' marr i) x+        | i == limit = FL.Done <$> extract s+        | otherwise = do+            unsafeWriteIndex marr i x+            return $ FL.Partial $ Tuple' marr (i + 1)++-- Use Tuple' instead?+data ArrayUnsafe a = ArrayUnsafe+    {-# UNPACK #-} !(Array a)+    {-# UNPACK #-} !Int++-- | 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, Prim a) => Int -> Fold m a (Array a)+writeNUnsafe n = FL.rmapM extract $ FL.foldlM' step initial++    where++    initial = do+        arr <- newArray (max n 0)+        return $ ArrayUnsafe arr 0+    step (ArrayUnsafe marr i) x = do+        unsafeWriteIndex marr i x+        return $ ArrayUnsafe marr (i + 1)+    extract (ArrayUnsafe marr i) = shrinkArray marr i >> return marr++{-# INLINE_NORMAL fromStreamDN #-}+fromStreamDN :: (MonadIO m, Prim a) => Int -> D.Stream m a -> m (Array a)+fromStreamDN limit str = do+    marr <- newArray (max limit 0)+    let step i x = i `seq` (unsafeWriteIndex marr i x) >> return (i + 1)+    n <- D.foldlM' step (return 0) $ D.take limit str+    shrinkArray marr n+    return marr++{-# INLINE fromStreamD #-}+fromStreamD :: (MonadIO m, Prim a) => D.Stream m a -> m (Array a)+fromStreamD str = D.fold write str++{-# INLINABLE fromListNM #-}+fromListNM :: (MonadIO m, Prim a) => Int -> [a] -> m (Array a)+fromListNM n xs = fromStreamDN n $ D.fromList xs++{-# INLINABLE fromListM #-}+fromListM :: (MonadIO m, Prim a) => [a] -> m (Array a)+fromListM xs = fromStreamD $ D.fromList xs++-------------------------------------------------------------------------------+-- Combining+-------------------------------------------------------------------------------++-- Splice two mutable arrays creating a new array.+{-# INLINE spliceTwo #-}+spliceTwo :: (MonadIO m, Prim a) => Array a -> Array a -> m (Array a)+spliceTwo a1 a2 = do+    l1 <- length a1+    l2 <- length a2+    a3 <- resizeArray a1 (l1 + l2)+    unsafeCopy a2 0 a3 l1 l2+    return a3++-------------------------------------------------------------------------------+-- Stream of Arrays+-------------------------------------------------------------------------------++data GroupState s a+    = GroupStart s+    | GroupBuffer s (Array a) Int+    | GroupYield (Array a) s+    | GroupLastYield (Array a) Int+    | GroupFinish++-- | @fromStreamArraysOf n stream@ groups the input stream into a stream of+-- arrays of size n.+{-# INLINE_NORMAL fromStreamDArraysOf #-}+fromStreamDArraysOf ::+       (MonadIO m, Prim a) => Int -> D.Stream m a -> D.Stream m (Array a)+-- fromStreamDArraysOf n str = D.groupsOf n (writeN n) str+fromStreamDArraysOf 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.Array.Foreign.Mut.Type.fromStreamDArraysOf: the size of " +++            "arrays [" ++ show n ++ "] must be a natural number"+        arr <- newArray n+        return $ D.Skip (GroupBuffer st arr 0)+    step' gst (GroupBuffer st arr i)+        | i < n = do+            r <- step (adaptState gst) st+            case r of+                D.Yield x s -> do+                    unsafeWriteIndex arr i x+                    return $ D.Skip (GroupBuffer s arr (i + 1))+                D.Skip s -> return $ D.Skip (GroupBuffer s arr i)+                D.Stop -> return $ D.Skip (GroupLastYield arr i)+        | otherwise = return $ D.Skip (GroupYield arr st)+    step' _ (GroupYield arr st) = do+        nArr <- newArray n+        return $ D.Yield arr (GroupBuffer st nArr 0)+    step' _ (GroupLastYield arr i)+        | i == 0 = return D.Stop+        | otherwise = do+            shrinkArray arr i+            return $ D.Yield arr GroupFinish+    step' _ GroupFinish = return D.Stop++data SpliceState s arr+    = SpliceInitial s+    | SpliceBuffering s arr+    | SpliceYielding arr (SpliceState s arr)+    | SpliceFinish++-- XXX can use general grouping combinators to achieve this?+-- | Coalesce adjacent arrays in incoming stream to form bigger arrays of a+-- maximum specified size in bytes. 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.+--+-- /Pre-release/+{-# INLINE_NORMAL packArraysChunksOf #-}+packArraysChunksOf ::+       (MonadIO m, Prim a)+    => Int+    -> D.Stream m (Array a)+    -> D.Stream m (Array 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.Foreign.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 -> do+              len <- byteLength arr+              return $+                  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+                blen <- byteLength buf+                alen <- byteLength arr+                let len = blen + alen+                if len > n+                then return $+                    D.Skip (SpliceYielding buf (SpliceBuffering s arr))+                else do+                    buf' <- spliceTwo 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++{-# INLINE_NORMAL lpackArraysChunksOf #-}+lpackArraysChunksOf ::+       (MonadIO m, Prim a) => Int -> Fold m (Array a) () -> Fold m (Array 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.Foreign.Mut.Type."+              ++ "packArraysChunksOf: the size of arrays ["+              ++ show n+              ++ "] must be a natural number"+        res <- initial1+        return $ first (Tuple' Nothing) res++    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 = do+        len <- byteLength arr+        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+        blen <- byteLength buf+        alen <- byteLength arr+        let len = blen + alen+        buf' <- spliceTwo buf arr+        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
+ src/Streamly/Internal/Data/Array/Prim/Pinned.hs view
@@ -0,0 +1,108 @@+#include "inline.hs"++-- |+-- Module      : Streamly.Internal.Data.Array.Prim.Pinned+-- Copyright   : (c) 2020 Composewell Technologies+--+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+module Streamly.Internal.Data.Array.Prim.Pinned+    (+      Array++    -- * Construction++    -- Pure List APIs+    , A.fromListN+    , A.fromList++    -- Stream Folds+    , fromStreamN+    , fromStream++    -- Monadic APIs+    -- , newArray+    , A.writeN      -- drop new+    , A.write       -- full buffer++    -- * Elimination++    , A.toList+    , toStream+    , toStreamRev+    , read+    , unsafeRead++    -- * Random Access+    , length+    , null+    , last+    -- , (!!)+    , readIndex+    , A.unsafeIndex+    -- , readIndices+    -- , readRanges++    -- , readFrom    -- read from a given position to the end of file+    -- , readFromRev -- read from a given position to 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++    -- , readChunksOfFrom+    -- , ...++    -- , writeIndex+    -- , writeFrom -- start writing at the given position+    -- , writeFromRev+    -- , writeTo   -- write from beginning up to the given position+    -- , writeToRev+    -- , writeFromTo+    -- , writeFromThenTo+    --+    -- , writeChunksOfFrom+    -- , ...++    -- , writeIndex+    -- , writeIndices+    -- , writeRanges++    -- -- * Search+    -- , bsearch+    -- , bsearchIndex+    -- , find+    -- , findIndex+    -- , findIndices++    -- -- * In-pace mutation (for Mutable Array type)+    -- , partitionBy+    -- , shuffleBy+    -- , foldtWith+    -- , foldbWith++    -- * Immutable Transformations+--    , streamTransform++    -- * Folding Arrays+    , streamFold+    , fold++    -- * Folds with Array as the container+--  , D.lastN++    -- * Streaming array operations++    , concat+    , compact++    )+where++import Streamly.Internal.Data.Array.Prim.Pinned.Type (Array(..), length)+import qualified Streamly.Internal.Data.Array.Prim.Pinned.Type as A++#include "Streamly/Internal/Data/Array/PrimInclude.hs"
+ src/Streamly/Internal/Data/Array/Prim/Pinned/Mut/Type.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE UnboxedTuples #-}++#include "inline.hs"++-- |+-- Module      : Streamly.Internal.Data.Array.Prim.Pinned.Mut.Type+-- Copyright   : (c) 2020 Composewell Technologies+--+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+module Streamly.Internal.Data.Array.Prim.Pinned.Mut.Type+    (+      Array (..)++    -- * Construction+    , newArray+    , newAlignedArray+    , unsafeWriteIndex++    , spliceTwo+    , unsafeCopy++    , fromListM+    , fromListNM+    , fromStreamDN+    , fromStreamD++    -- * Streams of arrays+    , fromStreamDArraysOf++    , packArraysChunksOf+    , lpackArraysChunksOf++#if !defined(mingw32_HOST_OS)+--    , groupIOVecsOf+#endif++    -- * Elimination+    , unsafeReadIndex+    , length+    , byteLength++    , writeN+    , ArrayUnsafe(..)+    , writeNUnsafe+    , writeNAligned+    , write++    -- * Utilities+    , resizeArray+    , shrinkArray++    , touchArray+    , withArrayAsPtr+    )+where++import GHC.IO (IO(..))++#include "Streamly/Internal/Data/Array/Prim/MutTypesInclude.hs"++-------------------------------------------------------------------------------+-- Allocation (Pinned)+-------------------------------------------------------------------------------++-- XXX we can use a single newArray routine which accepts an allocation+-- function which could be newByteArray#, newPinnedByteArray# or+-- newAlignedPinnedByteArray#. That function can go in the common include file.+--+-- | Allocate an array that is pinned and can hold 'count' items.  The memory of+-- the array is uninitialized.+--+-- Note that this is internal routine, the reference to this array cannot be+-- given out until the array has been written to and frozen.+{-# INLINE newArray #-}+newArray ::+       forall m a. (MonadIO m, Prim a)+    => Int+    -> m (Array a)+newArray (I# n#) =+    liftIO $ do+        let bytes = n# *# sizeOf# (undefined :: a)+        primitive $ \s# ->+            case newPinnedByteArray# bytes s# of+                (# s1#, arr# #) -> (# s1#, Array arr# #)++-- Change order of args?+-- | Allocate a new array aligned to the specified alignment and using pinned+-- memory.+{-# INLINE newAlignedArray #-}+newAlignedArray ::+       forall m a. (MonadIO m, Prim a)+    => Int -- size+    -> Int -- Alignment+    -> m (Array a)+newAlignedArray (I# n#) (I# a#) =+    liftIO $ do+        let bytes = n# *# sizeOf# (undefined :: a)+        primitive $ \s# ->+            case newAlignedPinnedByteArray# bytes a# s# of+                (# s1#, arr# #) -> (# s1#, Array arr# #)++-- | Resize (pinned) mutable byte array to new specified size (in elem+-- count). The returned array is either the original array resized in-place or,+-- if not possible, a newly allocated (pinned) array (with the original content+-- copied over).+{-# INLINE resizeArray #-}+resizeArray ::+       (MonadIO m, Prim a)+    => Array a+    -> Int -- ^ new size+    -> m (Array a)+resizeArray arr i = do+    len <- length arr+    if len == i+    then return arr+    else if i < len+         then shrinkArray arr i >> return arr+         else do+             nArr <- newArray i+             unsafeCopy nArr 0 arr 0 len+             return nArr++-------------------------------------------------------------------------------+-- Aligned Construction+-------------------------------------------------------------------------------++-- XXX we can also factor out common code in writeN and writeNAligned in the+-- same way as suggested above.+--+{-# INLINE_NORMAL writeNAligned #-}+writeNAligned ::+       (MonadIO m, Prim a)+    => Int+    -> Int+    -> Fold m a (Array a)+writeNAligned align limit = Fold step initial extract++    where++    initial = do+        marr <- newAlignedArray limit align+        return $ FL.Partial $ Tuple' marr 0++    extract (Tuple' marr len) = shrinkArray marr len >> return marr++    step s@(Tuple' marr i) x+        | i == limit = FL.Done <$> extract s+        | otherwise = do+            unsafeWriteIndex marr i x+            return $ FL.Partial $ Tuple' marr (i + 1)++-------------------------------------------------------------------------------+-- Mutation with pointers+-------------------------------------------------------------------------------++-- XXX This section can probably go in a common include file for pinned arrays.++-- Change name later.+{-# INLINE toPtr #-}+toPtr :: Array a -> Ptr a+toPtr (Array arr#) = Ptr (byteArrayContents# (unsafeCoerce# arr#))++{-# INLINE touchArray #-}+touchArray :: Array a -> IO ()+touchArray arr = IO $ \s -> case touch# arr s of s' -> (# s', () #)++{-# INLINE withArrayAsPtr #-}+withArrayAsPtr :: Array a -> (Ptr a -> IO b) -> IO b+withArrayAsPtr arr f = do+    r <- f (toPtr arr)+    touchArray arr+    return r
+ src/Streamly/Internal/Data/Array/Prim/Pinned/Type.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE UnboxedTuples #-}++#include "inline.hs"++-- |+-- Module      : Streamly.Internal.Data.Array.Prim.Pinned.Type+-- Copyright   : (c) 2020 Composewell Technologies+--+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+module Streamly.Internal.Data.Array.Prim.Pinned.Type+    (+      Array (..)+    , unsafeFreeze+    , unsafeFreezeWithShrink+--    , unsafeThaw+    , defaultChunkSize+    , nil++    -- * Construction+    , spliceTwo++    , fromList+    , fromListN+    , fromStreamDN+    , fromStreamD++    -- * Streams of arrays+    , fromStreamDArraysOf+    , FlattenState (..) -- for inspection testing+    , flattenArrays+    , flattenArraysRev+    , SpliceState (..) -- for inspection testing+    , packArraysChunksOf+    , lpackArraysChunksOf+#if !defined(mingw32_HOST_OS)+--    , groupIOVecsOf+#endif+    , splitOn+    , breakOn++    -- * Elimination+    , unsafeIndex+    , byteLength+    , length++    , foldl'+    , foldr+    , foldr'+    , foldlM'+    , splitAt++    , toStreamD+    , toStreamDRev+    , toStreamK+    , toStreamKRev+    , toList+--    , toArrayMinChunk+    , writeN+    , MA.ArrayUnsafe(..)+    , writeNUnsafe+    , write++    , unlines++    , toPtr++    , touchArray+    , withArrayAsPtr+    )+where++import Foreign.C.Types (CSize(..))+import GHC.IO (IO(..))+import Foreign.Ptr (minusPtr, nullPtr, plusPtr)++import qualified Streamly.Internal.Data.Array.Prim.Pinned.Mut.Type as MA++#include "Streamly/Internal/Data/Array/Prim/TypesInclude.hs"++-------------------------------------------------------------------------------+-- Utility functions+-------------------------------------------------------------------------------++foreign import ccall unsafe "string.h memchr" c_memchr+    :: Ptr Word8 -> Word8 -> CSize -> IO (Ptr Word8)++-------------------------------------------------------------------------------+-- Using as a Pointer+-------------------------------------------------------------------------------++-- Change name later.+{-# INLINE toPtr #-}+toPtr :: Array a -> Ptr a+toPtr (Array arr# off _) = Ptr (byteArrayContents# arr#) `plusPtr` off++{-# INLINE touchArray #-}+touchArray :: Array a -> IO ()+touchArray (Array arr# _ _) = IO $ \s -> case touch# arr# s of s1 -> (# s1, () #)++{-# INLINE withArrayAsPtr #-}+withArrayAsPtr :: Array a -> (Ptr a -> IO b) -> IO b+withArrayAsPtr arr f = do+    r <- f (toPtr arr)+    touchArray arr+    return r++-- Drops the separator byte+{-# INLINE breakOn #-}+breakOn ::+       MonadIO m+    => Word8+    -> Array Word8+    -> m (Array Word8, Maybe (Array Word8))+breakOn sep arr@(Array arr# off len) = do+    let p = toPtr arr+        loc = unsafePerformIO $ c_memchr p sep (fromIntegral (byteLength arr))+        len1 = loc `minusPtr` p+        len2 = len - len1 - 1+    return $+        if loc == nullPtr+        then (arr, Nothing)+        else ( Array arr# off len1+             , Just $ Array arr# (off + len1 + 1) len2)
+ src/Streamly/Internal/Data/Array/Prim/Type.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE UnboxedTuples #-}++#include "inline.hs"++-- |+-- Module      : Streamly.Internal.Data.Array.Prim.Type+-- Copyright   : (c) 2020 Composewell Technologies+--+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+module Streamly.Internal.Data.Array.Prim.Type+    (+      Array (..)+    , unsafeFreeze+    , unsafeFreezeWithShrink+--    , unsafeThaw+    , defaultChunkSize+    , nil++    -- * Construction+    , spliceTwo++    , fromList+    , fromListN+    , fromStreamDN+    , fromStreamD++    -- * Streams of arrays+    , fromStreamDArraysOf+    , FlattenState (..) -- for inspection testing+    , flattenArrays+    , flattenArraysRev+    , SpliceState (..) -- for inspection testing+    , packArraysChunksOf+    , lpackArraysChunksOf+#if !defined(mingw32_HOST_OS)+--    , groupIOVecsOf+#endif+    , splitOn+    , breakOn++    -- * Elimination+    , unsafeIndex+    , byteLength+    , length++    , foldl'+    , foldr+    , foldr'+    , foldlM'+    , splitAt++    , toStreamD+    , toStreamDRev+    , toStreamK+    , toStreamKRev+    , toList+--    , toArrayMinChunk+    , writeN+    , MA.ArrayUnsafe(..)+    , writeNUnsafe+    , write++    , unlines+    )+where++import qualified Streamly.Internal.Data.Array.Prim.Mut.Type as MA++#include "Streamly/Internal/Data/Array/Prim/TypesInclude.hs"++-- Drops the separator byte+-- Inefficient compared to Memory Array+{-# INLINE breakOn #-}+breakOn ::+       MonadIO m+    => Word8+    -> Array Word8+    -> m (Array Word8, Maybe (Array Word8))+breakOn sep arr@(Array arr# off len) =+    case loc of+        Left _ -> return (arr, Nothing)+        Right len1 -> do+            let len2 = len - len1 - 1+            return (Array arr# off len1, Just $ Array arr# (off + len1 + 1) len2)++    where++    loc = foldl' chk (Left 0) arr++    chk (Left i) a =+        if a == sep+            then Right i+            else Left (i + 1)+    chk r _ = r
+ src/Streamly/Internal/Data/Array/Prim/TypesInclude.hs view
@@ -0,0 +1,703 @@+-- Copyright   : (c) 2020 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++import Control.DeepSeq (NFData(..))+import Control.Monad (when)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Primitive (PrimMonad(..), primitive_)+import Data.Bifunctor (first)+import Data.Primitive.Types (Prim(..), sizeOf)+#if __GLASGOW_HASKELL__ < 808+import Data.Semigroup (Semigroup(..))+#endif+import Data.Word (Word8)+import Streamly.Internal.Data.Tuple.Strict (Tuple3'(..))+import Streamly.Internal.Data.Maybe.Strict (Maybe'(..))+import Streamly.Internal.Data.Fold.Type (Fold(..))+import Streamly.Internal.Data.SVar (adaptState)+import System.IO.Unsafe (unsafePerformIO)+import Text.Read (readPrec, readListPrec, readListPrecDefault)++import qualified GHC.Exts as Exts+import qualified Prelude as P+import qualified Streamly.Internal.Data.Fold as FL+import qualified Streamly.Internal.Data.Stream.StreamD.Type as D+import qualified Streamly.Internal.Data.Stream.StreamK as K++import GHC.Exts hiding (fromListN, fromList, toList)+import Prelude hiding (length, unlines, foldr)++-------------------------------------------------------------------------------+-- Array Data Type+-------------------------------------------------------------------------------++data Array a = Array ByteArray# Int Int++-------------------------------------------------------------------------------+-- Utilities+-------------------------------------------------------------------------------++-- | Both arrays must fully contain the specified ranges, but this is not+-- checked. The two arrays must not be the same array in different states, but+-- this is not checked either.+{-# INLINE unsafeCopy #-}+unsafeCopy ::+       forall m a. (MonadIO m, Prim a)+    => MA.Array a -- ^ destination array+    -> Int -- ^ offset into destination array+    -> Array a -- ^ source array+    -> Int -- ^ offset into source array+    -> Int -- ^ number of elements to copy+    -> m ()+unsafeCopy (MA.Array dst#) (I# doff#) (Array src# (I# off#) _) (I# soff#) (I# n#) =+    liftIO $ do+        let toBytes cnt# = cnt# *# (sizeOf# (undefined :: a))+        primitive_ $+            copyByteArray#+                src#+                (toBytes (off# +# soff#))+                dst#+                (toBytes doff#)+                (toBytes n#)++-------------------------------------------------------------------------------+-- Basic Byte Array Operations+-------------------------------------------------------------------------------++{-# INLINE unsafeFreeze #-}+unsafeFreeze :: (Prim a, MonadIO m) => MA.Array a -> m (Array a)+unsafeFreeze marr@(MA.Array arr#) =+    liftIO $ do+        len <- MA.length marr+        primitive $ \s# ->+            case unsafeFreezeByteArray# arr# s# of+                (# s1#, arr1# #) -> (# s1#, Array arr1# 0 len #)++{-# INLINE unsafeFreezeWithShrink #-}+unsafeFreezeWithShrink ::+       (Prim a, MonadIO m) => MA.Array a -> Int -> m (Array a)+unsafeFreezeWithShrink marr@(MA.Array arr#) n =+    liftIO $ do+        MA.shrinkArray marr n+        len <- MA.length marr+        primitive $ \s# ->+            case unsafeFreezeByteArray# arr# s# of+                (# s1#, arr1# #) -> (# s1#, Array arr1# 0 len #)++{-+-- Should never be used in general+{-# INLINE unsafeThaw #-}+unsafeThaw :: MonadIO m => Array a -> m (MA.Array a)+unsafeThaw (Array arr#) =+    primitive $ \s# -> (# s#, MA.Array (unsafeCoerce# arr#) #)+-}++-- Unsafe because the index bounds are not checked+{-# INLINE unsafeIndex #-}+unsafeIndex :: Prim a => Array a -> Int -> a+unsafeIndex (Array arr# (I# off#) _) (I# i#) = indexByteArray# arr# (off# +# i#)++-- unsafe+sameByteArray :: ByteArray# -> ByteArray# -> Bool+sameByteArray ba1 ba2 =+    case reallyUnsafePtrEquality#+             (unsafeCoerce# ba1 :: ())+             (unsafeCoerce# ba2 :: ()) of+        r -> isTrue# r++-------------------------------------------------------------------------------+-- Chunk Size+-------------------------------------------------------------------------------++-- XXX move this section to mutable array module?++mkChunkSizeKB :: Int -> Int+mkChunkSizeKB n = n * k+    where k = 1024++-- | 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 = mkChunkSizeKB 32++-------------------------------------------------------------------------------+-- Length+-------------------------------------------------------------------------------++-- XXX rename to byteCount?+{-# INLINE byteLength #-}+byteLength :: forall a. Prim a => Array a -> Int+byteLength (Array _ _ len) = len * sizeOf (undefined :: a)++-- XXX Also, rename to elemCount+-- XXX I would prefer length to keep the API consistent+-- XXX Also, re-export sizeOf from Primitive+{-# INLINE length #-}+length :: Array a -> Int+length (Array _ _ len) = len++-------------------------------------------------------------------------------+-- Construction+-------------------------------------------------------------------------------++-- | Use a slice of an array as another array. Note that this is unsafe and does+-- not check the bounds+slice :: Array a -> Int -> Int -> Array a+slice (Array arr# off _) off1 len1 = Array arr# (off + off1) len1++nil :: Prim a => Array a+nil =+    unsafePerformIO $ do+        arr <- MA.newArray 0+        unsafeFreeze arr++-- | Fold the whole input to a single array.+--+-- /Caution! Do not use this on infinite streams./+--+-- /Pre-release/+{-# INLINE_NORMAL write #-}+write :: (MonadIO m, Prim a) => Fold m a (Array a)+write = FL.rmapM unsafeFreeze MA.write++-- | @writeN n@ folds a maximum of @n@ elements from the input stream to an+-- 'Array'.+--+-- /Pre-release/+{-# INLINE_NORMAL writeN #-}+writeN :: (MonadIO m, Prim a) => Int -> Fold m a (Array a)+writeN limit = FL.rmapM unsafeFreeze (MA.writeN limit)++-- | 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, Prim a) => Int -> Fold m a (Array a)+writeNUnsafe limit = FL.rmapM unsafeFreeze (MA.writeNUnsafe limit)++{-# INLINE_NORMAL fromStreamDN #-}+fromStreamDN :: (MonadIO m, Prim a) => Int -> D.Stream m a -> m (Array a)+fromStreamDN limit str = MA.fromStreamDN limit str >>= unsafeFreeze++{-# INLINE fromStreamD #-}+fromStreamD :: (MonadIO m, Prim a) => D.Stream m a -> m (Array a)+fromStreamD str = MA.fromStreamD str >>= unsafeFreeze++-- | @fromStreamArraysOf n stream@ groups the input stream into a stream of+-- arrays of size n.+{-# INLINE_NORMAL fromStreamDArraysOf #-}+fromStreamDArraysOf ::+       (MonadIO m, Prim a) => Int -> D.Stream m a -> D.Stream m (Array a)+fromStreamDArraysOf n str = D.mapM unsafeFreeze (MA.fromStreamDArraysOf n str)++-- XXX derive from MA.fromListN?+{-# INLINE fromListN #-}+fromListN :: Prim a => Int -> [a] -> Array a+fromListN len xs = unsafePerformIO $ MA.fromListNM len xs >>= unsafeFreeze++-- XXX derive from MA.fromList?+{-# INLINE fromList #-}+fromList :: Prim a => [a] -> Array a+fromList xs = fromListN (P.length xs) xs++-------------------------------------------------------------------------------+-- Combining+-------------------------------------------------------------------------------++-- | Splice two immutable arrays creating a new immutable array.+{-# INLINE spliceTwo #-}+spliceTwo :: (MonadIO m, Prim a) => Array a -> Array a -> m (Array a)+spliceTwo a1 a2 = do+    let l1 = length a1+        l2 = length a2+    a3 <- MA.newArray (l1 + l2)+    unsafeCopy a3 0 a1 0 l1+    unsafeCopy a3 l1 a2 0 l2+    unsafeFreeze a3 -- Use `unsafeFreezeWith off len`?++-------------------------------------------------------------------------------+-- Elimination+-------------------------------------------------------------------------------++{-# INLINE_LATE toListFB #-}+toListFB :: Prim a => (a -> b -> b) -> b -> Array a -> b+toListFB c n arr = go 0+    where+    len = length arr+    go p | p == len = n+    go p =+        let !x = unsafeIndex arr p+        in c x (go (p + 1))++-- | Convert an 'Array' into a list.+--+-- /Pre-release/+{-# INLINE toList #-}+toList :: Prim a => Array a -> [a]+toList s = build (\c n -> toListFB c n s)++-------------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------------++instance (Eq a, Prim a) => Eq (Array a) where+    {-# INLINE (==) #-}+    a1@(Array ba1# _ len1) == a2@(Array ba2# _ len2)+        | sameByteArray ba1# ba2# = True+        | len1 /= len2 = False+        | otherwise = loop (len1 - 1)++        where++        loop !i+            | i < 0 = True+            | otherwise = unsafeIndex a1 i == unsafeIndex a2 i && loop (i - 1)++-- | Lexicographic ordering. Subject to change between major versions.+instance (Ord a, Prim a) => Ord (Array a) where+    {-# INLINE compare #-}+    compare a1@(Array ba1# _ len1) a2@(Array ba2# _ len2)+        | sameByteArray ba1# ba2# = EQ+        | otherwise = loop 0++        where++        sz = min len1 len2++        loop !i+            | i < sz =+                compare (unsafeIndex a1 i) (unsafeIndex a2 i) <> loop (i + 1)+            | otherwise = compare len1 len2++instance Prim a => Semigroup (Array a) where+    -- XXX can't we use runST instead of inlineIO?+    -- XXX I plan to remove MonadIO and replace it with IO+    a <> b = unsafePerformIO (spliceTwo a b :: IO (Array a))++instance Prim a => Monoid (Array a) where+    mempty = nil+    mappend = (<>)++instance NFData (Array a) where+    {-# INLINE rnf #-}+    rnf _ = ()+++-- XXX check if this is compatible with Memory.Array?+-- XXX It isn't. I might prefer this Show instance though+-- XXX Memory.Array: showsPrec _ = shows . toList+instance (Show a, Prim a) => Show (Array a) where+    showsPrec p a =+        showParen (p > 10) $+              showString "fromListN "+            . shows (length a)+            . showString " "+            . shows (toList a)++instance (a ~ Char) => IsString (Array a) where+    {-# INLINE fromString #-}+    fromString = fromList++-- GHC versions 8.0 and below cannot derive IsList+instance Prim a => IsList (Array a) where+    type (Item (Array a)) = a++    {-# INLINE fromList #-}+    fromList = fromList++    {-# INLINE fromListN #-}+    fromListN = fromListN++    {-# INLINE toList #-}+    toList = toList++instance (Prim a, Read a, Show a) => Read (Array a) where+    {-# INLINE readPrec #-}+    readPrec = fromList <$> readPrec+    readListPrec = readListPrecDefault++-- XXX these folds can be made common with mutable arrays by defining a+-- unsafeIndex in the specific module?++-------------------------------------------------------------------------------+-- Folds+-------------------------------------------------------------------------------++{-# INLINE foldr #-}+foldr :: Prim a => (a -> b -> b) -> b -> Array a -> b+foldr f z arr = go 0++    where++    !len = length arr++    go !i+        | len > i = f (unsafeIndex arr i) (go (i + 1))+        | otherwise = z++-- | Strict right-associated fold over the elements of an 'Array'.+{-# INLINE foldr' #-}+foldr' :: Prim a => (a -> b -> b) -> b -> Array a -> b+foldr' f z0 arr = go (length arr - 1) z0++    where++    go !i !acc+        | i < 0 = acc+        | otherwise = go (i - 1) (f (unsafeIndex arr i) acc)++-- | Strict left-associated fold over the elements of an 'Array'.+{-# INLINE foldl' #-}+foldl' :: Prim a => (b -> a -> b) -> b -> Array a -> b+foldl' f z0 arr = go 0 z0++    where++    !len = length arr++    go !i !acc+        | i < len = go (i + 1) (f acc (unsafeIndex arr i))+        | otherwise = acc++-- | Strict left-associated fold over the elements of an 'Array'.+{-# INLINE foldlM' #-}+foldlM' :: (Prim a, Monad m) => (b -> a -> m b) -> b -> Array a -> m b+foldlM' f z0 arr = go 0 z0++    where++    !len = length arr++    go !i !acc1+        | i < len = do+            acc2 <- f acc1 (unsafeIndex arr i)+            go (i + 1) acc2+        | otherwise = return acc1++-------------------------------------------------------------------------------+-- Converting to streams+-------------------------------------------------------------------------------++{-# INLINE_NORMAL toStreamD #-}+toStreamD :: (Prim a, Monad m) => Array a -> D.Stream m a+toStreamD arr = D.Stream step 0++    where++    {-# INLINE_LATE step #-}+    step _ i+        | i == length arr = return D.Stop+    step _ i = return $ D.Yield (unsafeIndex arr i) (i + 1)++{-# INLINE toStreamK #-}+toStreamK :: (K.IsStream t, Prim a) => Array a -> t m a+toStreamK arr = go 0++    where++    len = length arr++    go p+        | p == len = K.nil+        | otherwise =+            let !x = unsafeIndex arr p+            in x `K.cons` go (p + 1)++{-# INLINE_NORMAL toStreamDRev #-}+toStreamDRev :: (Prim a, Monad m) => Array a -> D.Stream m a+toStreamDRev arr = D.Stream step (length arr - 1)++    where++    {-# INLINE_LATE step #-}+    step _ i+        | i < 0 = return D.Stop+    step _ i = return $ D.Yield (unsafeIndex arr i) (i - 1)++{-# INLINE toStreamKRev #-}+toStreamKRev :: (K.IsStream t, Prim a) => Array a -> t m a+toStreamKRev arr = go (length arr - 1)++    where++    go p | p == -1 = K.nil+         | otherwise =+        let !x = unsafeIndex arr p+        in x `K.cons` go (p - 1)++-------------------------------------------------------------------------------+-- Stream of Arrays+-------------------------------------------------------------------------------++data FlattenState s a =+      OuterLoop s+    | InnerLoop s !(Array a) !Int !Int++{-# INLINE_NORMAL flattenArrays #-}+flattenArrays :: (MonadIO m, Prim a) => D.Stream m (Array 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 arr s ->+                let len = length arr+                in if len == 0+                   then D.Skip (OuterLoop s)+                   else D.Skip (InnerLoop s arr len 0)+            D.Skip s -> D.Skip (OuterLoop s)+            D.Stop -> D.Stop++    step' _ (InnerLoop st _ len i) | i == len =+        return $ D.Skip $ OuterLoop st++    step' _ (InnerLoop st arr len i) = do+        let x = unsafeIndex arr i+        return $ D.Yield x (InnerLoop st arr len (i + 1))++{-# INLINE_NORMAL flattenArraysRev #-}+flattenArraysRev :: (MonadIO m, Prim a) => D.Stream m (Array 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 arr s ->+                let len = length arr+                in if len == 0+                   then D.Skip (OuterLoop s)+                   else D.Skip (InnerLoop s arr len (len - 1))+            D.Skip s -> D.Skip (OuterLoop s)+            D.Stop -> D.Stop++    step' _ (InnerLoop st _ _ i) | i == -1 =+        return $ D.Skip $ OuterLoop st++    step' _ (InnerLoop st arr len i) = do+        let x = unsafeIndex arr i+        return $ D.Yield x (InnerLoop st arr len (i - 1))++{-# INLINE_NORMAL unlines #-}+unlines :: (MonadIO m, Prim 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 arr s ->+                let len = length arr+                in D.Skip (InnerLoop s arr len 0)+            D.Skip s -> D.Skip (OuterLoop s)+            D.Stop -> D.Stop++    step' _ (InnerLoop st _ len i) | i == len =+        return $ D.Yield sep $ OuterLoop st++    step' _ (InnerLoop st arr len i) = do+        let x = unsafeIndex arr i+        return $ D.Yield x (InnerLoop st arr len (i + 1))++-- Splice an array into a pre-reserved mutable array.  The user must ensure+-- that there is enough space in the mutable array.+{-# INLINE spliceInto #-}+spliceInto :: (MonadIO m, Prim a) => MA.Array a -> Int -> Array a -> m Int+spliceInto dst doff src@(Array _ _ len) = do+    unsafeCopy dst doff src 0 len+    return $ doff + len++data SpliceState s arr1 arr2+    = SpliceInitial s+    | SpliceBuffering s arr2+    | SpliceYielding arr1 (SpliceState s arr1 arr2)+    | SpliceFinish++-- | Coalesce adjacent arrays in incoming stream to form bigger arrays of a+-- maximum specified size in bytes. 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.+--+-- /Pre-release/+{-# INLINE_NORMAL packArraysChunksOf #-}+packArraysChunksOf ::+       forall m a. (MonadIO m, Prim a)+    => Int+    -> D.Stream m (Array a)+    -> D.Stream m (Array a)+packArraysChunksOf n (D.Stream step state) =+    D.Stream step' (SpliceInitial state)++    where++    nElem = n `quot` sizeOf (undefined :: a)++    {-# 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.Foreign.Type.packArraysChunksOf: the size of "+                 ++ "arrays [" ++ show n ++ "] must be a natural number"+        r <- step gst st+        case r of+            D.Yield arr s ->+                if length arr >= nElem+                then return $ D.Skip (SpliceYielding arr (SpliceInitial s))+                else do+                    buf <- MA.newArray nElem+                    noff <- spliceInto buf 0 arr+                    return $ D.Skip (SpliceBuffering s (buf, noff))+            D.Skip s -> return $ D.Skip (SpliceInitial s)+            D.Stop -> return $ D.Stop++    step' gst (SpliceBuffering st arr2@(buf, boff)) = do+        r <- step gst st+        case r of+            D.Yield arr s -> do+                if boff + length arr > nElem+                then do+                    nArr <- unsafeFreeze buf+                    return $ D.Skip (SpliceYielding (slice nArr 0 boff) (SpliceBuffering s arr2))+                else do+                    noff <- spliceInto buf boff arr+                    return $ D.Skip (SpliceBuffering s (buf, noff))+            D.Skip s -> return $ D.Skip (SpliceBuffering s arr2)+            D.Stop -> do+                nArr <- unsafeFreeze buf+                return $ D.Skip (SpliceYielding (slice nArr 0 boff) SpliceFinish)++    step' _ SpliceFinish = return D.Stop++    step' _ (SpliceYielding arr next) = return $ D.Yield arr next++{-# INLINE_NORMAL lpackArraysChunksOf #-}+lpackArraysChunksOf ::+       forall m a. (MonadIO m, Prim a)+    => Int+    -> Fold m (Array a) ()+    -> Fold m (Array a) ()+lpackArraysChunksOf n (Fold step1 initial1 extract1) =+    Fold step initial extract++    where++    nElem = n `quot` sizeOf (undefined :: a)++    initial = do+        when (n <= 0) $+            -- XXX we can pass the module string from the higher level API+            error $ "Streamly.Internal.Data.Array.Foreign.Type.packArraysChunksOf: the size of "+                 ++ "arrays [" ++ show n ++ "] must be a natural number"+        res <- initial1+        return $ first (Tuple3' Nothing' 0) res++    extract (Tuple3' Nothing' _ r1) = extract1 r1+    extract (Tuple3' (Just' buf) boff r1) = do+        nArr <- unsafeFreeze buf+        r <- step1 r1 (slice nArr 0 boff)+        case r of+            FL.Partial rr -> extract1 rr+            FL.Done _ -> return ()++    step (Tuple3' Nothing' _ r1) arr =+            if length arr >= nElem+            then do+                r <- step1 r1 arr+                case r of+                    FL.Done _ -> return $ FL.Done ()+                    FL.Partial s -> do+                        extract1 s+                        res <- initial1+                        return $ first (Tuple3' Nothing' 0) res+            else do+                buf <- MA.newArray nElem+                noff <- spliceInto buf 0 arr+                return $ FL.Partial $ Tuple3' (Just' buf) noff r1++    step (Tuple3' (Just' buf) boff r1) arr = do+            noff <- spliceInto buf boff arr++            if noff >= nElem+            then do+                nArr <- unsafeFreeze buf+                r <- step1 r1 (slice nArr 0 noff)+                case r of+                    FL.Done _ -> return $ FL.Done ()+                    FL.Partial s -> do+                        extract1 s+                        res <- initial1+                        return $ first (Tuple3' Nothing' 0) res+            else return $ FL.Partial $ Tuple3' (Just' buf) noff r1++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.+--+-- /Pre-release/+{-# 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) <- 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) <- breakOn byte arr+                buf' <- spliceTwo 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 byteLength buf == 0+                then D.Stop+                else D.Skip (Yielding buf Finishing)++    step' _ (Splitting st buf) = do+        (arr1, marr2) <- 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
+ src/Streamly/Internal/Data/Array/PrimInclude.hs view
@@ -0,0 +1,185 @@+-- Copyright   : (c) 2020 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++import Control.Monad (when)+import Control.Monad.IO.Class (MonadIO(..))+import Data.Primitive.Types (Prim(..))+import Streamly.Internal.Data.Fold.Type (Fold(..))+import Streamly.Internal.Data.Unfold.Type (Unfold(..))+import Streamly.Internal.Data.Stream.Serial (SerialT)+import Streamly.Internal.Data.Stream.StreamK.Type (IsStream)++import qualified Streamly.Internal.Data.Stream.Prelude as P+import qualified Streamly.Internal.Data.Stream.Serial as Serial+import qualified Streamly.Internal.Data.Stream.StreamD as D+import qualified Streamly.Internal.Data.Stream.StreamK as K++import Prelude hiding (length, null, last, map, (!!), read, concat)++-------------------------------------------------------------------------------+-- 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, Prim a) => Int -> SerialT m a -> m (Array a)+fromStreamN n m = do+    when (n < 0) $ error "writeN: negative write count specified"+    A.fromStreamDN n $ D.toStreamD 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, `arraysOf` followed by+-- processing of indvidual arrays in the resulting stream should be preferred.+--+-- /Pre-release/+{-# INLINE fromStream #-}+fromStream :: (MonadIO m, Prim a) => SerialT m a -> m (Array a)+fromStream = P.fold A.write+-- write m = A.fromStreamD $ D.toStreamD m++-------------------------------------------------------------------------------+-- Elimination+-------------------------------------------------------------------------------++-- | Convert an 'Array' into a stream.+--+-- /Pre-release/+{-# INLINE_EARLY toStream #-}+toStream :: (MonadIO m, K.IsStream t, Prim a) => Array a -> t m a+toStream = D.fromStreamD . A.toStreamD+-- 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 toStreamRev #-}+toStreamRev :: (MonadIO m, IsStream t, Prim a) => Array a -> t m a+toStreamRev = D.fromStreamD . A.toStreamDRev+-- XXX add fallback to StreamK rule+-- {-# RULES "Streamly.Array.readRev fallback to StreamK" [1]+--     forall a. S.toStreamK (readRev a) = K.revFromArray a #-}++-- | Unfold an array into a stream.+--+-- @since 0.7.0+{-# INLINE_NORMAL read #-}+read :: (MonadIO m, Prim a) => Unfold m (Array a) a+read = Unfold step inject+    where++    inject = return++    {-# INLINE_LATE step #-}+    step (Array _ _ len) | len == 0 = return D.Stop+    step arr@(Array arr# off len) =+            let !x = A.unsafeIndex arr 0+            in return $ D.Yield x (Array arr# (off + 1) (len - 1))++-- | 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.+--+-- The following might not be true, not that the representation changed.+-- 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 unsafeRead #-}+unsafeRead :: (MonadIO m, Prim a) => Unfold m (Array a) a+unsafeRead = Unfold step inject+    where++    inject = return++    {-# INLINE_LATE step #-}+    step arr@(Array arr# off len) =+            let !x = A.unsafeIndex arr 0+            in return $ D.Yield x (Array arr# (off + 1) (len - 1))++-- | > null arr = length arr == 0+--+-- /Pre-release/+{-# INLINE null #-}+null :: Array a -> Bool+null arr = length arr == 0++-------------------------------------------------------------------------------+-- Folds+-------------------------------------------------------------------------------++-- | Fold an array using a 'Fold'.+--+-- /Pre-release/+{-# INLINE fold #-}+fold :: forall m a b. (MonadIO m, Prim a) => Fold m a b -> Array a -> m b+fold f arr = P.fold f (toStream arr :: Serial.SerialT m a)++-- | Fold an array using a stream fold operation.+--+-- /Pre-release/+{-# INLINE streamFold #-}+streamFold :: (MonadIO m, Prim a) => (SerialT m a -> m b) -> Array a -> m b+streamFold f arr = f (toStream arr)++-------------------------------------------------------------------------------+-- Random reads+-------------------------------------------------------------------------------++-- | /O(1)/ Lookup the element at the given index, starting from 0.+--+-- /Pre-release/+{-# INLINE readIndex #-}+readIndex :: Prim a => Array a -> Int -> Maybe a+readIndex arr i =+    if i < 0 || i > length arr - 1+        then Nothing+        else Just $ A.unsafeIndex arr i++-- | > last arr = readIndex arr (length arr - 1)+--+-- /Pre-release/+{-# INLINE last #-}+last :: Prim a => Array a -> Maybe a+last arr = readIndex arr (length arr - 1)++-------------------------------------------------------------------------------+-- Array stream operations+-------------------------------------------------------------------------------++-- | Convert a stream of arrays into a stream of their elements.+--+-- Same as the following but more efficient:+--+-- > concat = S.concatMap A.read+--+-- /Pre-release/+{-# INLINE concat #-}+concat :: (IsStream t, MonadIO m, Prim a) => t m (Array a) -> t m a+-- concat m = D.fromStreamD $ A.flattenArrays (D.toStreamD m)+-- concat m = D.fromStreamD $ D.concatMap A.toStreamD (D.toStreamD m)+concat m = D.fromStreamD $ D.unfoldMany read (D.toStreamD m)++-- | Coalesce adjacent arrays in incoming stream to form bigger arrays of a+-- maximum specified size in bytes.+--+-- /Pre-release/+{-# INLINE compact #-}+compact ::+       (MonadIO m, Prim a) => Int -> SerialT m (Array a) -> SerialT m (Array a)+compact n xs = D.fromStreamD $ A.packArraysChunksOf n (D.toStreamD xs)
+ src/Streamly/Internal/Data/Array/Stream/Fold/Foreign.hs view
@@ -0,0 +1,338 @@+-- |+-- Module      : Streamly.Internal.Data.Array.Stream.Fold.Foreign+-- Copyright   : (c) 2021 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- 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.Array.Stream.Foreign as ArrayStream+-- >>> import qualified Streamly.Internal.Data.Array.Stream.Fold.Foreign as ArrayFold+-- >>> import qualified Streamly.Internal.Data.Stream.IsStream as Stream (arraysOf)+-- >>> import qualified Streamly.Prelude as Stream+--+-- >>> ArrayStream.fold (ArrayFold.fromFold (Fold.take 7 Fold.toList)) $ Stream.arraysOf 5 $ Stream.fromList "hello world"+-- "hello w"+--+module Streamly.Internal.Data.Array.Stream.Fold.Foreign+    (+      Fold (..)++    -- * Construction+    , fromFold+    , fromParser+    , fromArrayFold++    -- * Mapping+    , rmapM++    -- * Applicative+    , fromPure+    , fromEffect+    , serialWith++    -- * Monad+    , concatMap++    -- * Transformation+    , take+    )+where++import Control.Applicative (liftA2)+import Control.Exception (assert)+import Control.Monad.Catch (MonadThrow)+import Control.Monad.IO.Class (MonadIO(..))+import Foreign.ForeignPtr (touchForeignPtr)+import Foreign.Ptr (minusPtr, plusPtr)+import Foreign.Storable (Storable(..))+import GHC.ForeignPtr (ForeignPtr(..))+import GHC.Ptr (Ptr(..))+import GHC.Types (SPEC(..))+import Streamly.Internal.Data.Array.Foreign.Type (Array(..))+import Streamly.Internal.Data.Parser.ParserD (Initial(..), Step(..))+import Streamly.Internal.Data.Tuple.Strict (Tuple'(..))++import qualified Streamly.Internal.Data.Array.Foreign 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 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 Fold m a b = Fold (ParserD.Parser m (Array a) 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, Storable a) =>+    Fold.Fold m a b -> Fold m a b+fromFold (Fold.Fold fstep finitial fextract) =+    Fold (ParserD.Parser step initial fextract)++    where++    initial = do+        res <- finitial+        return+            $ case res of+                  Fold.Partial s1 -> IPartial s1+                  Fold.Done b -> IDone b++    step s (Array fp@(ForeignPtr start _) end) = do+        goArray SPEC (Ptr start) s++        where++        goArray !_ !cur !fs | cur >= end = do+            assert (cur == end) (return ())+            liftIO $ touchForeignPtr fp+            return $ Partial 0 fs+        goArray !_ !cur !fs = do+            x <- liftIO $ peek cur+            res <- fstep fs x+            let elemSize = sizeOf (undefined :: a)+                next = cur `plusPtr` elemSize+            case res of+                Fold.Done b ->+                    return $ Done ((end `minusPtr` next) `div` elemSize) b+                Fold.Partial fs1 ->+                    goArray SPEC next fs1++-- | Convert an element '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, Storable a) =>+    ParserD.Parser m a b -> Fold m a b+fromParser (ParserD.Parser step1 initial1 extract1) =+    Fold (ParserD.Parser step initial1 extract1)++    where++    step s (Array fp@(ForeignPtr start _) end) = do+        if Ptr start >= end+        then return $ Continue 0 s+        else goArray SPEC (Ptr start) s++        where++        {-# INLINE partial #-}+        partial arrRem cur next elemSize st n fs1 = do+            let next1 = next `plusPtr` negate (n * elemSize)+            if next1 >= Ptr start && cur < end+            then goArray SPEC next1 fs1+            else return $ st (arrRem + n) fs1++        goArray !_ !cur !fs = do+            x <- liftIO $ peek cur+            liftIO $ touchForeignPtr fp+            res <- step1 fs x+            let elemSize = sizeOf (undefined :: a)+                next = cur `plusPtr` elemSize+                arrRem = (end `minusPtr` 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++-- | Adapt an array stream fold.+--+-- /Pre-release/+{-# INLINE fromArrayFold #-}+fromArrayFold :: forall m a b. (MonadIO m) =>+    Fold.Fold m (Array a) b -> Fold m a b+fromArrayFold f = Fold $ ParserD.fromFold f++-------------------------------------------------------------------------------+-- Functor+-------------------------------------------------------------------------------++-- | Maps a function over the result of fold.+--+-- /Pre-release/+instance Functor m => Functor (Fold m a) where+    {-# INLINE fmap #-}+    fmap f (Fold p) = Fold $ fmap f p++-- | Map a monadic function on the output of a fold.+--+-- /Pre-release/+{-# INLINE rmapM #-}+rmapM :: Monad m => (b -> m c) -> Fold m a b -> Fold m a c+rmapM f (Fold p) = Fold $ 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 -> Fold m a b+fromPure = Fold . 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 -> Fold m a b+fromEffect = Fold . ParserD.fromEffect++-- | Applies two folds sequentially on the input stream and combines their+-- results using the supplied function.+--+-- /Pre-release/+{-# INLINE serial_ #-}+serial_ :: MonadThrow m => Fold m x a -> Fold m x b -> Fold m x b+serial_ (Fold p1) (Fold p2) = Fold $ ParserD.noErrorUnsafeSplit_ p1 p2++-- | Applies two folds sequentially on the input stream and combines their+-- results using the supplied function.+--+-- /Pre-release/+{-# INLINE serialWith #-}+serialWith :: MonadThrow m+    => (a -> b -> c) -> Fold m x a -> Fold m x b -> Fold m x c+serialWith f (Fold p1) (Fold p2) =+    Fold $ ParserD.noErrorUnsafeSplitWith f p1 p2++-- | 'Applicative' form of 'serialWith'.+-- > (<*>) = serialWith id+instance MonadThrow m => Applicative (Fold m a) where+    {-# INLINE pure #-}+    pure = fromPure++    {-# INLINE (<*>) #-}+    (<*>) = serialWith id++    {-# INLINE (*>) #-}+    (*>) = serial_++#if MIN_VERSION_base(4,10,0)+    {-# INLINE liftA2 #-}+    liftA2 f x = (<*>) (fmap f x)+#endif++-------------------------------------------------------------------------------+-- Monad+-------------------------------------------------------------------------------++-- | 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 :: MonadThrow m =>+    (b -> Fold m a c) -> Fold m a b -> Fold m a c+concatMap func (Fold p) =+    Fold $ ParserD.noErrorUnsafeConcatMap (\x -> let Fold y = func x in y) p++-- | Monad instance applies folds sequentially. Next fold can depend on the+-- output of the previous fold. See 'concatMap'.+--+-- > (>>=) = flip concatMap+instance MonadThrow m => Monad (Fold m a) where+    {-# INLINE return #-}+    return = pure++    {-# INLINE (>>=) #-}+    (>>=) = flip concatMap++    {-# INLINE (>>) #-}+    (>>) = (*>)++-------------------------------------------------------------------------------+-- Array to Array folds+-------------------------------------------------------------------------------++{-# INLINE take #-}+take :: forall m a b. (Monad m, Storable a) => Int -> Fold m a b -> Fold m a b+take n (Fold (ParserD.Parser step1 initial1 extract1)) =+    Fold $ ParserD.Parser step initial extract++    where++    initial = do+        res <- initial1+        case res of+            IPartial s ->+                if n > 0+                then return $ IPartial $ Tuple' n s+                else IDone <$> extract1 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 Done 0 <$> extract1 s -- i2 == i1 == j == 0++    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 (ForeignPtr start contents) _) = arr+                sz = sizeOf (undefined :: a)+                end = Ptr start `plusPtr` (i * sz)+                arr1 = Array (ForeignPtr start contents) end+                remaining = negate i1+            res <- step1 r arr1+            case res of+                Partial 0 s -> Done remaining <$> extract1 s+                Partial j s -> return $ Partial (remaining + j) (Tuple' j s)+                Continue 0 s -> Done remaining <$> 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' _ r) = extract1 r
+ src/Streamly/Internal/Data/Array/Stream/Foreign.hs view
@@ -0,0 +1,705 @@+-- |+-- Module      : Streamly.Internal.Data.Array.Stream.Foreign+-- 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.Array.Stream.Foreign+    (+    -- * Creation+      arraysOf++    -- * Flattening to elements+    , concat+    , concatRev+    , interpose+    , interposeSuffix+    , intercalateSuffix+    , unlines++    -- * Elimination+    , fold+    , fold_+    -- , parse+    , parseD+    , foldMany+    , toArray++    -- * Compaction+    , lpackArraysChunksOf+#if !defined(mingw32_HOST_OS)+    , groupIOVecsOf+#endif+    , compact++    -- * Splitting+    , splitOn+    , splitOnSuffix+    )+where++#include "inline.hs"++import Data.Bifunctor (second)+import Control.Exception (assert)+import Control.Monad.Catch (MonadThrow, throwM)+import Control.Monad.IO.Class (MonadIO(..))+import Data.Word (Word8)+import Foreign.ForeignPtr (touchForeignPtr)+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)+import Foreign.Ptr (minusPtr, plusPtr, castPtr)+import Foreign.Storable (Storable(..))+import Fusion.Plugin.Types (Fuse(..))+import GHC.Exts (SpecConstrAnnotation(..))+import GHC.ForeignPtr (ForeignPtr(..))+import GHC.Ptr (Ptr(..))+import GHC.Types (SPEC(..))+import Prelude hiding (null, last, (!!), read, concat, unlines)++#if !defined(mingw32_HOST_OS)+import Streamly.Internal.FileSystem.FDIO (IOVec(..))+#endif++import Streamly.Internal.BaseCompat+import Streamly.Internal.Data.Array.Foreign.Type (Array(..))+import Streamly.Internal.Data.Fold.Type (Fold(..))+import Streamly.Internal.Data.Parser (ParseError(..))+import Streamly.Internal.Data.Stream.Serial (SerialT)+import Streamly.Internal.Data.Stream.StreamK.Type (IsStream)+import Streamly.Internal.Data.SVar (adaptState, defState)++import qualified Streamly.Internal.Data.Array.Foreign as A+import qualified Streamly.Internal.Data.Array.Foreign as Array+import qualified Streamly.Internal.Data.Array.Foreign.Type as A+import qualified Streamly.Internal.Data.Array.Foreign.Mut.Type as MA+import qualified Streamly.Internal.Data.Array.Stream.Mut.Foreign as AS+import qualified Streamly.Internal.Data.Array.Stream.Fold.Foreign as ASF+import qualified Streamly.Internal.Data.Fold.Type as FL+import qualified Streamly.Internal.Data.Parser as PR+import qualified Streamly.Internal.Data.Parser.ParserD as PRD+import qualified Streamly.Internal.Data.Stream.IsStream as S+import qualified Streamly.Internal.Data.Stream.StreamD as D++-------------------------------------------------------------------------------+-- Generation+-------------------------------------------------------------------------------++-- | @arraysOf n stream@ groups the elements in the input stream into arrays of+-- @n@ elements each.+--+-- > arraysOf n = Stream.chunksOf n (Array.writeN n)+--+-- /Pre-release/+{-# INLINE arraysOf #-}+arraysOf :: (IsStream t, MonadIO m, Storable a)+    => Int -> t m a -> t m (Array a)+arraysOf n str = D.fromStreamD $ A.arraysOf n (D.toStreamD str)++-------------------------------------------------------------------------------+-- 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 but more efficient:+--+-- > concat = Stream.unfoldMany Array.read+--+-- @since 0.7.0+{-# INLINE concat #-}+concat :: (IsStream t, MonadIO m, Storable a) => t m (Array a) -> t m a+-- concat m = D.fromStreamD $ A.flattenArrays (D.toStreamD m)+-- concat m = D.fromStreamD $ D.concatMap A.toStreamD (D.toStreamD m)+concat m = D.fromStreamD $ D.unfoldMany A.read (D.toStreamD m)++-- | Convert a stream of arrays into a stream of their elements reversing the+-- contents of each array before flattening.+--+-- > concatRev = Stream.unfoldMany Array.readRev+--+-- @since 0.7.0+{-# INLINE concatRev #-}+concatRev :: (IsStream t, MonadIO m, Storable a) => t m (Array a) -> t m a+concatRev m = D.fromStreamD $ A.flattenArraysRev (D.toStreamD m)++-------------------------------------------------------------------------------+-- Intersperse and append+-------------------------------------------------------------------------------++-- | Flatten a stream of arrays after inserting the given element between+-- arrays.+--+-- /Pre-release/+{-# INLINE interpose #-}+interpose :: (MonadIO m, IsStream t, Storable a) => a -> t m (Array a) -> t m a+interpose x = S.interpose x A.read++{-# INLINE intercalateSuffix #-}+intercalateSuffix :: (MonadIO m, IsStream t, Storable a)+    => Array a -> t m (Array a) -> t m a+intercalateSuffix = S.intercalateSuffix A.read++-- | Flatten a stream of arrays appending the given element after each+-- array.+--+-- @since 0.7.0+{-# INLINE interposeSuffix #-}+interposeSuffix :: (MonadIO m, IsStream t, Storable a)+    => a -> t m (Array a) -> t m a+-- interposeSuffix x = D.fromStreamD . A.unlines x . D.toStreamD+interposeSuffix x = S.interposeSuffix x A.read++data FlattenState s a =+      OuterLoop s+    | InnerLoop s !(ForeignPtr a) !(Ptr a) !(Ptr a)++{-# INLINE_NORMAL unlines #-}+unlines :: forall m a. (MonadIO m, Storable 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 ->+                let p = unsafeForeignPtrToPtr aStart+                in D.Skip (InnerLoop s aStart p aEnd)+            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 startf p end) = do+        x <- liftIO $ do+                    r <- peek p+                    touchForeignPtr startf+                    return r+        return $ D.Yield x (InnerLoop st startf+                            (p `plusPtr` sizeOf (undefined :: a)) end)++-------------------------------------------------------------------------------+-- Compact+-------------------------------------------------------------------------------++{-# INLINE_NORMAL packArraysChunksOf #-}+packArraysChunksOf :: (MonadIO m, Storable 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.+{-# INLINE_NORMAL lpackArraysChunksOf #-}+lpackArraysChunksOf :: (MonadIO m, Storable a)+    => Int -> Fold m (Array a) () -> Fold m (Array a) ()+lpackArraysChunksOf n fld =+    FL.map A.unsafeThaw $ AS.lpackArraysChunksOf n (FL.map A.unsafeFreeze fld)++#if !defined(mingw32_HOST_OS)++-- | @groupIOVecsOf maxBytes maxEntries@ groups arrays in the incoming stream+-- to create a stream of 'IOVec' arrays with a maximum of @maxBytes@ bytes in+-- each array and a maximum of @maxEntries@ entries in each array.+--+-- @since 0.7.0+{-# INLINE_NORMAL groupIOVecsOf #-}+groupIOVecsOf :: MonadIO m+    => Int -> Int -> D.Stream m (Array a) -> D.Stream m (Array IOVec)+groupIOVecsOf n maxIOVLen str =+    D.map A.unsafeFreeze+        $ AS.groupIOVecsOf n maxIOVLen+        $ D.map A.unsafeThaw str+#endif++-- | 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, Storable a)+    => Int -> SerialT m (Array a) -> SerialT m (Array a)+compact n xs = D.fromStreamD $ packArraysChunksOf n (D.toStreamD xs)++-------------------------------------------------------------------------------+-- 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.spliceTwo 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++-- | 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+    :: (IsStream t, MonadIO m)+    => Word8+    -> t m (Array Word8)+    -> t m (Array Word8)+splitOn byte s =+    D.fromStreamD $ D.splitInnerBy (A.breakOn byte) A.spliceTwo $ D.toStreamD s++{-# INLINE splitOnSuffix #-}+splitOnSuffix+    :: (IsStream t, MonadIO m)+    => Word8+    -> t m (Array Word8)+    -> t m (Array Word8)+-- splitOn byte s = D.fromStreamD $ A.splitOn byte $ D.toStreamD s+splitOnSuffix byte s =+    D.fromStreamD $ D.splitInnerBySuffix (A.breakOn byte) A.spliceTwo $ D.toStreamD s++-------------------------------------------------------------------------------+-- Elimination+-------------------------------------------------------------------------------++-- When we have to take an array partially, take the last part of the array.+{-# INLINE takeArrayListRev #-}+takeArrayListRev :: forall a. Storable 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 (ForeignPtr _ contents) end) = x+                    sz = sizeOf (undefined :: a)+                    !(Ptr start) = end `plusPtr` negate (n * sz)+                 in [Array (ForeignPtr start contents) 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. Storable 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 (ForeignPtr start contents) end) = x+                         sz = sizeOf (undefined :: a)+                         end1 = end `plusPtr` negate (m * sz)+                         arr2 = Array (ForeignPtr start contents) end1+                         !(Ptr addrEnd1) = end1+                         arr1 = Array (ForeignPtr addrEnd1 contents) 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, Storable a)+    => Int -> SerialT m (MA.Array a) -> m (MA.Array a)+spliceArraysLenUnsafe len buffered = do+    arr <- liftIO $ MA.newArray len+    end <- S.foldlM' writeArr (return $ MA.aEnd arr) buffered+    return $ arr {MA.aEnd = end}++    where++    writeArr dst (MA.Array as ae _) =+        liftIO $ unsafeWithForeignPtr as $ \src -> do+                        let count = ae `minusPtr` src+                        A.memcpy (castPtr dst) (castPtr src) count+                        return $ dst `plusPtr` count++{-# INLINE _spliceArrays #-}+_spliceArrays :: (MonadIO m, Storable a)+    => SerialT m (Array a) -> m (Array a)+_spliceArrays s = do+    buffered <- S.foldr S.cons S.nil s+    len <- S.sum (S.map Array.length buffered)+    arr <- liftIO $ MA.newArray len+    end <- S.foldlM' writeArr (return $ MA.aEnd arr) s+    return $ A.unsafeFreeze $ arr {MA.aEnd = end}++    where++    writeArr dst (Array as ae) =+        liftIO $ unsafeWithForeignPtr as $ \src -> do+                        let count = ae `minusPtr` src+                        A.memcpy (castPtr dst) (castPtr src) count+                        return $ dst `plusPtr` count++{-# INLINE _spliceArraysBuffered #-}+_spliceArraysBuffered :: (MonadIO m, Storable a)+    => SerialT m (Array a) -> m (Array a)+_spliceArraysBuffered s = do+    buffered <- S.foldr S.cons S.nil s+    len <- S.sum (S.map Array.length buffered)+    A.unsafeFreeze <$> spliceArraysLenUnsafe len (S.map A.unsafeThaw s)++{-# INLINE spliceArraysRealloced #-}+spliceArraysRealloced :: forall m a. (MonadIO m, Storable a)+    => SerialT m (Array a) -> m (Array a)+spliceArraysRealloced s = do+    let idst = liftIO $ MA.newArray (A.bytesToElemCount (undefined :: a)+                                  (A.mkChunkSizeKB 4))++    arr <- S.foldlM' MA.spliceWithDoubling idst (S.map A.unsafeThaw s)+    liftIO $ A.unsafeFreeze <$> MA.shrinkToFit 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, Storable a) => SerialT 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 :: (IsStream t, MonadIO m, Storable 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, Storable a)+    => Int -> Fold m a (SerialT Identity (Array a))+_toArraysOf n = FL.chunksOf n (A.writeNF n) FL.toStream+-}++-------------------------------------------------------------------------------+-- 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 parseD #-}+parseD ::+       forall m a b. (MonadIO m, MonadThrow m, Storable a)+    => PRD.Parser m (Array a) b+    -> D.Stream m (Array.Array a)+    -> m (b, D.Stream m (Array.Array a))+parseD (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.+    {-# INLINE go #-}+    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 -> do+                b <- extract pst+                return (b, D.nil)++    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 ->+                return (b, D.Stream step s)+            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 (b, D.append (D.fromList src) (D.Stream step s))+            PR.Error err -> throwM $ ParseError err++{-+-- | Parse an array stream using the supplied 'Parser'.  Returns the parse+-- result and the unconsumed stream. Throws 'ParseError' if the parse fails.+--+-- /Internal/+--+{-# INLINE parse #-}+parse ::+       (MonadIO m, MonadThrow m, Storable a)+    => PRD.Parser m a b+    -> SerialT m (A.Array a)+    -> m (b, SerialT m (A.Array a))+parse p s = fmap D.fromStreamD <$> parseD p (D.toStreamD s)+-}++-- | Fold an array stream using the supplied array stream 'Fold'.+--+-- /Pre-release/+--+{-# INLINE fold #-}+fold :: (MonadIO m, MonadThrow m, Storable a) =>+    ASF.Fold m a b -> SerialT m (A.Array a) -> m b+fold (ASF.Fold p) s = fst <$> parseD p (D.toStreamD s)++-- | Like 'fold' but also returns the remaining stream.+--+-- /Pre-release/+--+{-# INLINE fold_ #-}+fold_ :: (MonadIO m, MonadThrow m, Storable a) =>+    ASF.Fold m a b -> SerialT m (A.Array a) -> m (b, SerialT m (A.Array a))+fold_ (ASF.Fold p) s = second D.fromStreamD <$> parseD p (D.toStreamD s)++{-# ANN type ParseChunksState Fuse #-}+data ParseChunksState x inpBuf st pst =+      ParseChunksInit inpBuf st+    | ParseChunksInitLeftOver inpBuf+    | ParseChunksStream st inpBuf !pst+    | ParseChunksBuf inpBuf st inpBuf !pst+    | ParseChunksYield x (ParseChunksState x inpBuf st pst)++{-# INLINE_NORMAL foldManyD #-}+foldManyD+    :: (MonadThrow m, Storable a)+    => ASF.Fold m a b+    -> D.Stream m (Array a)+    -> D.Stream m b+foldManyD (ASF.Fold (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 ->+                        let next = ParseChunksInit [x] s+                         in return $ D.Skip $ ParseChunksYield pb next+                    PRD.IError err -> throwM $ ParseError err+            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 pb next+            PRD.IError err -> throwM $ ParseError err++    -- 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 b (ParseChunksInit [] s)+                    PR.Done n b -> do+                        assert+                            (n <= sum (map Array.length (x:backBuf)))+                            (return ())+                        let src0 = takeArrayListRev n (x:backBuf)+                        let src = Prelude.reverse src0+                        return $ D.Skip $+                            ParseChunksYield b (ParseChunksInit src s)+                    PR.Error err -> throwM $ ParseError err+            D.Skip s -> return $ D.Skip $ ParseChunksStream s backBuf pst+            D.Stop   -> do+                b <- extract pst+                let src = Prelude.reverse backBuf+                return $ D.Skip $+                    ParseChunksYield b (ParseChunksInitLeftOver src)++    -- 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 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 b (ParseChunksInit src s)+            PR.Error err -> throwM $ ParseError err++    stepOuter _ (ParseChunksYield a next) = return $ D.Yield a next++-- | Apply an array stream 'Fold' repeatedly on an array stream and emit the+-- fold outputs in the output stream.+--+-- See "Streamly.Prelude.foldMany" for more details.+--+-- /Pre-release/+{-# INLINE foldMany #-}+foldMany+    :: (IsStream t, MonadThrow m, Storable a)+    => ASF.Fold m a b+    -> t m (Array a)+    -> t m b+foldMany p m = D.fromStreamD $ foldManyD p (D.toStreamD m)
+ src/Streamly/Internal/Data/Array/Stream/Mut/Foreign.hs view
@@ -0,0 +1,311 @@+-- |+-- Module      : Streamly.Internal.Data.Array.Stream.Mut.Foreign+-- 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.Stream.Mut.Foreign+    (+    -- * Generation+      arraysOf++    -- * Compaction+    , packArraysChunksOf+    , SpliceState (..)+    , lpackArraysChunksOf+#if !defined(mingw32_HOST_OS)+    , groupIOVecsOf+#endif+    , compact+    , compactLE+    , compactEQ+    , compactGE+    )+where++#include "inline.hs"++import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad (when)+import Data.Bifunctor (first)+import Foreign.Storable (Storable(..))+#if !defined(mingw32_HOST_OS)+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)+import Foreign.Ptr (castPtr)+import Streamly.Internal.FileSystem.FDIO (IOVec(..))+import Streamly.Internal.Data.Array.Foreign.Mut.Type (length)+import Streamly.Internal.Data.SVar (adaptState)+#endif+import Streamly.Internal.Data.Array.Foreign.Mut.Type (Array(..))+import Streamly.Internal.Data.Fold.Type (Fold(..))+import Streamly.Internal.Data.Stream.Serial (SerialT)+import Streamly.Internal.Data.Stream.StreamK.Type (IsStream)+import Streamly.Internal.Data.Tuple.Strict (Tuple'(..))++import qualified Streamly.Internal.Data.Array.Foreign.Mut.Type as MArray+import qualified Streamly.Internal.Data.Fold.Type as FL+import qualified Streamly.Internal.Data.Stream.StreamD as D++import Prelude hiding (length)++-- | @arraysOf n stream@ groups the elements in the input stream into arrays of+-- @n@ elements each.+--+-- Same as the following but may be more efficient:+--+-- > arraysOf n = Stream.foldMany (MArray.writeN n)+--+-- /Pre-release/+{-# INLINE arraysOf #-}+arraysOf :: (IsStream t, MonadIO m, Storable a)+    => Int -> t m a -> t m (Array a)+arraysOf n = D.fromStreamD . MArray.arraysOf n . D.toStreamD++-------------------------------------------------------------------------------+-- Compact+-------------------------------------------------------------------------------++data SpliceState s arr+    = SpliceInitial s+    | SpliceBuffering s arr+    | SpliceYielding arr (SpliceState s arr)+    | SpliceFinish++-- | This mutates the first array (if it has space) to append values from the+-- second one. This would work for immutable arrays as well because an+-- immutable array never has 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, Storable a)+    => Int -> D.Stream m (Array a) -> D.Stream m (Array 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.Foreign.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.spliceWith 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++{-# INLINE_NORMAL lpackArraysChunksOf #-}+lpackArraysChunksOf :: (MonadIO m, Storable a)+    => Int -> Fold m (Array a) () -> Fold m (Array 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.Foreign.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.spliceWith 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 replace by compactLE+--+-- | 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, Storable a)+    => Int -> SerialT m (Array a) -> SerialT m (Array a)+compact n xs = D.fromStreamD $ packArraysChunksOf n (D.toStreamD xs)++-- XXX Replace the above functions by a compactLEFold+-- | 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.+--+-- /Unimplemented/+{-# INLINE_NORMAL compactLEFold #-}+compactLEFold :: -- (MonadIO m, Storable a) =>+    Int -> Fold m (Array a) (Array a)+compactLEFold = undefined++compactLE :: (MonadIO m {-, Storable a-}) =>+    Int -> SerialT m (Array a) -> SerialT m (Array a)+compactLE n xs = D.fromStreamD $ D.foldMany (compactLEFold n) (D.toStreamD xs)++-- | Like 'compact' 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, Storable a) =>+    Int -> SerialT m (Array a) -> SerialT m (Array a)+compactEQ _n _xs = undefined+    -- D.fromStreamD $ D.foldMany (compactEQFold n) (D.toStreamD xs)++-- | Like 'compact' but generates arrays of size greater than or equal to the+-- specified except for the last array in the stream which could be shorter.+--+-- /Unimplemented/+{-# INLINE compactGE #-}+compactGE :: -- (MonadIO m, Storable a) =>+    Int -> SerialT m (Array a) -> SerialT m (Array a)+compactGE _n _xs = undefined+    -- D.fromStreamD $ D.foldMany (compactGEFold n) (D.toStreamD xs)++-------------------------------------------------------------------------------+-- IOVec+-------------------------------------------------------------------------------++#if !defined(mingw32_HOST_OS)+data GatherState s arr+    = GatherInitial s+    | GatherBuffering s arr Int+    | GatherYielding arr (GatherState s arr)+    | GatherFinish++-- | @groupIOVecsOf maxBytes maxEntries@ groups arrays in the incoming stream+-- to create a stream of 'IOVec' arrays with a maximum of @maxBytes@ bytes in+-- each array and a maximum of @maxEntries@ entries in each array.+--+-- @since 0.7.0+{-# INLINE_NORMAL groupIOVecsOf #-}+groupIOVecsOf :: MonadIO m+    => Int -> Int -> D.Stream m (Array a) -> D.Stream m (Array IOVec)+groupIOVecsOf n maxIOVLen (D.Stream step state) =+    D.Stream step' (GatherInitial state)++    where++    {-# INLINE_LATE step' #-}+    step' gst (GatherInitial st) = do+        when (n <= 0) $+            -- XXX we can pass the module string from the higher level API+            error $ "Streamly.Internal.Data.Array.Foreign.Mut.Type.groupIOVecsOf: the size of "+                 ++ "groups [" ++ show n ++ "] must be a natural number"+        when (maxIOVLen <= 0) $+            -- XXX we can pass the module string from the higher level API+            error $ "Streamly.Internal.Data.Array.Foreign.Mut.Type.groupIOVecsOf: the number of "+                 ++ "IOVec entries [" ++ show n ++ "] must be a natural number"+        r <- step (adaptState gst) st+        case r of+            D.Yield arr s -> do+                let p = unsafeForeignPtrToPtr (aStart arr)+                    len = MArray.byteLength arr+                iov <- liftIO $ MArray.newArray maxIOVLen+                iov' <- liftIO $ MArray.unsafeSnoc iov (IOVec (castPtr p)+                                                (fromIntegral len))+                if len >= n+                then return $ D.Skip (GatherYielding iov' (GatherInitial s))+                else return $ D.Skip (GatherBuffering s iov' len)+            D.Skip s -> return $ D.Skip (GatherInitial s)+            D.Stop -> return D.Stop++    step' gst (GatherBuffering st iov len) = do+        r <- step (adaptState gst) st+        case r of+            D.Yield arr s -> do+                let p = unsafeForeignPtrToPtr (aStart arr)+                    alen = MArray.byteLength arr+                    len' = len + alen+                if len' > n || length iov >= maxIOVLen+                then do+                    iov' <- liftIO $ MArray.newArray maxIOVLen+                    iov'' <- liftIO $ MArray.unsafeSnoc iov' (IOVec (castPtr p)+                                                      (fromIntegral alen))+                    return $ D.Skip (GatherYielding iov+                                        (GatherBuffering s iov'' alen))+                else do+                    iov' <- liftIO $ MArray.unsafeSnoc iov (IOVec (castPtr p)+                                                    (fromIntegral alen))+                    return $ D.Skip (GatherBuffering s iov' len')+            D.Skip s -> return $ D.Skip (GatherBuffering s iov len)+            D.Stop -> return $ D.Skip (GatherYielding iov GatherFinish)++    step' _ GatherFinish = return D.Stop++    step' _ (GatherYielding iov next) = return $ D.Yield iov next+#endif
src/Streamly/Internal/Data/Atomics.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP         #-}- -- | -- Module      : Streamly.Internal.Data.Atomics -- Copyright   : (c) 2018-2019 Composewell Technologies
+ src/Streamly/Internal/Data/Binary/Decode.hs view
@@ -0,0 +1,278 @@+-- |+-- Module      : Streamly.Internal.Data.Binary.Decode+-- Copyright   : (c) 2020 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : pre-release+-- Portability : GHC+--+-- Parsers for binary encoded basic Haskell data types.++module Streamly.Internal.Data.Binary.Decode+    ( unit+    , bool+    , ordering+    , eqWord8+    , word8+    , word16be+    , word16le+    , word32be+    , word32le+    , word64be+    , word64le+    , word64host+    )+where++import Control.Monad.Catch (MonadCatch, throwM)+import Control.Monad.IO.Class (MonadIO)+import Data.Bits ((.|.), unsafeShiftL)+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.Internal.Data.Array.Foreign as A+import qualified Streamly.Internal.Data.Parser as PR+import qualified Streamly.Internal.Data.Parser.ParserD as PRD+import qualified Streamly.Internal.Data.Parser.ParserK.Type as PRK++-- | A value of type '()' is encoded as @0@ in binary encoding.+--+-- @+-- 0 ==> ()+-- @+--+-- /Pre-release/+--+{-# INLINE unit #-}+unit :: MonadCatch m => Parser m Word8 ()+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 :: MonadCatch m => Parser m Word8 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 :: MonadCatch m => Parser m Word8 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 :: MonadCatch m => Word8 -> Parser m Word8 Word8+eqWord8 b = PR.satisfy (== b)++-- | Accept any byte.+--+-- /Pre-release/+--+{-# INLINE word8 #-}+word8 :: MonadCatch m => Parser m Word8 Word8+word8 = PR.satisfy (const True)++-- | Big endian (MSB first) Word16+{-# INLINE word16beD #-}+word16beD :: MonadCatch m => PRD.Parser m Word8 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 _ = throwM $ PRD.ParseError "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 :: MonadCatch m => Parser m Word8 Word16+word16be = PRK.toParserK word16beD++-- | Little endian (LSB first) Word16+{-# INLINE word16leD #-}+word16leD :: MonadCatch m => PRD.Parser m Word8 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 _ = throwM $ PRD.ParseError "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 :: MonadCatch m => Parser m Word8 Word16+word16le = PRK.toParserK word16leD++-- | Big endian (MSB first) Word32+{-# INLINE word32beD #-}+word32beD :: MonadCatch m => PRD.Parser m Word8 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 _ = throwM $ PRD.ParseError "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 :: MonadCatch m => Parser m Word8 Word32+word32be = PRK.toParserK word32beD++-- | Little endian (LSB first) Word32+{-# INLINE word32leD #-}+word32leD :: MonadCatch m => PRD.Parser m Word8 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 _ = throwM $ PRD.ParseError "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 :: MonadCatch m => Parser m Word8 Word32+word32le = PRK.toParserK word32leD++-- | Big endian (MSB first) Word64+{-# INLINE word64beD #-}+word64beD :: MonadCatch m => PRD.Parser m Word8 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 _ = throwM $ PRD.ParseError "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 :: MonadCatch m => Parser m Word8 Word64+word64be = PRK.toParserK word64beD++-- | Little endian (LSB first) Word64+{-# INLINE word64leD #-}+word64leD :: MonadCatch m => PRD.Parser m Word8 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 _ = throwM $ PRD.ParseError "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 :: MonadCatch m => Parser m Word8 Word64+word64le = PRK.toParserK word64leD++-------------------------------------------------------------------------------+-- Host byte order+-------------------------------------------------------------------------------++-- | Parse eight bytes as a 'Word64' in the host byte order.+--+-- /Pre-release/+--+{-# INLINE word64host #-}+word64host :: (MonadIO m, MonadCatch m) => Parser m Word8 Word64+word64host =+    fmap (flip A.unsafeIndex 0 . A.unsafeCast) $ PR.takeEQ 8 (A.writeN 8)
+ src/Streamly/Internal/Data/Cont.hs view
@@ -0,0 +1,36 @@+-- |+-- Module      : Streamly.Internal.Data.Cont+-- Copyright   : (c) 2020 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- Continuation style utilities.+--+module Streamly.Internal.Data.Cont+    ( contListMap+    )+where++import Control.Monad.Cont (runCont, cont)++-- | Given a continuation based transformation from @a@ to @b@ and a+-- continuation based transformation from @[b]@ to @c@, make continuation based+-- transformation from @[a]@ to @c@.+--+-- /Pre-release/++-- You can read the definition as:+--+-- > contListMap f g = \xs final ->+--+contListMap ::+       (a -> (b -> r) -> r)      -- transform a -> b+    -> ([b] -> (c -> r) -> r)    -- transform [b] -> c+    -> ([a] -> (c -> r) -> r)    -- transform [a] -> c+contListMap f g xs final =+    let bconts = fmap (cont . f) xs  -- [Cont b]+        blistCont = sequence bconts  -- Cont [b]+        k ys = g ys final            -- [b] -> r+     in runCont blistCont k          -- r
+ src/Streamly/Internal/Data/Either/Strict.hs view
@@ -0,0 +1,55 @@+-- |+-- 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' (..)+    , 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"
src/Streamly/Internal/Data/Fold.hs view
@@ -1,1590 +1,1790 @@-{-# LANGUAGE BangPatterns              #-}-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE RankNTypes                #-}-{-# LANGUAGE RecordWildCards           #-}-{-# LANGUAGE ScopedTypeVariables       #-}---- |--- Module      : Streamly.Internal.Data.Fold--- Copyright   : (c) 2019 Composewell Technologies---               (c) 2013 Gabriel Gonzalez--- License     : BSD3--- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC---- Also see the "Streamly.Internal.Data.Sink" module that provides specialized left folds--- that discard the outputs.------ IMPORTANT: keep the signatures consistent with the folds in Streamly.Prelude--module Streamly.Internal.Data.Fold-    (-    -- * Fold Type-      Fold (..)--    , hoist-    , generally--    -- , tail-    -- , init--    -- * Fold Creation Utilities-    , mkPure-    , mkPureId-    , mkFold-    , mkFoldId--    -- ** Full Folds-    , drain-    , drainBy-    , drainBy2-    , last-    , length-    , sum-    , product-    , maximumBy-    , maximum-    , minimumBy-    , minimum-    -- , the-    , mean-    , variance-    , stdDev-    , rollingHash-    , rollingHashWithSalt-    , rollingHashFirstN-    -- , rollingHashLastN--    -- ** Full Folds (Monoidal)-    , mconcat-    , foldMap-    , foldMapM--    -- ** Full Folds (To Containers)--    , toList-    , toListRevF  -- experimental--    -- ** Partial Folds-    , drainN-    , drainWhile-    -- , lastN-    -- , (!!)-    -- , genericIndex-    , index-    , head-    -- , findM-    , find-    , lookup-    , findIndex-    , elemIndex-    , null-    , elem-    , notElem-    -- XXX these are slower than right folds even when full input is used-    , all-    , any-    , and-    , or--    -- * Transformations--    -- ** Covariant Operations-    , sequence-    , mapM--    -- ** Mapping-    , transform-    , lmap-    --, lsequence-    , lmapM-    -- ** Filtering-    , lfilter-    , lfilterM-    -- , ldeleteBy-    -- , luniq-    , lcatMaybes--    {--    -- ** 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-    -}--    , lsessionsOf-    , lchunksOf--    -- ** Breaking--    -- Binary-    , splitAt -- spanN-    -- , splitIn -- sessionN--    -- By elements-    , span  -- spanWhile-    , break -- breakBefore-    -- , breakAfter-    -- , breakOn-    -- , breakAround-    , spanBy-    , spanByRolling--    -- By sequences-    -- , breakOnSeq-    -- , breakOnStream -- on a stream--    -- * Distributing--    , tee-    , distribute-    , distribute_--    -- * Partitioning--    -- , partitionByM-    -- , partitionBy-    , partition--    -- * Demultiplexing--    , demux-    -- , demuxWith-    , demux_-    , demuxDefault_-    -- , demuxWith_-    , demuxWithDefault_--    -- * Classifying--    , classify-    -- , classifyWith--    -- * Unzipping-    , unzip-    -- These can be expressed using lmap/lmapM and unzip-    -- , unzipWith-    -- , unzipWithM--    -- * Nested Folds-    -- , concatMap-    , foldChunks-    , duplicate--    -- * Running Folds-    , initialize-    , runStep--    -- * Folding to SVar-    , toParallelSVar-    , toParallelSVarLimited-    )-where--import Control.Monad (void)-import Control.Monad.IO.Class (MonadIO(..))-import Data.Functor.Identity (Identity(..))-import Data.Int (Int64)-import Data.Map.Strict (Map)--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)--import qualified Data.Map.Strict as Map-import qualified Prelude--import Streamly.Internal.Data.Pipe.Types (Pipe (..), PipeState(..))-import Streamly.Internal.Data.Fold.Types-import Streamly.Internal.Data.Strict-import Streamly.Internal.Data.SVar--import qualified Streamly.Internal.Data.Pipe.Types as Pipe----------------------------------------------------------------------------------- Smart constructors----------------------------------------------------------------------------------- | Make a fold using a pure step function, a pure initial state and--- a pure state extraction function.------ /Internal/----{-# INLINE mkPure #-}-mkPure :: Monad m => (s -> a -> s) -> s -> (s -> b) -> Fold m a b-mkPure step initial extract =-    Fold (\s a -> return $ step s a) (return initial) (return . extract)---- | Make a fold using a pure step function and a pure initial state. The--- final state extracted is identical to the intermediate state.------ /Internal/----{-# INLINE mkPureId #-}-mkPureId :: Monad m => (b -> a -> b) -> b -> Fold m a b-mkPureId step initial = mkPure step initial id---- | Make a fold with an effectful step function and initial state, and a state--- extraction function.------ > mkFold = Fold------  We can just use 'Fold' but it is provided for completeness.------ /Internal/----{-# INLINE mkFold #-}-mkFold :: (s -> a -> m s) -> m s -> (s -> m b) -> Fold m a b-mkFold = Fold---- | Make a fold with an effectful step function and initial state.  The final--- state extracted is identical to the intermediate state.------ /Internal/----{-# INLINE mkFoldId #-}-mkFoldId :: Monad m => (b -> a -> m b) -> m b -> Fold m a b-mkFoldId step initial = Fold step initial return----------------------------------------------------------------------------------- hoist----------------------------------------------------------------------------------- | Change the underlying monad of a fold------ /Internal/-hoist :: (forall x. m x -> n x) -> Fold m a b -> Fold n a b-hoist f (Fold step initial extract) =-    Fold (\x a -> f $ step x a) (f initial) (f . extract)---- | Adapt a pure fold to any monad------ > generally = hoist (return . runIdentity)------ /Internal/-generally :: Monad m => Fold Identity a b -> Fold m a b-generally = hoist (return . runIdentity)----------------------------------------------------------------------------------- Transformations on fold inputs----------------------------------------------------------------------------------- | Flatten the monadic output of a fold to pure output.------ @since 0.7.0-{-# INLINE sequence #-}-sequence :: Monad m => Fold m a (m b) -> Fold m a b-sequence (Fold step initial extract) = Fold step initial extract'-  where-    extract' x = do-        act <- extract x-        act >>= return---- | Map a monadic function on the output of a fold.------ @since 0.7.0-{-# INLINE mapM #-}-mapM :: Monad m => (b -> m c) -> Fold m a b -> Fold m a c-mapM f = sequence . fmap f----------------------------------------------------------------------------------- Transformations on fold inputs----------------------------------------------------------------------------------- rename to lpipe?------ | Apply a transformation on a 'Fold' using a 'Pipe'.------ @since 0.7.0-{-# 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 = Tuple' <$> return 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 (Tuple' ps' acc')--        go acc (Pipe.Yield b (Produce ps')) = do-            acc' <- fstep acc b-            r <- pstep2 ps'-            go acc' r--        go acc (Pipe.Continue (Consume ps')) = return (Tuple' ps' acc)--        go acc (Pipe.Continue (Produce ps')) = do-            r <- pstep2 ps'-            go acc r--    extract (Tuple' _ fs) = fextract fs----------------------------------------------------------------------------------- Utilities----------------------------------------------------------------------------------- | @_Fold1 step@ returns a new 'Fold' using just a step function that has the--- same type for the accumulator and the element. The result type is the--- accumulator type wrapped in 'Maybe'. The initial accumulator is retrieved--- from the 'Foldable', the result is 'None' for empty containers.-{-# INLINABLE _Fold1 #-}-_Fold1 :: Monad m => (a -> a -> a) -> Fold m a (Maybe a)-_Fold1 step = Fold step_ (return Nothing') (return . toMaybe)-  where-    step_ mx a = return $ Just' $-        case mx of-            Nothing' -> a-            Just' x -> step x a----------------------------------------------------------------------------------- Left folds------------------------------------------------------------------------------------------------------------------------------------------------------------------ Run Effects----------------------------------------------------------------------------------- | A fold that drains all its input, running the effects and discarding the--- results.------ @since 0.7.0-{-# INLINABLE drain #-}-drain :: Monad m => Fold m a ()-drain = Fold step begin done-    where-    begin = return ()-    step _ _ = return ()-    done = return---- |--- > drainBy f = lmapM f drain------ Drain all input after passing it through a monadic function. This is the--- dual of mapM_ on stream producers.------ @since 0.7.0-{-# INLINABLE drainBy #-}-drainBy ::  Monad m => (a -> m b) -> Fold m a ()-drainBy f = Fold (const (void . f)) (return ()) return--{-# INLINABLE drainBy2 #-}-drainBy2 ::  Monad m => (a -> m b) -> Fold2 m c a ()-drainBy2 f = Fold2 (const (void . f)) (\_ -> return ()) return---- | Extract the last element of the input stream, if any.------ @since 0.7.0-{-# INLINABLE last #-}-last :: Monad m => Fold m a (Maybe a)-last = _Fold1 (flip const)----------------------------------------------------------------------------------- To Summary----------------------------------------------------------------------------------- | Like 'length', except with a more general 'Num' return value------ @since 0.7.0-{-# INLINABLE genericLength #-}-genericLength :: (Monad m, Num b) => Fold m a b-genericLength = Fold (\n _ -> return $ n + 1) (return 0) return---- | Determine the length of the input stream.------ @since 0.7.0-{-# INLINABLE length #-}-length :: Monad m => Fold m a Int-length = genericLength---- | 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.------ @since 0.7.0-{-# INLINABLE sum #-}-sum :: (Monad m, Num a) => Fold m a a-sum = Fold (\x a -> return $ x + a) (return 0) return---- | Determine the product of all elements of a stream of numbers. Returns--- multiplicative identity (@1@) when the stream is empty.------ @since 0.7.0-{-# INLINABLE product #-}-product :: (Monad m, Num a) => Fold m a a-product = Fold (\x a -> return $ x * a) (return 1) return----------------------------------------------------------------------------------- To Summary (Maybe)----------------------------------------------------------------------------------- | Determine the maximum element in a stream using the supplied comparison--- function.------ @since 0.7.0-{-# INLINABLE maximumBy #-}-maximumBy :: Monad m => (a -> a -> Ordering) -> Fold m a (Maybe a)-maximumBy cmp = _Fold1 max'-  where-    max' x y = case cmp x y of-        GT -> x-        _  -> y---- |--- @--- maximum = 'maximumBy' compare--- @------ Determine the maximum element in a stream.------ @since 0.7.0-{-# INLINABLE maximum #-}-maximum :: (Monad m, Ord a) => Fold m a (Maybe a)-maximum = _Fold1 max---- | Computes the minimum element with respect to the given comparison function------ @since 0.7.0-{-# INLINABLE minimumBy #-}-minimumBy :: Monad m => (a -> a -> Ordering) -> Fold m a (Maybe a)-minimumBy cmp = _Fold1 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.------ @since 0.7.0-{-# INLINABLE minimum #-}-minimum :: (Monad m, Ord a) => Fold m a (Maybe a)-minimum = _Fold1 min----------------------------------------------------------------------------------- To Summary (Statistical)----------------------------------------------------------------------------------- | Compute a numerically stable arithmetic mean of all elements in the input--- stream.------ @since 0.7.0-{-# INLINABLE mean #-}-mean :: (Monad m, Fractional a) => Fold m a a-mean = Fold step (return begin) (return . done)-  where-    begin = Tuple' 0 0-    step (Tuple' x n) y = return $-        let n' = n + 1-        in Tuple' (x + (y - x) / n') n'-    done (Tuple' x _) = x---- | Compute a numerically stable (population) variance over all elements in--- the input stream.------ @since 0.7.0-{-# INLINABLE variance #-}-variance :: (Monad m, Fractional a) => Fold m a a-variance = Fold step (return begin) (return . done)-  where-    begin = Tuple3' 0 0 0--    step (Tuple3' n mean_ m2) x = return $ 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.------ @since 0.7.0-{-# INLINABLE 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------ @since 0.7.0-{-# INLINABLE rollingHashWithSalt #-}-rollingHashWithSalt :: (Monad m, Enum a) => Int64 -> Fold m a Int64-rollingHashWithSalt salt = Fold step initial extract-    where-    k = 2891336453 :: Int64-    initial = return salt-    step cksum a = return $ cksum * k + fromIntegral (fromEnum a)-    extract = return---- | 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 = rollingHashWithSalt defaultSalt------ @since 0.7.0-{-# INLINABLE 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 = ltake n rollingHash-{-# INLINABLE rollingHashFirstN #-}-rollingHashFirstN :: (Monad m, Enum a) => Int -> Fold m a Int64-rollingHashFirstN n = ltake n rollingHash----------------------------------------------------------------------------------- Monoidal left folds----------------------------------------------------------------------------------- | Fold an input stream consisting of monoidal elements using 'mappend'--- and 'mempty'.------ > S.fold FL.mconcat (S.map Sum $ S.enumerateFromTo 1 10)------ @since 0.7.0-{-# INLINABLE mconcat #-}-mconcat :: (Monad m, Monoid a) => Fold m a a-mconcat = Fold (\x a -> return $ mappend x a) (return mempty) return---- |--- > foldMap f = map f mconcat------ Make a fold from a pure function that folds the output of the function--- using 'mappend' and 'mempty'.------ > S.fold (FL.foldMap Sum) $ S.enumerateFromTo 1 10------ @since 0.7.0-{-# INLINABLE foldMap #-}-foldMap :: (Monad m, Monoid b) => (a -> b) -> Fold m a b-foldMap f = lmap f mconcat---- |--- > foldMapM f = mapM f mconcat------ Make a fold from a monadic function that folds the output of the function--- using 'mappend' and 'mempty'.------ > S.fold (FL.foldMapM (return . Sum)) $ S.enumerateFromTo 1 10------ @since 0.7.0-{-# INLINABLE foldMapM #-}-foldMapM ::  (Monad m, Monoid b) => (a -> m b) -> Fold m a b-foldMapM act = Fold step begin done-    where-    done = return-    begin = return mempty-    step m a = do-        m' <- act a-        return $! mappend m m'----------------------------------------------------------------------------------- To Containers----------------------------------------------------------------------------------- | Folds the input stream to a list.------ /Warning!/ working on large lists accumulated as buffers in memory could be--- very inefficient, consider using "Streamly.Memory.Array" instead.------ @since 0.7.0---- id . (x1 :) . (x2 :) . (x3 :) . ... . (xn :) $ []-{-# INLINABLE toList #-}-toList :: Monad m => Fold m a [a]-toList = Fold (\f x -> return $ f . (x :))-              (return id)-              (return . ($ []))----------------------------------------------------------------------------------- Partial Folds----------------------------------------------------------------------------------- | A fold that drains the first n elements of its input, running the effects--- and discarding the results.-{-# INLINABLE drainN #-}-drainN :: Monad m => Int -> Fold m a ()-drainN n = ltake n drain---- | A fold that drains elements of its input as long as the predicate succeeds,--- running the effects and discarding the results.-{-# INLINABLE drainWhile #-}-drainWhile :: Monad m => (a -> Bool) -> Fold m a ()-drainWhile p = ltakeWhile p drain----------------------------------------------------------------------------------- To Elements----------------------------------------------------------------------------------- | Like 'index', except with a more general 'Integral' argument------ @since 0.7.0-{-# INLINABLE genericIndex #-}-genericIndex :: (Integral i, Monad m) => i -> Fold m a (Maybe a)-genericIndex i = Fold step (return $ Left' 0) done-  where-    step x a = return $-        case x of-            Left'  j -> if i == j-                        then Right' a-                        else Left' (j + 1)-            _        -> x-    done x = return $-        case x of-            Left'  _ -> Nothing-            Right' a -> Just a---- | Lookup the element at the given index.------ @since 0.7.0-{-# INLINABLE index #-}-index :: Monad m => Int -> Fold m a (Maybe a)-index = genericIndex---- | Extract the first element of the stream, if any.------ @since 0.7.0-{-# INLINABLE head #-}-head :: Monad m => Fold m a (Maybe a)-head = _Fold1 const---- | Returns the first element that satisfies the given predicate.------ @since 0.7.0-{-# INLINABLE find #-}-find :: Monad m => (a -> Bool) -> Fold m a (Maybe a)-find predicate = Fold step (return Nothing') (return . toMaybe)-  where-    step x a = return $-        case x of-            Nothing' -> if predicate a-                        then Just' a-                        else Nothing'-            _        -> x---- | 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@.------ @since 0.7.0-{-# INLINABLE lookup #-}-lookup :: (Eq a, Monad m) => a -> Fold m (a,b) (Maybe b)-lookup a0 = Fold step (return Nothing') (return . toMaybe)-  where-    step x (a,b) = return $-        case x of-            Nothing' -> if a == a0-                        then Just' b-                        else Nothing'-            _ -> x---- | Convert strict 'Either'' to lazy 'Maybe'-{-# INLINABLE hush #-}-hush :: Either' a b -> Maybe b-hush (Left'  _) = Nothing-hush (Right' b) = Just b---- | Returns the first index that satisfies the given predicate.------ @since 0.7.0-{-# INLINABLE findIndex #-}-findIndex :: Monad m => (a -> Bool) -> Fold m a (Maybe Int)-findIndex predicate = Fold step (return $ Left' 0) (return . hush)-  where-    step x a = return $-        case x of-            Left' i ->-                if predicate a-                then Right' i-                else Left' (i + 1)-            _       -> x---- | Returns the first index where a given value is found in the stream.------ @since 0.7.0-{-# INLINABLE elemIndex #-}-elemIndex :: (Eq a, Monad m) => a -> Fold m a (Maybe Int)-elemIndex a = findIndex (a ==)----------------------------------------------------------------------------------- To Boolean----------------------------------------------------------------------------------- | Return 'True' if the input stream is empty.------ @since 0.7.0-{-# INLINABLE null #-}-null :: Monad m => Fold m a Bool-null = Fold (\_ _ -> return False) (return True) return---- |--- > any p = lmap p or------ | Returns 'True' if any of the elements of a stream satisfies a predicate.------ @since 0.7.0-{-# INLINABLE any #-}-any :: Monad m => (a -> Bool) -> Fold m a Bool-any predicate = Fold (\x a -> return $ x || predicate a) (return False) return---- | Return 'True' if the given element is present in the stream.------ @since 0.7.0-{-# INLINABLE elem #-}-elem :: (Eq a, Monad m) => a -> Fold m a Bool-elem a = any (a ==)---- |--- > all p = lmap p and------ | Returns 'True' if all elements of a stream satisfy a predicate.------ @since 0.7.0-{-# INLINABLE all #-}-all :: Monad m => (a -> Bool) -> Fold m a Bool-all predicate = Fold (\x a -> return $ x && predicate a) (return True) return---- | Returns 'True' if the given element is not present in the stream.------ @since 0.7.0-{-# INLINABLE notElem #-}-notElem :: (Eq a, Monad m) => a -> Fold m a Bool-notElem a = all (a /=)---- | Returns 'True' if all elements are 'True', 'False' otherwise------ @since 0.7.0-{-# INLINABLE and #-}-and :: Monad m => Fold m Bool Bool-and = Fold (\x a -> return $ x && a) (return True) return---- | Returns 'True' if any element is 'True', 'False' otherwise------ @since 0.7.0-{-# INLINABLE or #-}-or :: Monad m => Fold m Bool Bool-or = Fold (\x a -> return $ x || a) (return False) return----------------------------------------------------------------------------------- Grouping/Splitting------------------------------------------------------------------------------------------------------------------------------------------------------------------ Grouping without looking at elements------------------------------------------------------------------------------------------------------------------------------------------------------------------ Binary APIs------------------------------------------------------------------------------------- XXX These would just be applicative compositions of terminating folds.---- | @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 = S.fold (FL.splitAt n FL.toList FL.toList) $ S.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],[])------ /Internal/---- This can be considered as a two-fold version of 'ltake' where we take both--- the segments instead of discarding the leftover.----{-# INLINE splitAt #-}-splitAt-    :: Monad m-    => Int-    -> Fold m a b-    -> Fold m a c-    -> Fold m a (b, c)-splitAt n (Fold stepL initialL extractL) (Fold stepR initialR extractR) =-    Fold step initial extract-    where-      initial  = Tuple3' <$> return n <*> initialL <*> initialR--      step (Tuple3' i xL xR) input =-        if i > 0-        then stepL xL input >>= (\a -> return (Tuple3' (i - 1) a xR))-        else stepR xR input >>= (\b -> return (Tuple3' i xL b))--      extract (Tuple3' _ a b) = (,) <$> extractL a <*> extractR b----------------------------------------------------------------------------------- Element Aware APIs-------------------------------------------------------------------------------------------------------------------------------------------------------------------- Binary APIs----------------------------------------------------------------------------------- | 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.------ /Internal/----spanBy-    :: Monad m-    => (a -> a -> Bool)-    -> Fold m a b-    -> Fold m a c-    -> Fold m a (b, c)-spanBy cmp (Fold stepL initialL extractL) (Fold stepR initialR extractR) =-    Fold step initial extract--    where-      initial = Tuple3' <$> initialL <*> initialR <*> return (Tuple' Nothing True)--      step (Tuple3' a b (Tuple' (Just frst) isFirstG)) input =-        if cmp frst input && isFirstG-        then stepL a input-              >>= (\a' -> return (Tuple3' a' b (Tuple' (Just frst) isFirstG)))-        else stepR b input-              >>= (\a' -> return (Tuple3' a a' (Tuple' Nothing False)))--      step (Tuple3' a b (Tuple' Nothing isFirstG)) input =-        if isFirstG-        then stepL a input-              >>= (\a' -> return (Tuple3' a' b (Tuple' (Just input) isFirstG)))-        else stepR b input-              >>= (\a' -> return (Tuple3' a a' (Tuple' Nothing False)))--      extract (Tuple3' a b _) = (,) <$> extractL a <*> extractR b---- | @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 = S.fold (S.span p FL.toList FL.toList) $ S.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],[])------ /Internal/---- This can be considered as a two-fold version of 'ltakeWhile' where we take--- both the segments instead of discarding the leftover.-{-# INLINE span #-}-span-    :: Monad m-    => (a -> Bool)-    -> Fold m a b-    -> Fold m a c-    -> Fold m a (b, c)-span p (Fold stepL initialL extractL) (Fold stepR initialR extractR) =-    Fold step initial extract--    where--    initial = Tuple3' <$> initialL <*> initialR <*> return True--    step (Tuple3' a b isFirstG) input =-        if isFirstG && p input-        then stepL a input >>= (\a' -> return (Tuple3' a' b True))-        else stepR b input >>= (\a' -> return (Tuple3' a a' False))--    extract (Tuple3' a b _) = (,) <$> extractL a <*> extractR b---- |--- > break p = span (not . p)------ Break as soon as the predicate becomes 'True'. @break p f1 f2@ composes--- folds @f1@ and @f2@ such that @f1@ stops consuming input as soon as the--- predicate @p@ becomes 'True'. The rest of the input is consumed @f2@.------ This is the binary version of 'splitBy'.------ > let break_ p xs = S.fold (S.break p FL.toList FL.toList) $ S.fromList xs------ >>> break_ (< 1) [3,2,1]--- > ([3,2,1],[])------ >>> break_ (< 2) [3,2,1]--- > ([3,2],[1])------ >>> break_ (< 4) [3,2,1]--- > ([],[3,2,1])------ /Internal/-{-# INLINE break #-}-break-    :: Monad m-    => (a -> Bool)-    -> Fold m a b-    -> Fold m a c-    -> Fold m a (b, c)-break p = span (not . p)---- | Like 'spanBy' but applies the predicate in a rolling fashion i.e.--- predicate is applied to the previous and the next input elements.------ /Internal/-{-# INLINE spanByRolling #-}-spanByRolling-    :: Monad m-    => (a -> a -> Bool)-    -> Fold m a b-    -> Fold m a c-    -> Fold m a (b, c)-spanByRolling cmp (Fold stepL initialL extractL) (Fold stepR initialR extractR) =-    Fold step initial extract--  where-    initial = Tuple3' <$> initialL <*> initialR <*> return Nothing--    step (Tuple3' a b (Just frst)) input =-      if cmp input frst-      then stepL a input >>= (\a' -> return (Tuple3' a' b (Just input)))-      else stepR b input >>= (\b' -> return (Tuple3' a b' (Just input)))--    step (Tuple3' a b Nothing) input =-      stepL a input >>= (\a' -> return (Tuple3' a' b (Just input)))--    extract (Tuple3' a b _) = (,) <$> extractL a <*> extractR b----------------------------------------------------------------------------------- Binary splitting on a separator---------------------------------------------------------------------------------{---- | Find the first occurrence of the specified sequence in the input stream--- and break the input stream into two parts, the first part consisting of the--- stream before the sequence and the second part consisting of the sequence--- and the rest of the stream.------ > let breakOn_ pat xs = S.fold (S.breakOn pat FL.toList FL.toList) $ S.fromList xs------ >>> breakOn_ "dear" "Hello dear world!"--- > ("Hello ","dear world!")----{-# INLINE breakOn #-}-breakOn :: Monad m => Array a -> Fold m a b -> Fold m a c -> Fold m a (b,c)-breakOn pat f m = undefined--}----------------------------------------------------------------------------------- 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--------|--- @--- >>> S.fold (FL.tee FL.sum FL.length) (S.enumerateFromTo 1.0 100.0)--- (5050.0,100)------ @since 0.7.0-{-# INLINE tee #-}-tee :: Monad m => Fold m a b -> Fold m a c -> Fold m a (b,c)-tee f1 f2 = (,) <$> f1 <*> f2--{-# INLINE foldNil #-}-foldNil :: Monad m => Fold m a [b]-foldNil = Fold step begin done  where-  begin = return []-  step _ _ = return []-  done = return--{-# INLINE foldCons #-}-foldCons :: Monad m => Fold m a b -> Fold m a [b] -> Fold m a [b]-foldCons (Fold stepL beginL doneL) (Fold stepR beginR doneR) =-    Fold step begin done--    where--    begin = Tuple' <$> beginL <*> beginR-    step (Tuple' xL xR) a = Tuple' <$> stepL xL a <*> stepR xR a-    done (Tuple' xL xR) = (:) <$> (doneL xL) <*> (doneR xR)---- 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--------|---                 |                         |---                            ...--- @------ >>> S.fold (FL.distribute [FL.sum, FL.length]) (S.enumerateFromTo 1 5)--- [15,5]------ This is the consumer side dual of the producer side 'sequence' operation.------ @since 0.7.0-{-# INLINE distribute #-}-distribute :: Monad m => [Fold m a b] -> Fold m a [b]-distribute [] = foldNil-distribute (x:xs) = foldCons x (distribute xs)---- | Like 'distribute' but for folds that return (), this can be more efficient--- than 'distribute' as it does not need to maintain state.----{-# INLINE distribute_ #-}-distribute_ :: Monad m => [Fold m a ()] -> Fold m a ()-distribute_ fs = Fold step initial extract-    where-    initial    = Prelude.mapM (\(Fold s i e) ->-        i >>= \r -> return (Fold s (return r) e)) fs-    step ss a  = do-        Prelude.mapM_ (\(Fold s i _) -> i >>= \r -> s r a >> return ()) ss-        return ss-    extract ss = do-        Prelude.mapM_ (\(Fold _ i e) -> i >>= \r -> e r) ss-        return ()----------------------------------------------------------------------------------- Partitioning------------------------------------------------------------------------------------- | 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--------|--- @------ Send input to either fold randomly:------ >>> import System.Random (randomIO)--- >>> randomly a = randomIO >>= \x -> return $ if x then Left a else Right a--- >>> S.fold (FL.partitionByM randomly FL.length FL.length) (S.enumerateFromTo 1 100)--- (59,41)------ Send input to the two folds in a proportion of 2:1:------ @--- import Data.IORef (newIORef, readIORef, writeIORef)--- 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 $ head r a------ main = do---  f <- proportionately 2 1---  r <- S.fold (FL.partitionByM f FL.length FL.length) (S.enumerateFromTo (1 :: Int) 100)---  print r--- @--- @--- (67,33)--- @------ This is the consumer side dual of the producer side 'mergeBy' operation.------ @since 0.7.0-{-# INLINE partitionByM #-}-partitionByM :: Monad m-    => (a -> m (Either b c)) -> Fold m b x -> Fold m c y -> Fold m a (x, y)-partitionByM f (Fold stepL beginL doneL) (Fold stepR beginR doneR) =--    Fold step begin done--    where--    begin = Tuple' <$> beginL <*> beginR-    step (Tuple' xL xR) a = do-        r <- f a-        case r of-            Left b -> Tuple' <$> stepL xL b <*> return xR-            Right c -> Tuple' <$> return xL <*> stepR xR c-    done (Tuple' xL xR) = (,) <$> doneL xL <*> doneR xR---- 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.------ Count even and odd numbers in a stream:------ @--- >>> let f = FL.partitionBy (\\n -> if even n then Left n else Right n)---                       (fmap (("Even " ++) . show) FL.length)---                       (fmap (("Odd "  ++) . show) FL.length)---   in S.fold f (S.enumerateFromTo 1 100)--- ("Even 50","Odd 50")--- @------ @since 0.7.0-{-# 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.------ > partition = partitionBy id------ @since 0.7.0-{-# 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--}---- 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. We also want to make sure that the Map contains--- only those types and the full set of those types.------ TODO Instead of the input Map it should probably be a lookup-table using an--- array and not in GC memory. The same applies to the output Map as well.--- However, that would only be helpful if we have a very large data structure,--- need to measure and see how it scales.------ This is the consumer side dual of the producer side 'mux' operation (XXX to--- be implemented).---- | Split the input stream based on a key field and fold each split using a--- specific fold collecting the results in a map from the keys to the results.--- Useful for cases like protocol handlers to handle different type of packets--- using different handlers.------ @------                             |-------Fold m a b--- -----stream m a-----Map-----|---                             |-------Fold m a b---                             |---                                       ...--- @------ @since 0.7.0-{-# INLINE demuxWith #-}-demuxWith :: (Monad m, Ord k)-    => (a -> (k, a')) -> Map k (Fold m a' b) -> Fold m a (Map k b)-demuxWith f kv = Fold step initial extract--    where--    initial = return kv--- alterF is available only since containers version 0.5.8.2-#if MIN_VERSION_containers(0,5,8)-    step mp a = case f a of-      (k, a') -> Map.alterF twiddle k mp-        -- XXX should we raise an exception in Nothing case?-        -- Ideally we should enforce that it is a total map over k so that look-        -- up never fails-        -- XXX we could use a monadic update function for a single lookup and-        -- update in the map.-        where-          twiddle Nothing = pure Nothing-          twiddle (Just (Fold step' acc extract')) = do-            !r <- acc >>= \x -> step' x a'-            pure . Just $ Fold step' (return r) extract'-#else-    step mp a =-        let (k, a') = f a-        in case Map.lookup k mp of-            Nothing -> return mp-            Just (Fold step' acc extract') -> do-                !r <- acc >>= \x -> step' x a'-                return $ Map.insert k (Fold step' (return r) extract') mp-#endif-    extract = Prelude.mapM (\(Fold _ acc e) -> acc >>= e)---- | Fold a stream of key value pairs using a map of specific folds for each--- key into a map from keys to the results of fold outputs of the corresponding--- values.------ @--- > let table = Data.Map.fromList [(\"SUM", FL.sum), (\"PRODUCT", FL.product)]---       input = S.fromList [(\"SUM",1),(\"PRODUCT",2),(\"SUM",3),(\"PRODUCT",4)]---   in S.fold (FL.demux table) input--- fromList [("PRODUCT",8),("SUM",4)]--- @------ @since 0.7.0-{-# INLINE demux #-}-demux :: (Monad m, Ord k)-    => Map k (Fold m a b) -> Fold m (k, a) (Map k b)-demux = demuxWith id--{-# INLINE demuxWithDefault_ #-}-demuxWithDefault_ :: (Monad m, Ord k)-    => (a -> (k, a')) -> Map k (Fold m a' b) -> Fold m (k, a') b -> Fold m a ()-demuxWithDefault_ f kv (Fold dstep dinitial dextract) =-    Fold step initial extract--    where--    initFold (Fold s i e) = i >>= \r -> return (Fold s (return r) e)-    initial = do-        mp <- Prelude.mapM initFold kv-        dacc <- dinitial-        return (Tuple' mp dacc)-    step (Tuple' mp dacc) a-      | (k, a') <- f a-      = case Map.lookup k mp of-            Nothing -> do-                acc <- dstep dacc (k, a')-                return (Tuple' mp acc)-            Just (Fold step' acc _) -> do-                _ <- acc >>= \x -> step' x a'-                return (Tuple' mp dacc)-    extract (Tuple' mp dacc) = do-        void $ dextract dacc-        Prelude.mapM_ (\(Fold _ acc e) -> acc >>= e) mp---- | Split the input stream based on a key field and fold each split using a--- specific fold without collecting the results. Useful for cases like protocol--- handlers to handle different type of packets.------ @------                             |-------Fold m a ()--- -----stream m a-----Map-----|---                             |-------Fold m a ()---                             |---                                       ...--- @--------- @since 0.7.0---- demuxWith_ can be slightly faster than demuxWith because we do not need to--- update the Map in this case. This may be significant only if the map is--- large.-{-# INLINE demuxWith_ #-}-demuxWith_ :: (Monad m, Ord k)-    => (a -> (k, a')) -> Map k (Fold m a' b) -> Fold m a ()-demuxWith_ f kv = Fold step initial extract--    where--    initial = do-        Prelude.mapM (\(Fold s i e) ->-            i >>= \r -> return (Fold s (return r) e)) kv-    step mp a-        -- XXX should we raise an exception in Nothing case?-        -- Ideally we should enforce that it is a total map over k so that look-        -- up never fails-      | (k, a') <- f a-      = case Map.lookup k mp of-            Nothing -> return mp-            Just (Fold step' acc _) -> do-                _ <- acc >>= \x -> step' x a'-                return mp-    extract mp = Prelude.mapM_ (\(Fold _ acc e) -> acc >>= e) mp---- | Given a stream of key value pairs and a map from keys to folds, fold the--- values for each key using the corresponding folds, discarding the outputs.------ @--- > let prn = FL.drainBy print--- > let table = Data.Map.fromList [(\"ONE", prn), (\"TWO", prn)]---       input = S.fromList [(\"ONE",1),(\"TWO",2)]---   in S.fold (FL.demux_ table) input--- One 1--- Two 2--- @------ @since 0.7.0-{-# INLINE demux_ #-}-demux_ :: (Monad m, Ord k) => Map k (Fold m a ()) -> Fold m (k, a) ()-demux_ = demuxWith_ id--{-# INLINE demuxDefault_ #-}-demuxDefault_ :: (Monad m, Ord k)-    => Map k (Fold m a ()) -> Fold m (k, a) () -> Fold m (k, a) ()-demuxDefault_ = demuxWithDefault_ id---- TODO If the data is large we may need a map/hashmap in pinned memory instead--- of a regular Map. That may require a serializable constraint though. We can--- have another API for that.------ | 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.------ @--- > let input = S.fromList [(\"ONE",1),(\"ONE",1.1),(\"TWO",2), (\"TWO",2.2)]---   in S.fold (FL.classify FL.toList) input--- fromList [(\"ONE",[1.1,1.0]),(\"TWO",[2.2,2.0])]--- @------ @since 0.7.0-{-# INLINE classifyWith #-}-classifyWith :: (Monad m, Ord k) => (a -> k) -> Fold m a b -> Fold m a (Map k b)-classifyWith f (Fold step initial extract) = Fold step' initial' extract'--    where--    initial' = return Map.empty-    step' kv a =-        let k = f a-        in case Map.lookup k kv of-            Nothing -> do-                x <- initial-                r <- step x a-                return $ Map.insert k r kv-            Just x -> do-                r <- step x a-                return $ Map.insert k r kv-    extract' = Prelude.mapM extract---- | 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.------ @--- > let input = S.fromList [(\"ONE",1),(\"ONE",1.1),(\"TWO",2), (\"TWO",2.2)]---   in S.fold (FL.classify FL.toList) input--- fromList [(\"ONE",[1.1,1.0]),(\"TWO",[2.2,2.0])]--- @------ @since 0.7.0---- Same as:------ > classify fld = classifyWith fst (lmap snd fld)----{-# INLINE classify #-}-classify :: (Monad m, Ord k) => Fold m a b -> Fold m (k, a) (Map k b)-classify fld = classifyWith fst (lmap snd fld)----------------------------------------------------------------------------------- Unzipping------------------------------------------------------------------------------------- | Like 'unzipWith' but with a monadic splitter function.------ @since 0.7.0-{-# INLINE unzipWithM #-}-unzipWithM :: Monad m-    => (a -> m (b,c)) -> Fold m b x -> Fold m c y -> Fold m a (x,y)-unzipWithM f (Fold stepL beginL doneL) (Fold stepR beginR doneR) =-    Fold step begin done--    where--    step (Tuple' xL xR) a = do-        (b,c) <- f a-        Tuple' <$> stepL xL b <*> stepR xR c-    begin = Tuple' <$> beginL <*> beginR-    done (Tuple' xL xR) = (,) <$> doneL xL <*> doneR xR---- | 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.------ @since 0.7.0-{-# 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--------|------ @------ This is the consumer side dual of the producer side 'zip' operation.------ @since 0.7.0-{-# INLINE unzip #-}-unzip :: Monad m => Fold m a x -> Fold m b y -> Fold m (a,b) (x,y)-unzip = unzipWith id----------------------------------------------------------------------------------- Nesting---------------------------------------------------------------------------------{---- All the stream flattening transformations can also be applied to a fold--- input stream.---- | This can be used to apply all the stream generation operations on folds.-lconcatMap ::(IsStream t, Monad m) => (a -> t m b)-    -> Fold m b c-    -> Fold m a c-lconcatMap s f1 f2 = undefined--}---- 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 foldChunks to use those repeatedly on a stream.---- | Apply a terminating fold repeatedly to the input of another fold.------ Compare with: Streamly.Prelude.concatMap, Streamly.Prelude.foldChunks------ /Unimplemented/----{-# INLINABLE foldChunks #-}-foldChunks ::-    -- Monad m =>-    Fold m a b -> Fold m b c -> Fold m a c-foldChunks = undefined--{---- XXX this would be an application of foldChunks using a terminating fold.------ | 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.------ @------ XXX we should be able to implement it with parsers/terminating folds.----{-# INLINE lchunksInRange #-}-lchunksInRange :: Monad m-    => Int -> Int -> Fold m a b -> Fold m b c -> Fold m a c-lchunksInRange low high (Fold step1 initial1 extract1)-                        (Fold step2 initial2 extract2) = undefined--}----------------------------------------------------------------------------------- Fold to a Parallel SVar---------------------------------------------------------------------------------{-# INLINE toParallelSVar #-}-toParallelSVar :: MonadIO m => SVar t m a -> Maybe WorkerInfo -> Fold m a ()-toParallelSVar svar winfo = Fold step initial extract-    where--    initial = return ()--    step () x = liftIO $ do-        -- XXX we can have a separate fold for unlimited buffer case to avoid a-        -- branch in the step here.-        decrementBufferLimit svar-        void $ send svar (ChildYield x)--    extract () = liftIO $ do-        sendStop svar winfo--{-# INLINE toParallelSVarLimited #-}-toParallelSVarLimited :: MonadIO m-    => SVar t m a -> Maybe WorkerInfo -> Fold m a ()-toParallelSVarLimited svar winfo = Fold step initial extract-    where--    initial = return True--    step True x = liftIO $ do-        yieldLimitOk <- decrementYieldLimit svar-        if yieldLimitOk-        then do-            decrementBufferLimit svar-            void $ send svar (ChildYield x)-            return True-        else do-            cleanupSVarFromWorker svar-            sendStop svar winfo-            return False-    step False _ = return False--    extract True = liftIO $ sendStop svar winfo-    extract False = return ()+-- |+-- 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.Types" for design notes.+--+-- IMPORTANT: keep the signatures consistent with the folds in Streamly.Prelude++module Streamly.Internal.Data.Fold+    (+    -- * Fold Type+      Step (..)+    , Fold (..)++    -- * Constructors+    , foldl'+    , foldlM'+    , foldl1'+    , foldr+    , foldrM+    , mkFold+    , mkFold_+    , mkFoldM+    , mkFoldM_++    -- * Folds+    -- ** Identity+    , fromPure+    , fromEffect++    -- ** Accumulators+    -- *** Semigroups and Monoids+    , sconcat+    , mconcat+    , foldMap+    , foldMapM++    -- *** Reducers+    , drain+    , drainBy+    , last+    , length+    , mean+    , variance+    , stdDev+    , rollingHash+    , 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++    -- ** Terminating Folds+    , drainN+    -- , lastN+    -- , (!!)+    , genericIndex+    , index+    , head+    -- , findM+    , find+    , lookup+    , findIndex+    , elemIndex+    , null+    , elem+    , notElem+    , all+    , any+    , and+    , or+    -- , the++    -- * Combinators+    -- ** Utilities+    , with++    -- ** Transforming the Monad+    , hoist+    , generally++    -- ** Mapping on output+    , rmapM++    -- ** Mapping on Input+    , transform+    , map+    , lmap+    --, lsequence+    , lmapM+    , indexed++    -- ** Filtering+    , filter+    , filterM+    , sampleFromthen+    -- , ldeleteBy+    -- , luniq++    -- ** Mapping Filters+    , catMaybes+    , mapMaybe+    -- , mapMaybeM++    {-+    -- ** Scanning Filters+    , findIndices+    , elemIndices++    -- ** Insertion+    -- | Insertion adds more elements to the stream.++    , insertBy+    , intersperseM++    -- ** Reordering+    , reverse+    -}++    -- ** Trimming+    , take+    , takeInterval++    -- By elements+    , takeEndBy+    , takeEndBy_+    -- , takeEndBySeq+    {-+    , drop+    , dropWhile+    , dropWhileM+    -}++    -- ** Serial Append+    , serialWith+    -- , tail+    -- , init+    , splitAt -- spanN+    -- , splitIn -- sessionN++    -- ** Parallel Distribution+    , teeWith+    , tee+    , teeWithFst+    , teeWithMin+    , distribute+    -- , distributeFst+    -- , distributeMin++    -- ** Parallel Alternative+    , shortest+    , longest++    -- ** Partitioning+    , partitionByM+    , partitionByFstM+    , partitionByMinM+    , partitionBy+    , partition++    -- ** Demultiplexing+    -- | Direct values in the input stream to different folds using an n-ary+    -- fold selector.+    , demux        -- XXX rename this to demux_+    , demuxWith+    , demuxDefault -- XXX rename this to demux+    , demuxDefaultWith+    -- , demuxWithSel+    -- , demuxWithMin++    -- ** Classifying+    -- | In an input stream of key value pairs fold values for different keys+    -- in individual output buckets using the given fold.+    , classify+    , classifyWith+    -- , classifyWithSel+    -- , classifyWithMin++    -- ** Unzipping+    , unzip+    -- These two can be expressed using lmap/lmapM and unzip+    , unzipWith+    , unzipWithM+    , unzipWithFstM+    , unzipWithMinM++    -- ** Zipping+    , zipWithM+    , zip++    -- ** Splitting+    , many+    , intervalsOf+    , chunksOf+    , chunksBetween++    -- ** Nesting+    , concatSequence+    , concatMap++    -- * Running Partially+    , initialize+    , runStep+    , duplicate++    -- * Fold2+    , drainBy2++    -- * Deprecated+    , sequence+    , mapM+    )+where++import Control.Monad (void)+import Data.Bifunctor (first)+import Data.Functor.Identity (Identity(..))+import Data.Int (Int64)+import Data.Map.Strict (Map)+import Data.Maybe (isJust, fromJust)+#if __GLASGOW_HASKELL__ < 804+import Data.Semigroup (Semigroup((<>)))+#endif+import Streamly.Internal.Data.Either.Strict+    (Either'(..), fromLeft', fromRight', isLeft', isRight')+import Streamly.Internal.Data.Pipe.Type (Pipe (..), PipeState(..))+import Streamly.Internal.Data.Tuple.Strict (Tuple'(..), Tuple3'(..))+import Streamly.Internal.Data.Stream.Serial (SerialT)++import qualified Data.Map.Strict as Map+import qualified Streamly.Internal.Data.Pipe.Type as Pipe+import qualified Streamly.Internal.Data.Stream.IsStream.Enumeration as Stream+import qualified Streamly.Internal.Data.Stream.StreamK as K+import qualified Prelude++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)+import Streamly.Internal.Data.Fold.Type++-- $setup+-- >>> :m+-- >>> import Prelude hiding (break, map, span, splitAt)+-- >>> import qualified Streamly.Prelude as Stream+-- >>> import qualified Streamly.Internal.Data.Stream.IsStream as Stream (parse, foldMany)+-- >>> import qualified Streamly.Data.Fold as Fold+-- >>> import qualified Streamly.Internal.Data.Fold as Fold+-- >>> import qualified Streamly.Internal.Data.Parser as Parser++------------------------------------------------------------------------------+-- hoist+------------------------------------------------------------------------------++-- | Change the underlying monad of a fold+--+-- /Pre-release/+hoist :: (forall x. m x -> n x) -> Fold m a b -> Fold n a b+hoist f (Fold step initial extract) =+    Fold (\x a -> f $ step x a) (f initial) (f . extract)++-- | Adapt a pure fold to any monad+--+-- > generally = Fold.hoist (return . runIdentity)+--+-- /Pre-release/+generally :: Monad m => Fold Identity a b -> Fold m a b+generally = hoist (return . runIdentity)++------------------------------------------------------------------------------+-- Transformations on fold inputs+------------------------------------------------------------------------------++-- | Flatten the monadic output of a fold to pure output.+--+-- @since 0.7.0+{-# 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.+--+-- @since 0.7.0+{-# DEPRECATED mapM "Use rmapM instead" #-}+{-# INLINE mapM #-}+mapM :: Monad m => (b -> m c) -> Fold m a b -> Fold m a c+mapM = rmapM++-- | @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'.+--+-- >>> 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]+--+-- @since 0.8.0+{-# INLINE mapMaybe #-}+mapMaybe :: (Monad m) => (a -> Maybe b) -> Fold m b r -> Fold m a r+mapMaybe f = map f . filter isJust . map fromJust++------------------------------------------------------------------------------+-- Transformations on fold inputs+------------------------------------------------------------------------------++-- 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++------------------------------------------------------------------------------+-- Left folds+------------------------------------------------------------------------------++------------------------------------------------------------------------------+-- Run Effects+------------------------------------------------------------------------------++-- |+-- > drainBy f = lmapM f drain+-- > drainBy = Fold.foldMapM (void . f)+--+-- Drain all input after passing it through a monadic function. This is the+-- dual of mapM_ on stream producers.+--+-- See also: 'Streamly.Prelude.mapM_'+--+-- @since 0.7.0+{-# INLINABLE drainBy #-}+drainBy ::  Monad m => (a -> m b) -> Fold m a ()+drainBy f = lmapM f drain++-- |+--+-- /Internal/+{-# INLINABLE drainBy2 #-}+drainBy2 ::  Monad m => (a -> m b) -> Fold2 m c a ()+drainBy2 f = Fold2 (const (void . f)) (\_ -> return ()) return++-- | Extract the last element of the input stream, if any.+--+-- > last = fmap getLast $ Fold.foldMap (Last . Just)+--+-- @since 0.7.0+{-# INLINABLE last #-}+last :: Monad m => Fold m a (Maybe a)+last = foldl1' (\_ x -> x)++------------------------------------------------------------------------------+-- To Summary+------------------------------------------------------------------------------++-- | Like 'length', except with a more general 'Num' return value+--+-- > genericLength = fmap getSum $ foldMap (Sum . const  1)+--+-- /Pre-release/+{-# INLINE genericLength #-}+genericLength :: (Monad m, Num b) => Fold m a b+genericLength = foldl' (\n _ -> n + 1) 0++-- | Determine the length of the input stream.+--+-- > length = fmap getSum $ Fold.foldMap (Sum . const  1)+--+-- @since 0.7.0+{-# INLINE length #-}+length :: Monad m => Fold m a Int+length = genericLength++-- | 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 = fmap getSum $ Fold.foldMap Sum+--+-- @since 0.7.0+{-# INLINE sum #-}+sum :: (Monad m, Num a) => Fold m a a+sum =  foldl' (+) 0++-- | 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.+--+-- Compare with @Fold.foldMap Product@.+--+-- @since 0.7.0+-- /Since 0.8.0 (Added 'Eq' constraint)/+{-# INLINE product #-}+product :: (Monad m, Num a, Eq a) => Fold m a a+product =  mkFold_ step (Partial 1)++    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.+--+-- @since 0.7.0+{-# 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++-- |+-- @+-- maximum = Fold.maximumBy compare+-- @+--+-- Determine the maximum element in a stream.+--+-- Compare with @Fold.foldMap Max@.+--+-- @since 0.7.0+{-# 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+--+-- @since 0.7.0+{-# 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.+--+-- @+-- minimum = 'minimumBy' compare+-- @+--+-- Compare with @Fold.foldMap Min@.+--+-- @since 0.7.0+{-# 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.+--+-- @since 0.7.0+{-# INLINABLE 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.+--+-- @since 0.7.0+{-# INLINABLE 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.+--+-- @since 0.7.0+{-# INLINABLE 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+--+-- @since 0.8.0+{-# INLINABLE 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 defaultSalt+--+-- @since 0.8.0+{-# INLINABLE 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 = Fold.take n Fold.rollingHash+--+-- /Pre-release/+{-# INLINABLE rollingHashFirstN #-}+rollingHashFirstN :: (Monad m, Enum a) => Int -> Fold m a Int64+rollingHashFirstN n = take n rollingHash++------------------------------------------------------------------------------+-- Monoidal left folds+------------------------------------------------------------------------------++-- | Append the elements of an input stream to a provided starting value.+--+-- >>> Stream.fold (Fold.sconcat 10) (Stream.map Data.Monoid.Sum $ Stream.enumerateFromTo 1 10)+-- Sum {getSum = 65}+--+-- @+-- sconcat = Fold.foldl' (<>)+-- @+--+-- @since 0.8.0+{-# INLINE sconcat #-}+sconcat :: (Monad m, Semigroup a) => a -> Fold m a a+sconcat = foldl' (<>)++-- | Fold an input stream consisting of monoidal elements using 'mappend'+-- and 'mempty'.+--+-- >>> Stream.fold Fold.mconcat (Stream.map Data.Monoid.Sum $ Stream.enumerateFromTo 1 10)+-- Sum {getSum = 55}+--+-- > mconcat = Fold.sconcat mempty+--+-- @since 0.7.0+{-# INLINE mconcat #-}+mconcat ::+    ( Monad m+#if !MIN_VERSION_base(4,11,0)+    , Semigroup a+#endif+    , Monoid a) => Fold m a a+mconcat = sconcat mempty++-- |+-- > 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'.+--+-- >>> Stream.fold (Fold.foldMap Data.Monoid.Sum) $ Stream.enumerateFromTo 1 10+-- Sum {getSum = 55}+--+-- @since 0.7.0+{-# INLINABLE foldMap #-}+foldMap :: (Monad m, Monoid b+#if !MIN_VERSION_base(4,11,0)+    , Semigroup b+#endif+    ) => (a -> b) -> Fold m a b+foldMap f = lmap f mconcat++-- |+-- > 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'.+--+-- >>> Stream.fold (Fold.foldMapM (return . Data.Monoid.Sum)) $ Stream.enumerateFromTo 1 10+-- Sum {getSum = 55}+--+-- @since 0.7.0+{-# INLINABLE 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.+--+-- > toListRev = Fold.foldl' (flip (:)) []+--+-- /Warning!/ working on large lists accumulated as buffers in memory could be+-- very inefficient, consider using "Streamly.Array" instead.+--+-- @since 0.8.0++--  xn : ... : x2 : x1 : []+{-# INLINABLE 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.+--+-- > drainN n = Fold.take n Fold.drain+--+-- /Pre-release/+{-# INLINABLE 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/+{-# INLINABLE genericIndex #-}+genericIndex :: (Integral i, Monad m) => i -> Fold m a (Maybe a)+genericIndex i = mkFold step (Partial 0) (const Nothing)++    where++    step j a =+        if i == j+        then Done $ Just a+        else Partial (j + 1)++-- | Lookup the element at the given index.+--+-- See also: 'Streamly.Prelude.!!'+--+-- @since 0.7.0+{-# INLINABLE index #-}+index :: Monad m => Int -> Fold m a (Maybe a)+index = genericIndex++-- | Extract the first element of the stream, if any.+--+-- @since 0.7.0+{-# INLINABLE head #-}+head :: Monad m => Fold m a (Maybe a)+head = mkFold_ (const (Done . Just)) (Partial Nothing)++-- | Returns the first element that satisfies the given predicate.+--+-- @since 0.7.0+{-# INLINABLE find #-}+find :: Monad m => (a -> Bool) -> Fold m a (Maybe a)+find predicate = mkFold step (Partial ()) (const Nothing)++    where++    step () a =+        if predicate a+        then Done (Just a)+        else Partial ()++-- | 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@.+--+-- > lookup = snd <$> Fold.find ((==) . fst)+--+-- @since 0.7.0+{-# INLINABLE lookup #-}+lookup :: (Eq a, Monad m) => a -> Fold m (a,b) (Maybe b)+lookup a0 = mkFold 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.+--+-- @since 0.7.0+{-# INLINABLE findIndex #-}+findIndex :: Monad m => (a -> Bool) -> Fold m a (Maybe Int)+findIndex predicate = mkFold step (Partial 0) (const Nothing)++    where++    step i a =+        if predicate a+        then Done $ Just i+        else Partial (i + 1)++-- | Returns the first index where a given value is found in the stream.+--+-- > elemIndex a = Fold.findIndex (== a)+--+-- @since 0.7.0+{-# INLINABLE elemIndex #-}+elemIndex :: (Eq a, Monad m) => a -> Fold m a (Maybe Int)+elemIndex a = findIndex (a ==)++------------------------------------------------------------------------------+-- To Boolean+------------------------------------------------------------------------------++-- | Return 'True' if the input stream is empty.+--+-- > null = fmap isJust Fold.head+--+-- @since 0.7.0+{-# INLINABLE null #-}+null :: Monad m => Fold m a Bool+null = mkFold (\() _ -> Done False) (Partial ()) (const True)++-- | Returns 'True' if any of the elements of a stream satisfies a predicate.+--+-- >>> Stream.fold (Fold.any (== 0)) $ Stream.fromList [1,0,1]+-- True+--+-- > any p = Fold.lmap p Fold.or+--+-- @since 0.7.0+{-# INLINE any #-}+any :: Monad m => (a -> Bool) -> Fold m a Bool+any predicate = mkFold_ step initial++    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.+--+-- > elem a = Fold.any (== a)+--+-- @since 0.7.0+{-# INLINABLE elem #-}+elem :: (Eq a, Monad m) => a -> Fold m a Bool+elem a = any (a ==)++-- | Returns 'True' if all elements of a stream satisfy a predicate.+--+-- >>> Stream.fold (Fold.all (== 0)) $ Stream.fromList [1,0,1]+-- False+--+-- > all p = Fold.lmap p Fold.and+--+-- @since 0.7.0+{-# INLINABLE all #-}+all :: Monad m => (a -> Bool) -> Fold m a Bool+all predicate = mkFold_ step initial++    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.+--+-- > notElem a = Fold.all (/= a)+--+-- @since 0.7.0+{-# INLINABLE notElem #-}+notElem :: (Eq a, Monad m) => a -> Fold m a Bool+notElem a = all (a /=)++-- | Returns 'True' if all elements are 'True', 'False' otherwise+--+-- > and = Fold.all (== True)+--+-- @since 0.7.0+{-# INLINE and #-}+and :: Monad m => Fold m Bool Bool+and = all (== True)++-- | Returns 'True' if any element is 'True', 'False' otherwise+--+-- > or = Fold.any (== True)+--+-- @since 0.7.0+{-# 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.serialWith (,) (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 = serialWith (,) (take n fld)++------------------------------------------------------------------------------+-- Element Aware APIs+------------------------------------------------------------------------------+--+------------------------------------------------------------------------------+-- Binary APIs+------------------------------------------------------------------------------++-- 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.+--+-- | Like 'takeEndBy' but drops the element on which the predicate succeeds.+--+-- >>> Stream.fold (Fold.takeEndBy_ (== '\n') Fold.toList) $ Stream.fromList "hello\nthere\n"+-- "hello"+--+-- >>> Stream.toList $ Stream.foldMany (Fold.takeEndBy_ (== '\n') Fold.toList) $ Stream.fromList "hello\nthere\n"+-- ["hello","there"]+--+-- > Stream.splitOnSuffix p f = Stream.foldMany (Fold.takeEndBy_ p f)+--+-- See 'Streamly.Prelude.splitOnSuffix' for more details on splitting a+-- stream using 'takeEndBy_'.+--+-- @since 0.8.0+{-# INLINE takeEndBy_ #-}+takeEndBy_ :: Monad m => (a -> Bool) -> Fold m a b -> Fold m a b+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++-- | Take the input, stop when the predicate succeeds taking the succeeding+-- element as well.+--+-- >>> Stream.fold (Fold.takeEndBy (== '\n') Fold.toList) $ Stream.fromList "hello\nthere\n"+-- "hello\n"+--+-- >>> Stream.toList $ Stream.foldMany (Fold.takeEndBy (== '\n') Fold.toList) $ Stream.fromList "hello\nthere\n"+-- ["hello\n","there\n"]+--+-- > Stream.splitWithSuffix p f = Stream.foldMany (Fold.takeEndBy p f)+--+-- See 'Streamly.Prelude.splitWithSuffix' for more details on splitting a+-- stream using 'takeEndBy'.+--+-- @since 0.8.0+{-# INLINE takeEndBy #-}+takeEndBy :: Monad m => (a -> Bool) -> Fold m a b -> Fold m a b+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+------------------------------------------------------------------------------++{-+-- | Find the first occurrence of the specified sequence in the input stream+-- and break the input stream into two parts, the first part consisting of the+-- stream before the sequence and the second part consisting of the sequence+-- and the rest of the stream.+--+-- > let breakOn_ pat xs = S.fold (S.breakOn pat FL.toList FL.toList) $ S.fromList xs+--+-- >>> breakOn_ "dear" "Hello dear world!"+-- > ("Hello ","dear world!")+--+{-# INLINE breakOn #-}+breakOn :: Monad m => Array a -> Fold m a b -> Fold m a c -> Fold m a (b,c)+breakOn pat f m = undefined+-}++------------------------------------------------------------------------------+-- 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--------|+-- @+-- >>> Stream.fold (Fold.tee Fold.sum Fold.length) (Stream.enumerateFromTo 1.0 100.0)+-- (5050.0,100)+--+-- > tee = teeWith (,)+--+-- @since 0.7.0+{-# 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.+--+-- @since 0.7.0+{-# INLINE distribute #-}+distribute :: Monad m => [Fold m a b] -> Fold m a [b]+distribute = Prelude.foldr (teeWith (:)) (fromPure [])++------------------------------------------------------------------------------+-- Partitioning+------------------------------------------------------------------------------++-- | 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--------|+-- @+--+-- Send input to either fold randomly:+--+-- @+-- > import System.Random (randomIO)+-- > randomly a = randomIO >>= \\x -> return $ if x then Left a else Right a+-- > Stream.fold (Fold.partitionByM randomly Fold.length Fold.length) (Stream.enumerateFromTo 1 100)+-- (59,41)+-- @+--+-- Send input to the two folds in a proportion of 2:1:+--+-- @+-- import Data.IORef (newIORef, readIORef, writeIORef)+-- 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 $ head r a+--+-- main = do+--  f <- proportionately 2 1+--  r <- S.fold (FL.partitionByM f FL.length FL.length) (S.enumerateFromTo (1 :: Int) 100)+--  print r+-- @+-- @+-- (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 f (Fold stepL beginL doneL) (Fold stepR beginR doneR) =+    Fold step begin done++    where++    begin = do+        resL <- beginL+        resR <- beginR+        return+            $ case resL of+                  Partial sL ->+                      Partial+                          $ case resR of+                                Partial sR -> RunBoth sL sR+                                Done bR -> RunLeft sL bR+                  Done bL ->+                      case resR of+                          Partial sR -> Partial $ RunRight bL sR+                          Done bR -> Done (bL, bR)++    step (RunBoth sL sR) a = do+        r <- f a+        case r of+            Left b -> do+                res <- stepL sL b+                return+                  $ Partial+                  $ case res of+                        Partial sres -> RunBoth sres sR+                        Done bres -> RunRight bres sR+            Right c -> do+                res <- stepR sR c+                return+                  $ Partial+                  $ case res of+                        Partial sres -> RunBoth sL sres+                        Done bres -> RunLeft sL bres+    step (RunLeft sL bR) a = do+        r <- f a+        case r of+            Left b -> do+                res <- stepL sL b+                return+                  $ case res of+                        Partial sres -> Partial $ RunLeft sres bR+                        Done bres -> Done (bres, bR)+            Right _ -> return $ Partial $ RunLeft sL bR+    step (RunRight bL sR) a = do+        r <- f a+        case r of+            Left _ -> return $ Partial $ RunRight bL sR+            Right c -> do+                res <- stepR sR c+                return+                  $ case res of+                        Partial sres -> Partial $ RunRight bL sres+                        Done bres -> Done (bL, bres)++    done (RunBoth sL sR) = (,) <$> doneL sL <*> doneR sR+    done (RunLeft sL bR) = (,bR) <$> doneL sL+    done (RunRight bL sR) = (bL,) <$> doneR sR++-- | Similar to 'partitionByM' but terminates when the first fold terminates.+--+-- /Unimplemented/+--+{-# INLINE partitionByFstM #-}+partitionByFstM :: -- Monad m =>+       (a -> m (Either b c)) -> Fold m b x -> Fold m c y -> Fold m a (x, y)+partitionByFstM = undefined++-- | Similar to 'partitionByM' but terminates when any fold terminates.+--+-- /Unimplemented/+--+{-# INLINE partitionByMinM #-}+partitionByMinM :: -- Monad m =>+       (a -> m (Either b c)) -> Fold m b x -> Fold m c y -> Fold m a (x, y)+partitionByMinM = undefined++-- 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.+--+-- 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.+--+-- > partition = partitionBy id+--+-- @since 0.7.0+{-# 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+-}++-- 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. We also want to make sure that the Map contains+-- only those types and the full set of those types.+--+-- TODO Instead of the input Map it should probably be a lookup-table using an+-- array and not in GC memory. The same applies to the output Map as well.+-- However, that would only be helpful if we have a very large data structure,+-- need to measure and see how it scales.+--+-- This is the consumer side dual of the producer side 'mux' operation (XXX to+-- be implemented).++-- | Split the input stream based on a key field and fold each split using a+-- specific fold collecting the results in a map from the keys to the results.+-- Useful for cases like protocol handlers to handle different type of packets+-- using different handlers.+--+-- @+--+--                             |-------Fold m a b+-- -----stream m a-----Map-----|+--                             |-------Fold m a b+--                             |+--                                       ...+-- @+--+-- Any input that does not map to a fold in the input Map is silently ignored.+--+-- > demuxWith f kv = fmap fst $ demuxDefaultWith f kv drain+--+-- /Pre-release/+--+{-# INLINE demuxWith #-}+demuxWith :: (Monad m, Ord k)+    => (a -> (k, a')) -> Map k (Fold m a' b) -> Fold m a (Map k b)+demuxWith f kv = fmap fst $ demuxDefaultWith f kv drain++-- | Fold a stream of key value pairs using a map of specific folds for each+-- key into a map from keys to the results of fold outputs of the corresponding+-- values.+--+-- >>> import qualified Data.Map+-- >>> :{+--  let table = Data.Map.fromList [("SUM", Fold.sum), ("PRODUCT", Fold.product)]+--      input = Stream.fromList [("SUM",1),("PRODUCT",2),("SUM",3),("PRODUCT",4)]+--   in Stream.fold (Fold.demux table) input+-- :}+-- fromList [("PRODUCT",8),("SUM",4)]+--+-- > demux = demuxWith id+--+-- /Pre-release/+{-# INLINE demux #-}+demux :: (Monad m, Ord k)+    => Map k (Fold m a b) -> Fold m (k, a) (Map k b)+demux = demuxWith id++data DemuxState s b doneMap runMap =+      DemuxMapAndDefault !s !doneMap !runMap+    | DemuxOnlyMap b !doneMap !runMap+    | DemuxOnlyDefault s !doneMap++-- | Like 'demuxWith' but uses a default catchall fold to handle inputs which+-- do not have a specific fold in the map to handle them.+--+-- If any fold in the map stops, inputs meant for that fold are sent to the+-- catchall fold. If the catchall fold stops then inputs that do not match any+-- fold are ignored.+--+-- Stops when all the folds, including the catchall fold, stop.+--+-- /Pre-release/+--+{-# INLINE demuxDefaultWith #-}+demuxDefaultWith :: (Monad m, Ord k)+    => (a -> (k, a'))+    -> Map k (Fold m a' b)+    -> Fold m (k, a') c+    -> Fold m a (Map k b, c)+demuxDefaultWith f kv (Fold dstep dinitial dextract) =+    Fold step initial extract++    where++    initial = do+        let runInit (Fold step1 initial1 done1) = do+                r <- initial1+                return+                    $ case r of+                          Partial _ -> Right' (Fold step1 (return r) done1)+                          Done b -> Left' b++        -- initialize folds in the kv map and separate the ones that are done+        -- from running ones+        kv1 <- Prelude.mapM runInit kv+        let runMap = Map.map fromRight' $ Map.filter isRight' kv1+            doneMap = Map.map fromLeft' $ Map.filter isLeft' kv1++        -- Run the default fold, and decide the next state based on its result+        dres <- dinitial+        return+            $ case dres of+                  Partial s ->+                      Partial+                          $ if Map.size runMap > 0+                            then DemuxMapAndDefault s doneMap runMap+                            else DemuxOnlyDefault s doneMap+                  Done b ->+                      if Map.size runMap > 0+                      then Partial $ DemuxOnlyMap b doneMap runMap+                      else Done (doneMap, b)++    {-# INLINE runFold #-}+    runFold fPartial fDone doneMap runMap (Fold step1 initial1 done1) k a1 = do+        resi <- initial1+        case resi of+            Partial st -> do+                res <- step1 st a1+                return $ case res of+                    Partial s ->+                        let fld = Fold step1 (return $ Partial s) done1+                            runMap1 = Map.insert k fld runMap+                         in Partial $ fPartial doneMap runMap1+                    Done b -> do+                        let runMap1 = Map.delete k runMap+                            doneMap1 = Map.insert k b doneMap+                        if Map.size runMap1 == 0+                        then fDone doneMap1+                        else Partial $ fPartial doneMap1 runMap1+            Done _ -> error "Bug: demuxDefaultWith: Done fold"++    step (DemuxMapAndDefault dacc doneMap runMap) a = do+        let (k, a1) = f a+        case Map.lookup k runMap of+            Nothing -> do+                res <- dstep dacc (k, a1)+                return+                    $ Partial+                    $ case res of+                          Partial s -> DemuxMapAndDefault s doneMap runMap+                          Done b -> DemuxOnlyMap b doneMap runMap+            Just fld ->+                runFold+                    (DemuxMapAndDefault dacc)+                    (Partial . DemuxOnlyDefault dacc)+                    doneMap runMap fld k a1++    step (DemuxOnlyMap dval doneMap runMap) a = do+        let (k, a1) = f a+        case Map.lookup k runMap of+            Nothing -> return $ Partial $ DemuxOnlyMap dval doneMap runMap+            Just fld ->+                runFold+                    (DemuxOnlyMap dval)+                    (Done . (, dval))+                    doneMap runMap fld k a1+    step (DemuxOnlyDefault dacc doneMap) a = do+        let (k, a1) = f a+        res <- dstep dacc (k, a1)+        return+            $ case res of+                  Partial s -> Partial $ DemuxOnlyDefault s doneMap+                  Done b -> Done (doneMap, b)++    runExtract (Fold _ initial1 done1) = do+        res <- initial1+        case res of+            Partial s -> done1 s+            Done b -> return b++    extract (DemuxMapAndDefault dacc doneMap runMap) = do+        b <- dextract dacc+        runMap1 <- Prelude.mapM runExtract runMap+        return (doneMap `Map.union` runMap1, b)+    extract (DemuxOnlyMap dval doneMap runMap) = do+        runMap1 <- Prelude.mapM runExtract runMap+        return (doneMap `Map.union` runMap1, dval)+    extract (DemuxOnlyDefault dacc doneMap) = do+        b <- dextract dacc+        return (doneMap, b)++-- |+-- > demuxDefault = demuxDefaultWith id+--+-- /Pre-release/+{-# INLINE demuxDefault #-}+demuxDefault :: (Monad m, Ord k)+    => Map k (Fold m a b) -> Fold m (k, a) b -> Fold m (k, a) (Map k b, b)+demuxDefault = demuxDefaultWith id++-- TODO If the data is large we may need a map/hashmap in pinned memory instead+-- of a regular Map. That may require a serializable constraint though. We can+-- have another API for that.+--+-- | 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.+--+-- >>> :{+--  let input = Stream.fromList [("ONE",1),("ONE",1.1),("TWO",2), ("TWO",2.2)]+--   in Stream.fold (Fold.classifyWith fst (Fold.map snd Fold.toList)) input+-- :}+-- fromList [("ONE",[1.0,1.1]),("TWO",[2.0,2.2])]+--+-- If the classifier fold stops for a particular key any further inputs in that+-- bucket are ignored.+--+-- /Stops: never/+--+-- /Pre-release/+--+{-# INLINE classifyWith #-}+classifyWith :: (Monad m, Ord k) => (a -> k) -> Fold m a b -> Fold m a (Map k b)+classifyWith f (Fold step1 initial1 extract1) =+    rmapM extract $ foldlM' step initial++    where++    initial = return Map.empty++    step kv a =+        case Map.lookup k kv of+            Nothing -> do+                x <- initial1+                case x of+                      Partial s -> do+                        r <- step1 s a+                        return+                            $ flip (Map.insert k) kv+                            $ case r of+                                  Partial s1 -> Left' s1+                                  Done b -> Right' b+                      Done b -> return $ Map.insert k (Right' b) kv+            Just x -> do+                case x of+                    Left' s -> do+                        r <- step1 s a+                        return+                            $ flip (Map.insert k) kv+                            $ case r of+                                  Partial s1 -> Left' s1+                                  Done b -> Right' b+                    Right' _ -> return kv++        where++        k = f a++    extract =+        Prelude.mapM+            (\case+                 Left' s -> extract1 s+                 Right' b -> return b)++-- | 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.+--+-- >>> :{+--  let input = Stream.fromList [("ONE",1),("ONE",1.1),("TWO",2), ("TWO",2.2)]+--   in Stream.fold (Fold.classify Fold.toList) input+-- :}+-- fromList [("ONE",[1.0,1.1]),("TWO",[2.0,2.2])]+--+-- Same as:+--+-- > classify fld = Fold.classifyWith fst (map snd fld)+--+-- /Pre-release/+{-# INLINE classify #-}+classify :: (Monad m, Ord k) => Fold m a b -> Fold m (k, a) (Map k b)+classify fld = classifyWith fst (map snd fld)++------------------------------------------------------------------------------+-- Unzipping+------------------------------------------------------------------------------++-- | Like 'unzipWith' but with a monadic splitter function.+--+-- @unzipWithM k f1 f2 = lmapM k (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 f (Fold stepL beginL doneL) (Fold stepR beginR doneR) =+    Fold step begin done++    where++    begin = do+        resL <- beginL+        resR <- beginR+        return+            $ case resL of+                  Partial sL ->+                      Partial+                          $ case resR of+                                Partial sR -> RunBoth sL sR+                                Done bR -> RunLeft sL bR+                  Done bL ->+                      case resR of+                          Partial sR -> Partial $ RunRight bL sR+                          Done bR -> Done (bL, bR)++    step (RunBoth sL sR) a = do+        (b, c) <- f a+        resL <- stepL sL b+        resR <- stepR sR c+        case resL of+            Partial sresL ->+                return+                    $ Partial+                    $ case resR of+                          Partial sresR -> RunBoth sresL sresR+                          Done bresR -> RunLeft sresL bresR+            Done bresL ->+                return+                    $ case resR of+                          Partial sresR -> Partial $ RunRight bresL sresR+                          Done bresR -> Done (bresL, bresR)+    step (RunLeft sL bR) a = do+        (b, _) <- f a+        resL <- stepL sL b+        return+            $ case resL of+                  Partial sresL -> Partial $ RunLeft sresL bR+                  Done bresL -> Done (bresL, bR)+    step (RunRight bL sR) a = do+        (_, c) <- f a+        resR <- stepR sR c+        return+            $ case resR of+                  Partial sresR -> Partial $ RunRight bL sresR+                  Done bresR -> Done (bL, bresR)++    done (RunBoth sL sR) = (,) <$> doneL sL <*> doneR sR+    done (RunLeft sL bR) = (,bR) <$> doneL sL+    done (RunRight bL sR) = (bL,) <$> doneR sR++-- | Similar to 'unzipWithM' but terminates when the first fold terminates.+--+-- /Unimplemented/+--+{-# INLINE unzipWithFstM #-}+unzipWithFstM :: -- Monad m =>+     (a -> m (b,c)) -> Fold m b x -> Fold m c y -> Fold m a (x,y)+unzipWithFstM = undefined++-- | Similar to 'unzipWithM' but terminates when any fold terminates.+--+-- /Unimplemented/+--+{-# INLINE unzipWithMinM #-}+unzipWithMinM :: -- Monad m =>+     (a -> m (b,c)) -> Fold m b x -> Fold m c y -> Fold m a (x,y)+unzipWithMinM = undefined++-- | 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.+--+-- @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--------|+--+-- @+--+-- > unzip = Fold.unzipWith id+--+-- This is the consumer side dual of the producer side 'zip' operation.+--+-- @since 0.7.0+{-# 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+------------------------------------------------------------------------------++-- | Zip a stream with the input of a fold using the supplied function.+--+-- /Unimplemented/+--+{-# INLINE zipWithM #-}+zipWithM :: -- Monad m =>+    (a -> b -> m c) -> t m a -> Fold m c x -> Fold m b x+zipWithM = undefined++-- | Zip a stream with the input of a fold.+--+-- /Unimplemented/+--+{-# INLINE zip #-}+zip :: Monad m => t m a -> Fold m (a, b) x -> Fold m b x+zip = zipWithM (curry return)++-- | Pair each element of a fold input with its index, starting from index 0.+--+-- /Unimplemented/+{-# INLINE indexed #-}+indexed :: forall m a b. Monad m => Fold m (Int, a) b -> Fold m a b+indexed = zip (Stream.enumerateFrom 0 :: SerialT m Int)++-- | 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 = with indexed 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 . map snd++-- | @sampleFromthen offset stride@ samples the element at @offset@ index and+-- then every element at strides of @stride@.+--+-- /Unimplemented/+{-# 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 = foldr K.cons K.nil+--+-- /Pre-release/+{-# INLINE toStream #-}+toStream :: Monad m => Fold m a (SerialT Identity a)+toStream = foldr K.cons K.nil++-- 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 = foldl' (flip K.cons) K.nil+--+-- /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 : []+{-# INLINABLE toStreamRev #-}+toStreamRev :: Monad m => Fold m a (SerialT Identity a)+toStreamRev = foldl' (flip K.cons) K.nil
+ src/Streamly/Internal/Data/Fold/Tee.hs view
@@ -0,0 +1,157 @@+-- |+-- 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(..)+    )+where++import Control.Applicative (liftA2)+#if __GLASGOW_HASKELL__ < 808+import Data.Semigroup (Semigroup(..))+#endif+import Streamly.Internal.Data.Fold.Type (Fold)++import qualified Streamly.Internal.Data.Fold.Type as Fold++-- | @Tee@ is a newtype wrapper over the 'Fold' type providing distributing+-- 'Applicative', 'Semigroup', 'Monoid', 'Num', 'Floating' and 'Fractional'+-- instances.+--+-- @since 0.8.0+newtype Tee m a b =+    Tee { toFold :: Fold m a b }+    deriving (Functor)++-- | '<*>' 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 ($) (toFold a) (toFold 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
+ src/Streamly/Internal/Data/Fold/Type.hs view
@@ -0,0 +1,1331 @@+-- |+-- 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+--+-- These are the simplest folds that never fail and never terminate, they+-- accumulate the input values forever and can always accept new inputs (never+-- terminate) and always have a valid result value.  A+-- 'Streamly.Internal.Data.Fold.sum' operation is an example of an accumulator.+-- Traditional Haskell left folds like 'foldl' are accumulators.+--+-- We can distribute an input stream to two or more accumulators using a @tee@+-- style composition.  Accumulators cannot be applied on a stream one after the+-- other, which we call a @serial@ append style composition of folds. This is+-- because accumulators never terminate, since the first accumulator in a+-- series will never terminate, the next one will never get to run.+--+-- == Terminating Folds+--+-- Terminating folds are accumulators that can terminate. Once a fold+-- terminates it no longer accepts any more inputs.  Terminating folds can be+-- used in a @serial@ append style composition where one fold can be applied+-- after the other on an input stream. We can apply a terminating fold+-- repeatedly on an input stream, splitting the stream and consuming it in+-- fragments.  Terminating folds never fail, therefore, 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 split and process the stream into+-- chunks of fixed size.+--+-- == Terminating Folds with Leftovers+--+-- The next upgrade after terminating folds is terminating folds with leftover+-- inputs.  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 unconsumed input to the fold driver.+--+-- Single element leftover case is the most common and its easy to implement it+-- in terminating folds using 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 'many' combinator  requires+-- a @Partial1@ ('Partial' with leftover) to handle a @Done1@ from the top+-- level fold, for efficient implementation.  If the collecting fold in "many"+-- returns a @Partial1@ or @Done1@ then what to do with all the elements that+-- have been consumed?+--+-- Similarly, in distribute, if one fold consumes a value and others say its a+-- leftover then what do we do?  Folds like "many" require the leftover to be+-- fed to it again. So in a distribute operation those folds which gave a+-- leftover will have to be fed the leftover while the folds that consumed will+-- have to be fed the next input.  This is very complicated to implement. We+-- have the same issue in backtracking parsers being used in a distribute+-- operation.+--+-- To avoid these issues we want to enforce by typing that the collecting folds+-- can never return a leftover. So we need a fold type without @Done1@ or+-- @Partial1@. This leads us to design folds to never return a leftover and the+-- use cases of single leftover are 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.+-- "take 0" can implemented as a fold if we make initial return @Step@ type.+-- "takeInterval" can be implemented without @Done1@.+--+-- == 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.+--+-- = Types for Stream Consumers+--+-- In streamly, there is no 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 @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.+--+-- = Accumulators and Terminating Folds+--+-- Folds in this module can be classified in two categories viz. accumulators+-- and terminating folds. Accumulators do not have a terminating condition,+-- they run forever and consume the entire stream, for example the 'length'+-- fold. Terminating folds have a terminating condition and can terminate+-- without consuming the entire stream, for example, the 'head' fold.+--+-- = 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.+--+-- = Performance Notes+--+-- 'Streamly.Prelude' module provides fold functions to directly fold streams+-- e.g.  Streamly.Prelude/'Streamly.Prelude.sum' serves the same purpose as+-- Fold/'sum'.  However, the functions in Streamly.Prelude cannot be+-- efficiently combined together e.g. we cannot drive the input stream through+-- @sum@ and @length@ fold functions simultaneously.  Using the 'Fold' type we+-- can efficiently split the stream across multiple folds because it allows the+-- compiler to perform stream fusion optimizations.+--+module Streamly.Internal.Data.Fold.Type+    (+    -- * Types+      Step (..)+    , Fold (..)++    -- * Constructors+    , foldl'+    , foldlM'+    , foldl1'+    , foldr+    , foldrM+    , mkFold+    , mkFold_+    , mkFoldM+    , mkFoldM_++    -- * Folds+    , fromPure+    , fromEffect+    , drain+    , toList++    -- * Combinators++    -- ** Mapping output+    , rmapM++    -- ** Mapping Input+    , map+    , lmap+    , lmapM++    -- ** Filtering+    , filter+    , filterM+    , catMaybes++    -- ** Trimming+    , take+    , takeInterval++    -- ** Serial Append+    , serialWith+    , serial_++    -- ** Parallel Distribution+    , GenericRunner(..)+    , teeWith+    , teeWithFst+    , teeWithMin++    -- ** Parallel Alternative+    , shortest+    , longest++    -- ** Splitting+    , ManyState+    , many+    , manyPost+    , chunksOf+    , intervalsOf++    -- ** Nesting+    , concatMap++    -- * Running Partially+    , duplicate+    , initialize+    , runStep++    -- * Fold2+    , Fold2 (..)+    , simplify+    , chunksOf2+    )+where++import Control.Monad (void, (>=>))+import Control.Concurrent (threadDelay, forkIO, killThread)+import Control.Concurrent.MVar (MVar, newMVar, swapMVar, readMVar)+import Control.Exception (SomeException(..), catch, mask)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.Control (control)+import Data.Bifunctor (Bifunctor(..))+import Data.Maybe (isJust, fromJust)+import Fusion.Plugin.Types (Fuse(..))+import Streamly.Internal.Data.Maybe.Strict (Maybe'(..), toMaybe)+import Streamly.Internal.Data.Tuple.Strict (Tuple'(..), Tuple3'(..))+import Streamly.Internal.Data.SVar (MonadAsync)++import Prelude hiding (concatMap, filter, foldr, map, take)++-- $setup+-- >>> :m+-- >>> :set -XFlexibleContexts+-- >>> import Prelude hiding (concatMap, filter, map)+-- >>> import qualified Streamly.Prelude as Stream+-- >>> import qualified Streamly.Data.Fold as Fold+-- >>> import qualified Streamly.Internal.Data.Fold as Fold++------------------------------------------------------------------------------+-- 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++------------------------------------------------------------------------------+-- The Fold type+------------------------------------------------------------------------------++-- | 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 exposed via exposed modules, smart+-- constructors are provided to create folds.  If you think you need the+-- constructor of this type please consider using the smart constructors in+-- "Streamly.Internal.Data.Fold" instead.+--+-- /since 0.8.0 (type changed)/+--+-- @since 0.7.0++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.+--+-- @since 0.8.0+{-# 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)+-- @+--+-- See also: @Streamly.Prelude.foldl'@+--+-- @since 0.8.0+--+{-# 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)+-- @+--+-- See also: @Streamly.Prelude.foldlM'@+--+-- @since 0.8.0+--+{-# 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.+--+-- See also: @Streamly.Prelude.foldl1'@+--+-- /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++------------------------------------------------------------------------------+-- 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 this is strict fold, it can only be useful for constructing strict+-- structures in memory. For reductions this will be very inefficient.+--+-- For example,+--+-- > toList = foldr (:) []+--+-- See also: 'Streamly.Prelude.foldr'+--+-- @since 0.8.0+{-# INLINE foldr #-}+foldr :: Monad m => (a -> b -> b) -> b -> Fold m a b+foldr g z = fmap ($ z) $ foldl' (\f x -> f . g x) id++-- 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.+--+-- For example,+--+-- > toList = foldrM (\a xs -> return $ a : xs) (return [])+--+-- See also: 'Streamly.Prelude.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.++-- | Make a terminating fold using a pure step function, a pure initial state+-- and a pure state extraction function.+--+-- /Pre-release/+--+{-# INLINE mkFold #-}+mkFold :: Monad m => (s -> a -> Step s b) -> Step s b -> (s -> b) -> Fold m a b+mkFold step initial extract =+    Fold (\s a -> return $ step s a) (return initial) (return . extract)++-- | Similar to 'mkFold' but the final state extracted is identical to the+-- intermediate state.+--+-- @+-- mkFold_ step initial = mkFold step initial id+-- @+--+-- /Pre-release/+--+{-# INLINE mkFold_ #-}+mkFold_ :: Monad m => (b -> a -> Step b b) -> Step b b -> Fold m a b+mkFold_ step initial = mkFold step initial id++-- | Make a terminating fold with an effectful step function and initial state,+-- and a state extraction function.+--+-- > mkFoldM = Fold+--+--  We can just use 'Fold' but it is provided for completeness.+--+-- /Pre-release/+--+{-# INLINE mkFoldM #-}+mkFoldM :: (s -> a -> m (Step s b)) -> m (Step s b) -> (s -> m b) -> Fold m a b+mkFoldM = Fold++-- | Similar to 'mkFoldM' but the final state extracted is identical to the+-- intermediate state.+--+-- @+-- mkFoldM_ step initial = mkFoldM step initial return+-- @+--+-- /Pre-release/+--+{-# INLINE mkFoldM_ #-}+mkFoldM_ :: Monad m => (b -> a -> m (Step b b)) -> m (Step b b) -> Fold m a b+mkFoldM_ step initial = mkFoldM step initial return++------------------------------------------------------------------------------+-- Fold2+------------------------------------------------------------------------------++-- | Experimental type to provide a side input to the fold for generating the+-- initial state. For example, if we have to fold chunks of a stream and write+-- each chunk to a different file, then we can generate the file name using a+-- monadic action. This is a generalized version of 'Fold'.+--+-- /Internal/+data Fold2 m c a b =+  -- | @Fold @ @ step @ @ inject @ @ extract@+  forall s. Fold2 (s -> a -> m s) (c -> m s) (s -> m b)++-- | Convert more general type 'Fold2' into a simpler type 'Fold'+--+-- /Internal/+simplify :: Functor m => Fold2 m c a b -> c -> Fold m a b+simplify (Fold2 step inject extract) c =+    Fold (\x a -> Partial <$> step x a) (Partial <$> inject c) extract++------------------------------------------------------------------------------+-- Basic Folds+------------------------------------------------------------------------------++-- | A fold that drains all its input, running the effects and discarding the+-- results.+--+-- > drain = drainBy (const (return ()))+--+-- @since 0.7.0+{-# INLINABLE 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.Foreign"+-- instead.+--+-- > toList = foldr (:) []+--+-- @since 0.7.0+{-# INLINABLE toList #-}+toList :: Monad m => Fold m a [a]+toList = foldr (:) []++------------------------------------------------------------------------------+-- 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)++-- This is the dual of stream "fromPure".+--+-- | A fold that always yields a pure value without consuming any input.+--+-- /Pre-release/+--+{-# INLINE fromPure #-}+fromPure :: Applicative m => b -> Fold m a b+fromPure b = Fold undefined (pure $ Done b) pure++-- This is the dual of stream "fromEffect".+--+-- | A fold that always yields the result of an effectful action without+-- consuming any input.+--+-- /Pre-release/+--+{-# INLINE fromEffect #-}+fromEffect :: Applicative m => m b -> Fold m a b+fromEffect b = Fold undefined (Done <$> b) pure++{-# ANN type Step 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.+--+-- >>> f = Fold.serialWith (,) (Fold.take 8 Fold.toList) (Fold.takeEndBy (== '\n') Fold.toList)+-- >>> Stream.fold f $ Stream.fromList "header: hello\n"+-- ("header: ","hello\n")+--+-- Note: This is dual to appending streams using 'Streamly.Prelude.serial'.+--+-- 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.+--+-- /Time: O(n^2) where n is the number of compositions./+--+-- @since 0.8.0+--+{-# INLINE serialWith #-}+serialWith :: Monad m => (a -> b -> c) -> Fold m x a -> Fold m x b -> Fold m x c+serialWith func (Fold stepL initialL extractL) (Fold stepR initialR extractR) =+    Fold step initial extract++    where++    initial = do+        resL <- initialL+        case resL of+            Partial sl -> return $ Partial $ SeqFoldL sl+            Done bl -> do+                resR <- initialR+                return $ bimap (SeqFoldR (func bl)) (func bl) resR++    step (SeqFoldL st) a = do+        r <- stepL st a+        case r of+            Partial s -> return $ Partial (SeqFoldL s)+            Done b -> do+                res <- initialR+                return $ bimap (SeqFoldR (func b)) (func b) res+    step (SeqFoldR f st) a = do+        r <- stepR st a+        return+            $ case r of+                  Partial s -> Partial (SeqFoldR f s)+                  Done b -> Done (f b)++    extract (SeqFoldR f sR) = fmap f (extractR sR)+    extract (SeqFoldL sL) = do+        rL <- extractL sL+        res <- initialR+        case res of+            Partial sR -> do+                rR <- extractR sR+                return $ func rL rR+            Done rR -> return $ func rL rR++-- | Same as applicative '*>'. Run two folds serially one after the other+-- discarding the result of the first.+--+-- /Unimplemented/+--+{-# INLINE serial_ #-}+serial_ :: -- Monad m =>+    Fold m x a -> Fold m x b -> Fold m x b+serial_ _f1 _f2 = undefined++{-# ANN type GenericRunner Fuse #-}+data GenericRunner sL sR bL bR+    = RunBoth !sL !sR+    | RunLeft !sL !bR+    | RunRight !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@.+--+-- >>> avg = Fold.teeWith (/) Fold.sum (fmap fromIntegral Fold.length)+-- >>> Stream.fold avg $ Stream.fromList [1.0..100.0]+-- 50.5+--+-- > teeWith k f1 f2 = fmap (uncurry k) ((Fold.tee f1 f2)+--+-- For applicative composition using this combinator see+-- "Streamly.Internal.Data.Fold.Tee".+--+-- See also: "Streamly.Internal.Data.Fold.Tee"+--+-- @since 0.8.0+--+{-# INLINE teeWith #-}+teeWith :: Monad m => (a -> b -> c) -> Fold m x a -> Fold m x b -> Fold m x c+teeWith f (Fold stepL beginL doneL) (Fold stepR beginR doneR) =+    Fold step begin done++    where++    begin = do+        resL <- beginL+        resR <- beginR+        return+            $ case resL of+                  Partial sl ->+                      Partial+                          $ case resR of+                                Partial sr -> RunBoth sl sr+                                Done br -> RunLeft sl br+                  Done bl -> bimap (RunRight bl) (f bl) resR++    step (RunBoth sL sR) a = do+        resL <- stepL sL a+        resR <- stepR sR a+        case resL of+            Partial sL1 ->+                return+                    $ Partial+                    $ case resR of+                          Partial sR1 -> RunBoth sL1 sR1+                          Done bR -> RunLeft sL1 bR+            Done bL ->+                return+                    $ case resR of+                          Partial sR1 -> Partial $ RunRight bL sR1+                          Done bR -> Done $ f bL bR+    step (RunLeft sL bR) a = do+        resL <- stepL sL a+        return+            $ case resL of+                  Partial sL1 -> Partial $ RunLeft sL1 bR+                  Done bL -> Done $ f bL bR+    step (RunRight bL sR) a = do+        resR <- stepR sR a+        return+            $ case resR of+                  Partial sR1 -> Partial $ RunRight bL sR1+                  Done bR -> Done $ f bL bR++    done (RunBoth sL sR) = do+        bL <- doneL sL+        bR <- doneR sR+        return $ f bL bR+    done (RunLeft sL bR) = do+        bL <- doneL sL+        return $ f bL bR+    done (RunRight bL sR) = do+        bR <- doneR sR+        return $ f bL bR++-- | Like 'teeWith' but terminates as soon as the first fold terminates.+--+-- /Unimplemented/+--+{-# INLINE teeWithFst #-}+teeWithFst :: (b -> c -> d) -> Fold m a b -> Fold m a c -> Fold m a d+teeWithFst = undefined++-- | Like 'teeWith' but terminates as soon as any one of the two folds+-- terminates.+--+-- /Unimplemented/+--+{-# INLINE teeWithMin #-}+teeWithMin :: (b -> c -> d) -> Fold m a b -> Fold m a c -> Fold m a d+teeWithMin = undefined++-- | 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.+--+-- /Unimplemented/+--+{-# INLINE shortest #-}+shortest :: -- Monad m =>+    Fold m x a -> Fold m x a -> Fold m x a+shortest _f1 _f2 = undefined++-- | 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.+--+-- /Unimplemented/+--+{-# INLINE longest #-}+longest :: -- Monad m =>+    Fold m x a -> Fold m x a -> Fold m x a+longest _f1 _f2 = undefined++data ConcatMapState m sa a c+    = B !sa+    | forall s. C (s -> a -> m (Step s c)) !s (s -> m c)++-- Compare with foldIterate.+--+-- | 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.head+-- >>> total n = Fold.take n Fold.sum+-- >>> Stream.fold (Fold.concatMap total count) $ Stream.fromList [10,9..1]+-- 45+--+-- /Time: O(n^2) where @n@ is the number of compositions./+--+-- See also: 'Streamly.Internal.Data.Stream.IsStream.foldIterateM'+--+-- @since 0.8.0+--+{-# 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.+--+-- >>> Stream.fold (Fold.lmap (\x -> x * x) Fold.sum) (Stream.enumerateFromTo 1 100)+-- 338350+--+-- > lmap = Fold.lmapM return+--+-- @since 0.8.0+{-# INLINABLE 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)++-- XXX should be removed+-- |+-- /Internal/+{-# INLINE map #-}+map :: (a -> b) -> Fold m b r -> Fold m a r+map = lmap++-- | @lmapM f fold@ maps the monadic function @f@ on the input of the fold.+--+-- @since 0.8.0+{-# INLINABLE 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++------------------------------------------------------------------------------+-- Filtering+------------------------------------------------------------------------------++-- | Include only those elements that pass a predicate.+--+-- >>> Stream.fold (Fold.filter (> 5) Fold.sum) $ Stream.fromList [1..10]+-- 40+--+-- > filter f = Fold.filterM (return . f)+--+-- @since 0.8.0+{-# INLINABLE filter #-}+filter :: Monad m => (a -> Bool) -> Fold m a r -> Fold m a r+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.+--+-- @since 0.8.0+{-# INLINABLE 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++-- | Modify a fold to receive a 'Maybe' input, the 'Just' values are unwrapped+-- and sent to the original fold, 'Nothing' values are discarded.+--+-- @since 0.8.0+{-# INLINE catMaybes #-}+catMaybes :: Monad m => Fold m a b -> Fold m (Maybe a) b+catMaybes = filter isJust . map fromJust++------------------------------------------------------------------------------+-- Parsing+------------------------------------------------------------------------------++-- 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.+--+-- >>> Stream.fold (Fold.take 2 Fold.toList) $ Stream.fromList [1..10]+-- [1,2]+--+-- @since 0.8.0+{-# INLINE take #-}+take :: Monad m => Int -> Fold m a b -> Fold m a b+take n (Fold fstep finitial fextract) = Fold step initial extract++    where++    initial = do+        res <- finitial+        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++------------------------------------------------------------------------------+-- Nesting+------------------------------------------------------------------------------++-- | Modify the fold such that it returns a new 'Fold' instead of the output.+-- If the fold was already done the returned fold would always yield the+-- result. If the fold was partial, the returned fold starts from where we left+-- i.e. it uses the last accumulator value as the initial value of the+-- accumulator. Thus we can resume the fold later and feed it more input.+--+-- >>> :{+-- do+--  more <- Stream.fold (Fold.duplicate Fold.sum) (Stream.enumerateFromTo 1 10)+--  evenMore <- Stream.fold (Fold.duplicate more) (Stream.enumerateFromTo 11 20)+--  Stream.fold evenMore (Stream.enumerateFromTo 21 30)+-- :}+-- 465+--+-- /Pre-release/+{-# INLINABLE 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++-- | Run the initialization effect of a fold. The returned fold would use the+-- value returned by this effect as its initial value.+--+-- /Pre-release/+{-# INLINE initialize #-}+initialize :: Monad m => Fold m a b -> m (Fold m a b)+initialize (Fold step initial extract) = do+    i <- initial+    return $ Fold step (return i) extract++-- | Run one step of a fold and store the accumulator as an initial value in+-- the returned fold.+--+-- /Pre-release/+{-# INLINE runStep #-}+runStep :: Monad m => Fold m a b -> a -> m (Fold m a b)+runStep (Fold step initial extract) a = do+    res <- initial+    r <- case res of+          Partial fs -> step fs a+          b@(Done _) -> return b+    return $ Fold step (return r) extract++------------------------------------------------------------------------------+-- 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 split collect@ applies+-- the @split@ fold repeatedly on the input stream and accumulates zero or more+-- fold results using @collect@.+--+-- >>> 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 @collect@ stops.+--+-- See also: 'Streamly.Prelude.concatMap', 'Streamly.Prelude.foldMany'+--+-- @since 0.8.0+--+{-# 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 handleSplitStep #-}+    handleSplitStep branch cs sres =+        case sres of+            Partial ss1 -> return $ Partial $ branch ss1 cs+            Done sb -> runCollector ManyFirst cs sb++    {-# INLINE handleCollectStep #-}+    handleCollectStep branch cres =+        case cres of+            Partial cs -> do+                sres <- sinitial+                handleSplitStep branch cs sres+            Done cb -> return $ Done cb++    -- Do not inline this+    runCollector branch cs sb = cstep cs sb >>= handleCollectStep branch++    initial = cinitial >>= handleCollectStep ManyFirst++    {-# INLINE step_ #-}+    step_ ss cs a = do+        sres <- sstep ss a+        handleSplitStep ManyLoop cs sres++    {-# INLINE step #-}+    step (ManyFirst ss cs) a = step_ ss cs a+    step (ManyLoop ss cs) a = step_ ss cs a++    extract (ManyFirst _ cs) = cextract cs+    extract (ManyLoop ss cs) = do+        sb <- sextract ss+        cres <- cstep cs sb+        case cres of+            Partial s -> cextract s+            Done b -> return b++-- | Like many, but inner fold emits an output at the end even if no input is+-- received.+--+-- /Internal/+--+-- /See also: 'Streamly.Prelude.concatMap', 'Streamly.Prelude.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 handleSplitStep #-}+    handleSplitStep cs sres =+        case sres of+            Partial ss1 -> return $ Partial $ Tuple' ss1 cs+            Done sb -> runCollector cs sb++    {-# INLINE handleCollectStep #-}+    handleCollectStep cres =+        case cres of+            Partial cs -> do+                sres <- sinitial+                handleSplitStep cs sres+            Done cb -> return $ Done cb++    -- Do not inline this+    runCollector cs sb = cstep cs sb >>= handleCollectStep++    initial = cinitial >>= handleCollectStep++    {-# INLINE step #-}+    step (Tuple' ss cs) a = do+        sres <- sstep ss a+        handleSplitStep cs sres++    extract (Tuple' ss cs) = do+        sb <- sextract ss+        cres <- cstep cs sb+        case cres of+            Partial s -> cextract s+            Done b -> return b++-- | @chunksOf 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.+--+-- >>> twos = Fold.chunksOf 2 Fold.toList Fold.toList+-- >>> Stream.fold twos $ Stream.fromList [1..10]+-- [[1,2],[3,4],[5,6],[7,8],[9,10]]+--+-- > chunksOf n split = many (take n split)+--+-- Stops when @collect@ stops.+--+-- @since 0.8.0+--+{-# INLINE chunksOf #-}+chunksOf :: Monad m => Int -> Fold m a b -> Fold m b c -> Fold m a c+chunksOf n split = many (take n split)++-- |+--+-- /Internal/+{-# INLINE chunksOf2 #-}+chunksOf2 :: Monad m => Int -> Fold m a b -> Fold2 m x b c -> Fold2 m x a c+chunksOf2 n (Fold step1 initial1 extract1) (Fold2 step2 inject2 extract2) =+    Fold2 step' inject' extract'++    where++    loopUntilPartial s = do+        res <- initial1+        case res of+            Partial fs -> return $ Tuple3' 0 fs s+            Done _ -> loopUntilPartial s++    inject' x = inject2 x >>= loopUntilPartial++    step' (Tuple3' i r1 r2) a =+        if i < n+        then do+            res <- step1 r1 a+            case res of+                Partial s -> return $ Tuple3' (i + 1) s r2+                Done b -> step2 r2 b >>= loopUntilPartial+        else extract1 r1 >>= step2 r2 >>= loopUntilPartial++    extract' (Tuple3' _ r1 r2) = extract1 r1 >>= step2 r2 >>= extract2++-- XXX We can use asyncClock here. A parser can be used to return an input that+-- arrives after the timeout.+-- XXX If n is 0 return immediately in initial.+-- XXX we should probably discard the input received after the timeout like+-- takeEndBy_.+--+-- | @takeInterval n fold@ uses @fold@ to fold the input items arriving within+-- a window of first @n@ seconds.+--+-- >>> Stream.fold (Fold.takeInterval 1.0 Fold.toList) $ Stream.delay 0.1 $ Stream.fromList [1..]+-- [1,2,3,4,5,6,7,8,9,10,11]+--+-- Stops when @fold@ stops or when the timeout occurs. Note that the fold needs+-- an input after the timeout to stop. For example, if no input is pushed to+-- the fold until one hour after the timeout had occurred, then the fold will+-- be done only after consuming that input.+--+-- /Pre-release/+--+{-# INLINE takeInterval #-}+takeInterval :: MonadAsync m => Double -> Fold m a b -> Fold m a b+takeInterval n (Fold step initial done) = Fold step' initial' done'++    where++    initial' = do+        res <- initial+        case res of+            Partial s -> do+                mv <- liftIO $ newMVar False+                t <-+                    control $ \run ->+                        mask $ \restore -> do+                            tid <-+                                forkIO+                                  $ catch+                                        (restore $ void $ run (timerThread mv))+                                        (handleChildException mv)+                            run (return tid)+                return $ Partial $ Tuple3' s mv t+            Done b -> return $ Done b++    step' (Tuple3' s mv t) a = do+        val <- liftIO $ readMVar mv+        if val+        then do+            res <- step s a+            case res of+                Partial sres -> Done <$> done sres+                Done bres -> return $ Done bres+        else do+            res <- step s a+            case res of+                Partial fs -> return $ Partial $ Tuple3' fs mv t+                Done b -> liftIO (killThread t) >> return (Done b)++    done' (Tuple3' s _ _) = done s++    timerThread mv = do+        liftIO $ threadDelay (round $ n * 1000000)+        -- Use IORef + CAS? instead of MVar since its a Bool?+        liftIO $ void $ swapMVar mv True++    handleChildException :: MVar Bool -> SomeException -> IO ()+    handleChildException mv _ = void $ swapMVar mv True++-- For example, we can copy and distribute a stream to multiple folds where+-- each fold can group the input differently e.g. by one second, one minute and+-- one hour windows respectively and fold each resulting stream of folds.++-- | Group the input stream into windows of n second each using the first fold+-- and then fold the resulting groups using the second fold.+--+-- >>> intervals = Fold.intervalsOf 0.5 Fold.toList Fold.toList+-- >>> Stream.fold intervals $ Stream.delay 0.2 $ Stream.fromList [1..10]+-- [[1,2,3,4],[5,6,7],[8,9,10]]+--+-- > intervalsOf n split = many (takeInterval n split)+--+-- /Pre-release/+--+{-# INLINE intervalsOf #-}+intervalsOf :: MonadAsync m => Double -> Fold m a b -> Fold m b c -> Fold m a c+intervalsOf n split = many (takeInterval n split)
− src/Streamly/Internal/Data/Fold/Types.hs 
@@ -1,594 +0,0 @@-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts          #-}---- |--- Module      : Streamly.Internal.Data.Fold.Types--- 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------ These are the simplest folds that never fail and never terminate, they--- accumulate the input values forever and always remain @partial@ and--- @complete@ at the same time. It means that we can keep adding more input to--- them or at any time retrieve a consistent result. A--- 'Streamly.Internal.Data.Fold.sum' operation is an example of an accumulator.------ We can distribute an input stream to two or more accumulators using a @tee@--- style composition.  Accumulators cannot be applied on a stream one after the--- other, which we call a @split@ style composition, as the first one itself--- will never terminate, therefore, the next one will never get to run.------ == Splitters------ Splitters are accumulators that can terminate. When applied on a stream--- splitters consume part of the stream, thereby, splitting it.  Splitters can--- be used in a @split@ style composition where one splitter can be applied--- after the other on an input stream. We can apply a splitter repeatedly on an--- input stream splitting and consuming it in fragments.  Splitters never fail,--- therefore, they do not need backtracking, but they can lookahead and return--- unconsumed input. The 'Streamly.Internal.Data.Parser.take' operation is an--- example of a splitter. It terminates after consuming @n@ items. Coupled with--- an accumulator it can be used to split the stream into chunks of fixed size.------ 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 splitter will have to--- implement a way to return unconsumed input to the driver.------ == Parsers------ Parsers are splitters 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.------ = Types for Stream Consumers------ We use the 'Fold' type to implement the Accumulator and Splitter--- functionality.  Parsers are represented by 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 Splitter types would encode more information in types but it--- would make ease of use, implementation, maintenance effort worse. Combining--- Accumulator, Splitter 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 @Yield@ or @Stop@. A @Yield@ returns the next intermediate--- state of the fold, a @Stop@ indicates that the fold has terminated and--- returns the final value of the accumulator.------ Every @Yield@ 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 @Yield@ 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 @Stop@.  When--- using this approach, the @splitParse (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 @Yield@, 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.--module Streamly.Internal.Data.Fold.Types-    ( Fold (..)-    , Fold2 (..)-    , simplify-    , toListRevF  -- experimental-    -- $toListRevF-    , lmap-    , lmapM-    , lfilter-    , lfilterM-    , lcatMaybes-    , ltake-    , ltakeWhile-    , lsessionsOf-    , lchunksOf-    , lchunksOf2--    , duplicate-    , initialize-    , runStep-    )-where--import Control.Applicative (liftA2)-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.Control (control)-import Data.Maybe (isJust, fromJust)-#if __GLASGOW_HASKELL__ < 808-import Data.Semigroup (Semigroup(..))-#endif-import Streamly.Internal.Data.Strict (Tuple'(..), Tuple3'(..), Either'(..))-import Streamly.Internal.Data.SVar (MonadAsync)----------------------------------------------------------------------------------- Monadic left folds----------------------------------------------------------------------------------- | Represents a left fold over an input stream consisting of values of type--- @a@ to a single value of type @b@ in 'Monad' @m@.------ The fold uses an intermediate state @s@ as accumulator. The @step@ function--- updates the state and returns the new state. When the fold is done--- the final result of the fold is extracted from the intermediate state--- using the @extract@ function.------ @since 0.7.0--data Fold m a b =-  -- | @Fold @ @ step @ @ initial @ @ extract@-  forall s. Fold (s -> a -> m s) (m s) (s -> m b)---- | Experimental type to provide a side input to the fold for generating the--- initial state. For example, if we have to fold chunks of a stream and write--- each chunk to a different file, then we can generate the file name using a--- monadic action. This is a generalized version of 'Fold'.----data Fold2 m c a b =-  -- | @Fold @ @ step @ @ inject @ @ extract@-  forall s. Fold2 (s -> a -> m s) (c -> m s) (s -> m b)---- | Convert more general type 'Fold2' into a simpler type 'Fold'-simplify :: Fold2 m c a b -> c -> Fold m a b-simplify (Fold2 step inject extract) c = Fold step (inject c) extract---- | 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 step start done) = Fold step start done'-        where-        done' x = fmap f $! done x---- | The fold resulting from '<*>' distributes its input to both the argument--- folds and combines their output using the supplied function.-instance Applicative m => Applicative (Fold m a) where-    {-# INLINE pure #-}-    pure b = Fold (\() _ -> pure ()) (pure ()) (\() -> pure b)--    {-# INLINE (<*>) #-}-    (Fold stepL beginL doneL) <*> (Fold stepR beginR doneR) =-        let step (Tuple' xL xR) a = Tuple' <$> stepL xL a <*> stepR xR a-            begin = Tuple' <$> beginL <*> beginR-            done (Tuple' xL xR) = doneL xL <*> doneR xR-        in  Fold step begin done---- | Combines the outputs of the folds (the type @b@) using their 'Semigroup'--- instances.-instance (Semigroup b, Monad m) => Semigroup (Fold m a b) where-    {-# INLINE (<>) #-}-    (<>) = liftA2 (<>)---- | Combines the outputs of the folds (the type @b@) using their 'Monoid'--- instances.-instance (Semigroup b, Monoid b, Monad m) => Monoid (Fold m a b) where-    {-# INLINE mempty #-}-    mempty = pure mempty--    {-# INLINE mappend #-}-    mappend = (<>)---- | Combines the fold outputs (type @b@) using their 'Num' instances.-instance (Monad m, Num b) => Num (Fold 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 (-)---- | Combines the fold outputs (type @b@) using their 'Fractional' instances.-instance (Monad m, Fractional b) => Fractional (Fold m a b) where-    {-# INLINE fromRational #-}-    fromRational = pure . fromRational--    {-# INLINE recip #-}-    recip = fmap recip--    {-# INLINE (/) #-}-    (/) = liftA2 (/)---- | Combines the fold outputs using their 'Floating' instances.-instance (Monad m, Floating b) => Floating (Fold 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----------------------------------------------------------------------------------- Internal APIs----------------------------------------------------------------------------------- $toListRevF--- This is more efficient than 'Streamly.Internal.Data.Fold.toList'. toList is--- exactly the same as reversing the list after 'toListRevF'.---- | Buffers the input stream to a list in the reverse order of the input.------ /Warning!/ working on large lists accumulated as buffers in memory could be--- very inefficient, consider using "Streamly.Array" instead.------ @since 0.7.0----  xn : ... : x2 : x1 : []-{-# INLINABLE toListRevF #-}-toListRevF :: Monad m => Fold m a [a]-toListRevF = Fold (\xs x -> return $ x:xs) (return []) return---- | @(lmap f fold)@ maps the function @f@ on the input of the fold.------ >>> S.fold (FL.lmap (\x -> x * x) FL.sum) (S.enumerateFromTo 1 100)--- 338350------ @since 0.7.0-{-# INLINABLE 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.------ @since 0.7.0-{-# INLINABLE 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----------------------------------------------------------------------------------- Filtering----------------------------------------------------------------------------------- | Include only those elements that pass a predicate.------ >>> S.fold (lfilter (> 5) FL.sum) [1..10]--- 40------ @since 0.7.0-{-# INLINABLE lfilter #-}-lfilter :: Monad m => (a -> Bool) -> Fold m a r -> Fold m a r-lfilter f (Fold step begin done) = Fold step' begin done-  where-    step' x a = if f a then step x a else return x---- | Like 'lfilter' but with a monadic predicate.------ @since 0.7.0-{-# INLINABLE lfilterM #-}-lfilterM :: Monad m => (a -> m Bool) -> Fold m a r -> Fold m a r-lfilterM 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 x---- | Transform a fold from a pure input to a 'Maybe' input, consuming only--- 'Just' values.-{-# INLINE lcatMaybes #-}-lcatMaybes :: Monad m => Fold m a b -> Fold m (Maybe a) b-lcatMaybes = lfilter isJust . lmap fromJust----------------------------------------------------------------------------------- Parsing----------------------------------------------------------------------------------- XXX These should become terminating folds.------ | Take first @n@ elements from the stream and discard the rest.------ @since 0.7.0-{-# INLINABLE ltake #-}-ltake :: Monad m => Int -> Fold m a b -> Fold m a b-ltake n (Fold step initial done) = Fold step' initial' done'-    where-    initial' = fmap (Tuple' 0) initial-    step' (Tuple' i r) a = do-        if i < n-        then do-            res <- step r a-            return $ Tuple' (i + 1) res-        else return $ Tuple' i r-    done' (Tuple' _ r) = done r---- | Takes elements from the input as long as the predicate succeeds.------ @since 0.7.0-{-# INLINABLE ltakeWhile #-}-ltakeWhile :: Monad m => (a -> Bool) -> Fold m a b -> Fold m a b-ltakeWhile predicate (Fold step initial done) = Fold step' initial' done'-    where-    initial' = fmap Left' initial-    step' (Left' r) a = do-        if predicate a-        then fmap Left' $ step r a-        else return (Right' r)-    step' r _ = return r-    done' (Left' r) = done r-    done' (Right' r) = done r----------------------------------------------------------------------------------- Nesting------------------------------------------------------------------------------------- | Modify the fold such that when the fold is done, instead of returning the--- accumulator, it returns a fold. The returned fold starts from where we left--- i.e. it uses the last accumulator value as the initial value of the--- accumulator. Thus we can resume the fold later and feed it more input.------ >> do--- >    more <- S.fold (FL.duplicate FL.sum) (S.enumerateFromTo 1 10)--- >    evenMore <- S.fold (FL.duplicate more) (S.enumerateFromTo 11 20)--- >    S.fold evenMore (S.enumerateFromTo 21 30)--- > 465------ @since 0.7.0-{-# INLINABLE duplicate #-}-duplicate :: Applicative m => Fold m a b -> Fold m a (Fold m a b)-duplicate (Fold step begin done) =-    Fold step begin (\x -> pure (Fold step (pure x) done))---- | Run the initialization effect of a fold. The returned fold would use the--- value returned by this effect as its initial value.----{-# INLINABLE initialize #-}-initialize :: Monad m => Fold m a b -> m (Fold m a b)-initialize (Fold step initial extract) = do-    i <- initial-    return $ Fold step (return i) extract---- | Run one step of a fold and store the accumulator as an initial value in--- the returned fold.-{-# INLINABLE runStep #-}-runStep :: Monad m => Fold m a b -> a -> m (Fold m a b)-runStep (Fold step initial extract) a = do-    i <- initial-    r <- step i a-    return $ (Fold step (return r) extract)----------------------------------------------------------------------------------- Parsing----------------------------------------------------------------------------------- XXX These can be expressed using foldChunks repeatedly on the input of a--- fold.---- | For every n input items, apply the first fold and supply the result to the--- next fold.----{-# INLINE lchunksOf #-}-lchunksOf :: Monad m => Int -> Fold m a b -> Fold m b c -> Fold m a c-lchunksOf n (Fold step1 initial1 extract1) (Fold step2 initial2 extract2) =-    Fold step' initial' extract'--    where--    initial' = (Tuple3' 0) <$> initial1 <*> initial2-    step' (Tuple3' i r1 r2) a = do-        if i < n-        then do-            res <- step1 r1 a-            return $ Tuple3' (i + 1) res r2-        else do-            res <- extract1 r1-            acc2 <- step2 r2 res--            i1 <- initial1-            acc1 <- step1 i1 a-            return $ Tuple3' 1 acc1 acc2-    extract' (Tuple3' _ r1 r2) = do-        res <- extract1 r1-        acc2 <- step2 r2 res-        extract2 acc2--{-# INLINE lchunksOf2 #-}-lchunksOf2 :: Monad m => Int -> Fold m a b -> Fold2 m x b c -> Fold2 m x a c-lchunksOf2 n (Fold step1 initial1 extract1) (Fold2 step2 inject2 extract2) =-    Fold2 step' inject' extract'--    where--    inject' x = (Tuple3' 0) <$> initial1 <*> inject2 x-    step' (Tuple3' i r1 r2) a = do-        if i < n-        then do-            res <- step1 r1 a-            return $ Tuple3' (i + 1) res r2-        else do-            res <- extract1 r1-            acc2 <- step2 r2 res--            i1 <- initial1-            acc1 <- step1 i1 a-            return $ Tuple3' 1 acc1 acc2-    extract' (Tuple3' _ r1 r2) = do-        res <- extract1 r1-        acc2 <- step2 r2 res-        extract2 acc2---- | Group the input stream into windows of n second each and then fold each--- group using the provided fold function.------ For example, we can copy and distribute a stream to multiple folds where--- each fold can group the input differently e.g. by one second, one minute and--- one hour windows respectively and fold each resulting stream of folds.------ @------ -----Fold m a b----|-Fold n a c-|-Fold n a c-|-...-|----Fold m a c------ @-{-# INLINE lsessionsOf #-}-lsessionsOf :: MonadAsync m => Double -> Fold m a b -> Fold m b c -> Fold m a c-lsessionsOf n (Fold step1 initial1 extract1) (Fold step2 initial2 extract2) =-    Fold step' initial' extract'--    where--    -- XXX MVar may be expensive we need a cheaper synch mechanism here-    initial' = do-        i1 <- initial1-        i2 <- initial2-        mv1 <- liftIO $ newMVar i1-        mv2 <- liftIO $ newMVar (Right i2)-        t <- control $ \run ->-            mask $ \restore -> do-                tid <- forkIO $ catch (restore $ void $ run (timerThread mv1 mv2))-                                      (handleChildException mv2)-                run (return tid)-        return $ Tuple3' t mv1 mv2-    step' acc@(Tuple3' _ mv1 _) a = do-            r1 <- liftIO $ takeMVar mv1-            res <- step1 r1 a-            liftIO $ putMVar mv1 res-            return acc-    extract' (Tuple3' tid _ mv2) = do-        r2 <- liftIO $ takeMVar mv2-        liftIO $ killThread tid-        case r2 of-            Left e -> throwM e-            Right x -> extract2 x--    timerThread mv1 mv2 = do-        liftIO $ threadDelay (round $ n * 1000000)--        r1 <- liftIO $ takeMVar mv1-        i1 <- initial1-        liftIO $ putMVar mv1 i1--        res1 <- extract1 r1-        r2 <- liftIO $ takeMVar mv2-        res <- case r2 of-                    Left _ -> return r2-                    Right x -> fmap Right $ step2 x res1-        liftIO $ putMVar mv2 res-        timerThread mv1 mv2--    handleChildException ::-        MVar (Either SomeException a) -> SomeException -> IO ()-    handleChildException mv2 e = do-        r2 <- takeMVar mv2-        let r = case r2 of-                    Left _ -> r2-                    Right _ -> Left e-        putMVar mv2 r
+ src/Streamly/Internal/Data/IOFinalizer.hs view
@@ -0,0 +1,103 @@+-- |+-- 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 Control.Monad.Trans.Control (MonadBaseControl, control)+import Data.IORef (newIORef, readIORef, mkWeakIORef, writeIORef, IORef)+import Streamly.Internal.Data.SVar (captureMonadState, runInIO)++-- | 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 ())))++-- | Make a finalizer from a monadic action @m a@ that can run in IO monad.+mkIOFinalizer :: MonadBaseControl IO m => m b -> m (IO ())+mkIOFinalizer f = do+    mrun <- captureMonadState+    return $+        void $ do+            _ <- runInIO mrun f+            return ()++-- | 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, MonadBaseControl IO m) => m a -> m IOFinalizer+newIOFinalizer finalizer = do+    f <- mkIOFinalizer finalizer+    ref <- liftIO $ newIORef $ Just f+    _ <- liftIO $ 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 :: MonadBaseControl IO m => IOFinalizer -> m a -> m a+clearingIOFinalizer (IOFinalizer ref) action = do+    control $ \runinio ->+        mask_ $ do+            writeIORef ref Nothing+            runinio action
+ src/Streamly/Internal/Data/IORef/Prim.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE UnboxedTuples #-}++-- |+-- Module      : Streamly.Internal.Data.IORef.Prim+-- 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 'Prim'+-- 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.Prim+    (+      IORef+    , Prim++    -- * Construction+    , newIORef++    -- * Write+    , writeIORef+    , modifyIORef'++    -- * Read+    , readIORef+    , toStream+    , toStreamD+    )+where++#include "inline.hs"++import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Primitive (primitive_)+import Data.Primitive.Types (Prim, sizeOf#, readByteArray#, writeByteArray#)+import GHC.Exts (MutableByteArray#, newByteArray#, RealWorld)+import GHC.IO (IO(..))++import qualified Streamly.Internal.Data.Stream.StreamK.Type as K+import qualified Streamly.Internal.Data.Stream.StreamD.Type as D++-- | An 'IORef' holds a single 'Prim' value.+data IORef a = IORef (MutableByteArray# RealWorld)++-- | Create a new 'IORef'.+--+-- /Pre-release/+{-# INLINE newIORef #-}+newIORef :: forall a. Prim a => a -> IO (IORef a)+newIORef x = IO (\s# ->+      case newByteArray# (sizeOf# (undefined :: a)) s# of+        (# s1#, arr# #) ->+            case writeByteArray# arr# 0# x s1# of+                s2# -> (# s2#, IORef arr# #)+    )++-- | Write a value to an 'IORef'.+--+-- /Pre-release/+{-# INLINE writeIORef #-}+writeIORef :: Prim a => IORef a -> a -> IO ()+writeIORef (IORef arr#) x = primitive_ (writeByteArray# arr# 0# x)++-- | Read a value from an 'IORef'.+--+-- /Pre-release/+{-# INLINE readIORef #-}+readIORef :: Prim a => IORef a -> IO a+readIORef (IORef arr#) = IO (readByteArray# arr# 0#)++-- | Modify the value of an 'IORef' using a function with strict application.+--+-- /Pre-release/+{-# INLINE modifyIORef' #-}+modifyIORef' :: Prim a => IORef a -> (a -> a) -> IO ()+modifyIORef' (IORef arr#) g = primitive_ $ \s# ->+  case readByteArray# arr# 0# s# of+    (# s'#, a #) -> let a' = g a in a' `seq` writeByteArray# arr# 0# a' s'#++-- | Generate a stream by continuously reading the IORef.+--+-- /Pre-release/+{-# INLINE_NORMAL toStreamD #-}+toStreamD :: (MonadIO m, Prim 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 ()++-- | Construct a stream by reading a 'Prim' 'IORef' repeatedly.+--+-- /Pre-release/+--+{-# INLINE toStream #-}+toStream :: (K.IsStream t, MonadIO m, Prim a) => IORef a -> t m a+toStream = D.fromStreamD . toStreamD
src/Streamly/Internal/Data/List.hs view
@@ -1,14 +1,4 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE DeriveTraversable          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE PatternSynonyms            #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE UndecidableInstances       #-} -- XXX-{-# LANGUAGE ViewPatterns               #-}--#if MIN_VERSION_base(4,17,0)-{-# LANGUAGE TypeOperators             #-}-#endif+{-# LANGUAGE UndecidableInstances #-}  -- | -- Module      : Streamly.Internal.Data.List@@ -16,7 +6,7 @@ -- -- License     : BSD3 -- Maintainer  : streamly@composewell.com--- Stability   : experimental+-- Stability   : pre-release -- Portability : GHC -- -- Lists are just a special case of monadic streams. The stream type @SerialT@@ -61,13 +51,8 @@ -- module Streamly.Internal.Data.List     (-#if __GLASGOW_HASKELL__ >= 800     List (.., Nil, Cons)-#else-    List (..)-    , pattern Nil-    , pattern Cons-#endif+     -- XXX we may want to use rebindable syntax for variants instead of using     -- different types (applicative do and apWith).     , ZipList (..)@@ -90,7 +75,7 @@ import Streamly.Internal.Data.Stream.Serial (SerialT) import Streamly.Internal.Data.Stream.Zip (ZipSerialM) -import qualified Streamly.Internal.Data.Stream.Prelude as P+import qualified Streamly.Internal.Data.Stream.IsStream as Stream import qualified Streamly.Internal.Data.Stream.StreamK as K  -- We implement list as a newtype instead of a type synonym to make type@@ -118,15 +103,15 @@  instance (a ~ Char) => IsString (List a) where     {-# INLINE fromString #-}-    fromString = List . P.fromList+    fromString = List . Stream.fromList  -- GHC versions 8.0 and below cannot derive IsList instance IsList (List a) where     type (Item (List a)) = a     {-# INLINE fromList #-}-    fromList = List . P.fromList+    fromList = List . Stream.fromList     {-# INLINE toList #-}-    toList = runIdentity . P.toList . toSerial+    toList = runIdentity . Stream.toList . toSerial  ------------------------------------------------------------------------------ -- Patterns@@ -180,15 +165,15 @@  instance (a ~ Char) => IsString (ZipList a) where     {-# INLINE fromString #-}-    fromString = ZipList . P.fromList+    fromString = ZipList . Stream.fromList  -- GHC versions 8.0 and below cannot derive IsList instance IsList (ZipList a) where     type (Item (ZipList a)) = a     {-# INLINE fromList #-}-    fromList = ZipList . P.fromList+    fromList = ZipList . Stream.fromList     {-# INLINE toList #-}-    toList = runIdentity . P.toList . toZipSerial+    toList = runIdentity . Stream.toList . K.adapt . toZipSerial  -- | Convert a 'ZipList' to a regular 'List' --
+ src/Streamly/Internal/Data/Maybe/Strict.hs view
@@ -0,0 +1,48 @@+-- |+-- 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.+--+module Streamly.Internal.Data.Maybe.Strict+    ( Maybe' (..)+    , toMaybe+    , isJust'+    , fromJust'+    )+where++-- | A strict 'Maybe'+data Maybe' a = Just' !a | Nothing' deriving Show++-- | Convert strict Maybe' to lazy Maybe+{-# INLINABLE 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'.+{-# INLINABLE 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' _".+{-# INLINABLE isJust' #-}+isJust' :: Maybe' a -> Bool+isJust' (Just' _) = True+isJust' Nothing' = False
src/Streamly/Internal/Data/Parser.hs view
@@ -1,869 +1,1118 @@-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}---- |--- Module      : Streamly.Internal.Data.Parser--- Copyright   : (c) 2020 Composewell Technologies--- License     : BSD3--- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC------ Fast streaming parsers.------ 'Applicative' and 'Alternative' type class based combinators from the--- <http://hackage.haskell.org/package/parser-combinators parser-combinators>--- package can also be used with the 'Parser' type. However, there are two--- important differences between @parser-combinators@ and the equivalent ones--- provided in this module in terms of performance:------ 1) @parser-combinators@ 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', thus providing a scalability--- and a generic consumer.------ 2) Several combinators in this module can be many times faster 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 'Alternative' type class.------ Failing parsers in this module throw the 'ParseError' exception.---- XXX As far as possible, try that the combinators in this module and in--- "Text.ParserCombinators.ReadP/parser-combinators/parsec/megaparsec/attoparsec"--- have consistent names. takeP/takeWhileP/munch?--module Streamly.Internal.Data.Parser-    (-      Parser (..)--    -- First order parsers-    -- * Accumulators-    , fromFold-    , any-    , all-    , yield-    , yieldM-    , die-    , dieM--    -- * Element parsers-    , peek-    , eof-    , satisfy--    -- * Sequence parsers-    ---    -- 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:-    ---    -- sliceSepByMax cond n p = sliceBy cond (take n p)-    -- sliceSepByBetween cond m n p = sliceBy cond (takeBetween m n p)-    -- takeWhileBetween cond m n p = takeWhile cond (takeBetween m n p)-    ---    -- Grab a sequence of input elements without inspecting them-    , take-    -- , takeBetween-    -- , takeLE -- take   -- takeBetween 0 n-    -- , takeLE1 -- take1 -- takeBetween 1 n-    , takeEQ -- takeBetween n n-    , takeGE -- takeBetween n maxBound--    -- Grab a sequence of input elements by inspecting them-    , lookAhead-    , takeWhile-    , takeWhile1-    , sliceSepBy-    , sliceSepByMax-    -- , sliceSepByBetween-    , sliceEndWith-    , sliceBeginWith-    -- , sliceSepWith-    ---    -- , frameSepBy -- parse frames escaped by an escape char/sequence-    -- , frameEndWith-    ---    , wordBy-    , groupBy-    , eqBy-    -- , prefixOf -- match any prefix of a given string-    -- , suffixOf -- match any suffix of a given string-    -- , infixOf -- match any substring of a given string--    -- Second order parsers (parsers using parsers)-    -- * Binary Combinators--    -- ** Sequential Applicative-    , splitWith--    -- ** Parallel Applicatives-    , teeWith-    , teeWithFst-    , teeWithMin-    -- , teeTill -- like manyTill but parallel--    -- ** Sequential Interleaving-    -- Use two folds, run a primary parser, its rejected values go to the-    -- secondary parser.-    , deintercalate--    -- ** Parallel Alternatives-    , shortest-    , longest-    -- , fastest--    -- * N-ary Combinators-    -- ** Sequential Collection-    , sequence--    -- ** Sequential Repetition-    , count-    , countBetween-    -- , countBetweenTill--    , many-    , some-    , manyTill--    -- -- ** Special cases-    -- XXX 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-    -- , sepBy-    -- , sepEndBy-    -- , beginBy-    -- , sepBeginBy-    -- , sepAroundBy--    -- -- * 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-    -- Round robin-    -- Priority based-    -- -- ** 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-    -- , shortestN-    -- , longestN-    -- , fastestN -- first N successful in time-    -- , choiceN  -- first N successful in position-    , choice   -- first successful in position--    -- -- ** Repeated Alternatives-    -- , retryMax    -- try N times-    -- , retryUntil  -- try until successful-    -- , retryUntilN -- try until successful n times-    )-where--import Control.Exception (assert)-import Control.Monad.Catch (MonadCatch, MonadThrow(..))-import Prelude-       hiding (any, all, take, takeWhile, sequence)--import Streamly.Internal.Data.Fold.Types (Fold(..))--import Streamly.Internal.Data.Parser.Tee-import Streamly.Internal.Data.Parser.Types-import Streamly.Internal.Data.Strict------------------------------------------------------------------------------------ Upgrade folds to parses-------------------------------------------------------------------------------------- | The resulting parse never terminates and never errors out.----{-# INLINE fromFold #-}-fromFold :: Monad m => Fold m a b -> Parser m a b-fromFold (Fold fstep finitial fextract) = Parser step finitial fextract--    where--    step s a = Yield 0 <$> fstep s a------------------------------------------------------------------------------------ Terminating but not failing folds-------------------------------------------------------------------------------------- |--- >>> S.parse (PR.any (== 0)) $ S.fromList [1,0,1]--- > Right True----{-# INLINABLE any #-}-any :: Monad m => (a -> Bool) -> Parser m a Bool-any predicate = Parser step initial return--    where--    initial = return False--    step s a = return $-        if s-        then Stop 0 True-        else-            if predicate a-            then Stop 0 True-            else Yield 0 False---- |--- >>> S.parse (PR.all (== 0)) $ S.fromList [1,0,1]--- > Right False----{-# INLINABLE all #-}-all :: Monad m => (a -> Bool) -> Parser m a Bool-all predicate = Parser step initial return--    where--    initial = return True--    step s a = return $-        if s-        then-            if predicate a-            then Yield 0 True-            else Stop 0 False-        else Stop 0 False------------------------------------------------------------------------------------ Failing Parsers------------------------------------------------------------------------------------ | Peek the head element of a stream, without consuming it. Fails if it--- encounters end of input.------ >>> S.parse ((,) <$> PR.peek <*> PR.satisfy (> 0)) $ S.fromList [1]--- (1,1)------ @--- peek = lookAhead (satisfy True)--- @------ /Internal/----{-# INLINABLE peek #-}-peek :: MonadThrow m => Parser m a a-peek = Parser step initial extract--    where--    initial = return ()--    step () a = return $ Stop 1 a--    extract () = throwM $ ParseError "peek: end of input"---- | Succeeds if we are at the end of input, fails otherwise.------ >>> S.parse ((,) <$> PR.satisfy (> 0) <*> PR.eof) $ S.fromList [1]--- > (1,())------ /Internal/----{-# INLINABLE eof #-}-eof :: Monad m => Parser m a ()-eof = Parser step initial return--    where--    initial = return ()--    step () _ = return $ Error "eof: not at end of input"---- | Returns the next element if it passes the predicate, fails otherwise.------ >>> S.parse (PR.satisfy (== 1)) $ S.fromList [1,0,1]--- > 1------ /Internal/----{-# INLINE satisfy #-}-satisfy :: MonadThrow m => (a -> Bool) -> Parser m a a-satisfy predicate = Parser step initial extract--    where--    initial = return ()--    step () a = return $-        if predicate a-        then Stop 0 a-        else Error "satisfy: predicate failed"--    extract _ = throwM $ ParseError "satisfy: end of input"------------------------------------------------------------------------------------ Taking elements-------------------------------------------------------------------------------------- XXX Once we have terminating folds, this Parse should get replaced by Fold.--- Alternatively, we can name it "chunkOf" and the corresponding time domain--- combinator as "intervalOf" or even "chunk" and "interval".------ | Take at most @n@ input elements and fold them using the supplied fold.------ Stops after @n@ elements.--- Never fails.------ >>> S.parse (PR.take 1 FL.toList) $ S.fromList [1]--- [1]------ @--- S.chunksOf n f = S.splitParse (FL.take n f)--- @------ /Internal/----{-# INLINE take #-}-take :: Monad m => Int -> Fold m a b -> Parser m a b-take n (Fold fstep finitial fextract) = Parser step initial extract--    where--    initial = Tuple' 0 <$> finitial--    step (Tuple' i r) a = do-        res <- fstep r a-        let i1 = i + 1-            s1 = Tuple' i1 res-        if i1 < n-        then return $ Yield 0 s1-        else Stop 0 <$> fextract res--    extract (Tuple' _ r) = fextract r------- XXX can we use a "cmp" operation in a common implementation?------ | Stops after taking exactly @n@ input elements.------ * Stops - after @n@ elements.--- * Fails - if the stream ends before it can collect @n@ elements.------ >>> S.parse (PR.takeEQ 4 FL.toList) $ S.fromList [1,0,1]--- > "takeEQ: Expecting exactly 4 elements, got 3"------ /Internal/----{-# INLINE takeEQ #-}-takeEQ :: MonadThrow m => Int -> Fold m a b -> Parser m a b-takeEQ n (Fold fstep finitial fextract) = Parser step initial extract--    where--    initial = Tuple' 0 <$> finitial--    step (Tuple' i r) a = do-        res <- fstep r a-        let i1 = i + 1-            s1 = Tuple' i1 res-        if i1 < n then return (Skip 0 s1) else Stop 0 <$> fextract res--    extract (Tuple' i r) =-        if n == i-        then fextract r-        else throwM $ ParseError err--        where--        err =-               "takeEQ: Expecting exactly " ++ show n-            ++ " elements, got " ++ show i---- | Take at least @n@ input elements, but can collect more.------ * Stops - never.--- * Fails - if the stream ends before producing @n@ elements.------ >>> S.parse (PR.takeGE 4 FL.toList) $ S.fromList [1,0,1]--- > "takeGE: Expecting at least 4 elements, got only 3"------ >>> S.parse (PR.takeGE 4 FL.toList) $ S.fromList [1,0,1,0,1]--- > [1,0,1,0,1]------ /Internal/----{-# INLINE takeGE #-}-takeGE :: MonadThrow m => Int -> Fold m a b -> Parser m a b-takeGE n (Fold fstep finitial fextract) = Parser step initial extract--    where--    initial = Tuple' 0 <$> finitial--    step (Tuple' i r) a = do-        res <- fstep r a-        let i1 = i + 1-            s1 = Tuple' i1 res-        return $-            if i1 < n-            then Skip 0 s1-            else Yield 0 s1--    extract (Tuple' i r) = fextract r >>= f--        where--        err =-              "takeGE: Expecting at least " ++ show n-           ++ " elements, got only " ++ show i--        f x =-            if i >= n-            then return x-            else throwM $ ParseError err---- | 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.--- * Fails - never.------ >>> S.parse (PR.takeWhile (== 0) FL.toList) $ S.fromList [0,0,1,0,1]--- > [0,0]------ We can implement a @breakOn@ using 'takeWhile':------ @--- breakOn p = takeWhile (not p)--- @------ /Internal/----{-# INLINE takeWhile #-}-takeWhile :: Monad m => (a -> Bool) -> Fold m a b -> Parser m a b-takeWhile predicate (Fold fstep finitial fextract) =-    Parser step initial fextract--    where--    initial = finitial--    step s a =-        if predicate a-        then Yield 0 <$> fstep s a-        else Stop 1 <$> fextract s---- | Like 'takeWhile' but takes at least one element otherwise fails.------ /Internal/----{-# INLINE takeWhile1 #-}-takeWhile1 :: MonadThrow m => (a -> Bool) -> Fold m a b -> Parser m a b-takeWhile1 predicate (Fold fstep finitial fextract) =-    Parser step initial extract--    where--    initial = return Nothing--    step Nothing a =-        if predicate a-        then do-            s <- finitial-            r <- fstep s a-            return $ Yield 0 (Just r)-        else return $ Error "takeWhile1: empty"-    step (Just s) a =-        if predicate a-        then do-            r <- fstep s a-            return $ Yield 0 (Just r)-        else do-            b <- fextract s-            return $ Stop 1 b--    extract Nothing = throwM $ ParseError "takeWhile1: end of input"-    extract (Just s) = fextract s---- | Collect stream elements until an element succeeds the predicate. Drop the--- element on which the predicate succeeded. The succeeding element is treated--- as an infix separator which is dropped from the output.------ * Stops - when the predicate succeeds.--- * Fails - never.------ >>> S.parse (PR.sliceSepBy (== 1) FL.toList) $ S.fromList [0,0,1,0,1]--- > [0,0]------ S.splitOn pred f = S.splitParse (PR.sliceSepBy pred f)------ >>> S.toList $ S.splitParse (PR.sliceSepBy (== 1) FL.toList) $ S.fromList [0,0,1,0,1]--- > [[0,0],[0],[]]------ /Internal/----{-# INLINABLE sliceSepBy #-}-sliceSepBy :: Monad m => (a -> Bool) -> Fold m a b -> Parser m a b-sliceSepBy predicate (Fold fstep finitial fextract) =-    Parser step initial fextract--    where--    initial = finitial-    step s a =-        if not (predicate a)-        then Yield 0 <$> fstep s a-        else Stop 0 <$> fextract s---- | Collect stream elements until an element succeeds the predicate. Also take--- the element on which the predicate succeeded. The succeeding element is--- treated as a suffix separator which is kept in the output segement.------ * Stops - when the predicate succeeds.--- * Fails - never.------ S.splitWithSuffix pred f = S.splitParse (PR.sliceEndWith pred f)------ /Unimplemented/----{-# INLINABLE sliceEndWith #-}-sliceEndWith ::-    -- Monad m =>-    (a -> Bool) -> Fold m a b -> Parser m a b-sliceEndWith = undefined---- | Collect stream elements until an elements passes the predicate, return the--- last element on which the predicate succeeded back to the input stream.  If--- the predicate succeeds on the first element itself then it is kept in the--- stream and we continue collecting. The succeeding element is treated as a--- prefix separator which is kept in the output segement.------ * Stops - when the predicate succeeds in non-leading position.--- * Fails - never.------ S.splitWithPrefix pred f = S.splitParse (PR.sliceBeginWith pred f)------ /Unimplemented/----{-# INLINABLE sliceBeginWith #-}-sliceBeginWith ::-    -- Monad m =>-    (a -> Bool) -> Fold m a b -> Parser m a b-sliceBeginWith = undefined---- | Split using a condition or a count whichever occurs first. This is a--- hybrid of 'splitOn' and 'take'. The element on which the condition succeeds--- is dropped.------ /Internal/----{-# INLINABLE sliceSepByMax #-}-sliceSepByMax :: Monad m-    => (a -> Bool) -> Int -> Fold m a b -> Parser m a b-sliceSepByMax predicate cnt (Fold fstep finitial fextract) =-    Parser step initial extract--    where--    initial = Tuple' 0 <$> finitial-    step (Tuple' i r) a = do-        res <- fstep r a-        let i1 = i + 1-            s1 = Tuple' i1 res-        if not (predicate a) && i1 < cnt-        then return $ Yield 0 s1-        else do-            b <- fextract res-            return $ Stop 0 b-    extract (Tuple' _ r) = fextract r---- | 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.------ @--- S.wordsBy pred f = S.splitParse (PR.wordBy pred f)--- @------ /Unimplemented/----{-# INLINABLE wordBy #-}-wordBy ::-    -- Monad m =>-    (a -> Bool) -> Fold m a b -> Parser m a b-wordBy = undefined---- | @groupBy cmp f $ S.fromList [a,b,c,...]@ 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 a new group is started. Each--- group is folded using the 'Fold' @f@ and the result of the fold is emitted--- in the output stream.------ * Stops - when the comparison fails.--- * Fails - never.------ @--- S.groupsBy cmp f = S.splitParse (PR.groupBy cmp f)--- @------ /Unimplemented/----{-# INLINABLE groupBy #-}-groupBy ::-    -- Monad m =>-    (a -> a -> Bool) -> Fold m a b -> Parser m a b-groupBy = undefined---- XXX use an Unfold instead of a list?--- XXX custom combinators for matching list, array and stream?------ | Match the given sequence of elements using the given comparison function.------ /Internal/----{-# INLINE eqBy #-}-eqBy :: MonadThrow m => (a -> a -> Bool) -> [a] -> Parser m a ()-eqBy cmp str = Parser step initial extract--    where--    initial = return str--    step [] _ = error "Bug: unreachable"-    step [x] a = return $-        if x `cmp` a-        then Stop 0 ()-        else Error $-            "eqBy: failed, at the last element"-    step (x:xs) a = return $-        if x `cmp` a-        then Skip 0 xs-        else Error $-            "eqBy: failed, yet to match " ++ show (length xs) ++ " elements"--    extract xs = throwM $ ParseError $-        "eqBy: end of input, yet to match " ++ show (length xs) ++ " elements"------------------------------------------------------------------------------------ nested parsers----------------------------------------------------------------------------------{-# INLINE lookAhead #-}-lookAhead :: MonadThrow m => Parser m a b -> Parser m a b-lookAhead (Parser step1 initial1 _) =-    Parser step initial extract--    where--    initial = Tuple' 0 <$> initial1--    step (Tuple' cnt st) a = do-        r <- step1 st a-        let cnt1 = cnt + 1-        return $ case r of-            Yield _ s -> Skip 0 (Tuple' cnt1 s)-            Skip n s -> Skip n (Tuple' (cnt1 - n) s)-            Stop _ b -> Stop 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' n _) = throwM $ ParseError $-        "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.------ | 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.------ This undoes a "gintercalate" of two streams.------ /Unimplemented/----{-# INLINE deintercalate #-}-deintercalate ::-    -- Monad m =>-       Fold m a y -> Parser m x a-    -> Fold m b z -> Parser m x b-    -> Parser m x (y, z)-deintercalate = undefined------------------------------------------------------------------------------------ Sequential Collection-------------------------------------------------------------------------------------- | @sequence f t@ collects sequential parses of parsers in the container @t@--- using the fold @f@. Fails if the input ends or any of the parsers fail.------ /Unimplemented/----{-# INLINE sequence #-}-sequence ::-    -- Foldable t =>-    Fold m b c -> t (Parser m a b) -> Parser m a c-sequence _f _p = undefined------------------------------------------------------------------------------------ Alternative Collection-------------------------------------------------------------------------------------- | @choice parsers@ applies the @parsers@ in order and returns the first--- successful parse.----{-# INLINE choice #-}-choice ::-    -- Foldable t =>-    t (Parser m a b) -> Parser m a b-choice _ps = undefined------------------------------------------------------------------------------------ Sequential Repetition-------------------------------------------------------------------------------------- XXX "many" is essentially a Fold because it cannot fail. So it can be--- downgraded to a Fold. Or we can make the return type a Fold instead and--- upgrade that to a parser when needed.------ | Collect zero or more parses. Apply the parser repeatedly on the input--- stream, stop when the parser fails, accumulate zero or more parse results--- using the supplied 'Fold'. This parser never fails, in case the first--- application of parser fails it returns an empty result.------ Compare with 'Control.Applicative.many'.------ /Internal/----{-# INLINE many #-}-many :: MonadCatch m => Fold m b c -> Parser m a b -> Parser m a c-many = splitMany--- many = countBetween 0 maxBound---- | Collect one or more parses. Apply the supplied parser repeatedly on the--- input stream and accumulate the parse results as long as the parser--- succeeds, stop when it fails.  This parser fails if not even one result is--- collected.------ Compare with 'Control.Applicative.some'.------ /Internal/----{-# INLINE some #-}-some :: MonadCatch m => Fold m b c -> Parser m a b -> Parser m a c-some = splitSome--- some f p = many (takeGE 1 f) p--- many = 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.------ /Unimplemented/----{-# INLINE countBetween #-}-countBetween ::-    -- MonadCatch m =>-    Int -> Int -> Fold m b c -> Parser m a b -> Parser m a c-countBetween _m _n _f = undefined--- countBetween m n f p = many (takeBetween m n f) p---- | @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.------ /Unimplemented/----{-# INLINE count #-}-count ::-    -- MonadCatch m =>-    Int -> Fold m b c -> Parser m a b -> Parser m a c-count n = countBetween n n--- count n f p = many (takeEQ n f) p--data ManyTillState fs sr sl = ManyTillR Int fs sr | ManyTillL fs sl---- | @manyTill f collect test@ 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 accumulated by the--- supplied fold. The parser fails if @collect@ fails.------ /Internal/----{-# INLINE manyTill #-}-manyTill :: MonadCatch m-    => Fold m b c -> Parser m a b -> Parser m a x -> Parser m a c-manyTill (Fold fstep finitial fextract)-         (Parser stepL initialL extractL)-         (Parser stepR initialR _) =-    Parser step initial extract--    where--    initial = do-        fs <- finitial-        ManyTillR 0 fs <$> initialR--    step (ManyTillR cnt fs st) a = do-        r <- stepR st a-        case r of-            Yield n s -> return $ Yield n (ManyTillR 0 fs s)-            Skip n s -> do-                assert (cnt + 1 - n >= 0) (return ())-                return $ Skip n (ManyTillR (cnt + 1 - n) fs s)-            Stop n _ -> do-                b <- fextract fs-                return $ Stop n b-            Error _ -> do-                rR <- initialL-                return $ Skip (cnt + 1) (ManyTillL fs rR)--    step (ManyTillL fs st) a = do-        r <- stepL st a-        case r of-            Yield n s -> return $ Yield n (ManyTillL fs s)-            Skip n s -> return $ Skip n (ManyTillL fs s)-            Stop n b -> do-                fs1 <- fstep fs b-                l <- initialR-                -- XXX we need a yield with backtrack here-                -- return $ Yield n (ManyTillR 0 fs1 l)-                return $ Skip n (ManyTillR 0 fs1 l)-            Error err -> return $ Error err--    extract (ManyTillL fs sR) = extractL sR >>= fstep fs >>= fextract-    extract (ManyTillR _ fs _) = fextract fs+{-# OPTIONS_GHC -Wno-orphans  #-}++-- |+-- Module      : Streamly.Internal.Data.Parser+-- Copyright   : (c) 2020 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : pre-release+-- Portability : GHC+--+-- Fast backtracking parsers with stream fusion and native streaming+-- capability.+--+-- 'Applicative' and 'Control.Applicative.Alternative' type class based+-- combinators from the+-- <http://hackage.haskell.org/package/parser-combinators parser-combinators>+-- package can also be used with the 'Parser' type. However, there are two+-- important differences between @parser-combinators@ and the equivalent ones+-- provided in this module in terms of performance:+--+-- 1) @parser-combinators@ 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', thus providing a scalability+-- and a composable consumer.+--+-- 2) Several combinators in this module can be many times faster 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.+--+-- = Errors+--+-- Failing parsers in this module throw the 'D.ParseError' exception.+--+-- = Naming+--+-- As far as possible, try that the names of the combinators in this module are+-- consistent with:+--+-- * <https://hackage.haskell.org/package/base/docs/Text-ParserCombinators-ReadP.html base/Text.ParserCombinators.ReadP>+-- * <http://hackage.haskell.org/package/parser-combinators parser-combinators>+-- * <http://hackage.haskell.org/package/megaparsec megaparsec>+-- * <http://hackage.haskell.org/package/attoparsec attoparsec>+-- * <http://hackage.haskell.org/package/parsec parsec>++module Streamly.Internal.Data.Parser+    (+      K.Parser (..)+    , D.ParseError (..)+    , D.Step (..)++    -- First order parsers+    -- * Accumulators+    , fromFold+    , fromPure+    , fromEffect+    , die+    , dieM++    -- * Element parsers+    , peek+    , eof+    , satisfy+    , maybe+    , either++    -- * Sequence parsers+    --+    -- | Parsers chained in series, if one parser terminates the composition+    -- terminates.++    -- | Grab a sequence of input elements without inspecting them+    , takeBetween+    -- , take   -- takeBetween 0 n+    , takeEQ -- takeBetween n n+    , takeGE -- takeBetween n maxBound++    -- Grab a sequence of input elements by inspecting them+    , lookAhead+    , takeWhileP+    , takeWhile+    -- $takeWhile+    , takeWhile1+    , drainWhile++    , sliceSepByP+    , sliceBeginWith+    , sliceSepWith+    , escapedSliceSepBy+    , escapedFrameBy+    , wordBy+    , groupBy+    , groupByRolling+    , eqBy+    -- | Unimplemented+    --+    -- @+    -- , prefixOf -- match any prefix of a given string+    -- , suffixOf -- match any suffix of a given string+    -- , infixOf -- match any substring of a given string+    -- @++    -- Second order parsers (parsers using parsers)+    -- * Binary Combinators++    -- ** Sequential Applicative+    , serialWith+    , split_++    -- ** Parallel Applicatives+    , teeWith+    , teeWithFst+    , teeWithMin+    -- , teeTill -- like manyTill but parallel++    -- ** Sequential Interleaving+    -- Use two folds, run a primary parser, its rejected values go to the+    -- secondary parser.+    , deintercalate++    -- ** Sequential Alternative+    , alt++    -- ** Parallel Alternatives+    , shortest+    , longest+    -- , fastest++    -- * N-ary Combinators+    -- ** Sequential Collection+    , concatSequence+    , concatMap++    -- ** Sequential Repetition+    , count+    , countBetween++    , manyP+    , many+    , some+    , manyTillP+    , manyTill+    , manyThen++    -- ** 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+    -- , sepBy+    -- , sepEndBy+    -- , beginBy+    -- , sepBeginBy+    -- , sepAroundBy+    -- @++    -- * 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++    -- ** 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+    )+where++import Control.Monad.Catch (MonadCatch)+import Prelude+       hiding (any, all, take, takeWhile, sequence, concatMap, maybe, either)++import Streamly.Internal.Data.Fold.Type (Fold(..))+import Streamly.Internal.Data.Parser.ParserK.Type (Parser)++import qualified Streamly.Internal.Data.Fold.Type as FL+import qualified Streamly.Internal.Data.Parser.ParserD as D+import qualified Streamly.Internal.Data.Parser.ParserK.Type as K++--+-- $setup+-- >>> :m+-- >>> import Prelude hiding (any, all, take, takeWhile, sequence, concatMap, maybe, either)+-- >>> import qualified Streamly.Prelude as Stream+-- >>> import qualified Streamly.Internal.Data.Stream.IsStream as Stream (parse, parseMany)+-- >>> import qualified Streamly.Data.Fold as Fold+-- >>> import qualified Streamly.Internal.Data.Parser as Parser++-------------------------------------------------------------------------------+-- Upgrade folds to parses+-------------------------------------------------------------------------------+--+-- | Make a 'Parser' from a 'Fold'.+--+-- /Pre-release/+--+{-# INLINE fromFold #-}+fromFold :: MonadCatch m => Fold m a b -> Parser m a b+fromFold = K.toParserK . D.fromFold++-------------------------------------------------------------------------------+-- Terminating but not failing folds+-------------------------------------------------------------------------------+--+-- This is the dual of stream "fromPure".+--+-- | A parser that always yields a pure value without consuming any input.+--+-- /Pre-release/+--+{-# INLINE [3] fromPure #-}+fromPure :: MonadCatch m => b -> Parser m a b+fromPure = K.toParserK . D.fromPure+{-# RULES "fromPure fallback to CPS" [2]+    forall a. K.toParserK (D.fromPure a) = K.fromPure a #-}++-- This is the dual of stream "fromEffect".+--+-- | A parser that always yields the result of an effectful action without+-- consuming any input.+--+-- /Pre-release/+--+{-# INLINE fromEffect #-}+fromEffect :: MonadCatch m => m b -> Parser m a b+fromEffect = K.fromEffect -- K.toParserK . D.fromEffect++-- This is the dual of "nil".+--+-- | A parser that always fails with an error message without consuming+-- any input.+--+-- /Pre-release/+--+{-# INLINE [3] die #-}+die :: MonadCatch m => String -> Parser m a b+die = K.toParserK . D.die+{-# RULES "die fallback to CPS" [2]+    forall a. K.toParserK (D.die a) = K.die a #-}++-- This is the dual of "nilM".+--+-- | A parser that always fails with an effectful error message and without+-- consuming any input.+--+-- /Pre-release/+--+{-# INLINE dieM #-}+dieM :: MonadCatch m => m String -> Parser m a b+dieM = K.toParserK . D.dieM++-------------------------------------------------------------------------------+-- 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]+-- (1,1)+--+-- @+-- peek = lookAhead (satisfy True)+-- @+--+-- /Pre-release/+--+{-# INLINE peek #-}+peek :: MonadCatch m => Parser m a a+peek = K.toParserK D.peek++-- | Succeeds if we are at the end of input, fails otherwise.+--+-- >>> Stream.parse ((,) <$> Parser.satisfy (> 0) <*> Parser.eof) $ Stream.fromList [1]+-- (1,())+--+-- /Pre-release/+--+{-# INLINE eof #-}+eof :: MonadCatch m => Parser m a ()+eof = K.toParserK D.eof++-- | Returns the next element if it passes the predicate, fails otherwise.+--+-- >>> Stream.parse (Parser.satisfy (== 1)) $ Stream.fromList [1,0,1]+-- 1+--+-- /Pre-release/+--+{-# INLINE satisfy #-}+satisfy :: MonadCatch m => (a -> Bool) -> Parser m a a+satisfy = K.toParserK . D.satisfy++-- | 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.+--+-- /Pre-release/+--+{-# INLINE maybe #-}+maybe :: MonadCatch m => (a -> Maybe b) -> Parser m a b+maybe = K.toParserK . D.maybe++-- | 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 :: MonadCatch m => (a -> Either String b) -> Parser m a b+either = K.toParserK . D.either++-------------------------------------------------------------------------------+-- Taking elements+-------------------------------------------------------------------------------++-- | @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]+-- [1,2,3,4]+--+-- >>> takeBetween' 2 4 [1, 2]+-- [1,2]+--+-- >>> takeBetween' 2 4 [1]+-- *** Exception: ParseError "takeBetween: Expecting alteast 2 elements, got 1"+--+-- >>> takeBetween' 0 0 [1, 2]+-- []+--+-- >>> takeBetween' 0 1 []+-- []+--+-- @takeBetween@ is the most general take operation, other take operations can+-- be defined in terms of takeBetween. For example:+--+-- @+-- take = takeBetween 0 n  -- equivalent of take+-- take1 = takeBetween 1 n -- equivalent of takeLE1+-- takeEQ = takeBetween n n+-- takeGE = takeBetween n maxBound+-- @+--+-- /Pre-release/+--+{-# INLINE takeBetween #-}+takeBetween ::  MonadCatch m =>+    Int -> Int -> Fold m a b -> Parser m a b+takeBetween m n = K.toParserK . D.takeBetween m n++-- | 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 4 Fold.toList) $ Stream.fromList [1,0,1]+-- *** Exception: ParseError "takeEQ: Expecting exactly 4 elements, input terminated on 3"+--+-- /Pre-release/+--+{-# INLINE takeEQ #-}+takeEQ :: MonadCatch m => Int -> Fold m a b -> Parser m a b+takeEQ n = K.toParserK . D.takeEQ n++-- | 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]+-- *** Exception: 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]+-- [1,0,1,0,1]+--+-- /Pre-release/+--+{-# INLINE takeGE #-}+takeGE :: MonadCatch m => Int -> Fold m a b -> Parser m a b+takeGE n = K.toParserK . D.takeGE n++-- $takeWhile+-- Note: This is called @takeWhileP@ and @munch@ in some parser libraries.++-- | 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.+--+-- This is a generalized version of takeWhile, for example 'takeWhile1' can be+-- implemented in terms of this:+--+-- @+-- takeWhile1 cond p = takeWhile cond (takeBetween 1 maxBound p)+-- @+--+-- Stops: when the condition fails or the collecting parser stops.+-- Fails: when the collecting parser fails.+--+-- /Unimplemented/+--+{-# INLINE takeWhileP #-}+takeWhileP :: -- MonadCatch m =>+    (a -> Bool) -> Parser m a b -> Parser m a b+takeWhileP _cond = undefined -- K.toParserK . D.takeWhileP cond++-- | 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]+-- [0,0]+--+-- We can implement a @breakOn@ using 'takeWhile':+--+-- @+-- breakOn p = takeWhile (not p)+-- @+--+-- /Pre-release/+--+{-# INLINE takeWhile #-}+takeWhile :: MonadCatch m => (a -> Bool) -> Fold m a b -> Parser m a b+takeWhile cond = K.toParserK . D.takeWhile cond++-- | Like 'takeWhile' but takes at least one element otherwise fails.+--+-- /Pre-release/+--+{-# INLINE takeWhile1 #-}+takeWhile1 :: MonadCatch m => (a -> Bool) -> Fold m a b -> Parser m a b+takeWhile1 cond = K.toParserK . D.takeWhile1 cond++-- | 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.+--+-- /Pre-release/+--+{-# INLINE drainWhile #-}+drainWhile :: MonadCatch m => (a -> Bool) -> Parser m a ()+drainWhile p = takeWhile p FL.drain++-- | @sliceSepByP cond parser@ parses a slice of the input using @parser@ until+-- @cond@ succeeds or the parser stops.+--+-- This is a generalized slicing parser which can be used to implement other+-- parsers e.g.:+--+-- @+-- sliceSepByMax cond n p = sliceSepByP cond (take n p)+-- sliceSepByBetween cond m n p = sliceSepByP cond (takeBetween m n p)+-- @+--+-- /Pre-release/+--+{-# INLINABLE sliceSepByP #-}+sliceSepByP ::+    MonadCatch m =>+    (a -> Bool) -> Parser m a b -> Parser m a b+sliceSepByP cond = K.toParserK . D.sliceSepByP cond . K.fromParserK++-- | Like 'sliceSepBy' but does not drop the separator element, instead+-- separator is emitted as a separate element in the output.+--+-- /Unimplemented/+{-# INLINABLE sliceSepWith #-}+sliceSepWith :: -- MonadCatch m =>+    (a -> Bool) -> Fold m a b -> Parser m a b+sliceSepWith _cond = undefined -- K.toParserK . D.sliceSepBy cond++-- | Collect stream elements until an elements passes the predicate, return the+-- last element on which the predicate succeeded back to the input stream.  If+-- the predicate succeeds on the first element itself then the parser does not+-- terminate there. The succeeding element in the leading position+-- is treated as a prefix separator which is kept in the output segment.+--+-- * Stops - when the predicate succeeds in non-leading position.+-- * Fails - never.+--+-- S.splitWithPrefix pred f = S.parseMany (PR.sliceBeginWith pred f)+--+-- Examples: -+--+-- >>> :{+--  sliceBeginWithOdd ls = Stream.parse prsr (Stream.fromList ls)+--      where prsr = Parser.sliceBeginWith odd Fold.toList+-- :}+--+--+-- >>> sliceBeginWithOdd [2, 4, 6, 3]+-- *** Exception: sliceBeginWith : slice begins with an element which fails the predicate+-- ...+--+-- >>> sliceBeginWithOdd [3, 5, 7, 4]+-- [3]+--+-- >>> sliceBeginWithOdd [3, 4, 6, 8, 5]+-- [3,4,6,8]+--+-- >>> sliceBeginWithOdd []+-- []+--+-- /Pre-release/+--+{-# INLINABLE sliceBeginWith #-}+sliceBeginWith ::+    MonadCatch m =>+    (a -> Bool) -> Fold m a b -> Parser m a b+sliceBeginWith cond = K.toParserK . D.sliceBeginWith cond++-- | Like 'sliceSepBy' but the separator elements can be escaped using an+-- escape char determined by the second predicate.+--+-- /Unimplemented/+{-# INLINABLE escapedSliceSepBy #-}+escapedSliceSepBy :: -- MonadCatch m =>+    (a -> Bool) -> (a -> Bool) -> Fold m a b -> Parser m a b+escapedSliceSepBy _cond _esc = undefined+    -- K.toParserK . D.escapedSliceSepBy cond esc++-- | @escapedFrameBy begin end escape@ parses a string framed using @begin@ and+-- @end@ as the frame begin and end marker elements and @escape@ as an escaping+-- element to escape the occurrence of the framing elements within the frame.+-- Nested frames are allowed, but nesting is removed when parsing.+--+-- For example,+--+-- @+-- > Stream.parse (Parser.escapedFrameBy (== '{') (== '}') (== '\\') Fold.toList) $ Stream.fromList "{hello}"+-- "hello"+--+-- > Stream.parse (Parser.escapedFrameBy (== '{') (== '}') (== '\\') Fold.toList) $ Stream.fromList "{hello {world}}"+-- "hello world"+--+-- > Stream.parse (Parser.escapedFrameBy (== '{') (== '}') (== '\\') Fold.toList) $ Stream.fromList "{hello \\{world\\}}"+-- "hello {world}"+--+-- > Stream.parse (Parser.escapedFrameBy (== '{') (== '}') (== '\\') Fold.toList) $ Stream.fromList "{hello {world}"+-- ParseError "Unterminated '{'"+--+-- @+--+-- /Unimplemented/+{-# INLINABLE escapedFrameBy #-}+escapedFrameBy :: -- MonadCatch m =>+    (a -> Bool) -> (a -> Bool) -> (a -> Bool) -> Fold m a b -> Parser m a b+escapedFrameBy _begin _end _escape _p = undefined+    -- K.toParserK . D.frameBy begin end escape p++-- | 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.+--+-- @+-- S.wordsBy pred f = S.parseMany (PR.wordBy pred f)+-- @+--+{-# INLINE wordBy #-}+wordBy :: MonadCatch m => (a -> Bool) -> Fold m a b -> Parser m a b+wordBy f = K.toParserK . D.wordBy f++-- | 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.toList+--          . Stream.parseMany (Parser.groupBy eq Fold.toList)+--          . Stream.fromList+-- :}+--+-- >>> runGroupsBy (<) []+-- []+--+-- >>> runGroupsBy (<) [1]+-- [[1]]+--+-- >>> runGroupsBy (<) [3, 5, 4, 1, 2, 0]+-- [[3,5,4],[1,2],[0]]+--+-- /Pre-release/+--+{-# INLINABLE groupBy #-}+groupBy :: MonadCatch m => (a -> a -> Bool) -> Fold m a b -> Parser m a b+groupBy eq = K.toParserK . D.groupBy eq++-- | Unlike 'groupBy' this combinator performs a rolling comparison of two+-- successive elements in the input stream.  Assuming the input stream to the+-- parser 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.toList+--          . Stream.parseMany (Parser.groupByRolling eq Fold.toList)+--          . Stream.fromList+-- :}+--+-- >>> runGroupsByRolling (<) []+-- []+--+-- >>> runGroupsByRolling (<) [1]+-- [[1]]+--+-- >>> runGroupsByRolling (<) [3, 5, 4, 1, 2, 0]+-- [[3,5],[4],[1,2],[0]]+--+-- /Pre-release/+--+{-# INLINABLE groupByRolling #-}+groupByRolling :: MonadCatch m => (a -> a -> Bool) -> Fold m a b -> Parser m a b+groupByRolling eq = K.toParserK . D.groupByRolling eq++-- | Match the given sequence of elements using the given comparison function.+--+-- >>> Stream.parse (Parser.eqBy (==) "string") $ Stream.fromList "string"+--+-- >>> Stream.parse (Parser.eqBy (==) "mismatch") $ Stream.fromList "match"+-- *** Exception: ParseError "eqBy: failed, yet to match 7 elements"+--+-- /Pre-release/+--+{-# INLINE eqBy #-}+eqBy :: MonadCatch m => (a -> a -> Bool) -> [a] -> Parser m a ()+eqBy cmp = K.toParserK . D.eqBy cmp++-------------------------------------------------------------------------------+-- nested parsers+-------------------------------------------------------------------------------++-- | Sequential parser application. 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. If both the parsers+-- succeed their outputs are combined using the supplied function. The+-- operation fails if any of the parsers fail.+--+-- Note: This is a parsing dual of appending streams using+-- 'Streamly.Prelude.serial', it splits the streams using two parsers and zips+-- the results.+--+-- This implementation is strict in the second argument, therefore, the+-- following will fail:+--+-- >>> Stream.parse (Parser.serialWith const (Parser.satisfy (> 0)) undefined) $ Stream.fromList [1]+-- *** Exception: Prelude.undefined+-- ...+--+-- Compare with 'Applicative' instance method '<*>'. This implementation allows+-- stream fusion but has quadratic complexity. This can fuse with other+-- operations and can be faster than 'Applicative' instance for small number+-- (less than 8) of compositions.+--+-- Many combinators can be expressed using @serialWith@ and other parser+-- primitives. Some common idioms are described below,+--+-- @+-- span :: (a -> Bool) -> Fold m a b -> Fold m a b -> Parser m a b+-- span pred f1 f2 = serialWith (,) ('takeWhile' pred f1) ('fromFold' f2)+-- @+--+-- @+-- spanBy :: (a -> a -> Bool) -> Fold m a b -> Fold m a b -> Parser m a b+-- spanBy eq f1 f2 = serialWith (,) ('groupBy' eq f1) ('fromFold' f2)+-- @+--+-- @+-- spanByRolling :: (a -> a -> Bool) -> Fold m a b -> Fold m a b -> Parser m a b+-- spanByRolling eq f1 f2 = serialWith (,) ('groupByRolling' eq f1) ('fromFold' f2)+-- @+--+-- /Pre-release/+--+{-# INLINE serialWith #-}+serialWith :: MonadCatch m+    => (a -> b -> c) -> Parser m x a -> Parser m x b -> Parser m x c+serialWith f p1 p2 =+    K.toParserK $ D.serialWith f (K.fromParserK p1) (K.fromParserK p2)++-- | 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+-- ...+--+-- Compare with 'Applicative' instance method '*>'. This implementation allows+-- stream fusion but has quadratic complexity. This can fuse with other+-- operations, and can be faster than 'Applicative' instance for small+-- number (less than 8) of compositions.+--+-- /Pre-release/+--+{-# INLINE split_ #-}+split_ :: MonadCatch m => Parser m x a -> Parser m x b -> Parser m x b+split_ p1 p2 = K.toParserK $ D.split_ (K.fromParserK p1) (K.fromParserK p2)++-- | @teeWith f p1 p2@ distributes its input to both @p1@ and @p2@ until both+-- of them succeed or anyone of them fails and combines their output using @f@.+-- The parser succeeds if both the parsers succeed.+--+-- /Pre-release/+--+{-# INLINE teeWith #-}+teeWith :: MonadCatch m+    => (a -> b -> c) -> Parser m x a -> Parser m x b -> Parser m x c+teeWith f p1 p2 =+    K.toParserK $ D.teeWith f (K.fromParserK p1) (K.fromParserK p2)++-- | Like 'teeWith' but ends parsing and zips the results, if available,+-- whenever the first parser ends.+--+-- /Pre-release/+--+{-# INLINE teeWithFst #-}+teeWithFst :: MonadCatch m+    => (a -> b -> c) -> Parser m x a -> Parser m x b -> Parser m x c+teeWithFst f p1 p2 =+    K.toParserK $ D.teeWithFst f (K.fromParserK p1) (K.fromParserK p2)++-- | Like 'teeWith' but ends parsing and zips the results, if available,+-- whenever any of the parsers ends or fails.+--+-- /Unimplemented/+--+{-# INLINE teeWithMin #-}+teeWithMin :: MonadCatch m+    => (a -> b -> c) -> Parser m x a -> Parser m x b -> Parser m x c+teeWithMin f p1 p2 =+    K.toParserK $ D.teeWithMin f (K.fromParserK p1) (K.fromParserK p2)++-- | Sequential alternative. Apply the input to the first parser and return the+-- result if the parser succeeds. If the first parser fails then backtrack and+-- apply the same input to the second parser and return the result.+--+-- 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]+-- 1+--+-- Compare with 'Alternative' instance method '<|>'. This implementation allows+-- stream fusion but has quadratic complexity. This can fuse with other+-- operations and can be much faster than 'Alternative' instance for small+-- number (less than 8) of alternatives.+--+-- /Pre-release/+--+{-# INLINE alt #-}+alt :: MonadCatch m => Parser m x a -> Parser m x a -> Parser m x a+alt p1 p2 = K.toParserK $ D.alt (K.fromParserK p1) (K.fromParserK p2)++-- | Shortest alternative. Apply both parsers in parallel but choose the result+-- from the one which consumed least input i.e. take the shortest succeeding+-- parse.+--+-- /Pre-release/+--+{-# INLINE shortest #-}+shortest :: MonadCatch m+    => Parser m x a -> Parser m x a -> Parser m x a+shortest p1 p2 = K.toParserK $ D.shortest (K.fromParserK p1) (K.fromParserK p2)++-- | Longest alternative. Apply both parsers in parallel but choose the result+-- from the one which consumed more input i.e. take the longest succeeding+-- parse.+--+-- /Pre-release/+--+{-# INLINE longest #-}+longest :: MonadCatch m+    => Parser m x a -> Parser m x a -> Parser m x a+longest p1 p2 = K.toParserK $ D.longest (K.fromParserK p1) (K.fromParserK p2)++-- | Run a parser without consuming the input.+--+-- /Pre-release/+--+{-# INLINE lookAhead #-}+lookAhead :: MonadCatch m => Parser m a b -> Parser m a b+lookAhead p = K.toParserK $ D.lookAhead $ K.fromParserK p++-------------------------------------------------------------------------------+-- 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.+--+-- | 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.+--+-- This undoes a "gintercalate" of two streams.+--+-- /Unimplemented/+--+{-# INLINE deintercalate #-}+deintercalate ::+    -- Monad m =>+       Fold m a y -> Parser m x a+    -> Fold m b z -> Parser m x b+    -> Parser m x (y, z)+deintercalate = undefined++-------------------------------------------------------------------------------+-- Sequential Collection+-------------------------------------------------------------------------------+--+-- | @concatSequence f t@ collects sequential parses of parsers in the+-- container @t@ using the fold @f@. Fails if the input ends or any of the+-- parsers fail.+--+-- This is same as 'Data.Traversable.sequence' but more efficient.+--+-- /Unimplemented/+--+{-# INLINE concatSequence #-}+concatSequence ::+    -- Foldable t =>+    Fold m b c -> t (Parser m a b) -> Parser m a c+concatSequence _f _p = undefined++-- | Map a 'Parser' returning function on the result of a 'Parser'.+--+-- Compare with 'Monad' instance method '>>='. This implementation allows+-- stream fusion but has quadratic complexity. This can fuse with other+-- operations and can be much faster than 'Monad' instance for small number+-- (less than 8) of compositions.+--+-- /Pre-release/+--+{-# INLINE concatMap #-}+concatMap :: MonadCatch m+    => (b -> Parser m a c) -> Parser m a b -> Parser m a c+concatMap f p = K.toParserK $ D.concatMap (K.fromParserK . f) (K.fromParserK p)++-------------------------------------------------------------------------------+-- Alternative Collection+-------------------------------------------------------------------------------+--+-- | @choice parsers@ applies the @parsers@ in order and returns the first+-- successful parse.+--+-- This is same as 'asum' but more efficient.+--+-- /Unimplemented/+--+{-# INLINE choice #-}+choice ::+    -- Foldable t =>+    t (Parser m a b) -> Parser m a b+choice _ps = undefined++-------------------------------------------------------------------------------+-- Sequential Repetition+-------------------------------------------------------------------------------+--+-- $many+-- TODO "many" is essentially a Fold because it cannot fail. So it can be+-- downgraded to a Fold. Or we can make the return type a Fold instead and+-- upgrade that to a parser when needed.++-- | 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 m a b -> Parser m b c -> Parser m a c+manyP _p _f = undefined -- K.toParserK $ D.manyP (K.fromParserK p) f++-- | 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.+--+-- Compare with 'Control.Applicative.many'.+--+-- /Pre-release/+--+{-# INLINE many #-}+many :: MonadCatch m => Parser m a b -> Fold m b c -> Parser m a c+many p f = K.toParserK $ D.many (K.fromParserK p) f+-- 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 fld parser = manyP (takeGE 1 fld) parser@+--+-- Compare with 'Control.Applicative.some'.+--+-- /Pre-release/+--+{-# INLINE some #-}+some :: MonadCatch m => Parser m a b -> Fold m b c -> Parser m a c+some p f = K.toParserK $ D.some (K.fromParserK p) f+-- some p f = manyP p (takeGE 1 f)+-- many = 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.+--+-- /Unimplemented/+--+{-# INLINE countBetween #-}+countBetween ::+    -- MonadCatch m =>+    Int -> Int -> Parser m a b -> Fold m b c -> Parser m a c+countBetween _m _n _p = undefined+-- countBetween m n p f = manyP (takeBetween m n f) p++-- | @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.+--+-- /Unimplemented/+--+{-# INLINE count #-}+count ::+    -- MonadCatch m =>+    Int -> Parser m a b -> Fold m b c -> Parser m a c+count n = countBetween n n+-- count n p f = manyP (takeEQ n f) p++-- | 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 :: -- MonadCatch m =>+    Parser m a b -> Parser m a x -> Parser m b c -> Parser m a c+manyTillP _p1 _p2 _f = undefined+    -- K.toParserK $ D.manyTillP (K.fromParserK p1) (K.fromParserK p2) f++-- | @manyTill f collect test@ 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 accumulated by the+-- supplied fold. The parser fails if @collect@ fails.+--+-- Stops when the fold @f@ stops.+--+-- /Pre-release/+--+{-# INLINE manyTill #-}+manyTill :: MonadCatch m+    => Parser m a b -> Parser m a x -> Fold m b c -> Parser m a c+manyTill p1 p2 f =+    K.toParserK $ D.manyTill f (K.fromParserK p1) (K.fromParserK p2)++-- | @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, MonadCatch m) =>+    Parser m a b -> Parser m a x -> Fold m b c -> Parser m a c+manyThen _parser _recover _f = undefined++-------------------------------------------------------------------------------+-- 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, MonadCatch m) =>+    t (Parser m a b) -> Fold m b c -> Parser m a c+roundRobin _ps _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 :: -- (MonadCatch m) =>+    Int -> Parser m a b -> Fold m b c -> Parser m a c+retryMaxTotal _n _p _f  = undefined++-- | Like 'retryMaxTotal' but aborts after @n@ successive failures.+--+-- /Unimplemented/+--+{-# INLINE retryMaxSuccessive #-}+retryMaxSuccessive :: -- (MonadCatch m) =>+    Int -> Parser m a b -> Fold m b c -> Parser m a 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 :: -- (MonadCatch m) =>+    Parser m a b -> Parser m a b+retry _p = undefined
+ src/Streamly/Internal/Data/Parser/ParserD.hs view
@@ -0,0 +1,1034 @@+#include "inline.hs"++-- |+-- Module      : Streamly.Internal.Data.Parser.ParserD+-- Copyright   : (c) 2020 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- Direct style parser implementation with stream fusion.++module Streamly.Internal.Data.Parser.ParserD+    (+      Parser (..)+    , ParseError (..)+    , Step (..)+    , Initial (..)+    , rmapM++    -- First order parsers+    -- * Accumulators+    , fromFold+    , fromPure+    , fromEffect+    , die+    , dieM++    -- * Element parsers+    , peek+    , eof+    , satisfy+    , maybe+    , either++    -- * Sequence parsers+    --+    -- 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:+    --+    -- sliceSepByMax cond n p = sliceBy cond (take n p)+    -- sliceSepByBetween cond m n p = sliceBy cond (takeBetween m n p)+    -- takeWhileBetween cond m n p = takeWhile cond (takeBetween m n p)+    --+    -- Grab a sequence of input elements without inspecting them+    , takeBetween+    -- , take -- take   -- takeBetween 0 n+    -- , takeLE1 -- take1 -- takeBetween 1 n+    , takeEQ -- takeBetween n n+    , takeGE -- takeBetween n maxBound++    -- Grab a sequence of input elements by inspecting them+    , lookAhead+    , takeWhile+    , takeWhile1+    , sliceSepByP+    -- , sliceSepByBetween+    , sliceBeginWith+    -- , sliceSepWith+    --+    -- , frameSepBy -- parse frames escaped by an escape char/sequence+    -- , frameEndWith+    --+    , wordBy+    , groupBy+    , groupByRolling+    , eqBy+    -- , 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+    , serialWith+    , split_++    -- ** Parallel Applicatives+    , teeWith+    , teeWithFst+    , teeWithMin+    -- , teeTill -- like manyTill but parallel++    -- ** Sequential Interleaving+    -- Use two folds, run a primary parser, its rejected values go to the+    -- secondary parser.+    , deintercalate++    -- ** Sequential Alternative+    , alt++    -- ** Parallel Alternatives+    , shortest+    , longest+    -- , fastest++    -- * N-ary Combinators+    -- ** Sequential Collection+    , sequence+    , concatMap++    -- ** Sequential Repetition+    , count+    , countBetween+    -- , countBetweenTill++    , many+    , some+    , manyTill++    -- -- ** Special cases+    -- XXX 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+    -- , sepBy+    -- , sepEndBy+    -- , beginBy+    -- , sepBeginBy+    -- , sepAroundBy++    -- -- * 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+    -- Round robin+    -- Priority based+    -- -- ** 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+    -- , shortestN+    -- , longestN+    -- , fastestN -- first N successful in time+    -- , choiceN  -- first N successful in position+    , choice   -- first successful in position++    -- -- ** Repeated Alternatives+    -- , retryMax    -- try N times+    -- , retryUntil  -- try until successful+    -- , retryUntilN -- try until successful n times+    )+where++import Control.Exception (assert)+import Control.Monad.Catch (MonadCatch, MonadThrow(..))+import Fusion.Plugin.Types (Fuse(..))+import Streamly.Internal.Data.Fold.Type (Fold(..))+import Streamly.Internal.Data.Tuple.Strict (Tuple'(..))++import qualified Streamly.Internal.Data.Fold.Type as FL++import Prelude hiding+       (any, all, take, takeWhile, sequence, concatMap, maybe, either, span)+import Streamly.Internal.Data.Parser.ParserD.Tee+import Streamly.Internal.Data.Parser.ParserD.Type++--+-- $setup+-- >>> :m+-- >>> import Prelude hiding ()+-- >>> import qualified Streamly.Prelude as Stream+-- >>> import qualified Streamly.Internal.Data.Stream.IsStream as Stream+-- >>> import qualified Streamly.Data.Fold as Fold+-- >>> import qualified Streamly.Internal.Data.Parser as Parser++-------------------------------------------------------------------------------+-- Upgrade folds to parses+-------------------------------------------------------------------------------+--+-- | See 'Streamly.Internal.Data.Parser.fromFold'.+--+-- /Pre-release/+--+{-# INLINE fromFold #-}+fromFold :: Monad m => Fold m a b -> Parser m a b+fromFold (Fold fstep finitial fextract) = Parser step initial fextract++    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++-------------------------------------------------------------------------------+-- Failing Parsers+-------------------------------------------------------------------------------++-- | See 'Streamly.Internal.Data.Parser.peek'.+--+-- /Pre-release/+--+{-# INLINABLE peek #-}+peek :: MonadThrow m => Parser m a a+peek = Parser step initial extract++    where++    initial = return $ IPartial ()++    step () a = return $ Done 1 a++    extract () = throwM $ ParseError "peek: end of input"++-- | See 'Streamly.Internal.Data.Parser.eof'.+--+-- /Pre-release/+--+{-# INLINABLE eof #-}+eof :: Monad m => Parser m a ()+eof = Parser step initial return++    where++    initial = return $ IPartial ()++    step () _ = return $ Error "eof: not at end of input"++-- | See 'Streamly.Internal.Data.Parser.satisfy'.+--+-- /Pre-release/+--+{-# INLINE satisfy #-}+satisfy :: MonadThrow m => (a -> Bool) -> Parser m a a+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 _ = throwM $ ParseError "satisfy: end of input"++-- | See 'Streamly.Internal.Data.Parser.maybe'.+--+-- /Pre-release/+--+{-# INLINE maybe #-}+maybe :: MonadThrow m => (a -> Maybe b) -> Parser m a b+maybe parser = Parser step initial extract++    where++    initial = return $ IPartial ()++    step () a = return $+        case parser a of+            Just b -> Done 0 b+            Nothing -> Error "maybe: predicate failed"++    extract _ = throwM $ ParseError "maybe: end of input"++-- | See 'Streamly.Internal.Data.Parser.either'.+--+-- /Pre-release/+--+{-# INLINE either #-}+either :: MonadThrow m => (a -> Either String b) -> Parser m a b+either parser = Parser step initial extract++    where++    initial = return $ IPartial ()++    step () a = return $+        case parser a of+            Right b -> Done 0 b+            Left err -> Error $ "either: " ++ err++    extract _ = throwM $ ParseError "either: end of input"++-------------------------------------------------------------------------------+-- Taking elements+-------------------------------------------------------------------------------++-- | See 'Streamly.Internal.Data.Parser.takeBetween'.+--+-- /Pre-release/+--+{-# INLINE takeBetween #-}+takeBetween :: MonadCatch m => Int -> Int -> Fold m a b -> Parser m a b+takeBetween low high (Fold fstep finitial fextract) =++    Parser step initial extract++    where++    initial = do+        res <- finitial+        return $ case res of+            FL.Partial s -> IPartial $ Tuple' 0 s+            FL.Done b ->+                if low <= 0+                then IDone b+                else IError+                         $ "takeBetween: the collecting fold terminated without"+                             ++ " consuming any elements"+                             ++ " minimum" ++ show low ++ " elements needed"++    step (Tuple' i s) a+        | low > high =+            throwM+                $ ParseError+                $ "takeBetween: lower bound - " ++ show low+                    ++ " is greater than higher bound - " ++ show high+        | high <= 0 = Done 1 <$> fextract s+        | i1 < low = do+            res <- fstep s a+            return+                $ case res of+                    FL.Partial s1 -> Continue 0 $ Tuple' i1 s1+                    FL.Done _ ->+                        Error+                            $ "takeBetween: the collecting fold terminated after"+                                ++ " consuming" ++ show i1 ++ " elements"+                                ++ " minimum" ++ show low ++ " elements needed"+        | otherwise = do+            res <- fstep s a+            case res of+                FL.Partial s1 ->+                    if i1 >= high+                    then Done 0 <$> fextract s1+                    else return $ Partial 0 $ Tuple' i1 s1+                FL.Done b -> return $ Done 0 b++        where++        i1 = i + 1++    extract (Tuple' i s)+        | i >= low && i <= high = fextract s+        | otherwise = throwM $ ParseError err++        where++        err =+               "takeBetween: Expecting alteast " ++ show low+            ++ " elements, got " ++ show i++-- | See 'Streamly.Internal.Data.Parser.takeEQ'.+--+-- /Pre-release/+--+{-# INLINE takeEQ #-}+takeEQ :: MonadThrow m => Int -> Fold m a b -> Parser m a b+takeEQ n (Fold fstep finitial fextract) = Parser step initial extract++    where++    cnt = max n 0++    initial = do+        res <- finitial+        return $ case res of+            FL.Partial s -> IPartial $ Tuple' 0 s+            FL.Done b ->+                if cnt == 0+                then IDone b+                else IError+                         $ "takeEQ: Expecting exactly " ++ show cnt+                             ++ " elements, fold terminated without"+                             ++ " consuming any elements"++    step (Tuple' i r) a+        | i1 < cnt = do+            res <- fstep r a+            return+                $ case res of+                    FL.Partial s -> Continue 0 $ Tuple' i1 s+                    FL.Done _ ->+                        Error+                            $ "takeEQ: Expecting exactly " ++ show cnt+                                ++ " elements, fold terminated on " ++ show i1+        | i1 == cnt = do+            res <- fstep r a+            Done 0+                <$> case res of+                        FL.Partial s -> fextract s+                        FL.Done b -> return b+        -- XXX we should not reach here when initial returns Step type+        -- reachable only when n == 0+        | otherwise = Done 1 <$> fextract r++        where++        i1 = i + 1++    extract (Tuple' i r)+        | i == 0 && cnt == 0 = fextract r+        | otherwise =+            throwM+                $ ParseError+                $ "takeEQ: Expecting exactly " ++ show cnt+                    ++ " elements, input terminated on " ++ show i++-- | See 'Streamly.Internal.Data.Parser.takeGE'.+--+-- /Pre-release/+--+{-# INLINE takeGE #-}+takeGE :: MonadThrow m => Int -> Fold m a b -> Parser m a b+takeGE n (Fold fstep finitial fextract) = Parser step initial extract++    where++    cnt = max n 0+    initial = do+        res <- finitial+        return $ case res of+            FL.Partial s -> IPartial $ Tuple' 0 s+            FL.Done b ->+                if cnt == 0+                then IDone b+                else IError+                         $ "takeGE: Expecting at least " ++ show cnt+                             ++ " elements, fold terminated without"+                             ++ " consuming any elements"++    step (Tuple' i r) a+        | i1 < cnt = do+            res <- fstep r a+            return+                $ case res of+                      FL.Partial s -> Continue 0 $ Tuple' i1 s+                      FL.Done _ ->+                        Error+                            $ "takeGE: Expecting at least " ++ show cnt+                                ++ " elements, fold terminated on " ++ show i1+        | otherwise = do+            res <- fstep r a+            return+                $ case res of+                      FL.Partial s -> Partial 0 $ Tuple' i1 s+                      FL.Done b -> Done 0 b++        where++        i1 = i + 1++    extract (Tuple' i r)+        | i >= cnt = fextract r+        | otherwise =+            throwM+                $ ParseError+                $ "takeGE: Expecting at least " ++ show cnt+                    ++ " elements, input terminated on " ++ show i++-- | See 'Streamly.Internal.Data.Parser.takeWhile'.+--+-- /Pre-release/+--+{-# INLINE takeWhile #-}+takeWhile :: Monad m => (a -> Bool) -> Fold m a b -> Parser m a b+takeWhile predicate (Fold fstep finitial fextract) =+    Parser step initial fextract++    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++-- | See 'Streamly.Internal.Data.Parser.takeWhile1'.+--+-- /Pre-release/+--+{-# INLINE takeWhile1 #-}+takeWhile1 :: MonadThrow m => (a -> Bool) -> Fold m a b -> Parser m a b+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 _) = throwM $ ParseError "takeWhile1: end of input"+    extract (Right s) = fextract s++-- | See 'Streamly.Internal.Data.Parser.sliceSepByP'.+--+-- /Pre-release/+--+sliceSepByP :: MonadCatch m =>+    (a -> Bool) -> Parser m a b -> Parser m a b+sliceSepByP cond (Parser pstep pinitial pextract) =++    Parser step initial pextract++    where++    initial = pinitial++    step s a =+        if cond a+        then do+            res <- pextract s+            return $ Done 0 res+        else pstep s a++-- | See 'Streamly.Internal.Data.Parser.sliceBeginWith'.+--+-- /Pre-release/+--+data SliceBeginWithState s = Left' s | Right' s++{-# INLINE sliceBeginWith #-}+sliceBeginWith :: Monad m => (a -> Bool) -> Fold m a b -> Parser m a b+sliceBeginWith 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 "sliceBeginWith : bad finitial"++    {-# 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 error $ "sliceBeginWith : slice begins with an element which "+                        ++ "fails the predicate"+    step (Right' s) a =+        if not (cond a)+        then process s a+        else Done 1 <$> fextract s++    extract (Left' s) = fextract s+    extract (Right' s) = fextract s++data WordByState s b = WBLeft !s | WBWord !s | WBRight !b++-- | See 'Streamly.Internal.Data.Parser.wordBy'.+--+--+{-# INLINE wordBy #-}+wordBy :: Monad m => (a -> Bool) -> Fold m a b -> Parser m a 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) = fextract s+    extract (WBWord s) = fextract s+    extract (WBRight b) = return b++{-# ANN type GroupByState Fuse #-}+data GroupByState a s+    = GroupByInit !s+    | GroupByGrouping !a !s++-- | See 'Streamly.Internal.Data.Parser.groupBy'.+--+{-# INLINE groupBy #-}+groupBy :: Monad m => (a -> a -> Bool) -> Fold m a b -> Parser m a 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) = fextract s+    extract (GroupByGrouping _ s) = fextract s++-- | See 'Streamly.Internal.Data.Parser.groupByRolling'.+--+{-# INLINE groupByRolling #-}+groupByRolling :: Monad m => (a -> a -> Bool) -> Fold m a b -> Parser m a 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) = fextract s+    extract (GroupByGrouping _ s) = fextract s++-- XXX use an Unfold instead of a list?+-- XXX custom combinators for matching list, array and stream?+--+-- | See 'Streamly.Internal.Data.Parser.eqBy'.+--+-- /Pre-release/+--+{-# INLINE eqBy #-}+eqBy :: MonadThrow m => (a -> a -> Bool) -> [a] -> Parser m a ()+eqBy cmp str = Parser step initial extract++    where++    initial = return $ IPartial str++    step [] _ = return $ Done 0 ()+    step [x] a =+        return+            $ if x `cmp` a+              then Done 0 ()+              else Error "eqBy: failed, yet to match the last element"+    step (x:xs) a =+        return+            $ if x `cmp` a+              then Continue 0 xs+              else Error+                       $ "eqBy: failed, yet to match "+                       ++ show (length xs + 1) ++ " elements"++    extract xs =+        throwM+            $ ParseError+            $ "eqBy: end of input, yet to match "+            ++ show (length xs) ++ " elements"++--------------------------------------------------------------------------------+--- 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 m a (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 m a (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 m a (b, c)+spanByRolling eq f1 f2 =+    noErrorUnsafeSplitWith (,) (groupByRolling eq f1) (fromFold f2)++-------------------------------------------------------------------------------+-- nested parsers+-------------------------------------------------------------------------------++-- | See 'Streamly.Internal.Data.Parser.lookahead'.+--+-- /Pre-release/+--+{-# INLINE lookAhead #-}+lookAhead :: MonadThrow m => Parser m a b -> Parser m a b+lookAhead (Parser step1 initial1 _) = Parser step initial extract++    where++    initial = do+        res <- initial1+        return $ case res of+            IPartial s -> IPartial (Tuple' 0 s)+            IDone b -> IDone b+            IError e -> IError e++    step (Tuple' cnt st) a = do+        r <- step1 st a+        let cnt1 = cnt + 1+        return+            $ case r of+                  Partial n s -> Continue n (Tuple' (cnt1 - n) s)+                  Continue n s -> Continue n (Tuple' (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' n _) =+        throwM+            $ ParseError+            $ "lookAhead: end of input after consuming "+            ++ show n ++ " elements"++-------------------------------------------------------------------------------+-- Interleaving+-------------------------------------------------------------------------------+--+-- | See 'Streamly.Internal.Data.Parser.deintercalate'.+--+-- /Unimplemented/+--+{-# INLINE deintercalate #-}+deintercalate ::+    -- Monad m =>+       Fold m a y -> Parser m x a+    -> Fold m b z -> Parser m x b+    -> Parser m x (y, z)+deintercalate = undefined++-------------------------------------------------------------------------------+-- Sequential Collection+-------------------------------------------------------------------------------+--+-- | See 'Streamly.Internal.Data.Parser.sequence'.+--+-- /Unimplemented/+--+{-# INLINE sequence #-}+sequence ::+    -- Foldable t =>+    Fold m b c -> t (Parser m a b) -> Parser m a c+sequence _f _p = undefined++-------------------------------------------------------------------------------+-- Alternative Collection+-------------------------------------------------------------------------------+--+-- | See 'Streamly.Internal.Data.Parser.choice'.+--+-- /Unimplemented/+--+{-# INLINE choice #-}+choice ::+    -- Foldable t =>+    t (Parser m a b) -> Parser m a b+choice _ps = undefined++-------------------------------------------------------------------------------+-- Sequential Repetition+-------------------------------------------------------------------------------+--+-- | See 'Streamly.Internal.Data.Parser.many'.+--+-- /Pre-release/+--+{-# INLINE many #-}+many :: MonadCatch m => Parser m a b -> Fold m b c -> Parser m a c+many = splitMany+-- many = countBetween 0 maxBound++-- | See 'Streamly.Internal.Data.Parser.some'.+--+-- /Pre-release/+--+{-# INLINE some #-}+some :: MonadCatch m => Parser m a b -> Fold m b c -> Parser m a c+some = splitSome+-- some f p = many (takeGE 1 f) p+-- many = countBetween 1 maxBound++-- | See 'Streamly.Internal.Data.Parser.countBetween'.+--+-- /Unimplemented/+--+{-# INLINE countBetween #-}+countBetween ::+    -- MonadCatch m =>+    Int -> Int -> Parser m a b -> Fold m b c -> Parser m a c+countBetween _m _n _p = undefined+-- countBetween m n p f = many (takeBetween m n f) p++-- | See 'Streamly.Internal.Data.Parser.count'.+--+-- /Unimplemented/+--+{-# INLINE count #-}+count ::+    -- MonadCatch m =>+    Int -> Parser m a b -> Fold m b c -> Parser m a c+count n = countBetween n n+-- count n f p = many (takeEQ n f) p++data ManyTillState fs sr sl+    = ManyTillR Int fs sr+    | ManyTillL Int fs sl++-- | See 'Streamly.Internal.Data.Parser.manyTill'.+--+-- /Pre-release/+--+{-# INLINE manyTill #-}+manyTill :: MonadCatch m+    => Fold m b c -> Parser m a b -> Parser m a x -> Parser m a c+manyTill (Fold fstep finitial fextract)+         (Parser stepL initialL extractL)+         (Parser stepR initialR _) =+    Parser step initial extract++    where++    -- Caution: Mutual recursion++    -- Don't inline this+    scrutL fs p c d e = do+        resL <- initialL+        case resL of+            IPartial sl -> return $ c (ManyTillL 0 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++    {-# INLINE scrutR #-}+    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+                assert (cnt + 1 - n >= 0) (return ())+                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 0 fs sl)+                    IDone bl -> do+                        fr <- fstep fs bl+                        let cnt1 = cnt + 1+                            p = Partial cnt+                            c = Continue cnt+                            d = Done cnt+                        case fr of+                            FL.Partial fs1 -> scrutR fs1 p c d Error+                            FL.Done fb -> return $ Done cnt1 fb+                    IError err -> return $ Error err+    -- XXX the cnt is being used only by the assert+    step (ManyTillL cnt fs st) a = do+        r <- stepL st a+        case r of+            Partial n s -> return $ Partial n (ManyTillL 0 fs s)+            Continue n s -> do+                assert (cnt + 1 - n >= 0) (return ())+                return $ Continue n (ManyTillL (cnt + 1 - n) 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 >>= fstep fs+        case res of+            FL.Partial s -> fextract s+            FL.Done b -> return b+    extract (ManyTillR _ fs _) = fextract fs
+ src/Streamly/Internal/Data/Parser/ParserD/Tee.hs view
@@ -0,0 +1,613 @@+{-# 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 m x a -> Parser m x b -> Parser m x 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 m x a -> Parser m x b -> Parser m x 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 m x a -> Parser m x b -> Parser m x 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 m x a -> Parser m x a -> Parser m x 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 m x a -> Parser m x a -> Parser m x 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"
+ src/Streamly/Internal/Data/Parser/ParserD/Type.hs view
@@ -0,0 +1,1098 @@+#include "inline.hs"++-- |+-- 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 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.+--+-- = 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).++module Streamly.Internal.Data.Parser.ParserD.Type+    (+      Initial (..)+    , Step (..)+    , Parser (..)+    , ParseError (..)+    , rmapM++    , fromPure+    , fromEffect+    , serialWith+    , split_++    , die+    , dieM+    , splitSome -- parseSome?+    , splitMany -- parseMany?+    , splitManyPost+    , alt+    , concatMap++    , noErrorUnsafeSplit_+    , noErrorUnsafeSplitWith+    , noErrorUnsafeConcatMap+    )+where++import Control.Applicative (Alternative(..), liftA2)+import Control.Exception (assert, Exception(..))+import Control.Monad (MonadPlus(..), (>=>))+import Control.Monad.Catch (MonadCatch, try, throwM, MonadThrow)+import Data.Bifunctor (Bifunctor(..))+import Fusion.Plugin.Types (Fuse(..))+import Streamly.Internal.Data.Fold.Type (Fold(..), toList)+import Streamly.Internal.Data.Tuple.Strict (Tuple3'(..))++import qualified Streamly.Internal.Data.Fold.Type as FL++import Prelude hiding (concatMap)+--+-- $setup+-- >>> :m+-- >>> import Control.Applicative ((<|>))+-- >>> import Prelude hiding (concatMap)+-- >>> import qualified Streamly.Prelude as Stream+-- >>> import qualified Streamly.Internal.Data.Stream.IsStream as Stream (parse)+-- >>> import qualified Streamly.Internal.Data.Parser as Parser++-- | 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++    {-# INLINE first #-}+    first f (IPartial a) = IPartial (f a)+    first _ (IDone x) = IDone x+    first _ (IError err) = IError err++    {-# INLINE second #-}+    second _ (IPartial x) = IPartial x+    second f (IDone a) = IDone (f a)+    second _ (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++-- | 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 result with an optional backtrack request.+    --+    -- @Partial count state@ means a partial result is available which+    -- can be extracted successfully, @state@ is the opaque state of the+    -- parser to be supplied to the next invocation of the step operation.+    -- The current input position is reset to @count@ elements back and any+    -- input before that is dropped from the backtrack buffer.++    | Continue Int s+    -- ^ Need more input with an optional backtrack request.+    --+    -- @Continue count state@ means the parser has consumed the current input+    -- but no new result is generated, @state@ is the next state of the parser.+    -- The current input is retained in the backtrack buffer and the input+    -- position is reset to @count@ elements back.++    | 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.++instance Functor (Step s) where+    {-# INLINE fmap #-}+    fmap _ (Partial n s) = Partial n s+    fmap _ (Continue n s) = Continue n s+    fmap f (Done n b) = Done n (f b)+    fmap _ (Error err) = 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. It may result in an error or an output value.+--+-- /Pre-release/+--+data Parser m a b =+    forall s. Parser (s -> a -> m (Step s b)) (m (Initial s b)) (s -> m b)++-- | This exception is used for two purposes:+--+-- * When a parser ultimately fails, the user of the parser is intimated via+--    this exception.+-- * When the "extract" function of a parser needs to throw an error.+--+-- /Pre-release/+--+newtype ParseError = ParseError String+    deriving Show++instance Exception ParseError where+    displayException (ParseError err) = err++instance Functor m => Functor (Parser m a) where+    {-# INLINE fmap #-}+    fmap f (Parser step1 initial1 extract) =+        Parser step initial (fmap2 f extract)++        where++        initial = fmap2 f initial1+        step s b = fmap2 f (step1 s b)+        fmap2 g = fmap (fmap g)++------------------------------------------------------------------------------+-- Mapping on the output+------------------------------------------------------------------------------++-- | Map a monadic function on the output of a parser.+--+-- /Pre-release/+{-# INLINE rmapM #-}+rmapM :: Monad m => (b -> m c) -> Parser m a b -> Parser m a c+rmapM f (Parser step initial extract) = Parser step1 initial1 (extract >=> f)++    where++    initial1 = do+        res <- initial+        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++-- | See 'Streamly.Internal.Data.Parser.fromPure'.+--+-- /Pre-release/+--+{-# INLINE_NORMAL fromPure #-}+fromPure :: Monad m => b -> Parser m a b+fromPure b = Parser undefined (pure $ IDone b) undefined++-- | See 'Streamly.Internal.Data.Parser.fromEffect'.+--+-- /Pre-release/+--+{-# INLINE fromEffect #-}+fromEffect :: Monad m => m b -> Parser m a b+fromEffect b = Parser undefined (IDone <$> b) undefined++-------------------------------------------------------------------------------+-- Sequential applicative+-------------------------------------------------------------------------------++{-# ANN type SeqParseState Fuse #-}+data SeqParseState sl f sr = SeqParseL sl | SeqParseR f sr++-- | See 'Streamly.Internal.Data.Parser.serialWith'.+--+-- Note: this implementation of serialWith 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.+--+-- /Pre-release/+--+{-# INLINE serialWith #-}+serialWith :: MonadThrow m+    => (a -> b -> c) -> Parser m x a -> Parser m x b -> Parser m x c+serialWith func (Parser stepL initialL extractL)+               (Parser stepR initialR extractR) =+    Parser step initial extract++    where++    initial = do+        resL <- initialL+        case resL of+            IPartial sl -> return $ IPartial $ SeqParseL sl+            IDone bl -> do+                resR <- initialR+                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 =+      (\resL initR ->+        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 -> Continue n (SeqParseL s)+            Continue n s -> Continue n (SeqParseL s)+            Done n b ->+                case initR of+                   IPartial sr -> Continue n $ SeqParseR (func b) sr+                   IDone br -> Done n (func b br)+                   IError err -> Error err+            Error err -> Error err) <$> stepL st a <*> initialR++    step (SeqParseR f st) a =+        (\case+            Partial n s -> Partial n (SeqParseR f s)+            Continue n s -> Continue n (SeqParseR f s)+            Done n b -> Done n (f b)+            Error err -> Error err) <$> stepR st a++    extract (SeqParseR f sR) = fmap f (extractR sR)+    extract (SeqParseL sL) = do+        rL <- extractL sL+        res <- initialR+        case res of+            IPartial sR -> do+                rR <- extractR sR+                return $ func rL rR+            IDone rR -> return $ func rL rR+            IError err -> throwM $ ParseError err++-- | Works correctly only if the first parser is guaranteed to never fail.+{-# INLINE noErrorUnsafeSplitWith #-}+noErrorUnsafeSplitWith :: Monad m+    => (a -> b -> c) -> Parser m x a -> Parser m x b -> Parser m x c+noErrorUnsafeSplitWith func (Parser stepL initialL extractL)+               (Parser stepR initialR extractR) =+    Parser step initial extract++    where++    initial = do+        resL <- initialL+        case resL of+            IPartial sl -> return $ IPartial $ SeqParseL sl+            IDone bl -> do+                resR <- initialR+                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+        r <- stepL st a+        case r of+            -- Assume that the first 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 -> Error err+            Error err -> return $ Error err++    step (SeqParseR f st) a = do+        r <- stepR st a+        return $ case r of+            Partial n s -> Partial n (SeqParseR f s)+            Continue n s -> Continue n (SeqParseR f s)+            Done n b -> Done n (f b)+            Error err -> Error err++    extract (SeqParseR f sR) = fmap f (extractR sR)+    extract (SeqParseL sL) = do+        rL <- extractL sL+        res <- initialR+        case res of+            IPartial sR -> do+                rR <- extractR sR+                return $ func rL rR+            IDone rR -> return $ func rL rR+            IError err -> error $ "noErrorUnsafeSplitWith: cannot use a "+                ++ "failing parser. Parser failed with: " ++ err++{-# ANN type SeqAState Fuse #-}+data SeqAState sl sr = SeqAL sl | SeqAR sr++-- This turns out to be slightly faster than serialWith+-- | See 'Streamly.Internal.Data.Parser.split_'.+--+-- /Pre-release/+--+{-# INLINE split_ #-}+split_ :: MonadThrow m => Parser m x a -> Parser m x b -> Parser m x 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 $ case resR of+                    IPartial sr -> IPartial $ SeqAR sr+                    IDone br -> IDone 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 (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 =+        (\case+            Partial n s -> Partial n (SeqAR s)+            Continue n s -> Continue n (SeqAR s)+            Done n b -> Done n b+            Error err -> Error err) <$> stepR st a++    extract (SeqAR sR) = extractR sR+    extract (SeqAL sL) = do+        _ <- extractL sL+        res <- initialR+        case res of+            IPartial sR -> extractR sR+            IDone rR -> return rR+            IError err -> throwM $ ParseError err++{-# INLINE noErrorUnsafeSplit_ #-}+noErrorUnsafeSplit_ :: MonadThrow m => Parser m x a -> Parser m x b -> Parser m x b+noErrorUnsafeSplit_ (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 $ case resR of+                    IPartial sr -> IPartial $ SeqAR sr+                    IDone br -> IDone 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 (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 -> Error err+            Error err -> return $ Error err++    step (SeqAR st) a =+        (\case+            Partial n s -> Partial n (SeqAR s)+            Continue n s -> Continue n (SeqAR s)+            Done n b -> Done n b+            Error err -> Error err) <$> stepR st a++    extract (SeqAR sR) = extractR sR+    extract (SeqAL sL) = do+        _ <- extractL sL+        res <- initialR+        case res of+            IPartial sR -> extractR sR+            IDone rR -> return rR+            IError err -> throwM $ ParseError err++-- | 'Applicative' form of 'serialWith'.+instance MonadThrow m => Applicative (Parser m a) where+    {-# INLINE pure #-}+    pure = fromPure++    {-# INLINE (<*>) #-}+    (<*>) = serialWith id++    {-# INLINE (*>) #-}+    (*>) = split_++#if MIN_VERSION_base(4,10,0)+    {-# INLINE liftA2 #-}+    liftA2 f x = (<*>) (fmap f x)+#endif++-------------------------------------------------------------------------------+-- 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+--+-- | See 'Streamly.Internal.Data.Parser.alt'.+--+-- /Pre-release/+--+{-# INLINE alt #-}+alt :: Monad m => Parser m x a -> Parser m x a -> Parser m x 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.+    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+                assert (cnt + 1 - n >= 0) (return ())+                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) = extractR sR+    extract (AltParseL _ sL) = extractL sL++-- | See documentation of 'Streamly.Internal.Data.Parser.many'.+--+-- /Pre-release/+--+{-# INLINE splitMany #-}+splitMany :: MonadCatch m =>  Parser m a b -> Fold m b c -> Parser m a 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.++    {-# INLINE handleCollect #-}+    handleCollect partial done fres =+        case fres of+            FL.Partial fs -> do+                pres <- initial1+                case pres of+                    IPartial ps -> return $ partial $ Tuple3' ps 0 fs+                    IDone pb ->+                        runCollectorWith (handleCollect partial done) fs pb+                    IError _ -> done <$> fextract fs+            FL.Done fb -> return $ done fb++    -- Do not inline this+    runCollectorWith cont fs pb = fstep fs pb >>= cont++    initial = finitial >>= handleCollect IPartial IDone++    {-# INLINE step #-}+    step (Tuple3' st cnt fs) a = do+        r <- step1 st a+        let cnt1 = cnt + 1+        case r of+            Partial n s -> do+                assert (cnt1 - n >= 0) (return ())+                return $ Continue n (Tuple3' s (cnt1 - n) fs)+            Continue n s -> do+                assert (cnt1 - n >= 0) (return ())+                return $ Continue n (Tuple3' s (cnt1 - n) fs)+            Done n b -> do+                assert (cnt1 - n >= 0) (return ())+                fstep fs b >>= handleCollect (Partial n) (Done n)+            Error _ -> do+                xs <- fextract fs+                return $ Done cnt1 xs++    extract (Tuple3' _ 0 fs) = fextract fs+    -- XXX The "try" may impact performance if this parser is used as a scan+    extract (Tuple3' s _ fs) = do+        r <- try $ extract1 s+        case r of+            Left (_ :: ParseError) -> fextract fs+            Right b -> do+                fs1 <- fstep fs b+                case fs1 of+                    FL.Partial s1 -> fextract s1+                    FL.Done b1 -> return b1++-- | Like splitMany, but inner fold emits an output at the end even if no input+-- is received.+--+-- /Internal/+--+{-# INLINE splitManyPost #-}+splitManyPost :: MonadCatch m =>  Parser m a b -> Fold m b c -> Parser m a 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.++    {-# INLINE handleCollect #-}+    handleCollect partial done fres =+        case fres of+            FL.Partial fs -> do+                pres <- initial1+                case pres of+                    IPartial ps -> return $ partial $ Tuple3' ps 0 fs+                    IDone pb ->+                        runCollectorWith (handleCollect partial done) fs pb+                    IError _ -> done <$> fextract fs+            FL.Done fb -> return $ done fb++    -- Do not inline this+    runCollectorWith cont fs pb = fstep fs pb >>= cont++    initial = finitial >>= handleCollect IPartial IDone++    {-# INLINE step #-}+    step (Tuple3' st cnt fs) a = do+        r <- step1 st a+        let cnt1 = cnt + 1+        case r of+            Partial n s -> do+                assert (cnt1 - n >= 0) (return ())+                return $ Continue n (Tuple3' s (cnt1 - n) fs)+            Continue n s -> do+                assert (cnt1 - n >= 0) (return ())+                return $ Continue n (Tuple3' s (cnt1 - n) fs)+            Done n b -> do+                assert (cnt1 - n >= 0) (return ())+                fstep fs b >>= handleCollect (Partial n) (Done n)+            Error _ -> do+                xs <- fextract fs+                return $ Done cnt1 xs++    -- XXX The "try" may impact performance if this parser is used as a scan+    extract (Tuple3' s _ fs) = do+        r <- try $ extract1 s+        case r of+            Left (_ :: ParseError) -> fextract fs+            Right b -> do+                fs1 <- fstep fs b+                case fs1 of+                    FL.Partial s1 -> fextract s1+                    FL.Done b1 -> return b1++-- | See documentation of 'Streamly.Internal.Data.Parser.some'.+--+-- /Pre-release/+--+{-# INLINE splitSome #-}+splitSome :: MonadCatch m => Parser m a b -> Fold m b c -> Parser m a 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.++    {-# INLINE handleCollect #-}+    handleCollect partial done fres =+        case fres of+            FL.Partial fs -> do+                pres <- initial1+                case pres of+                    IPartial ps -> return $ partial $ Tuple3' ps 0 $ Right fs+                    IDone pb ->+                        runCollectorWith (handleCollect partial done) fs pb+                    IError _ -> done <$> fextract fs+            FL.Done fb -> return $ done fb++    -- Do not inline this+    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 $ Tuple3' 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 (Tuple3' 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+                assert (cnt1 - n >= 0) (return ())+                return $ Continue n (Tuple3' s (cnt1 - n) (Left fs))+            Continue n s -> do+                assert (cnt1 - n >= 0) (return ())+                return $ Continue n (Tuple3' s (cnt1 - n) (Left fs))+            Done n b -> do+                assert (cnt1 - n >= 0) (return ())+                fstep fs b >>= handleCollect (Partial n) (Done n)+            Error err -> return $ Error err+    step (Tuple3' st cnt (Right fs)) a = do+        r <- step1 st a+        let cnt1 = cnt + 1+        case r of+            Partial n s -> do+                assert (cnt1 - n >= 0) (return ())+                return $ Partial n (Tuple3' s (cnt1 - n) (Right fs))+            Continue n s -> do+                assert (cnt1 - n >= 0) (return ())+                return $ Continue n (Tuple3' s (cnt1 - n) (Right fs))+            Done n b -> do+                assert (cnt1 - n >= 0) (return ())+                fstep fs b >>= handleCollect (Partial n) (Done n)+            Error _ -> Done cnt1 <$> fextract fs++    -- XXX The "try" may impact performance if this parser is used as a scan+    extract (Tuple3' s _ (Left fs)) = do+        b <- extract1 s+        fs1 <- fstep fs b+        case fs1 of+            FL.Partial s1 -> fextract s1+            FL.Done b1 -> return b1+    extract (Tuple3' s _ (Right fs)) = do+        r <- try $ extract1 s+        case r of+            Left (_ :: ParseError) -> fextract fs+            Right b -> do+                fs1 <- fstep fs b+                case fs1 of+                    FL.Partial s1 -> fextract s1+                    FL.Done b1 -> return b1++-- | See 'Streamly.Internal.Data.Parser.die'.+--+-- /Pre-release/+--+{-# INLINE_NORMAL die #-}+die :: MonadThrow m => String -> Parser m a b+die err = Parser undefined (pure (IError err)) undefined++-- | See 'Streamly.Internal.Data.Parser.dieM'.+--+-- /Pre-release/+--+{-# INLINE dieM #-}+dieM :: MonadThrow m => m String -> Parser m a 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.++-- | 'Alternative' instance using 'alt'.+--+-- 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]+-- 1+--+instance MonadCatch m => Alternative (Parser m a) 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 b)++-- | See 'Streamly.Internal.Data.Parser.concatMap'.+--+-- /Pre-release/+--+{-# INLINE concatMap #-}+concatMap :: MonadThrow m =>+    (b -> Parser m a c) -> Parser m a b -> Parser m a 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 (Parser _ initialR extractR) = do+        res <- initialR+        case res of+            IPartial s -> extractR s+            IDone b -> return b+            IError err -> throwM $ ParseError err++    extract (ConcatParseR _ s extractR) = extractR s+    extract (ConcatParseL sL) = extractL sL >>= extractP . func++{-# INLINE noErrorUnsafeConcatMap #-}+noErrorUnsafeConcatMap :: MonadThrow m =>+    (b -> Parser m a c) -> Parser m a b -> Parser m a 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 (Parser _ initialR extractR) = do+        res <- initialR+        case res of+            IPartial s -> extractR s+            IDone b -> return b+            IError err -> throwM $ ParseError err++    extract (ConcatParseR _ s extractR) = extractR s+    extract (ConcatParseL sL) = extractL sL >>= extractP . func++-- 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'.+--+instance MonadThrow m => Monad (Parser m a) where+    {-# INLINE return #-}+    return = pure++    {-# INLINE (>>=) #-}+    (>>=) = flip concatMap++    {-# INLINE (>>) #-}+    (>>) = (*>)++-- | See documentation of 'Streamly.Internal.Data.Parser.ParserK.Type.Parser'.+--+instance MonadCatch m => MonadPlus (Parser m a) where+    {-# INLINE mzero #-}+    mzero = die "mzero"++    {-# INLINE mplus #-}+    mplus = alt
+ src/Streamly/Internal/Data/Parser/ParserK/Type.hs view
@@ -0,0 +1,471 @@+#include "inline.hs"++-- |+-- 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, sequenceA,+-- Monad, sequence, and Alternative, choice operations compared to the+-- quadratic complexity of the corresponding direct style operations. However,+-- direct style operations allow fusion with ~10x better performance than CPS.+--+-- The direct style representation does not allow for recursive definitions of+-- "some" and "many" whereas CPS allows that.++module Streamly.Internal.Data.Parser.ParserK.Type+    (+      Parser (..)+    , fromPure+    , fromEffect+    , die++    -- * Conversion+    , toParserK+    , fromParserK+    )+where++import Control.Applicative (Alternative(..), liftA2)+import Control.Exception (assert, Exception(..))+import Control.Monad (MonadPlus(..), ap)+import Control.Monad.Catch (MonadCatch, MonadThrow(..), try)+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif+#if !(MIN_VERSION_base(4,10,0))+import Data.Semigroup ((<>))+#endif+import Streamly.Internal.Control.Exception++import qualified Streamly.Internal.Data.Parser.ParserD.Type as D++-- | The parse driver result. The driver may stop with a final result, pause+-- with a continuation to resume, or fail with an error.+--+-- /Pre-release/+--+data Driver m a r =+      Stop !Int r+      -- XXX we can use a "resume" and a "stop" continuations instead of Maybe.+      -- measure if that works any better.+    | Partial !Int (Maybe a -> m (Driver m a r))+    | Continue !Int (Maybe a -> m (Driver m a r))+    | Failed String++instance Functor m => Functor (Driver m a) where+    fmap f (Stop n r) = Stop n (f r)+    fmap f (Partial n yld) = Partial n (fmap (fmap f) . yld)+    fmap f (Continue n yld) = Continue n (fmap (fmap f) . yld)+    fmap _ (Failed e) = Failed e++-- The parser's result.+--+-- /Pre-release/+--+data Parse b =+      Done !Int !b      -- Done, no more input needed+    | Error !String     -- Failed++instance Functor Parse where+    fmap f (Done n b) = Done n (f b)+    fmap _ (Error e) = Error e++-- | A continuation passing style parser representation.+newtype Parser m a b = MkParser+    { runParser :: forall r.+           -- The number of elements that were not used by the previous+           -- consumer and should be carried forward.+           Int+           -- (nesting level, used elem count). Nesting level is increased+           -- whenever we enter an Alternative composition and decreased when+           -- it is done. The used element count is a count of elements+           -- consumed by the Alternative. If the Alternative fails we need to+           -- backtrack by this amount.+           --+           -- The nesting level is used in parseDToK to optimize the case when+           -- we are not in an alternative, in that case we do not need to+           -- maintain the element count for backtracking.+        -> (Int, Int)+           -- The first argument is the (nest level, used count) tuple as+           -- described above. The leftover element count is carried as part of+           -- 'Done' constructor of 'Parse'.+        -> ((Int, Int) -> Parse b -> m (Driver m a r))+        -> m (Driver m a r)+    }++-------------------------------------------------------------------------------+-- Convert direct style 'D.Parser' to CPS style 'Parser'+-------------------------------------------------------------------------------++-- XXX Unlike the direct style folds/parsers, the initial action in CPS parsers+-- is not performed when the fold is initialized. It is performed when the+-- first element is processed by the fold or if no elements are processed then+-- at the extraction. We should either make the direct folds like this or make+-- the CPS folds behavior also like the direct ones.+--+-- | Convert a direct style parser ('D.Parser') to a CPS style parser+-- ('Parser').+--+{-# INLINE_NORMAL parseDToK #-}+parseDToK+    :: MonadCatch m+    => (s -> a -> m (D.Step s b))+    -> m (D.Initial s b)+    -> (s -> m b)+    -> Int+    -> (Int, Int)+    -> ((Int, Int) -> Parse b -> m (Driver m a r))+    -> m (Driver m a r)++parseDToK pstep initial extract leftover (0, _) cont = do+    res <- initial+    case res of+        D.IPartial r -> return $ Continue leftover (parseCont (return r))+        D.IDone b -> cont (0,0) (Done 0 b)+        D.IError err -> cont (0,0) (Error err)++    where++    parseCont pst (Just x) = do+        r <- pst+        pRes <- pstep r x+        case pRes of+            D.Done n b -> cont (0,0) (Done n b)+            D.Error err -> cont (0,0) (Error err)+            D.Partial n pst1 -> return $ Partial n (parseCont (return pst1))+            D.Continue n pst1 -> return $ Continue n (parseCont (return pst1))++    parseCont acc Nothing = do+        pst <- acc+        r <- try $ extract pst+        case r of+            Left (e :: D.ParseError) -> cont (0,0) (Error (displayException e))+            Right b -> cont (0,0) (Done 0 b)++parseDToK pstep initial extract leftover (level, count) cont = do+    res <- initial+    case res of+        D.IPartial r -> return $ Continue leftover (parseCont count (return r))+        D.IDone b -> cont (level,count) (Done 0 b)+        D.IError err -> cont (level,count) (Error err)++    where++    parseCont !cnt pst (Just x) = do+        let !cnt1 = cnt + 1+        r <- pst+        pRes <- pstep r x+        case pRes of+            D.Done n b -> do+                assert (n <= cnt1) (return ())+                cont (level, cnt1 - n) (Done n b)+            D.Error err ->+                cont (level, cnt1) (Error err)+            D.Partial n pst1 -> do+                assert (n <= cnt1) (return ())+                return $ Partial n (parseCont (cnt1 - n) (return pst1))+            D.Continue n pst1 -> do+                assert (n <= cnt1) (return ())+                return $ Continue n (parseCont (cnt1 - n) (return pst1))+    parseCont cnt acc Nothing = do+        pst <- acc+        r <- try $ extract pst+        let s = (level, cnt)+        case r of+            Left (e :: D.ParseError) -> cont s (Error (displayException e))+            Right b -> cont s (Done 0 b)++-- | Convert a direct style 'D.Parser' to a CPS style 'Parser'.+--+-- /Pre-release/+--+{-# INLINE_LATE toParserK #-}+toParserK :: MonadCatch m => D.Parser m a b -> Parser m a b+toParserK (D.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 => (Int, Int) -> Parse b -> m (Driver m a b)+parserDone (0,_) (Done n b) = return $ Stop n b+parserDone st (Done _ _) =+    error $ "Bug: fromParserK: inside alternative: " ++ show st+parserDone _ (Error e) = return $ Failed e++-- | When there is no more input to feed, extract the result from the Parser.+--+-- /Pre-release/+--+extractParse :: MonadThrow m => (Maybe a -> m (Driver m a b)) -> m b+extractParse cont = do+    r <- cont Nothing+    case r of+        Stop _ b -> return b+        Partial _ _ -> error "Bug: extractParse got Partial"+        Continue _ cont1 -> extractParse cont1+        Failed e -> throwM $ D.ParseError e++data FromParserK b c = FPKDone !Int !b | FPKCont c++-- | Convert a CPS style 'Parser' to a direct style 'D.Parser'.+--+-- "initial" returns a continuation which can be called one input at a time+-- using the "step" function.+--+-- /Pre-release/+--+{-# INLINE_LATE fromParserK #-}+fromParserK :: MonadThrow m => Parser m a b -> D.Parser m a b+fromParserK parser = D.Parser step initial extract++    where++    initial = do+        r <- runParser parser 0 (0,0) parserDone+        return $ case r of+            Stop n b -> D.IPartial $ FPKDone n b+            Failed e -> D.IError e+            Partial _ cont -> D.IPartial $ FPKCont cont -- XXX can we get this?+            Continue _ cont -> D.IPartial $ FPKCont cont++    -- Note, we can only reach FPKDone and FPKError from "initial". FPKCont+    -- always transitions to only FPKCont.  The input remains unconsumed in+    -- this case so we use "n + 1".+    step (FPKDone n b) _ = do+        assertM (n == 0)+        return $ D.Done (n + 1) b+    step (FPKCont cont) a = do+        r <- cont (Just a)+        return $ case r of+            Stop n b -> D.Done n b+            Failed e -> D.Error e+            Partial n cont1 -> D.Partial n (FPKCont cont1)+            Continue n cont1 -> D.Continue n (FPKCont cont1)++    -- Note, we can only reach FPKDone and FPKError from "initial".+    extract (FPKDone _ b) = return b+    extract (FPKCont cont) = extractParse cont++#ifndef DISABLE_FUSION+{-# RULES "fromParserK/toParserK fusion" [2]+    forall s. toParserK (fromParserK s) = s #-}+{-# RULES "toParserK/fromParserK fusion" [2]+    forall s. fromParserK (toParserK s) = s #-}+#endif++-------------------------------------------------------------------------------+-- Functor+-------------------------------------------------------------------------------++-- | Maps a function over the output of the parser.+--+instance Functor m => Functor (Parser m a) where+    {-# INLINE fmap #-}+    fmap f parser = MkParser $ \lo st yieldk ->+        let yld s res = yieldk s (fmap f res)+         in runParser parser lo st yld++-------------------------------------------------------------------------------+-- 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 -> Parser m a b+fromPure b = MkParser $ \lo st yieldk -> yieldk st (Done lo b)++-- | See 'Streamly.Internal.Data.Parser.fromEffect'.+--+-- /Pre-release/+--+{-# INLINE fromEffect #-}+fromEffect :: Monad m => m b -> Parser m a b+fromEffect eff = MkParser $ \lo st yieldk -> eff >>= \b -> yieldk st (Done lo b)++-- | 'Applicative' form of 'Streamly.Internal.Data.Parser.serialWith'. Note that+-- this operation does not fuse, use 'Streamly.Internal.Data.Parser.serialWith'+-- when fusion is important.+--+instance Monad m => Applicative (Parser m a) where+    {-# INLINE pure #-}+    pure = fromPure++    {-# INLINE (<*>) #-}+    (<*>) = ap++    {-# INLINE (*>) #-}+    m1 *> m2 = MkParser $ \lo st yieldk ->+        let yield1 s (Done n _) = runParser m2 n s yieldk+            yield1 s (Error e) = yieldk s (Error e)+        in runParser m1 lo st yield1++    {-# INLINE (<*) #-}+    m1 <* m2 = MkParser $ \lo st yieldk ->+        let yield1 s (Done n b) =+                let yield2 s1 (Done n1 _) = yieldk s1 (Done n1 b)+                    yield2 s1 (Error e) = yieldk s1 (Error e)+                in runParser m2 n s yield2+            yield1 s (Error e) = yieldk s (Error e)+        in runParser m1 lo st yield1++#if MIN_VERSION_base(4,10,0)+    {-# INLINE liftA2 #-}+    liftA2 f x = (<*>) (fmap f x)+#endif++-------------------------------------------------------------------------------+-- 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 -> Parser m a b+die err = MkParser (\_ st yieldk -> yieldk st (Error err))++-- | 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 m Char 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 m Char 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 (Parser m a) where+    {-# INLINE return #-}+    return = pure++    {-# INLINE (>>=) #-}+    m >>= k = MkParser $ \lo st yieldk ->+        let yield1 s (Done n b) = runParser (k b) n s yieldk+            yield1 s (Error e) = yieldk s (Error e)+         in runParser m lo st yield1++    {-# 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++#if MIN_VERSION_base(4,9,0)+instance Monad m => Fail.MonadFail (Parser m a) where+    {-# INLINE fail #-}+    fail = die+#endif++-------------------------------------------------------------------------------+-- 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 (Parser m a) where+    {-# INLINE empty #-}+    empty = die "empty"++    {-# INLINE (<|>) #-}+    m1 <|> m2 = MkParser $ \lo (level, _) yieldk ->+        let yield1 (0, _) _ = error "0 nest level in Alternative"+            yield1 (lvl, _) (Done n b) = yieldk (lvl - 1, 0) (Done n b)+            yield1 (lvl, cnt) (Error _) = runParser m2 cnt (lvl - 1, 0) yieldk+        in runParser m1 lo (level + 1, 0) yield1++    -- 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.+--+-- /Pre-release/+--+instance Monad m => MonadPlus (Parser m a) where+    {-# INLINE mzero #-}+    mzero = die "mzero"++    {-# INLINE mplus #-}+    mplus = (<|>)
− src/Streamly/Internal/Data/Parser/Tee.hs 
@@ -1,529 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}--#if __GLASGOW_HASKELL__ >= 800-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}-#endif--#include "inline.hs"---- |--- Module      : Streamly.Internal.Data.Parser.Tee--- Copyright   : (c) 2020 Composewell Technologies--- License     : BSD3--- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC------ Parallel parsers. Distributing the input to multiple parsers at the same--- time.------ For simplicity, we are using code where a particular state is unreachable--- but it is not prevented by types.  Somehow uni-pattern match using "let"--- produces better optimized code compared to using @case@ match and using--- explicit error messages in unreachable cases.------ There seem to be no way to silence individual warnings so we use a global--- incomplete uni-pattern match warning suppression option for the file.--- Disabling the warning for other code as well  has the potential to mask off--- some legit warnings, therefore, we have segregated only the code that uses--- uni-pattern matches in this module.--module Streamly.Internal.Data.Parser.Tee-    (-    -- Parallel zipped-      teeWith-    , teeWithFst-    , teeWithMin--    -- Parallel alternatives-    , shortest-    , longest-    )-where--import Control.Exception (assert)-import Control.Monad.Catch (MonadCatch, try)-import Prelude-       hiding (any, all, takeWhile)--import Fusion.Plugin.Types (Fuse(..))-import Streamly.Internal.Data.Parser.Types (Parser(..), Step(..), ParseError)------------------------------------------------------------------------------------ Distribute input to two parsers and collect both results----------------------------------------------------------------------------------{-# ANN type StepState Fuse #-}-data StepState s a = StepState s | StepResult a---- XXX Use a Zipper structure for buffering?------ | 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---- XXX: With the current "Step" semantics, it is hard to write, and not sure--- how useful, an efficient teeWith that returns a correct unused input count.------ XXX Teeing a parser with a Fold could be more useful and simpler to--- implement. A fold never fails or backtracks so we do not need to buffer the--- input for the fold. It can be useful in, for example, maintaining the line--- and column number position to report for errors. We can always have the--- line/column fold running in parallel with the main parser, whenever an error--- occurs we can zip the error with the context fold.------ | @teeWith f p1 p2@ distributes its input to both @p1@ and @p2@ until both--- of them succeed or fail and combines their output using @f@. The parser--- succeeds if both the parsers succeed.------ /Internal/----{-# INLINE teeWith #-}-teeWith :: Monad m-    => (a -> b -> c) -> Parser m x a -> Parser m x b -> Parser m x c-teeWith zf (Parser stepL initialL extractL) (Parser stepR initialR extractR) =-    Parser step initial extract--    where--    {-# INLINE_LATE initial #-}-    initial = do-        sL <- initialL-        sR <- initialR-        return $ TeePair ([], StepState sL, [], []) ([], StepState sR, [], [])--    {-# 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-            Yield n s ->-                let state = (Prelude.take n buf1, StepState s, inp11, inp21)-                 in assert (n <= length buf1) (return (state, Yld n))-            Stop n b ->-                let state = (Prelude.take n buf1, StepResult b, inp11, inp21)-                 in assert (n <= length buf1) (return (state, Stp n))-            -- Skip 0 s -> (buf1, Right s, inp11, inp21)-            Skip 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) -> Yield (min n1 n2) next-            (Yld n1, Stp n2) -> Yield (min n1 n2) next-            (Stp n1, Yld n2) -> Yield (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 Stop (min n1 n2) (zf rL rR)-            (Err err, _) -> Error err-            (_, Err err) -> Error err-            _ -> Skip 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 -> Yield n next-            Stp n ->-                let (_, StepResult rL, _, _) = l-                 in Stop n (zf rL rR)-            Skp -> Skip 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 -> Yield n next-            Stp n ->-                let (_, StepResult rR, _, _) = r-                 in Stop n (zf rL rR)-            Skp -> Skip 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---- | Like 'teeWith' but ends parsing and zips the results, if available,--- whenever the first parser ends.------ /Internal/----{-# INLINE teeWithFst #-}-teeWithFst :: Monad m-    => (a -> b -> c) -> Parser m x a -> Parser m x b -> Parser m x c-teeWithFst zf (Parser stepL initialL extractL)-              (Parser stepR initialR extractR) =-    Parser step initial extract--    where--    {-# INLINE_LATE initial #-}-    initial = do-        sL <- initialL-        sR <- initialR-        return $ TeePair ([], StepState sL, [], []) ([], StepState sR, [], [])--    {-# 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-            Yield n s ->-                let state = (Prelude.take n buf1, StepState s, inp11, inp21)-                 in assert (n <= length buf1) (return (state, Yld n))-            Stop n b ->-                let state = (Prelude.take n buf1, StepResult b, inp11, inp21)-                 in assert (n <= length buf1) (return (state, Stp n))-            -- Skip 0 s -> (buf1, Right s, inp11, inp21)-            Skip 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 $ Stop n1 (zf rL rR)-            (Stp n1, Yld _) ->-                let (_, StepResult rL, _, _) = l-                    (_, StepState  ssR, _, _) = r-                 in do-                    rR <- extractR ssR-                    return $ Stop n1 (zf rL rR)-            (Yld n1, Yld n2) -> return $ Yield (min n1 n2) next-            (Yld n1, Stp n2) -> return $ Yield (min n1 n2) next-            (Err err, _) -> return $ Error err-            (_, Err err) -> return $ Error err-            _ -> return $ Skip 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 -> Yield n next-            Stp n ->-                let (_, StepResult rL, _, _) = l-                 in Stop n (zf rL rR)-            Skp -> Skip 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"---- | Like 'teeWith' but ends parsing and zips the results, if available,--- whenever any of the parsers ends or fails.------ /Unimplemented/----{-# INLINE teeWithMin #-}-teeWithMin ::-    -- Monad m =>-    (a -> b -> c) -> Parser m x a -> Parser m x b -> Parser m x c-teeWithMin = undefined------------------------------------------------------------------------------------ Distribute input to two parsers and choose one result------------------------------------------------------------------------------------ | Shortest alternative. Apply both parsers in parallel but choose the result--- from the one which consumed least input i.e. take the shortest succeeding--- parse.------ /Internal/----{-# INLINE shortest #-}-shortest :: Monad m => Parser m x a -> Parser m x a -> Parser m x a-shortest (Parser stepL initialL extractL) (Parser stepR initialR _) =-    Parser step initial extract--    where--    {-# INLINE_LATE initial #-}-    initial = do-        sL <- initialL-        sR <- initialR-        return $ TeePair ([], StepState sL, [], []) ([], StepState sR, [], [])--    {-# 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-            Yield n s ->-                let state = (Prelude.take n buf1, StepState s, inp11, inp21)-                 in assert (n <= length buf1) (return (state, Yld n))-            Stop n b ->-                let state = (Prelude.take n buf1, StepResult b, inp11, inp21)-                 in assert (n <= length buf1) (return (state, Stp n))-            -- Skip 0 s -> (buf1, Right s, inp11, inp21)-            Skip 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 Stop n1 rL-            (_, Stp n2) ->-                let (_, StepResult rR, _, _) = r-                 in Stop n2 rR-            (Yld n1, Yld n2) -> Yield (min n1 n2) next-            (Err err, _) -> Error err-            (_, Err err) -> Error err-            _ -> Skip 0 next--    step _ _ = undefined--    {-# INLINE_LATE extract #-}-    extract st =-        case st of-            TeePair (_, StepState sL, _, _) _ -> extractL sL-            _ -> error "unreachable"---- | Longest alternative. Apply both parsers in parallel but choose the result--- from the one which consumed more input i.e. take the longest succeeding--- parse.------ /Internal/----{-# INLINE longest #-}-longest :: MonadCatch m => Parser m x a -> Parser m x a -> Parser m x a-longest (Parser stepL initialL extractL) (Parser stepR initialR extractR) =-    Parser step initial extract--    where--    {-# INLINE_LATE initial #-}-    initial = do-        sL <- initialL-        sR <- initialR-        return $ TeePair ([], StepState sL, [], []) ([], StepState sR, [], [])--    {-# 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-            Yield n s ->-                let state = (Prelude.take n buf1, StepState s, inp11, inp21)-                 in assert (n <= length buf1) (return (state, Yld n))-            Stop n b ->-                let state = (Prelude.take n buf1, StepResult b, inp11, inp21)-                 in assert (n <= length buf1) (return (state, Stp n))-            -- Skip 0 s -> (buf1, Right s, inp11, inp21)-            Skip 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) -> Yield (min n1 n2) next-            (Yld n1, Stp n2) -> Yield (min n1 n2) next-            (Stp n1, Yld n2) -> Yield (min n1 n2) next-            (Stp n1, Stp n2) ->-                let (_, StepResult rL, _, _) = l-                    (_, StepResult rR, _, _) = r-                 in Stop (max n1 n2) (if n1 >= n2 then rL else rR)-            (Err err, _) -> Error err-            (_, Err err) -> Error err-            _ -> Skip 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 -> Yield n next-            Stp n ->-                let (_, StepResult rL, _, _) = l-                 in Stop n rL-            Skp -> Skip 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 -> Yield n next-            Stp n ->-                let (_, StepResult rR, _, _) = r-                 in Stop n rR-            Skp -> Skip 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"
− src/Streamly/Internal/Data/Parser/Types.hs 
@@ -1,634 +0,0 @@-{-# LANGUAGE ExistentialQuantification          #-}-{-# LANGUAGE ScopedTypeVariables #-}---- |--- Module      : Streamly.Parser.Types--- Copyright   : (c) 2020 Composewell Technologies--- License     : BSD3--- 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.Types" 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. 'Skip': hold (buffer) the input or go back to a previous position in the stream--- 2. 'Yield', 'Stop': tell how much input is unconsumed--- 3. '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 @Skip 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 @Stop 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 @Yield@--- 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 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 @Stop@ for termination after the first @Yield@, 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 iterminate by either a--- 'Stop' 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.------ = 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).--module Streamly.Internal.Data.Parser.Types-    (-      Step (..)-    , Parser (..)-    , ParseError (..)--    , yield-    , yieldM-    , splitWith--    , die-    , dieM-    , splitSome-    , splitMany-    , alt-    )-where--import Control.Applicative (Alternative(..))-import Control.Exception (assert, Exception(..))-import Control.Monad (MonadPlus(..))-import Control.Monad.Catch (MonadCatch, try, throwM, MonadThrow)--import Fusion.Plugin.Types (Fuse(..))-import Streamly.Internal.Data.Fold (Fold(..), toList)-import Streamly.Internal.Data.Strict (Tuple3'(..))---- | The return type of a 'Parser' step.------ A parser is driven by a parse driver one step at a time, at any time the--- driver may @extract@ the result of the parser. The parser may ask the driver--- to backtrack at any point, therefore, the driver holds the input up to a--- point of no return in a backtracking buffer.  The buffer grows or shrinks--- based on the return values of the parser step execution.------ When a parser step is executed it generates a new intermediate state of the--- parse result along with a command to the driver. The command tells the--- driver whether to keep the input stream for a potential backtracking later--- on or drop it, and how much to keep. The constructors of 'Step' represent--- the commands to the driver.------ /Internal/----{-# ANN type Step Fuse #-}-data Step s b =-      Yield Int s-      -- ^ @Yield offset state@ indicates that the parser has yielded a new-      -- result which is a point of no return. The result can be extracted-      -- using @extract@. The driver drops the buffer except @offset@ elements-      -- before the current position in stream. The rule is that if a parser-      -- has yielded at least once it cannot return a failure result.--    | Skip Int s-    -- ^ @Skip offset state@ indicates that the parser has consumed the current-    -- input but no new result has been generated. A new @state@ is generated.-    -- However, if we use @extract@ on @state@ it will generate a result from-    -- the previous @Yield@.  When @offset@ is non-zero it is a backward offset-    -- from the current position in the stream from which the driver will feed-    -- the next input to the parser. The offset cannot be beyond the latest-    -- point of no return created by @Yield@.--    | Stop Int b-    -- ^ @Stop offset result@ asks the driver to stop driving the parser-    -- because it has reached a fixed point and further input will not change-    -- the result.  @offset@ is the count of unused elements which includes the-    -- element on which 'Stop' occurred.-    | Error String-    -- ^ An error makes the parser backtrack to the last checkpoint and try-    -- another alternative.--instance Functor (Step s) where-    {-# INLINE fmap #-}-    fmap _ (Yield n s) = Yield n s-    fmap _ (Skip n s) = Skip n s-    fmap f (Stop n b) = Stop n (f b)-    fmap _ (Error err) = 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. It may result in an error or an output value.------ /Internal/----data Parser m a b =-    forall s. Parser (s -> a -> m (Step s b)) (m s) (s -> m b)---- | This exception is used for two purposes:------ * When a parser ultimately fails, the user of the parser is intimated via---    this exception.--- * When the "extract" function of a parser needs to throw an error.------ /Internal/----newtype ParseError = ParseError String-    deriving Show--instance Exception ParseError where-    displayException (ParseError err) = err--instance Functor m => Functor (Parser m a) where-    {-# INLINE fmap #-}-    fmap f (Parser step1 initial extract) =-        Parser step initial (fmap2 f extract)--        where--        step s b = fmap2 f (step1 s b)-        fmap2 g = fmap (fmap g)---- This is the dual of stream "yield".------ | A parser that always yields a pure value without consuming any input.------ /Internal/----{-# INLINE yield #-}-yield :: Monad m => b -> Parser m a b-yield b = Parser (\_ _ -> pure $ Stop 1 b)  -- step-                 (pure ())                  -- initial-                 (\_ -> pure b)             -- extract---- This is the dual of stream "yieldM".------ | A parser that always yields the result of an effectful action without--- consuming any input.------ /Internal/----{-# INLINE yieldM #-}-yieldM :: Monad m => m b -> Parser m a b-yieldM b = Parser (\_ _ -> Stop 1 <$> b) -- step-                  (pure ())              -- initial-                  (\_ -> b)              -- extract------------------------------------------------------------------------------------ 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.------ | Sequential application. 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. If both the parsers succeed their--- outputs are combined using the supplied function. The operation fails if any--- of the parsers fail.------ This undoes an "append" of two streams, it splits the streams using two--- parsers and zips the results.------ This implementation is strict in the second argument, therefore, the--- following will fail:------ >>> S.parse (PR.satisfy (> 0) *> undefined) $ S.fromList [1]------ /Internal/----{-# INLINE splitWith #-}-splitWith :: Monad m-    => (a -> b -> c) -> Parser m x a -> Parser m x b -> Parser m x c-splitWith func (Parser stepL initialL extractL)-               (Parser stepR initialR extractR) =-    Parser step initial extract--    where--    initial = SeqParseL <$> initialL--    -- Note: For the composed parse to terminate, the left parser has to be-    -- a terminating parser returning a Stop at some point.-    step (SeqParseL st) a = do-        r <- stepL st a-        case r of-            -- Note: this leads to buffering even if we are not in an-            -- Alternative composition.-            Yield _ s -> return $ Skip 0 (SeqParseL s)-            Skip n s -> return $ Skip n (SeqParseL s)-            Stop n b -> Skip n <$> (SeqParseR (func b) <$> initialR)-            Error err -> return $ Error err--    step (SeqParseR f st) a = do-        r <- stepR st a-        return $ case r of-            Yield n s -> Yield n (SeqParseR f s)-            Skip n s -> Skip n (SeqParseR f s)-            Stop n b -> Stop n (f b)-            Error err -> Error err--    extract (SeqParseR f sR) = fmap f (extractR sR)-    extract (SeqParseL sL) = do-        rL <- extractL sL-        sR <- initialR-        rR <- extractR sR-        return $ func rL rR---- | 'Applicative' form of 'splitWith'.-instance Monad m => Applicative (Parser m a) where-    {-# INLINE pure #-}-    pure = yield--    {-# INLINE (<*>) #-}-    (<*>) = splitWith id------------------------------------------------------------------------------------ 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. Apply the input to the first parser and return the--- result if the parser succeeds. If the first parser fails then backtrack and--- apply the same input to the second parser and return the result.------ Note: This implementation is not lazy in the second argument. The following--- will fail:------ >>> S.parse (PR.satisfy (> 0) `PR.alt` undefined) $ S.fromList [1..10]------ /Internal/----{-# INLINE alt #-}-alt :: Monad m => Parser m x a -> Parser m x a -> Parser m x a-alt (Parser stepL initialL extractL) (Parser stepR initialR extractR) =-    Parser step initial extract--    where--    initial = AltParseL 0 <$> initialL--    -- 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.-    step (AltParseL cnt st) a = do-        r <- stepL st a-        case r of-            Yield n s -> return $ Yield n (AltParseL 0 s)-            Skip n s -> do-                assert (cnt + 1 - n >= 0) (return ())-                return $ Skip n (AltParseL (cnt + 1 - n) s)-            Stop n b -> return $ Stop n b-            Error _ -> do-                rR <- initialR-                return $ Skip (cnt + 1) (AltParseR rR)--    step (AltParseR st) a = do-        r <- stepR st a-        return $ case r of-            Yield n s -> Yield n (AltParseR s)-            Skip n s -> Skip n (AltParseR s)-            Stop n b -> Stop n b-            Error err -> Error err--    extract (AltParseR sR) = extractR sR-    extract (AltParseL _ sL) = extractL sL---- | See documentation of 'Streamly.Internal.Data.Parser.many'.------ /Internal/----{-# INLINE splitMany #-}-splitMany :: MonadCatch m => Fold m b c -> Parser m a b -> Parser m a c-splitMany (Fold fstep finitial fextract) (Parser step1 initial1 extract1) =-    Parser step initial extract--    where--    initial = do-        ps <- initial1 -- parse state-        fs <- finitial -- fold state-        pure (Tuple3' ps 0 fs)--    {-# INLINE step #-}-    step (Tuple3' st cnt fs) a = do-        r <- step1 st a-        let cnt1 = cnt + 1-        case r of-            Yield _ s -> return $ Skip 0 (Tuple3' s cnt1 fs)-            Skip n s -> do-                assert (cnt1 - n >= 0) (return ())-                return $ Skip n (Tuple3' s (cnt1 - n) fs)-            Stop n b -> do-                s <- initial1-                fs1 <- fstep fs b-                -- XXX we need to yield and backtrack here-                return $ Skip n (Tuple3' s 0 fs1)-            Error _ -> do-                xs <- fextract fs-                return $ Stop cnt1 xs--    -- XXX The "try" may impact performance if this parser is used as a scan-    extract (Tuple3' s _ fs) = do-        r <- try $ extract1 s-        case r of-            Left (_ :: ParseError) -> fextract fs-            Right b -> fstep fs b >>= fextract---- | See documentation of 'Streamly.Internal.Data.Parser.some'.------ /Internal/----{-# INLINE splitSome #-}-splitSome :: MonadCatch m => Fold m b c -> Parser m a b -> Parser m a c-splitSome (Fold fstep finitial fextract) (Parser step1 initial1 extract1) =-    Parser step initial extract--    where--    initial = do-        ps <- initial1 -- parse state-        fs <- finitial -- fold state-        pure (Tuple3' ps 0 (Left fs))--    {-# INLINE step #-}-    step (Tuple3' st _ (Left fs)) a = do-        r <- step1 st a-        case r of-            Yield _ s -> return $ Skip 0 (Tuple3' s undefined (Left fs))-            Skip  n s -> return $ Skip n (Tuple3' s undefined (Left fs))-            Stop n b -> do-                s <- initial1-                fs1 <- fstep fs b-                -- XXX this is also a yield point, we will never fail beyond-                -- this point. If we do not yield then if an error occurs after-                -- this then we will backtrack to the previous yield point-                -- instead of this point which is wrong.-                ---                -- so we need a yield with backtrack-                return $ Skip n (Tuple3' s 0 (Right fs1))-            Error err -> return $ Error err-    step (Tuple3' st cnt (Right fs)) a = do-        r <- step1 st a-        let cnt1 = cnt + 1-        case r of-            Yield _ s -> return $ Yield 0 (Tuple3' s cnt1 (Right fs))-            Skip n s -> do-                assert (cnt1 - n >= 0) (return ())-                return $ Skip n (Tuple3' s (cnt1 - n) (Right fs))-            Stop n b -> do-                s <- initial1-                fs1 <- fstep fs b-                -- XXX we need to yield here but also backtrack-                return $ Skip n (Tuple3' s 0 (Right fs1))-            Error _ -> Stop cnt1 <$> fextract fs--    -- XXX The "try" may impact performance if this parser is used as a scan-    extract (Tuple3' s _ (Left fs)) = extract1 s >>= fstep fs >>= fextract-    extract (Tuple3' s _ (Right fs)) = do-        r <- try $ extract1 s-        case r of-            Left (_ :: ParseError) -> fextract fs-            Right b -> fstep fs b >>= fextract---- This is the dual of "nil".------ | A parser that always fails with an error message without consuming--- any input.------ /Internal/----{-# INLINE die #-}-die :: MonadThrow m => String -> Parser m a b-die err =-    Parser (\_ _ -> pure $ Error err)      -- step-           (pure ())                       -- initial-           (\_ -> throwM $ ParseError err) -- extract---- This is the dual of "nilM".------ | A parser that always fails with an effectful error message and without--- consuming any input.------ /Internal/----{-# INLINE dieM #-}-dieM :: MonadThrow m => m String -> Parser m a b-dieM err =-    Parser (\_ _ -> Error <$> err)         -- step-           (pure ())                       -- initial-           (\_ -> err >>= throwM . ParseError) -- extract---- 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.---- | 'Alternative' instance using 'alt'.------ Note: The implementation of '<|>' is not lazy in the second--- argument. The following code will fail:------ >>> S.parse (PR.satisfy (> 0) <|> undefined) $ S.fromList [1..10]----instance MonadCatch m => Alternative (Parser m a) where-    {-# INLINE empty #-}-    empty = die "empty"--    {-# INLINE (<|>) #-}-    (<|>) = alt--    {-# INLINE many #-}-    many = splitMany toList--    {-# INLINE some #-}-    some = splitSome toList--{-# ANN type ConcatParseState Fuse #-}-data ConcatParseState sl p = ConcatParseL sl | ConcatParseR p---- 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.---- | 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 m Char 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 m Char 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]--- @----instance Monad m => Monad (Parser m a) where-    {-# INLINE return #-}-    return = pure--    -- (>>=) :: Parser m a b -> (b -> Parser m a c) -> Parser m a c-    {-# INLINE (>>=) #-}-    (Parser stepL initialL extractL) >>= func = Parser step initial extract--        where--        initial = ConcatParseL <$> initialL--        step (ConcatParseL st) a = do-            r <- stepL st a-            return $ case r of-                Yield _ s -> Skip 0 (ConcatParseL s)-                Skip n s -> Skip n (ConcatParseL s)-                Stop n b -> Skip n (ConcatParseR (func b))-                Error err -> Error err--        step (ConcatParseR (Parser stepR initialR extractR)) a = do-            st <- initialR-            r <- stepR st a-            return $ case r of-                Yield n s ->-                    Yield n (ConcatParseR (Parser stepR (return s) extractR))-                Skip n s ->-                    Skip n (ConcatParseR (Parser stepR (return s) extractR))-                Stop n b -> Stop n b-                Error err -> Error err--        extract (ConcatParseR (Parser _ initialR extractR)) =-            initialR >>= extractR--        extract (ConcatParseL sL) = extractL sL >>= f . func--            where--            f (Parser _ initialR extractR) = initialR >>= extractR---- | 'mzero' is same as 'empty', it aborts the parser. 'mplus' is same as--- '<|>', it selects the first succeeding parser.------ /Internal/----instance MonadCatch m => MonadPlus (Parser m a) where-    {-# INLINE mzero #-}-    mzero = die "mzero"--    {-# INLINE mplus #-}-    mplus = alt
src/Streamly/Internal/Data/Pipe.hs view
@@ -1,11 +1,3 @@-{-# LANGUAGE BangPatterns              #-}-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE RankNTypes                #-}-{-# LANGUAGE RecordWildCards           #-}-{-# LANGUAGE ScopedTypeVariables       #-}- -- | -- Module      : Streamly.Internal.Data.Pipe -- Copyright   : (c) 2019 Composewell Technologies@@ -27,7 +19,7 @@ -- fold to produce a fold, or multiple pipes can be merged or zipped into a -- single pipe. ----- > import qualified Streamly.Internal.Data.Pipe as P+-- > import qualified Streamly.Internal.Data.Pipe as Pipe  module Streamly.Internal.Data.Pipe     (@@ -250,12 +242,12 @@ -- import qualified Data.Map.Strict as Map -- import qualified Prelude --- import Streamly (MonadAsync, parallel)+-- import Streamly.Prelude (MonadAsync, parallel) -- import Streamly.Data.Fold.Types (Fold(..))-import Streamly.Internal.Data.Pipe.Types+import Streamly.Internal.Data.Pipe.Type        (Pipe(..), PipeState(..), Step(..), zipWith, tee, map, compose)--- import Streamly.Internal.Memory.Array.Types (Array)--- import Streamly.Memory.Ring (Ring)+-- import Streamly.Internal.Data.Array.Foreign.Type (Array)+-- import Streamly.Internal.Ring.Foreign (Ring) -- import Streamly.Internal.Data.Stream.Serial (SerialT) -- import Streamly.Internal.Data.Stream.StreamK (IsStream()) -- import Streamly.Internal.Data.Time.Units@@ -264,7 +256,7 @@  -- import Streamly.Internal.Data.Strict --- import qualified Streamly.Internal.Memory.Array.Types as A+-- import qualified Streamly.Internal.Data.Array.Foreign.Type as A -- import qualified Streamly.Prelude as S -- import qualified Streamly.Internal.Data.Stream.StreamD as D -- import qualified Streamly.Internal.Data.Stream.StreamK as K@@ -1853,7 +1845,7 @@                 let (r, mp') = Map.updateLookupWithKey (\_ _ -> Nothing) key mp                 Tuple' _ acc <- accumulate r                 res <- extract acc-                return $ Tuple4' evTime hp mp' (S.yield (key, res))+                return $ Tuple4' evTime hp mp' (S.fromPure (key, res))            else do                     let r = Map.lookup key mp                     acc <- accumulate r
+ src/Streamly/Internal/Data/Pipe/Type.hs view
@@ -0,0 +1,446 @@+#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)+#if __GLASGOW_HASKELL__ < 808+import Data.Semigroup (Semigroup(..))+#endif+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 (,)
− src/Streamly/Internal/Data/Pipe/Types.hs 
@@ -1,449 +0,0 @@-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE ExistentialQuantification #-}--#include "inline.hs"---- |--- Module      : Streamly.Internal.Data.Pipe.Types--- Copyright   : (c) 2019 Composewell Technologies--- License     : BSD3--- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC--module Streamly.Internal.Data.Pipe.Types-    ( Step (..)-    , Pipe (..)-    , PipeState (..)-    , zipWith-    , tee-    , map-    , compose-    )-where--import Control.Arrow (Arrow(..))-import Control.Category (Category(..))-import Data.Maybe (isJust)-#if __GLASGOW_HASKELL__ < 808-import Data.Semigroup (Semigroup(..))-#endif-import Prelude hiding (zipWith, map, id, unzip, null)-import Streamly.Internal.Data.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 = do-                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 = do-                case stt of-                    Consume st -> do-                        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 = do-                case res of-                    Nothing -> goProduce stt q fConsume fProduce-                    Just x -> return (stt, Just x, q)--            {-# INLINE goProduce #-}-            goProduce stt queue fConsume fProduce = do-                case stt of-                    Consume st -> do-                        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 = do-        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) = do-        case sL of-            Consume _ -> do-                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) = do-        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 = do-        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) = do-        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 (,)
− src/Streamly/Internal/Data/Prim/Array.hs 
@@ -1,205 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}--{-# LANGUAGE CPP           #-}-{-# LANGUAGE MagicHash     #-}-{-# LANGUAGE UnboxedTuples #-}--#include "inline.hs"---- |--- Module      : Streamly.Internal.Data.Prim.Array--- Copyright   : (c) 2019 Composewell Technologies------ License     : BSD-3-Clause--- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC----module Streamly.Internal.Data.Prim.Array-    (--    -- XXX should it be just Array instead? We should be able to replace one-    -- array type with another easily.-      PrimArray(..)--    -- XXX Prim should be exported from Data.Prim module?-    , Prim(..)--    , foldl'-    , foldr--    , length--    , writeN-    , write--    , toStreamD-    , toStreamDRev--    , toStream-    , toStreamRev-    , read-    , readSlice--    , fromListN-    , fromList-    , fromStreamDN-    , fromStreamD--    , fromStreamN-    , fromStream--    , streamFold-    , fold-    )-where--import Prelude hiding (foldr, length, read)-import Control.DeepSeq (NFData(..))-import Control.Monad (when)-import Control.Monad.IO.Class (liftIO, MonadIO)-import GHC.IO (unsafePerformIO)-import Data.Primitive.Types (Prim(..))--import Streamly.Internal.Data.Prim.Array.Types-import Streamly.Internal.Data.Unfold.Types (Unfold(..))-import Streamly.Internal.Data.Fold.Types (Fold(..))-import Streamly.Internal.Data.Stream.StreamK.Type (IsStream)-import Streamly.Internal.Data.Stream.Serial (SerialT)--import qualified Streamly.Internal.Data.Stream.StreamD as D--{-# INLINE_NORMAL toStreamD #-}-toStreamD :: (Prim a, Monad m) => PrimArray a -> D.Stream m a-toStreamD arr = D.Stream step 0-  where-    {-# INLINE_LATE step #-}-    step _ i-        | i == sizeofPrimArray arr = return D.Stop-    step _ i = return $ D.Yield (indexPrimArray arr i) (i + 1)--{-# INLINE length #-}-length :: Prim a => PrimArray a -> Int-length arr = sizeofPrimArray arr--{-# INLINE_NORMAL toStreamDRev #-}-toStreamDRev :: (Prim a, Monad m) => PrimArray a -> D.Stream m a-toStreamDRev arr = D.Stream step (sizeofPrimArray arr - 1)-  where-    {-# INLINE_LATE step #-}-    step _ i-        | i < 0 = return D.Stop-    step _ i = return $ D.Yield (indexPrimArray arr i) (i - 1)--{-# INLINE_NORMAL foldl' #-}-foldl' :: Prim a => (b -> a -> b) -> b -> PrimArray a -> b-foldl' = foldlPrimArray'--{-# INLINE_NORMAL foldr #-}-foldr :: Prim a => (a -> b -> b) -> b -> PrimArray a -> b-foldr = foldrPrimArray---- writeN n = S.evertM (fromStreamDN n)-{-# INLINE_NORMAL writeN #-}-writeN :: (MonadIO m, Prim a) => Int -> Fold m a (PrimArray a)-writeN limit = Fold step initial extract-  where-    initial = do-        marr <- liftIO $ newPrimArray limit-        return (marr, 0)-    step (marr, i) x-        | i == limit = return (marr, i)-        | otherwise = do-            liftIO $ writePrimArray marr i x-            return (marr, i + 1)-    extract (marr, _) = liftIO $ unsafeFreezePrimArray marr--{-# INLINE_NORMAL write #-}-write :: (MonadIO m, Prim a) => Fold m a (PrimArray a)-write = Fold step initial extract-  where-    initial = do-        marr <- liftIO $ newPrimArray 0-        return (marr, 0, 0)-    step (marr, i, capacity) x-        | i == capacity =-            let newCapacity = max (capacity * 2) 1-             in do newMarr <- liftIO $ resizeMutablePrimArray marr newCapacity-                   liftIO $ writePrimArray newMarr i x-                   return (newMarr, i + 1, newCapacity)-        | otherwise = do-            liftIO $ writePrimArray marr i x-            return (marr, i + 1, capacity)-    extract (marr, len, _) = do liftIO $ shrinkMutablePrimArray marr len-                                liftIO $ unsafeFreezePrimArray marr--{-# INLINE_NORMAL fromStreamDN #-}-fromStreamDN :: (MonadIO m, Prim a) => Int -> D.Stream m a -> m (PrimArray a)-fromStreamDN limit str = do-    marr <- liftIO $ newPrimArray (max limit 0)-    _ <--        D.foldlM'-            (\i x -> i `seq` (liftIO $ writePrimArray marr i x) >> return (i + 1))-            0 $-        D.take limit str-    liftIO $ unsafeFreezePrimArray marr--{-# INLINE fromStreamD #-}-fromStreamD :: (MonadIO m, Prim a) => D.Stream m a -> m (PrimArray a)-fromStreamD str = D.runFold write str--{-# INLINABLE fromListN #-}-fromListN :: Prim a => Int -> [a] -> PrimArray a-fromListN n xs = unsafePerformIO $ fromStreamDN n $ D.fromList xs--{-# INLINABLE fromList #-}-fromList :: Prim a => [a] -> PrimArray a-fromList xs = unsafePerformIO $ fromStreamD $ D.fromList xs--instance Prim a => NFData (PrimArray a) where-    {-# INLINE rnf #-}-    rnf = foldl' (\_ _ -> ()) ()--{-# INLINE fromStreamN #-}-fromStreamN :: (MonadIO m, Prim a) => Int -> SerialT m a -> m (PrimArray a)-fromStreamN n m = do-    when (n < 0) $ error "fromStreamN: negative write count specified"-    fromStreamDN n $ D.toStreamD m--{-# INLINE fromStream #-}-fromStream :: (MonadIO m, Prim a) => SerialT m a -> m (PrimArray a)-fromStream m = fromStreamD $ D.toStreamD m--{-# INLINE_EARLY toStream #-}-toStream :: (Prim a, Monad m, IsStream t) => PrimArray a -> t m a-toStream = D.fromStreamD . toStreamD--{-# INLINE_EARLY toStreamRev #-}-toStreamRev :: (Prim a, Monad m, IsStream t) => PrimArray a -> t m a-toStreamRev = D.fromStreamD . toStreamDRev--{-# INLINE fold #-}-fold :: (Prim a, Monad m) => Fold m a b -> PrimArray a -> m b-fold f arr = D.runFold f (toStreamD arr)--{-# INLINE streamFold #-}-streamFold :: (Prim a, Monad m) => (SerialT m a -> m b) -> PrimArray a -> m b-streamFold f arr = f (toStream arr)--{-# INLINE_NORMAL read #-}-read :: (Prim a, Monad m) => Unfold m (PrimArray a) a-read = Unfold step inject-  where-    inject arr = return (arr, 0)-    step (arr, i)-        | i == length arr = return D.Stop-    step (arr, i) = return $ D.Yield (indexPrimArray arr i) (arr, i + 1)--{-# INLINE_NORMAL readSlice #-}-readSlice :: (Prim a, Monad m) => Int -> Int -> Unfold m (PrimArray a) a-readSlice off len = Unfold step inject-  where-    inject arr = return (arr, off)-    step (arr, i)-        | i == min (off + len) (length arr) = return D.Stop-    step (arr, i) = return $ D.Yield (indexPrimArray arr i) (arr, i + 1)
− src/Streamly/Internal/Data/Prim/Array/Types.hs 
@@ -1,212 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UnboxedTuples #-}---- |--- Module      : Streamly.Internal.Data.Prim.Array.Types--- Copyright   : (c) Roman Leshchinskiy 2009-2012--- License     : BSD-style------ Maintainer  : streamly@composewell.com--- Portability : non-portable------ Arrays of unboxed primitive types. The function provided by this module--- match the behavior of those provided by @Data.Primitive.ByteArray@, and--- the underlying types and primops that back them are the same.--- However, the type constructors 'PrimArray' and 'MutablePrimArray' take one additional--- argument than their respective counterparts 'ByteArray' and 'MutableByteArray'.--- This argument is used to designate the type of element in the array.--- Consequently, all function this modules accepts length and incides in--- terms of elements, not bytes.------ @since 0.6.4.0-module Streamly.Internal.Data.Prim.Array.Types-  ( -- * Types-    PrimArray(..)-  , MutablePrimArray(..)-    -- * Allocation-  , newPrimArray-  , resizeMutablePrimArray-  , shrinkMutablePrimArray-    -- * Element Access-  , writePrimArray-  , indexPrimArray-    -- * Freezing and Thawing-  , unsafeFreezePrimArray-    -- * Information-  , sizeofPrimArray-    -- * Folding-  , foldrPrimArray-  , foldlPrimArray'-  ) where--import GHC.Exts--import Data.Primitive.Types-import Data.Primitive.ByteArray (ByteArray(..))-import Control.Monad.Primitive-import qualified Data.Primitive.ByteArray as PB---- | Arrays of unboxed elements. This accepts types like 'Double', 'Char',--- 'Int', and 'Word', as well as their fixed-length variants ('Word8',--- 'Word16', etc.). Since the elements are unboxed, a 'PrimArray' is strict--- in its elements. This differs from the behavior of 'Array', which is lazy--- in its elements.-data PrimArray a = PrimArray ByteArray#---- | Mutable primitive arrays associated with a primitive state token.--- These can be written to and read from in a monadic context that supports--- sequencing such as 'IO' or 'ST'. Typically, a mutable primitive array will--- be built and then convert to an immutable primitive array using--- 'unsafeFreezePrimArray'. However, it is also acceptable to simply discard--- a mutable primitive array since it lives in managed memory and will be--- garbage collected when no longer referenced.-data MutablePrimArray s a = MutablePrimArray (MutableByteArray# s)--sameByteArray :: ByteArray# -> ByteArray# -> Bool-sameByteArray ba1 ba2 =-    case reallyUnsafePtrEquality# (unsafeCoerce# ba1 :: ()) (unsafeCoerce# ba2 :: ()) of-      r -> isTrue# r---- | @since 0.6.4.0-instance (Eq a, Prim a) => Eq (PrimArray a) where-  a1@(PrimArray ba1#) == a2@(PrimArray ba2#)-    | sameByteArray ba1# ba2# = True-    | sz1 /= sz2 = False-    | otherwise = loop (quot sz1 (sizeOf (undefined :: a)) - 1)-    where-    -- Here, we take the size in bytes, not in elements. We do this-    -- since it allows us to defer performing the division to-    -- calculate the size in elements.-    sz1 = PB.sizeofByteArray (ByteArray ba1#)-    sz2 = PB.sizeofByteArray (ByteArray ba2#)-    loop !i-      | i < 0 = True-      | otherwise = indexPrimArray a1 i == indexPrimArray a2 i && loop (i-1)-  {-# INLINE (==) #-}---- | Lexicographic ordering. Subject to change between major versions.------   @since 0.6.4.0-instance (Ord a, Prim a) => Ord (PrimArray a) where-  compare a1@(PrimArray ba1#) a2@(PrimArray ba2#)-    | sameByteArray ba1# ba2# = EQ-    | otherwise = loop 0-    where-    cmp LT _ = LT-    cmp EQ y = y-    cmp GT _ = GT-    sz1 = PB.sizeofByteArray (ByteArray ba1#)-    sz2 = PB.sizeofByteArray (ByteArray ba2#)-    sz = quot (min sz1 sz2) (sizeOf (undefined :: a))-    loop !i-      | i < sz = compare (indexPrimArray a1 i) (indexPrimArray a2 i) `cmp` loop (i+1)-      | otherwise = compare sz1 sz2-  {-# INLINE compare #-}---- | @since 0.6.4.0-instance (Show a, Prim a) => Show (PrimArray a) where-  showsPrec p a = showParen (p > 10) $-    showString "fromListN " . shows (sizeofPrimArray a) . showString " "-      . shows (primArrayToList a)---- | Convert the primitive array to a list.-{-# INLINE primArrayToList #-}-primArrayToList :: forall a. Prim a => PrimArray a -> [a]-primArrayToList xs = build (\c n -> foldrPrimArray c n xs)---- | Create a new mutable primitive array of the given length. The--- underlying memory is left uninitialized.-newPrimArray :: forall m a. (PrimMonad m, Prim a) => Int -> m (MutablePrimArray (PrimState m) a)-{-# INLINE newPrimArray #-}-newPrimArray (I# n#)-  = primitive (\s# ->-      case newByteArray# (n# *# sizeOf# (undefined :: a)) s# of-        (# s'#, arr# #) -> (# s'#, MutablePrimArray arr# #)-    )---- | Resize a mutable primitive array. The new size is given in elements.------ This will either resize the array in-place or, if not possible, allocate the--- contents into a new, unpinned array and copy the original array\'s contents.------ To avoid undefined behaviour, the original 'MutablePrimArray' shall not be--- accessed anymore after a 'resizeMutablePrimArray' has been performed.--- Moreover, no reference to the old one should be kept in order to allow--- garbage collection of the original 'MutablePrimArray' in case a new--- 'MutablePrimArray' had to be allocated.-resizeMutablePrimArray :: forall m a. (PrimMonad m, Prim a)-  => MutablePrimArray (PrimState m) a-  -> Int -- ^ new size-  -> m (MutablePrimArray (PrimState m) a)-{-# INLINE resizeMutablePrimArray #-}-resizeMutablePrimArray (MutablePrimArray arr#) (I# n#)-  = primitive (\s# -> case resizeMutableByteArray# arr# (n# *# sizeOf# (undefined :: a)) s# of-                        (# s'#, arr'# #) -> (# s'#, MutablePrimArray arr'# #))---- Although it is possible to shim resizeMutableByteArray for old GHCs, this--- is not the case with shrinkMutablePrimArray.---- | Shrink a mutable primitive array. The new size is given in elements.--- It must be smaller than the old size. The array will be resized in place.--- This function is only available when compiling with GHC 7.10 or newer.-shrinkMutablePrimArray :: forall m a. (PrimMonad m, Prim a)-  => MutablePrimArray (PrimState m) a-  -> Int -- ^ new size-  -> m ()-{-# INLINE shrinkMutablePrimArray #-}-shrinkMutablePrimArray (MutablePrimArray arr#) (I# n#)-  = primitive_ (shrinkMutableByteArray# arr# (n# *# sizeOf# (undefined :: a)))---- | Write an element to the given index.-writePrimArray ::-     (Prim a, PrimMonad m)-  => MutablePrimArray (PrimState m) a -- ^ array-  -> Int -- ^ index-  -> a -- ^ element-  -> m ()-{-# INLINE writePrimArray #-}-writePrimArray (MutablePrimArray arr#) (I# i#) x-  = primitive_ (writeByteArray# arr# i# x)---- | Convert a mutable byte array to an immutable one without copying. The--- array should not be modified after the conversion.-unsafeFreezePrimArray-  :: PrimMonad m => MutablePrimArray (PrimState m) a -> m (PrimArray a)-{-# INLINE unsafeFreezePrimArray #-}-unsafeFreezePrimArray (MutablePrimArray arr#)-  = primitive (\s# -> case unsafeFreezeByteArray# arr# s# of-                        (# s'#, arr'# #) -> (# s'#, PrimArray arr'# #))---- | Read a primitive value from the primitive array.-indexPrimArray :: forall a. Prim a => PrimArray a -> Int -> a-{-# INLINE indexPrimArray #-}-indexPrimArray (PrimArray arr#) (I# i#) = indexByteArray# arr# i#---- | Get the size, in elements, of the primitive array.-sizeofPrimArray :: forall a. Prim a => PrimArray a -> Int-{-# INLINE sizeofPrimArray #-}-sizeofPrimArray (PrimArray arr#) = I# (quotInt# (sizeofByteArray# arr#) (sizeOf# (undefined :: a)))---- | Lazy right-associated fold over the elements of a 'PrimArray'.-{-# INLINE foldrPrimArray #-}-foldrPrimArray :: forall a b. Prim a => (a -> b -> b) -> b -> PrimArray a -> b-foldrPrimArray f z arr = go 0-  where-    !sz = sizeofPrimArray arr-    go !i-      | sz > i = f (indexPrimArray arr i) (go (i+1))-      | otherwise = z---- | Strict left-associated fold over the elements of a 'PrimArray'.-{-# INLINE foldlPrimArray' #-}-foldlPrimArray' :: forall a b. Prim a => (b -> a -> b) -> b -> PrimArray a -> b-foldlPrimArray' f z0 arr = go 0 z0-  where-    !sz = sizeofPrimArray arr-    go !i !acc-      | i < sz = go (i + 1) (f acc (indexPrimArray arr i))-      | otherwise = acc
+ src/Streamly/Internal/Data/Producer.hs view
@@ -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 (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
+ src/Streamly/Internal/Data/Producer/Source.hs view
@@ -0,0 +1,238 @@+-- |+-- 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 Control.Monad.Catch (MonadThrow, throwM)+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 parseD #-}+parseD+    :: MonadThrow m+    => ParserD.Parser m a b+    -> Producer m (Source s a) a+    -> Source s a+    -> m (b, Source s a)+parseD+    (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 (b, seed)+        ParserD.IError err -> throwM $ ParseError err++    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.+    {-# INLINE go #-}+    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 (b, unread src s1)+                    Error err -> throwM $ ParseError err+            Skip s -> go SPEC s buf pst+            Stop   -> do+                b <- extract pst+                return (b, unread (reverse $ getList buf) (source Nothing))++    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 (b, unread src s1)+            Error err -> throwM $ ParseError err++-- | Parse a buffered source using a parser, returning the parsed value and the+-- remaining source.+--+-- /Pre-release/+{-# INLINE [3] parse #-}+parse+    :: MonadThrow m+    => ParserK.Parser m a b+    -> Producer m (Source s a) a+    -> Source s a+    -> m (b, Source s a)+parse = parseD . ParserK.fromParserK++-------------------------------------------------------------------------------+-- Nested parsing+-------------------------------------------------------------------------------++{-# INLINE parseManyD #-}+parseManyD :: MonadThrow m =>+       ParserD.Parser m a b+    -> Producer m (Source x a) a+    -> Producer m (Source x a) 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) <- parseD parser reader src+            return $ Yield b s1++-- | Apply a parser repeatedly on a buffered source producer to generate a+-- producer of parsed values.+--+-- /Pre-release/+{-# INLINE parseMany #-}+parseMany :: MonadThrow m =>+       ParserK.Parser m a b+    -> Producer m (Source x a) a+    -> Producer m (Source x a) b+parseMany parser = parseManyD (ParserK.fromParserK parser)
+ src/Streamly/Internal/Data/Producer/Type.hs view
@@ -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)
src/Streamly/Internal/Data/SVar.hs view
@@ -1,20 +1,8 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE KindSignatures             #-}-{-# LANGUAGE ConstraintKinds            #-}-{-# LANGUAGE ExistentialQuantification  #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase                 #-}-{-# LANGUAGE MagicHash                  #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE RankNTypes                 #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE UnboxedTuples              #-}+{-# LANGUAGE UnboxedTuples #-}  -- | -- Module      : Streamly.Internal.Data.SVar--- Copyright   : (c) 2017 Harendra Kumar+-- Copyright   : (c) 2017 Composewell Technologies -- -- License     : BSD3 -- Maintainer  : streamly@composewell.com@@ -117,20 +105,17 @@     ) where -import Control.Concurrent-       (ThreadId, myThreadId, threadDelay, throwTo, forkIO, killThread)+import Control.Concurrent (ThreadId, myThreadId, threadDelay, throwTo) import Control.Concurrent.MVar        (MVar, newEmptyMVar, tryPutMVar, takeMVar, tryTakeMVar, newMVar,         tryReadMVar) import Control.Exception-       (SomeException(..), catch, mask, assert, Exception, catches,+       (SomeException(..), assert, Exception, catches,         throwIO, Handler(..), BlockedIndefinitelyOnMVar(..),         BlockedIndefinitelyOnSTM(..)) import Control.Monad (when)-import Control.Monad.Catch (MonadThrow) import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad.Trans.Control-       (MonadBaseControl, control, StM, liftBaseDiscard)+import Control.Monad.Trans.Control (MonadBaseControl, control) import Streamly.Internal.Data.Atomics        (atomicModifyIORefCAS, atomicModifyIORefCAS_, writeBarrier,         storeLoadBarrier)@@ -138,23 +123,19 @@ import Data.Functor (void) import Data.Heap (Heap, Entry(..)) import Data.Int (Int64)-#if __GLASGOW_HASKELL__ >= 800-import Data.Kind (Type)-#endif import Data.IORef        (IORef, modifyIORef, newIORef, readIORef, writeIORef, atomicModifyIORef)-import Data.Maybe (fromJust)+import Data.Kind (Type)+import Data.Maybe (fromJust, fromMaybe) #if __GLASGOW_HASKELL__ < 808 import Data.Semigroup ((<>)) #endif import Data.Set (Set)-import GHC.Conc (ThreadId(..))-import GHC.Exts-import GHC.IO (IO(..)) import System.IO (hPutStrLn, stderr)-import System.Mem.Weak (addFinalizer) -import Streamly.Internal.Data.Time.Clock (Clock(..), getTime)+import Streamly.Internal.Control.Concurrent+    (MonadAsync, RunInIO(..), doFork, fork, forkManaged)+import Streamly.Internal.Data.Time.Clock.Type (Clock(..), getTime) import Streamly.Internal.Data.Time.Units        (AbsTime, NanoSecond64(..), MicroSecond64(..), diffAbsTime64,         fromRelTime64, toRelTime64, showNanoSecond64, showRelTime64)@@ -187,14 +168,11 @@       ChildYield a     | ChildStop ThreadId (Maybe SomeException) -#if __GLASGOW_HASKELL__ < 800-#define Type *-#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 (t m a)+    | AheadEntryStream (RunInIO m, t m a) #undef Type  ------------------------------------------------------------------------------@@ -245,7 +223,6 @@     , workerLatencyStart  :: IORef (Count, AbsTime)     } - -- | 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@@ -265,7 +242,9 @@ -- 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+-- /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@@ -459,7 +438,7 @@     , yieldRateInfo  :: Maybe YieldRateInfo      -- Used only by bounded SVar types-    , enqueue        :: t m a -> IO ()+    , enqueue        :: (RunInIO m, t m a) -> IO ()     , isWorkDone     :: IO Bool     , isQueueDone    :: IO Bool     , needDoorBell   :: IORef Bool@@ -704,7 +683,7 @@     assert (latCount == 0 || latTime /= 0) (return ())     let latPair =             if latCount > 0 && latTime > 0-            then Just $ (latCount, latTime)+            then Just (latCount, latTime)             else Nothing     return (totalCount, latPair) @@ -748,7 +727,7 @@     case newLatPair of         Nothing -> retWith prevLat         Just (count, time) -> do-            let newLat = time `div` (fromIntegral count)+            let newLat = time `div` fromIntegral count             when (svarInspectMode sv) $ recordMinMaxLatency sv newLat             -- When we have collected a significant sized batch we compute the             -- new latency using that batch and return the new latency,@@ -882,7 +861,7 @@     svInfo <- dumpSVar sv     hPutStrLn stderr $ "\n" <> how <> "\n" <> svInfo --- MVar diagnostics has some overhead - around 5% on asyncly null benchmark, we+-- MVar diagnostics has some overhead - around 5% on AsyncT null benchmark, we -- can keep it on in production to debug problems quickly if and when they -- happen, but it may result in unexpected output when threads are left hanging -- until they are GCed because the consumer went away.@@ -914,66 +893,16 @@ -- Spawning threads ------------------------------------------------------------------------------ --- | A monad that can perform concurrent or parallel IO operations. Streams--- that can be composed concurrently require the underlying monad to be--- 'MonadAsync'.------ @since 0.1.0-type MonadAsync m = (MonadIO m, MonadBaseControl IO m, MonadThrow m)---- When we run computations concurrently, we completely isolate the state of+-- | When we run computations concurrently, we completely isolate the state of -- the concurrent computations from the parent computation.  The invariant is -- that we should never be running two concurrent computations in the same -- thread without using the runInIO function.  Also, we should never be running -- a concurrent computation in the parent thread, otherwise it may affect the -- state of the parent which is against the defined semantics of concurrent -- execution.-newtype RunInIO m = RunInIO { runInIO :: forall b. m b -> IO (StM m b) }- captureMonadState :: MonadBaseControl IO m => m (RunInIO m) captureMonadState = control $ \run -> run (return $ RunInIO run) --- 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-#if MIN_VERSION_base(4,17,0)-rawForkIO (IO action) =-#else-rawForkIO action =-#endif-   IO $ \ s -> case fork# action s of (# s1, tid #) -> (# s1, ThreadId tid #)--{-# INLINE doFork #-}-doFork :: MonadBaseControl IO m-    => m ()-    -> RunInIO m-    -> (SomeException -> IO ())-    -> m ThreadId-doFork action (RunInIO mrun) exHandler =-    control $ \run ->-        mask $ \restore -> do-                tid <- rawForkIO $ catch (restore $ void $ mrun action)-                                         exHandler-                run (return tid)--{-# INLINABLE fork #-}-fork :: MonadBaseControl IO m => m () -> m ThreadId-fork = liftBaseDiscard forkIO---- | Fork a thread that is automatically killed as soon as the reference to the--- returned threadId is garbage collected.----{-# INLINABLE forkManaged #-}-forkManaged :: (MonadIO m, MonadBaseControl IO m) => m () -> m ThreadId-forkManaged action = do-    tid <- fork action-    liftIO $ addFinalizer tid (killThread tid)-    return tid- ------------------------------------------------------------------------------ -- Collecting results from child workers in a streamed fashion ------------------------------------------------------------------------------@@ -1106,7 +1035,7 @@ -- | This function is used by the producer threads to queue output for the -- consumer thread to consume. Returns whether the queue has more space. send :: SVar t m a -> ChildEvent a -> IO Int-send sv msg = sendWithDoorBell (outputQueue sv) (outputDoorBell sv) msg+send sv = sendWithDoorBell (outputQueue sv) (outputDoorBell sv)  -- There is no bound implemented on the buffer, this is assumed to be low -- traffic.@@ -1279,7 +1208,8 @@ -- expressions. Large left associated compositions can grow this to a -- large size {-# INLINE enqueueLIFO #-}-enqueueLIFO :: SVar t m a -> IORef [t m a] -> t m a -> IO ()+enqueueLIFO ::+       SVar t m a -> IORef [(RunInIO m, t m a)] -> (RunInIO m, t m a) -> IO () enqueueLIFO sv q m = do     atomicModifyIORefCAS_ q $ \ms -> m : ms     ringDoorBell sv@@ -1293,7 +1223,11 @@ -- first as long as possible.  {-# INLINE enqueueFIFO #-}-enqueueFIFO :: SVar t m a -> LinkedQueue (t m a) -> t m a -> IO ()+enqueueFIFO ::+       SVar t m a+    -> LinkedQueue (RunInIO m, t m a)+    -> (RunInIO m, t m a)+    -> IO () enqueueFIFO sv q m = do     pushL q m     ringDoorBell sv@@ -1363,10 +1297,10 @@ -- we can even run the already queued items but they will have to be sorted in -- layers in the heap. We can use a list of heaps for that. {-# INLINE enqueueAhead #-}-enqueueAhead :: SVar t m a -> IORef ([t m a], Int) -> t m a -> IO ()+enqueueAhead :: SVar t m a -> IORef ([t m a], Int) -> (RunInIO m, t m a) -> IO () enqueueAhead sv q m = do     atomicModifyIORefCAS_ q $ \ case-        ([], n) -> ([m], n + 1)  -- increment sequence+        ([], n) -> ([snd m], n + 1)  -- increment sequence         _ -> error "enqueueAhead: queue is not empty"     ringDoorBell sv @@ -1860,10 +1794,7 @@         let elapsed = fromRelTime64 $ diffAbsTime64 now baseTime         let latency =                 if lat == 0-                then-                    case workerBootstrapLatency yinfo of-                        Nothing -> lat-                        Just t -> t+                then fromMaybe lat (workerBootstrapLatency yinfo)                 else lat          return (yieldCount, elapsed, latency)@@ -2353,7 +2284,7 @@     let bufLim =             case getMaxBuffer st of                 Unlimited -> undefined-                Limited x -> (fromIntegral x)+                Limited x -> fromIntegral x     remBuf <- newIORef bufLim     pbMVar <- newMVar () @@ -2423,7 +2354,8 @@     -- Note: We must have all the work on the queue before sending the     -- pushworker, otherwise the pushworker may exit before we even get a     -- chance to push.-    liftIO $ enqueue sv m+    runIn <- captureMonadState+    liftIO $ enqueue sv (runIn, m)     case yieldRateInfo sv of         Nothing -> pushWorker 0 sv         Just yinfo  ->@@ -2464,7 +2396,8 @@ -- be read back from the SVar using 'fromSVar'. toStreamVar :: MonadAsync m => SVar t m a -> t m a -> m () toStreamVar sv m = do-    liftIO $ enqueue sv m+    runIn <- captureMonadState+    liftIO $ enqueue sv (runIn, m)     done <- allThreadsDone sv     -- XXX This is safe only when called from the consumer thread or when no     -- consumer is present.  There may be a race if we are not running in the
src/Streamly/Internal/Data/Sink.hs view
@@ -57,7 +57,7 @@     ) where -import Control.Monad (when, void)+import Control.Monad ((>=>), when, void) import Data.Map.Strict (Map) import Prelude        hiding (filter, drop, dropWhile, take, takeWhile, zipWith, foldr,@@ -66,8 +66,8 @@                reverse, iterate, init, and, or, lookup, foldr1, (!!),                scanl, scanl1, replicate, concatMap, mconcat, foldMap, unzip) -import Streamly.Internal.Data.Fold.Types (Fold(..))-import Streamly.Internal.Data.Sink.Types (Sink(..))+import Streamly.Internal.Data.Fold.Type (Fold(..), Step(..))+import Streamly.Internal.Data.Sink.Type (Sink(..))  import qualified Data.Map.Strict as Map @@ -80,8 +80,8 @@ toFold :: Monad m => Sink m a -> Fold m a () toFold (Sink f) = Fold step begin done     where-    begin = return ()-    step _ = f+    begin = return $ Partial ()+    step _ a = Partial <$> f a     done _ = return ()  ------------------------------------------------------------------------------@@ -190,14 +190,14 @@ -- @ -- @ -- > let pr x = Sink.drainM (putStrLn . ((x ++ " ") ++) . show)---   in Sink.sink (Sink.unzip return (pr \"L") (pr \"R")) (S.yield (1,2))+--   in Sink.sink (Sink.unzip return (pr \"L") (pr \"R")) (S.fromPure (1,2)) -- L 1 -- R 2 -- @ {-# INLINE unzipM #-} unzipM :: Monad m => (a -> m (b,c)) -> Sink m b -> Sink m c -> Sink m a unzipM f (Sink stepB) (Sink stepC) =-    Sink (\a -> f a >>= \(b,c) -> stepB b >> stepC c)+    Sink (f >=> (\(b, c) -> stepB b >> stepC c))  -- | Same as 'unzipM' but with a pure unzip function. {-# INLINE unzip #-}@@ -216,7 +216,7 @@ -- | Map a monadic function on the input of a 'Sink'. {-# INLINABLE lmapM #-} lmapM :: Monad m => (a -> m b) -> Sink m b -> Sink m a-lmapM f (Sink step) = Sink (\x -> f x >>= step)+lmapM f (Sink step) = Sink (f >=> step)  -- | Filter the input of a 'Sink' using a pure predicate function. {-# INLINABLE lfilter #-}
+ src/Streamly/Internal/Data/Sink/Type.hs view
@@ -0,0 +1,24 @@+-- |+-- Module      : Streamly.Internal.Data.Sink.Type+-- Copyright   : (c) 2019 Composewell Technologies+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Internal.Data.Sink.Type+    (+      Sink (..)+    )+where++------------------------------------------------------------------------------+-- Sink+------------------------------------------------------------------------------++-- | A 'Sink' is a special type of 'Fold' that does not accumulate any value,+-- but runs only effects. A 'Sink' has no state to maintain therefore can be a+-- bit more efficient than a 'Fold' with '()' as the state, especially when+-- 'Sink's are composed with other operations. A Sink can be upgraded to a+-- 'Fold', but a 'Fold' cannot be converted into a Sink.+newtype Sink m a = Sink (a -> m ())
− src/Streamly/Internal/Data/Sink/Types.hs 
@@ -1,24 +0,0 @@--- |--- Module      : Streamly.Internal.Data.Sink.Types--- Copyright   : (c) 2019 Composewell Technologies--- License     : BSD3--- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC--module Streamly.Internal.Data.Sink.Types-    (-      Sink (..)-    )-where----------------------------------------------------------------------------------- Sink----------------------------------------------------------------------------------- | A 'Sink' is a special type of 'Fold' that does not accumulate any value,--- but runs only effects. A 'Sink' has no state to maintain therefore can be a--- bit more efficient than a 'Fold' with '()' as the state, especially when--- 'Sink's are composed with other operations. A Sink can be upgraded to a--- 'Fold', but a 'Fold' cannot be converted into a Sink.-data Sink m a = Sink (a -> m ())
src/Streamly/Internal/Data/SmallArray.hs view
@@ -8,9 +8,6 @@ -- Portability : GHC  {-# OPTIONS_GHC -fno-warn-orphans #-}--{-# LANGUAGE CPP           #-}-{-# LANGUAGE MagicHash     #-} {-# LANGUAGE UnboxedTuples #-}  #include "inline.hs"@@ -51,13 +48,16 @@ import GHC.IO (unsafePerformIO) import Data.Functor.Identity (runIdentity) -import Streamly.Internal.Data.SmallArray.Types-import Streamly.Internal.Data.Unfold.Types (Unfold(..))-import Streamly.Internal.Data.Fold.Types (Fold(..))+import Streamly.Internal.Data.SmallArray.Type++import Streamly.Internal.Data.Tuple.Strict (Tuple'(..))+import Streamly.Internal.Data.Unfold.Type (Unfold(..))+import Streamly.Internal.Data.Fold.Type (Fold(..)) import Streamly.Internal.Data.Stream.StreamK.Type (IsStream) import Streamly.Internal.Data.Stream.Serial (SerialT)  import qualified Streamly.Internal.Data.Stream.StreamD as D+import qualified Streamly.Internal.Data.Fold.Type as FL  {-# NOINLINE bottomElement #-} bottomElement :: a@@ -65,7 +65,7 @@  {-# INLINE length #-} length :: SmallArray a -> Int-length arr = sizeofSmallArray arr+length = sizeofSmallArray  {-# INLINE_NORMAL toStreamD #-} toStreamD :: Monad m => SmallArray a -> D.Stream m a@@ -103,29 +103,33 @@ -- 'SmallArray'. -- -- Since we are folding to a 'SmallArray' @n@ should be <= 128, for larger number--- of elements use an 'Array' from either "Streamly.Data.Array" or "Streamly.Memory.Array".+-- of elements use an 'Array' from either "Streamly.Data.Array" or "Streamly.Data.Array.Foreign". {-# INLINE_NORMAL writeN #-} writeN :: MonadIO m => Int -> Fold m a (SmallArray a) writeN limit = Fold step initial extract-  where++    where+     initial = do         marr <- liftIO $ newSmallArray limit bottomElement-        return (marr, 0)-    step (marr, i) x-        | i == limit = return (marr, i)+        return $ FL.Partial (Tuple' marr 0)++    step st@(Tuple' marr i) x+        | i == limit = FL.Done <$> extract st         | otherwise = do             liftIO $ writeSmallArray marr i x-            return (marr, i + 1)-    extract (marr, len) = liftIO $ freezeSmallArray marr 0 len+            return $ FL.Partial (Tuple' marr (i + 1)) +    extract (Tuple' marr len) = liftIO $ freezeSmallArray marr 0 len+ {-# INLINE_NORMAL fromStreamDN #-} fromStreamDN :: MonadIO m => Int -> D.Stream m a -> m (SmallArray a) fromStreamDN limit str = do     marr <- liftIO $ newSmallArray (max limit 0) bottomElement     i <-         D.foldlM'-            (\i x -> i `seq` (liftIO $ writeSmallArray marr i x) >> return (i + 1))-            0 $+            (\i x -> i `seq` liftIO (writeSmallArray marr i x) >> return (i + 1))+            (return 0) $         D.take limit str     liftIO $ freezeSmallArray marr 0 i @@ -135,7 +139,7 @@ -- -- It is recommended to use a value of @n@ <= 128. For larger sized -- arrays, use an 'Array' from "Streamly.Data.Array" or--- "Streamly.Memory.Array"+-- "Streamly.Data.Array.Foreign" {-# INLINABLE fromListN #-} fromListN :: Int -> [a] -> SmallArray a fromListN n xs = unsafePerformIO $ fromStreamDN n $ D.fromList xs@@ -165,7 +169,7 @@  {-# INLINE fold #-} fold :: Monad m => Fold m a b -> SmallArray a -> m b-fold f arr = D.runFold f (toStreamD arr)+fold f arr = D.fold f (toStreamD arr)  {-# INLINE streamFold #-} streamFold :: Monad m => (SerialT m a -> m b) -> SmallArray a -> m b
+ src/Streamly/Internal/Data/SmallArray/Type.hs view
@@ -0,0 +1,827 @@+{-# LANGUAGE UnboxedTuples #-}++-- |+-- Module : Data.Primitive.SmallArray+-- Copyright: (c) 2015 Dan Doel+-- License: BSD3+--+-- Maintainer  : streamly@composewell.com+-- Portability: non-portable+--+-- Small arrays are boxed (im)mutable arrays.+--+-- The underlying structure of the 'Array' type contains a card table, allowing+-- segments of the array to be marked as having been mutated. This allows the+-- garbage collector to only re-traverse segments of the array that have been+-- marked during certain phases, rather than having to traverse the entire+-- array.+--+-- 'SmallArray' lacks this table. This means that it takes up less memory and+-- has slightly faster writes. It is also more efficient during garbage+-- collection so long as the card table would have a single entry covering the+-- entire array. These advantages make them suitable for use as arrays that are+-- known to be small.+--+-- The card size is 128, so for uses much larger than that, 'Array' would likely+-- be superior.+--+-- The underlying type, 'SmallArray#', was introduced in GHC 7.10, so prior to+-- that version, this module simply implements small arrays as 'Array'.++module Streamly.Internal.Data.SmallArray.Type+  ( SmallArray(..)+  , SmallMutableArray(..)+  , newSmallArray+  , readSmallArray+  , writeSmallArray+  , copySmallArray+  , copySmallMutableArray+  , indexSmallArray+  , indexSmallArrayM+  , indexSmallArray##+  , cloneSmallArray+  , cloneSmallMutableArray+  , freezeSmallArray+  , unsafeFreezeSmallArray+  , thawSmallArray+  , runSmallArray+  , unsafeThawSmallArray+  , sizeofSmallArray+  , sizeofSmallMutableArray+  , smallArrayFromList+  , smallArrayFromListN+  , mapSmallArray'+  , traverseSmallArrayP+  ) where++import GHC.Exts hiding (toList)+import qualified GHC.Exts++import Control.Applicative+import Control.Monad+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif+import Control.Monad.Fix+import Control.Monad.Primitive+import Control.Monad.ST+import Control.Monad.Zip+import Data.Data+import Data.Foldable as Foldable+import Data.Functor.Identity+#if !(MIN_VERSION_base(4,10,0))+import Data.Monoid+#endif+#if MIN_VERSION_base(4,9,0)+import qualified GHC.ST as GHCST+import qualified Data.Semigroup as Sem+#endif+import Text.ParserCombinators.ReadP++#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,10,0)+import GHC.Base (runRW#)+#endif++#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)+import Data.Functor.Classes (Eq1(..),Ord1(..),Show1(..),Read1(..))+#endif++data SmallArray a = SmallArray (SmallArray# a)+  deriving Typeable++data SmallMutableArray s a = SmallMutableArray (SmallMutableArray# s a)+  deriving Typeable++-- | Create a new small mutable array.+newSmallArray+  :: PrimMonad m+  => Int -- ^ size+  -> a   -- ^ initial contents+  -> m (SmallMutableArray (PrimState m) a)+newSmallArray (I# i#) x = primitive $ \s ->+  case newSmallArray# i# x s of+    (# s', sma# #) -> (# s', SmallMutableArray sma# #)+{-# INLINE newSmallArray #-}++-- | Read the element at a given index in a mutable array.+readSmallArray+  :: PrimMonad m+  => SmallMutableArray (PrimState m) a -- ^ array+  -> Int                               -- ^ index+  -> m a+readSmallArray (SmallMutableArray sma#) (I# i#) =+  primitive $ readSmallArray# sma# i#+{-# INLINE readSmallArray #-}++-- | Write an element at the given idex in a mutable array.+writeSmallArray+  :: PrimMonad m+  => SmallMutableArray (PrimState m) a -- ^ array+  -> Int                               -- ^ index+  -> a                                 -- ^ new element+  -> m ()+writeSmallArray (SmallMutableArray sma#) (I# i#) x =+  primitive_ $ writeSmallArray# sma# i# x+{-# INLINE writeSmallArray #-}++-- | Look up an element in an immutable array.+--+-- The purpose of returning a result using a monad is to allow the caller to+-- avoid retaining references to the array. Evaluating the return value will+-- cause the array lookup to be performed, even though it may not require the+-- element of the array to be evaluated (which could throw an exception). For+-- instance:+--+-- > data Box a = Box a+-- > ...+-- >+-- > f sa = case indexSmallArrayM sa 0 of+-- >   Box x -> ...+--+-- 'x' is not a closure that references 'sa' as it would be if we instead+-- wrote:+--+-- > let x = indexSmallArray sa 0+--+-- And does not prevent 'sa' from being garbage collected.+--+-- Note that 'Identity' is not adequate for this use, as it is a newtype, and+-- cannot be evaluated without evaluating the element.+indexSmallArrayM+  :: Monad m+  => SmallArray a -- ^ array+  -> Int          -- ^ index+  -> m a+indexSmallArrayM (SmallArray sa#) (I# i#) =+  case indexSmallArray# sa# i# of+    (# x #) -> pure x+{-# INLINE indexSmallArrayM #-}++-- | Look up an element in an immutable array.+indexSmallArray+  :: SmallArray a -- ^ array+  -> Int          -- ^ index+  -> a+indexSmallArray sa i = runIdentity $ indexSmallArrayM sa i+{-# INLINE indexSmallArray #-}++-- | Read a value from the immutable array at the given index, returning+-- the result in an unboxed unary tuple. This is currently used to implement+-- folds.+indexSmallArray## :: SmallArray a -> Int -> (# a #)+indexSmallArray## (SmallArray ary) (I# i) = indexSmallArray# ary i+{-# INLINE indexSmallArray## #-}++-- | Create a copy of a slice of an immutable array.+cloneSmallArray+  :: SmallArray a -- ^ source+  -> Int          -- ^ offset+  -> Int          -- ^ length+  -> SmallArray a+cloneSmallArray (SmallArray sa#) (I# i#) (I# j#) =+  SmallArray (cloneSmallArray# sa# i# j#)+{-# INLINE cloneSmallArray #-}++-- | Create a copy of a slice of a mutable array.+cloneSmallMutableArray+  :: PrimMonad m+  => SmallMutableArray (PrimState m) a -- ^ source+  -> Int                               -- ^ offset+  -> Int                               -- ^ length+  -> m (SmallMutableArray (PrimState m) a)+cloneSmallMutableArray (SmallMutableArray sma#) (I# o#) (I# l#) =+  primitive $ \s -> case cloneSmallMutableArray# sma# o# l# s of+    (# s', smb# #) -> (# s', SmallMutableArray smb# #)+{-# INLINE cloneSmallMutableArray #-}++-- | Create an immutable array corresponding to a slice of a mutable array.+--+-- This operation copies the portion of the array to be frozen.+freezeSmallArray+  :: PrimMonad m+  => SmallMutableArray (PrimState m) a -- ^ source+  -> Int                               -- ^ offset+  -> Int                               -- ^ length+  -> m (SmallArray a)+freezeSmallArray (SmallMutableArray sma#) (I# i#) (I# j#) =+  primitive $ \s -> case freezeSmallArray# sma# i# j# s of+    (# s', sa# #) -> (# s', SmallArray sa# #)+{-# INLINE freezeSmallArray #-}++-- | Render a mutable array immutable.+--+-- This operation performs no copying, so care must be taken not to modify the+-- input array after freezing.+unsafeFreezeSmallArray+  :: PrimMonad m => SmallMutableArray (PrimState m) a -> m (SmallArray a)+unsafeFreezeSmallArray (SmallMutableArray sma#) =+  primitive $ \s -> case unsafeFreezeSmallArray# sma# s of+    (# s', sa# #) -> (# s', SmallArray sa# #)+{-# INLINE unsafeFreezeSmallArray #-}++-- | Create a mutable array corresponding to a slice of an immutable array.+--+-- This operation copies the portion of the array to be thawed.+thawSmallArray+  :: PrimMonad m+  => SmallArray a -- ^ source+  -> Int          -- ^ offset+  -> Int          -- ^ length+  -> m (SmallMutableArray (PrimState m) a)+thawSmallArray (SmallArray sa#) (I# o#) (I# l#) =+  primitive $ \s -> case thawSmallArray# sa# o# l# s of+    (# s', sma# #) -> (# s', SmallMutableArray sma# #)+{-# INLINE thawSmallArray #-}++-- | Render an immutable array mutable.+--+-- This operation performs no copying, so care must be taken with its use.+unsafeThawSmallArray+  :: PrimMonad m => SmallArray a -> m (SmallMutableArray (PrimState m) a)+unsafeThawSmallArray (SmallArray sa#) =+  primitive $ \s -> case unsafeThawSmallArray# sa# s of+    (# s', sma# #) -> (# s', SmallMutableArray sma# #)+{-# INLINE unsafeThawSmallArray #-}++-- | Copy a slice of an immutable array into a mutable array.+copySmallArray+  :: PrimMonad m+  => SmallMutableArray (PrimState m) a -- ^ destination+  -> Int                               -- ^ destination offset+  -> SmallArray a                      -- ^ source+  -> Int                               -- ^ source offset+  -> Int                               -- ^ length+  -> m ()+copySmallArray+  (SmallMutableArray dst#) (I# do#) (SmallArray src#) (I# so#) (I# l#) =+    primitive_ $ copySmallArray# src# so# dst# do# l#+{-# INLINE copySmallArray #-}++-- | Copy a slice of one mutable array into another.+copySmallMutableArray+  :: PrimMonad m+  => SmallMutableArray (PrimState m) a -- ^ destination+  -> Int                               -- ^ destination offset+  -> SmallMutableArray (PrimState m) a -- ^ source+  -> Int                               -- ^ source offset+  -> Int                               -- ^ length+  -> m ()+copySmallMutableArray+  (SmallMutableArray dst#) (I# do#)+  (SmallMutableArray src#) (I# so#)+  (I# l#) =+    primitive_ $ copySmallMutableArray# src# so# dst# do# l#+{-# INLINE copySmallMutableArray #-}++sizeofSmallArray :: SmallArray a -> Int+sizeofSmallArray (SmallArray sa#) = I# (sizeofSmallArray# sa#)+{-# INLINE sizeofSmallArray #-}++sizeofSmallMutableArray :: SmallMutableArray s a -> Int+sizeofSmallMutableArray (SmallMutableArray sa#) =+  I# (sizeofSmallMutableArray# sa#)+{-# INLINE sizeofSmallMutableArray #-}++-- | This is the fastest, most straightforward way to traverse+-- an array, but it only works correctly with a sufficiently+-- "affine" 'PrimMonad' instance. In particular, it must only produce+-- *one* result array. 'Control.Monad.Trans.List.ListT'-transformed+-- monads, for example, will not work right at all.+traverseSmallArrayP+  :: PrimMonad m+  => (a -> m b)+  -> SmallArray a+  -> m (SmallArray b)+traverseSmallArrayP f !ary =+  let+    !sz = sizeofSmallArray ary+    go !i !mary+      | i == sz+      = unsafeFreezeSmallArray mary+      | otherwise+      = do+          a <- indexSmallArrayM ary i+          b <- f a+          writeSmallArray mary i b+          go (i + 1) mary+  in do+    mary <- newSmallArray sz badTraverseValue+    go 0 mary+{-# INLINE traverseSmallArrayP #-}++-- | Strict map over the elements of the array.+mapSmallArray' :: (a -> b) -> SmallArray a -> SmallArray b+mapSmallArray' f sa = createSmallArray (length sa) (die "mapSmallArray'" "impossible") $ \smb ->+  fix ? 0 $ \go i ->+    when (i < length sa) $ do+      x <- indexSmallArrayM sa i+      let !y = f x+      writeSmallArray smb i y *> go (i+1)+{-# INLINE mapSmallArray' #-}++#if !MIN_VERSION_base(4,9,0)+runSmallArray+  :: (forall s. ST s (SmallMutableArray s a))+  -> SmallArray a+runSmallArray m = runST $ m >>= unsafeFreezeSmallArray++#else+-- This low-level business is designed to work with GHC's worker-wrapper+-- transformation. A lot of the time, we don't actually need an Array+-- constructor. By putting it on the outside, and being careful about+-- how we special-case the empty array, we can make GHC smarter about this.+-- The only downside is that separately created 0-length arrays won't share+-- their Array constructors, although they'll share their underlying+-- Array#s.+runSmallArray+  :: (forall s. ST s (SmallMutableArray s a))+  -> SmallArray a+runSmallArray m = SmallArray (runSmallArray# m)++runSmallArray#+  :: (forall s. ST s (SmallMutableArray s a))+  -> SmallArray# a+runSmallArray# m = case runRW# $ \s ->+  case unST m s of { (# s', SmallMutableArray mary# #) ->+  unsafeFreezeSmallArray# mary# s'} of (# _, ary# #) -> ary#++unST :: ST s a -> State# s -> (# State# s, a #)+unST (GHCST.ST f) = f++#endif++-- See the comment on runSmallArray for why we use emptySmallArray#.+createSmallArray+  :: Int+  -> a+  -> (forall s. SmallMutableArray s a -> ST s ())+  -> SmallArray a+createSmallArray 0 _ _ = SmallArray (emptySmallArray# (# #))+createSmallArray n x f = runSmallArray $ do+  mary <- newSmallArray n x+  f mary+  pure mary++emptySmallArray# :: (# #) -> SmallArray# a+emptySmallArray# _ = case emptySmallArray of SmallArray ar -> ar+{-# NOINLINE emptySmallArray# #-}++die :: String -> String -> a+die fun problem = error $ "Data.Primitive.SmallArray." ++ fun ++ ": " ++ problem++emptySmallArray :: SmallArray a+emptySmallArray =+  runST $ newSmallArray 0 (die "emptySmallArray" "impossible")+            >>= unsafeFreezeSmallArray+{-# NOINLINE emptySmallArray #-}+++infixl 1 ?+(?) :: (a -> b -> c) -> (b -> a -> c)+(?) = flip+{-# INLINE (?) #-}++noOp :: a -> ST s ()+noOp = const $ pure ()++smallArrayLiftEq :: (a -> b -> Bool) -> SmallArray a -> SmallArray b -> Bool+smallArrayLiftEq p sa1 sa2 = length sa1 == length sa2 && loop (length sa1 - 1)+  where+  loop i+    | i < 0+    = True+    | (# x #) <- indexSmallArray## sa1 i+    , (# y #) <- indexSmallArray## sa2 i+    = p x y && loop (i-1)++#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)+-- | @since 0.6.4.0+instance Eq1 SmallArray where+#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)+  liftEq = smallArrayLiftEq+#else+  eq1 = smallArrayLiftEq (==)+#endif+#endif++instance Eq a => Eq (SmallArray a) where+  sa1 == sa2 = smallArrayLiftEq (==) sa1 sa2++instance Eq (SmallMutableArray s a) where+  SmallMutableArray sma1# == SmallMutableArray sma2# =+    isTrue# (sameSmallMutableArray# sma1# sma2#)++smallArrayLiftCompare :: (a -> b -> Ordering) -> SmallArray a -> SmallArray b -> Ordering+smallArrayLiftCompare elemCompare a1 a2 = loop 0+  where+  mn = length a1 `min` length a2+  loop i+    | i < mn+    , (# x1 #) <- indexSmallArray## a1 i+    , (# x2 #) <- indexSmallArray## a2 i+    = elemCompare x1 x2 `mappend` loop (i+1)+    | otherwise = compare (length a1) (length a2)++#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)+-- | @since 0.6.4.0+instance Ord1 SmallArray where+#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)+  liftCompare = smallArrayLiftCompare+#else+  compare1 = smallArrayLiftCompare compare+#endif+#endif++-- | Lexicographic ordering. Subject to change between major versions.+instance Ord a => Ord (SmallArray a) where+  compare = smallArrayLiftCompare compare++instance Foldable SmallArray where+  -- Note: we perform the array lookups eagerly so we won't+  -- create thunks to perform lookups even if GHC can't see+  -- that the folding function is strict.+  foldr f = \z !ary ->+    let+      !sz = sizeofSmallArray ary+      go i+        | i == sz = z+        | (# x #) <- indexSmallArray## ary i+        = f x (go (i+1))+    in go 0+  {-# INLINE foldr #-}+  foldl f = \z !ary ->+    let+      go i+        | i < 0 = z+        | (# x #) <- indexSmallArray## ary i+        = f (go (i-1)) x+    in go (sizeofSmallArray ary - 1)+  {-# INLINE foldl #-}+  foldr1 f = \ !ary ->+    let+      !sz = sizeofSmallArray ary - 1+      go i =+        case indexSmallArray## ary i of+          (# x #) | i == sz -> x+                  | otherwise -> f x (go (i+1))+    in if sz < 0+       then die "foldr1" "Empty SmallArray"+       else go 0+  {-# INLINE foldr1 #-}+  foldl1 f = \ !ary ->+    let+      !sz = sizeofSmallArray ary - 1+      go i =+        case indexSmallArray## ary i of+          (# x #) | i == 0 -> x+                  | otherwise -> f (go (i - 1)) x+    in if sz < 0+       then die "foldl1" "Empty SmallArray"+       else go sz+  {-# INLINE foldl1 #-}+  foldr' f = \z !ary ->+    let+      go i !acc+        | i == -1 = acc+        | (# x #) <- indexSmallArray## ary i+        = go (i-1) (f x acc)+    in go (sizeofSmallArray ary - 1) z+  {-# INLINE foldr' #-}+  foldl' f = \z !ary ->+    let+      !sz = sizeofSmallArray ary+      go i !acc+        | i == sz = acc+        | (# x #) <- indexSmallArray## ary i+        = go (i+1) (f acc x)+    in go 0 z+  {-# INLINE foldl' #-}+  null a = sizeofSmallArray a == 0+  {-# INLINE null #-}+  length = sizeofSmallArray+  {-# INLINE length #-}+  maximum ary | sz == 0   = die "maximum" "Empty SmallArray"+              | (# frst #) <- indexSmallArray## ary 0+              = go 1 frst+   where+     sz = sizeofSmallArray ary+     go i !e+       | i == sz = e+       | (# x #) <- indexSmallArray## ary i+       = go (i+1) (max e x)+  {-# INLINE maximum #-}+  minimum ary | sz == 0   = die "minimum" "Empty SmallArray"+              | (# frst #) <- indexSmallArray## ary 0+              = go 1 frst+   where sz = sizeofSmallArray ary+         go i !e+           | i == sz = e+           | (# x #) <- indexSmallArray## ary i+           = go (i+1) (min e x)+  {-# INLINE minimum #-}+  sum = foldl' (+) 0+  {-# INLINE sum #-}+  product = foldl' (*) 1+  {-# INLINE product #-}++newtype STA a = STA {_runSTA :: forall s. SmallMutableArray# s a -> ST s (SmallArray a)}++runSTA :: Int -> STA a -> SmallArray a+runSTA !sz = \ (STA m) -> runST $ newSmallArray_ sz >>=+                        \ (SmallMutableArray ar#) -> m ar#+{-# INLINE runSTA #-}++newSmallArray_ :: Int -> ST s (SmallMutableArray s a)+newSmallArray_ !n = newSmallArray n badTraverseValue++badTraverseValue :: a+badTraverseValue = die "traverse" "bad indexing"+{-# NOINLINE badTraverseValue #-}++instance Traversable SmallArray where+  traverse f = traverseSmallArray f+  {-# INLINE traverse #-}++traverseSmallArray+  :: Applicative f+  => (a -> f b) -> SmallArray a -> f (SmallArray b)+traverseSmallArray f = \ !ary ->+  let+    !len = sizeofSmallArray ary+    go !i+      | i == len+      = pure $ STA $ \mary -> unsafeFreezeSmallArray (SmallMutableArray mary)+      | (# x #) <- indexSmallArray## ary i+      = liftA2 (\b (STA m) -> STA $ \mary ->+                  writeSmallArray (SmallMutableArray mary) i b >> m mary)+               (f x) (go (i + 1))+  in if len == 0+     then pure emptySmallArray+     else runSTA len <$> go 0+{-# INLINE [1] traverseSmallArray #-}++{-# RULES+"traverse/ST" forall (f :: a -> ST s b). traverseSmallArray f = traverseSmallArrayP f+"traverse/IO" forall (f :: a -> IO b). traverseSmallArray f = traverseSmallArrayP f+"traverse/Id" forall (f :: a -> Identity b). traverseSmallArray f =+   (coerce :: (SmallArray a -> SmallArray (Identity b))+           -> SmallArray a -> Identity (SmallArray b)) (fmap f)+ #-}+++instance Functor SmallArray where+  fmap f sa = createSmallArray (length sa) (die "fmap" "impossible") $ \smb ->+    fix ? 0 $ \go i ->+      when (i < length sa) $ do+        x <- indexSmallArrayM sa i+        writeSmallArray smb i (f x) *> go (i+1)+  {-# INLINE fmap #-}++  x <$ sa = createSmallArray (length sa) x noOp++instance Applicative SmallArray where+  pure x = createSmallArray 1 x noOp++  sa *> sb = createSmallArray (la*lb) (die "*>" "impossible") $ \smb ->+    fix ? 0 $ \go i ->+      when (i < la) $+        copySmallArray smb 0 sb 0 lb *> go (i+1)+   where+   la = length sa ; lb = length sb++  a <* b = createSmallArray (sza*szb) (die "<*" "impossible") $ \ma ->+    let fill off i e = when (i < szb) $+                         writeSmallArray ma (off+i) e >> fill off (i+1) e+        go i = when (i < sza) $ do+                 x <- indexSmallArrayM a i+                 fill (i*szb) 0 x+                 go (i+1)+     in go 0+   where sza = sizeofSmallArray a ; szb = sizeofSmallArray b++  ab <*> a = createSmallArray (szab*sza) (die "<*>" "impossible") $ \mb ->+    let go1 i = when (i < szab) $+            do+              f <- indexSmallArrayM ab i+              go2 (i*sza) f 0+              go1 (i+1)+        go2 off f j = when (j < sza) $+            do+              x <- indexSmallArrayM a j+              writeSmallArray mb (off + j) (f x)+              go2 off f (j + 1)+    in go1 0+   where szab = sizeofSmallArray ab ; sza = sizeofSmallArray a++instance Alternative SmallArray where+  empty = emptySmallArray++  sl <|> sr =+    createSmallArray (length sl + length sr) (die "<|>" "impossible") $ \sma ->+      copySmallArray sma 0 sl 0 (length sl)+        *> copySmallArray sma (length sl) sr 0 (length sr)++  many sa | null sa   = pure []+          | otherwise = die "many" "infinite arrays are not well defined"++  some sa | null sa   = emptySmallArray+          | otherwise = die "some" "infinite arrays are not well defined"++data ArrayStack a+  = PushArray !(SmallArray a) !(ArrayStack a)+  | EmptyStack+-- TODO: This isn't terribly efficient. It would be better to wrap+-- ArrayStack with a type like+--+-- data NES s a = NES !Int !(SmallMutableArray s a) !(ArrayStack a)+--+-- We'd copy incoming arrays into the mutable array until we would+-- overflow it. Then we'd freeze it, push it on the stack, and continue.+-- Any sufficiently large incoming arrays would go straight on the stack.+-- Such a scheme would make the stack much more compact in the case+-- of many small arrays.++instance Monad SmallArray where+  return = pure+  (>>) = (*>)++  sa >>= f = collect 0 EmptyStack (la-1)+   where+   la = length sa+   collect sz stk i+     | i < 0 = createSmallArray sz (die ">>=" "impossible") $ fill 0 stk+     | (# x #) <- indexSmallArray## sa i+     , let sb = f x+           lsb = length sb+       -- If we don't perform this check, we could end up allocating+       -- a stack full of empty arrays if someone is filtering most+       -- things out. So we refrain from pushing empty arrays.+     = if lsb == 0+       then collect sz stk (i-1)+       else collect (sz + lsb) (PushArray sb stk) (i-1)++   fill _ EmptyStack _ = return ()+   fill off (PushArray sb sbs) smb =+     copySmallArray smb off sb 0 (length sb)+       *> fill (off + length sb) sbs smb++#if !(MIN_VERSION_base(4,13,0)) && MIN_VERSION_base(4,9,0)+  fail = Fail.fail+#endif++#if MIN_VERSION_base(4,9,0)+instance Fail.MonadFail SmallArray where+  fail _ = emptySmallArray+#endif++instance MonadPlus SmallArray where+  mzero = empty+  mplus = (<|>)++zipW :: String -> (a -> b -> c) -> SmallArray a -> SmallArray b -> SmallArray c+zipW nm f sa sb =+  let mn = length sa `min` length sb in+  createSmallArray mn (die nm "impossible") $ \mc ->+    fix ? 0 $ \go i -> when (i < mn) $ do+      x <- indexSmallArrayM sa i+      y <- indexSmallArrayM sb i+      writeSmallArray mc i (f x y)+      go (i+1)+{-# INLINE zipW #-}++instance MonadZip SmallArray where+  mzip = zipW "mzip" (,)+  mzipWith = zipW "mzipWith"+  {-# INLINE mzipWith #-}+  munzip sab = runST $ do+    let sz = length sab+    sma <- newSmallArray sz $ die "munzip" "impossible"+    smb <- newSmallArray sz $ die "munzip" "impossible"+    fix ? 0 $ \go i ->+      when (i < sz) $ case indexSmallArray sab i of+        (x, y) -> do writeSmallArray sma i x+                     writeSmallArray smb i y+                     go $ i+1+    (,) <$> unsafeFreezeSmallArray sma+        <*> unsafeFreezeSmallArray smb++instance MonadFix SmallArray where+  mfix f = createSmallArray (sizeofSmallArray (f err))+                            (die "mfix" "impossible") $ flip fix 0 $+    \r !i !mary -> when (i < sz) $ do+                      writeSmallArray mary i (fix (\xi -> f xi `indexSmallArray` i))+                      r (i + 1) mary+    where+      sz = sizeofSmallArray (f err)+      err = error "mfix for Data.Primitive.SmallArray applied to strict function."++#if MIN_VERSION_base(4,9,0)+-- | @since 0.6.3.0+instance Sem.Semigroup (SmallArray a) where+  (<>) = (<|>)+  sconcat = mconcat . toList+#endif++instance Monoid (SmallArray a) where+  mempty = empty+#if !(MIN_VERSION_base(4,11,0))+  mappend = (<|>)+#endif+  mconcat l = createSmallArray n (die "mconcat" "impossible") $ \ma ->+    let go !_  [    ] = return ()+        go off (a:as) =+          copySmallArray ma off a 0 (sizeofSmallArray a) >> go (off + sizeofSmallArray a) as+     in go 0 l+   where n = sum . fmap length $ l++instance IsList (SmallArray a) where+  type Item (SmallArray a) = a+  fromListN = smallArrayFromListN+  fromList = smallArrayFromList+  toList = Foldable.toList++smallArrayLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> SmallArray a -> ShowS+smallArrayLiftShowsPrec elemShowsPrec elemListShowsPrec p sa = showParen (p > 10) $+  showString "fromListN " . shows (length sa) . showString " "+    . listLiftShowsPrec elemShowsPrec elemListShowsPrec 11 (toList sa)++-- this need to be included for older ghcs+listLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> [a] -> ShowS+listLiftShowsPrec _ sl _ = sl++instance Show a => Show (SmallArray a) where+  showsPrec = smallArrayLiftShowsPrec showsPrec showList++#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)+-- | @since 0.6.4.0+instance Show1 SmallArray where+#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)+  liftShowsPrec = smallArrayLiftShowsPrec+#else+  showsPrec1 = smallArrayLiftShowsPrec showsPrec showList+#endif+#endif++smallArrayLiftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (SmallArray a)+smallArrayLiftReadsPrec _ listReadsPrec p = readParen (p > 10) . readP_to_S $ do+  () <$ string "fromListN"+  skipSpaces+  n <- readS_to_P reads+  skipSpaces+  l <- readS_to_P listReadsPrec+  return $ smallArrayFromListN n l++instance Read a => Read (SmallArray a) where+  readsPrec = smallArrayLiftReadsPrec readsPrec readList++#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)+-- | @since 0.6.4.0+instance Read1 SmallArray where+#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)+  liftReadsPrec = smallArrayLiftReadsPrec+#else+  readsPrec1 = smallArrayLiftReadsPrec readsPrec readList+#endif+#endif++++smallArrayDataType :: DataType+smallArrayDataType =+  mkDataType "Data.Primitive.SmallArray.SmallArray" [fromListConstr]++fromListConstr :: Constr+fromListConstr = mkConstr smallArrayDataType "fromList" [] Prefix++instance Data a => Data (SmallArray a) where+  toConstr _ = fromListConstr+  dataTypeOf _ = smallArrayDataType+  gunfold k z c = case constrIndex c of+    1 -> k (z fromList)+    _ -> die "gunfold" "SmallArray"+  gfoldl f z m = z fromList `f` toList m++instance (Typeable s, Typeable a) => Data (SmallMutableArray s a) where+  toConstr _ = die "toConstr" "SmallMutableArray"+  gunfold _ _ = die "gunfold" "SmallMutableArray"+  dataTypeOf _ = mkNoRepType "Data.Primitive.SmallArray.SmallMutableArray"++-- | Create a 'SmallArray' from a list of a known length. If the length+--   of the list does not match the given length, this throws an exception.+smallArrayFromListN :: Int -> [a] -> SmallArray a+smallArrayFromListN n l =+  createSmallArray n+      (die "smallArrayFromListN" "uninitialized element") $ \sma ->+  let go !ix [] = if ix == n+        then return ()+        else die "smallArrayFromListN" "list length less than specified size"+      go !ix (x : xs) = if ix < n+        then do+          writeSmallArray sma ix x+          go (ix+1) xs+        else die "smallArrayFromListN" "list length greater than specified size"+  in go 0 l++-- | Create a 'SmallArray' from a list.+smallArrayFromList :: [a] -> SmallArray a+smallArrayFromList l = smallArrayFromListN (length l) l
− src/Streamly/Internal/Data/SmallArray/Types.hs 
@@ -1,834 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UnboxedTuples #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE BangPatterns #-}---- |--- Module : Data.Primitive.SmallArray--- Copyright: (c) 2015 Dan Doel--- License: BSD3------ Maintainer  : streamly@composewell.com--- Portability: non-portable------ Small arrays are boxed (im)mutable arrays.------ The underlying structure of the 'Array' type contains a card table, allowing--- segments of the array to be marked as having been mutated. This allows the--- garbage collector to only re-traverse segments of the array that have been--- marked during certain phases, rather than having to traverse the entire--- array.------ 'SmallArray' lacks this table. This means that it takes up less memory and--- has slightly faster writes. It is also more efficient during garbage--- collection so long as the card table would have a single entry covering the--- entire array. These advantages make them suitable for use as arrays that are--- known to be small.------ The card size is 128, so for uses much larger than that, 'Array' would likely--- be superior.------ The underlying type, 'SmallArray#', was introduced in GHC 7.10, so prior to--- that version, this module simply implements small arrays as 'Array'.--module Streamly.Internal.Data.SmallArray.Types-  ( SmallArray(..)-  , SmallMutableArray(..)-  , newSmallArray-  , readSmallArray-  , writeSmallArray-  , copySmallArray-  , copySmallMutableArray-  , indexSmallArray-  , indexSmallArrayM-  , indexSmallArray##-  , cloneSmallArray-  , cloneSmallMutableArray-  , freezeSmallArray-  , unsafeFreezeSmallArray-  , thawSmallArray-  , runSmallArray-  , unsafeThawSmallArray-  , sizeofSmallArray-  , sizeofSmallMutableArray-  , smallArrayFromList-  , smallArrayFromListN-  , mapSmallArray'-  , traverseSmallArrayP-  ) where--import GHC.Exts hiding (toList)-import qualified GHC.Exts--import Control.Applicative-import Control.Monad-#if MIN_VERSION_base(4,9,0)-import qualified Control.Monad.Fail as Fail-#endif-import Control.Monad.Fix-import Control.Monad.Primitive-import Control.Monad.ST-import Control.Monad.Zip-import Data.Data-import Data.Foldable as Foldable-import Data.Functor.Identity-#if !(MIN_VERSION_base(4,10,0))-import Data.Monoid-#endif-#if MIN_VERSION_base(4,9,0)-import qualified GHC.ST as GHCST-import qualified Data.Semigroup as Sem-#endif-import Text.ParserCombinators.ReadP--#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,10,0)-import GHC.Base (runRW#)-#endif--#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)-import Data.Functor.Classes (Eq1(..),Ord1(..),Show1(..),Read1(..))-#endif--data SmallArray a = SmallArray (SmallArray# a)-  deriving Typeable--data SmallMutableArray s a = SmallMutableArray (SmallMutableArray# s a)-  deriving Typeable---- | Create a new small mutable array.-newSmallArray-  :: PrimMonad m-  => Int -- ^ size-  -> a   -- ^ initial contents-  -> m (SmallMutableArray (PrimState m) a)-newSmallArray (I# i#) x = primitive $ \s ->-  case newSmallArray# i# x s of-    (# s', sma# #) -> (# s', SmallMutableArray sma# #)-{-# INLINE newSmallArray #-}---- | Read the element at a given index in a mutable array.-readSmallArray-  :: PrimMonad m-  => SmallMutableArray (PrimState m) a -- ^ array-  -> Int                               -- ^ index-  -> m a-readSmallArray (SmallMutableArray sma#) (I# i#) =-  primitive $ readSmallArray# sma# i#-{-# INLINE readSmallArray #-}---- | Write an element at the given idex in a mutable array.-writeSmallArray-  :: PrimMonad m-  => SmallMutableArray (PrimState m) a -- ^ array-  -> Int                               -- ^ index-  -> a                                 -- ^ new element-  -> m ()-writeSmallArray (SmallMutableArray sma#) (I# i#) x =-  primitive_ $ writeSmallArray# sma# i# x-{-# INLINE writeSmallArray #-}---- | Look up an element in an immutable array.------ The purpose of returning a result using a monad is to allow the caller to--- avoid retaining references to the array. Evaluating the return value will--- cause the array lookup to be performed, even though it may not require the--- element of the array to be evaluated (which could throw an exception). For--- instance:------ > data Box a = Box a--- > ...--- >--- > f sa = case indexSmallArrayM sa 0 of--- >   Box x -> ...------ 'x' is not a closure that references 'sa' as it would be if we instead--- wrote:------ > let x = indexSmallArray sa 0------ And does not prevent 'sa' from being garbage collected.------ Note that 'Identity' is not adequate for this use, as it is a newtype, and--- cannot be evaluated without evaluating the element.-indexSmallArrayM-  :: Monad m-  => SmallArray a -- ^ array-  -> Int          -- ^ index-  -> m a-indexSmallArrayM (SmallArray sa#) (I# i#) =-  case indexSmallArray# sa# i# of-    (# x #) -> pure x-{-# INLINE indexSmallArrayM #-}---- | Look up an element in an immutable array.-indexSmallArray-  :: SmallArray a -- ^ array-  -> Int          -- ^ index-  -> a-indexSmallArray sa i = runIdentity $ indexSmallArrayM sa i-{-# INLINE indexSmallArray #-}---- | Read a value from the immutable array at the given index, returning--- the result in an unboxed unary tuple. This is currently used to implement--- folds.-indexSmallArray## :: SmallArray a -> Int -> (# a #)-indexSmallArray## (SmallArray ary) (I# i) = indexSmallArray# ary i-{-# INLINE indexSmallArray## #-}---- | Create a copy of a slice of an immutable array.-cloneSmallArray-  :: SmallArray a -- ^ source-  -> Int          -- ^ offset-  -> Int          -- ^ length-  -> SmallArray a-cloneSmallArray (SmallArray sa#) (I# i#) (I# j#) =-  SmallArray (cloneSmallArray# sa# i# j#)-{-# INLINE cloneSmallArray #-}---- | Create a copy of a slice of a mutable array.-cloneSmallMutableArray-  :: PrimMonad m-  => SmallMutableArray (PrimState m) a -- ^ source-  -> Int                               -- ^ offset-  -> Int                               -- ^ length-  -> m (SmallMutableArray (PrimState m) a)-cloneSmallMutableArray (SmallMutableArray sma#) (I# o#) (I# l#) =-  primitive $ \s -> case cloneSmallMutableArray# sma# o# l# s of-    (# s', smb# #) -> (# s', SmallMutableArray smb# #)-{-# INLINE cloneSmallMutableArray #-}---- | Create an immutable array corresponding to a slice of a mutable array.------ This operation copies the portion of the array to be frozen.-freezeSmallArray-  :: PrimMonad m-  => SmallMutableArray (PrimState m) a -- ^ source-  -> Int                               -- ^ offset-  -> Int                               -- ^ length-  -> m (SmallArray a)-freezeSmallArray (SmallMutableArray sma#) (I# i#) (I# j#) =-  primitive $ \s -> case freezeSmallArray# sma# i# j# s of-    (# s', sa# #) -> (# s', SmallArray sa# #)-{-# INLINE freezeSmallArray #-}---- | Render a mutable array immutable.------ This operation performs no copying, so care must be taken not to modify the--- input array after freezing.-unsafeFreezeSmallArray-  :: PrimMonad m => SmallMutableArray (PrimState m) a -> m (SmallArray a)-unsafeFreezeSmallArray (SmallMutableArray sma#) =-  primitive $ \s -> case unsafeFreezeSmallArray# sma# s of-    (# s', sa# #) -> (# s', SmallArray sa# #)-{-# INLINE unsafeFreezeSmallArray #-}---- | Create a mutable array corresponding to a slice of an immutable array.------ This operation copies the portion of the array to be thawed.-thawSmallArray-  :: PrimMonad m-  => SmallArray a -- ^ source-  -> Int          -- ^ offset-  -> Int          -- ^ length-  -> m (SmallMutableArray (PrimState m) a)-thawSmallArray (SmallArray sa#) (I# o#) (I# l#) =-  primitive $ \s -> case thawSmallArray# sa# o# l# s of-    (# s', sma# #) -> (# s', SmallMutableArray sma# #)-{-# INLINE thawSmallArray #-}---- | Render an immutable array mutable.------ This operation performs no copying, so care must be taken with its use.-unsafeThawSmallArray-  :: PrimMonad m => SmallArray a -> m (SmallMutableArray (PrimState m) a)-unsafeThawSmallArray (SmallArray sa#) =-  primitive $ \s -> case unsafeThawSmallArray# sa# s of-    (# s', sma# #) -> (# s', SmallMutableArray sma# #)-{-# INLINE unsafeThawSmallArray #-}---- | Copy a slice of an immutable array into a mutable array.-copySmallArray-  :: PrimMonad m-  => SmallMutableArray (PrimState m) a -- ^ destination-  -> Int                               -- ^ destination offset-  -> SmallArray a                      -- ^ source-  -> Int                               -- ^ source offset-  -> Int                               -- ^ length-  -> m ()-copySmallArray-  (SmallMutableArray dst#) (I# do#) (SmallArray src#) (I# so#) (I# l#) =-    primitive_ $ copySmallArray# src# so# dst# do# l#-{-# INLINE copySmallArray #-}---- | Copy a slice of one mutable array into another.-copySmallMutableArray-  :: PrimMonad m-  => SmallMutableArray (PrimState m) a -- ^ destination-  -> Int                               -- ^ destination offset-  -> SmallMutableArray (PrimState m) a -- ^ source-  -> Int                               -- ^ source offset-  -> Int                               -- ^ length-  -> m ()-copySmallMutableArray-  (SmallMutableArray dst#) (I# do#)-  (SmallMutableArray src#) (I# so#)-  (I# l#) =-    primitive_ $ copySmallMutableArray# src# so# dst# do# l#-{-# INLINE copySmallMutableArray #-}--sizeofSmallArray :: SmallArray a -> Int-sizeofSmallArray (SmallArray sa#) = I# (sizeofSmallArray# sa#)-{-# INLINE sizeofSmallArray #-}--sizeofSmallMutableArray :: SmallMutableArray s a -> Int-sizeofSmallMutableArray (SmallMutableArray sa#) =-  I# (sizeofSmallMutableArray# sa#)-{-# INLINE sizeofSmallMutableArray #-}---- | This is the fastest, most straightforward way to traverse--- an array, but it only works correctly with a sufficiently--- "affine" 'PrimMonad' instance. In particular, it must only produce--- *one* result array. 'Control.Monad.Trans.List.ListT'-transformed--- monads, for example, will not work right at all.-traverseSmallArrayP-  :: PrimMonad m-  => (a -> m b)-  -> SmallArray a-  -> m (SmallArray b)-traverseSmallArrayP f = \ !ary ->-  let-    !sz = sizeofSmallArray ary-    go !i !mary-      | i == sz-      = unsafeFreezeSmallArray mary-      | otherwise-      = do-          a <- indexSmallArrayM ary i-          b <- f a-          writeSmallArray mary i b-          go (i + 1) mary-  in do-    mary <- newSmallArray sz badTraverseValue-    go 0 mary-{-# INLINE traverseSmallArrayP #-}---- | Strict map over the elements of the array.-mapSmallArray' :: (a -> b) -> SmallArray a -> SmallArray b-mapSmallArray' f sa = createSmallArray (length sa) (die "mapSmallArray'" "impossible") $ \smb ->-  fix ? 0 $ \go i ->-    when (i < length sa) $ do-      x <- indexSmallArrayM sa i-      let !y = f x-      writeSmallArray smb i y *> go (i+1)-{-# INLINE mapSmallArray' #-}--#if !MIN_VERSION_base(4,9,0)-runSmallArray-  :: (forall s. ST s (SmallMutableArray s a))-  -> SmallArray a-runSmallArray m = runST $ m >>= unsafeFreezeSmallArray--#else--- This low-level business is designed to work with GHC's worker-wrapper--- transformation. A lot of the time, we don't actually need an Array--- constructor. By putting it on the outside, and being careful about--- how we special-case the empty array, we can make GHC smarter about this.--- The only downside is that separately created 0-length arrays won't share--- their Array constructors, although they'll share their underlying--- Array#s.-runSmallArray-  :: (forall s. ST s (SmallMutableArray s a))-  -> SmallArray a-runSmallArray m = SmallArray (runSmallArray# m)--runSmallArray#-  :: (forall s. ST s (SmallMutableArray s a))-  -> SmallArray# a-runSmallArray# m = case runRW# $ \s ->-  case unST m s of { (# s', SmallMutableArray mary# #) ->-  unsafeFreezeSmallArray# mary# s'} of (# _, ary# #) -> ary#--unST :: ST s a -> State# s -> (# State# s, a #)-unST (GHCST.ST f) = f--#endif---- See the comment on runSmallArray for why we use emptySmallArray#.-createSmallArray-  :: Int-  -> a-  -> (forall s. SmallMutableArray s a -> ST s ())-  -> SmallArray a-createSmallArray 0 _ _ = SmallArray (emptySmallArray# (# #))-createSmallArray n x f = runSmallArray $ do-  mary <- newSmallArray n x-  f mary-  pure mary--emptySmallArray# :: (# #) -> SmallArray# a-emptySmallArray# _ = case emptySmallArray of SmallArray ar -> ar-{-# NOINLINE emptySmallArray# #-}--die :: String -> String -> a-die fun problem = error $ "Data.Primitive.SmallArray." ++ fun ++ ": " ++ problem--emptySmallArray :: SmallArray a-emptySmallArray =-  runST $ newSmallArray 0 (die "emptySmallArray" "impossible")-            >>= unsafeFreezeSmallArray-{-# NOINLINE emptySmallArray #-}---infixl 1 ?-(?) :: (a -> b -> c) -> (b -> a -> c)-(?) = flip-{-# INLINE (?) #-}--noOp :: a -> ST s ()-noOp = const $ pure ()--smallArrayLiftEq :: (a -> b -> Bool) -> SmallArray a -> SmallArray b -> Bool-smallArrayLiftEq p sa1 sa2 = length sa1 == length sa2 && loop (length sa1 - 1)-  where-  loop i-    | i < 0-    = True-    | (# x #) <- indexSmallArray## sa1 i-    , (# y #) <- indexSmallArray## sa2 i-    = p x y && loop (i-1)--#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)--- | @since 0.6.4.0-instance Eq1 SmallArray where-#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)-  liftEq = smallArrayLiftEq-#else-  eq1 = smallArrayLiftEq (==)-#endif-#endif--instance Eq a => Eq (SmallArray a) where-  sa1 == sa2 = smallArrayLiftEq (==) sa1 sa2--instance Eq (SmallMutableArray s a) where-  SmallMutableArray sma1# == SmallMutableArray sma2# =-    isTrue# (sameSmallMutableArray# sma1# sma2#)--smallArrayLiftCompare :: (a -> b -> Ordering) -> SmallArray a -> SmallArray b -> Ordering-smallArrayLiftCompare elemCompare a1 a2 = loop 0-  where-  mn = length a1 `min` length a2-  loop i-    | i < mn-    , (# x1 #) <- indexSmallArray## a1 i-    , (# x2 #) <- indexSmallArray## a2 i-    = elemCompare x1 x2 `mappend` loop (i+1)-    | otherwise = compare (length a1) (length a2)--#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)--- | @since 0.6.4.0-instance Ord1 SmallArray where-#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)-  liftCompare = smallArrayLiftCompare-#else-  compare1 = smallArrayLiftCompare compare-#endif-#endif---- | Lexicographic ordering. Subject to change between major versions.-instance Ord a => Ord (SmallArray a) where-  compare sa1 sa2 = smallArrayLiftCompare compare sa1 sa2--instance Foldable SmallArray where-  -- Note: we perform the array lookups eagerly so we won't-  -- create thunks to perform lookups even if GHC can't see-  -- that the folding function is strict.-  foldr f = \z !ary ->-    let-      !sz = sizeofSmallArray ary-      go i-        | i == sz = z-        | (# x #) <- indexSmallArray## ary i-        = f x (go (i+1))-    in go 0-  {-# INLINE foldr #-}-  foldl f = \z !ary ->-    let-      go i-        | i < 0 = z-        | (# x #) <- indexSmallArray## ary i-        = f (go (i-1)) x-    in go (sizeofSmallArray ary - 1)-  {-# INLINE foldl #-}-  foldr1 f = \ !ary ->-    let-      !sz = sizeofSmallArray ary - 1-      go i =-        case indexSmallArray## ary i of-          (# x #) | i == sz -> x-                  | otherwise -> f x (go (i+1))-    in if sz < 0-       then die "foldr1" "Empty SmallArray"-       else go 0-  {-# INLINE foldr1 #-}-  foldl1 f = \ !ary ->-    let-      !sz = sizeofSmallArray ary - 1-      go i =-        case indexSmallArray## ary i of-          (# x #) | i == 0 -> x-                  | otherwise -> f (go (i - 1)) x-    in if sz < 0-       then die "foldl1" "Empty SmallArray"-       else go sz-  {-# INLINE foldl1 #-}-  foldr' f = \z !ary ->-    let-      go i !acc-        | i == -1 = acc-        | (# x #) <- indexSmallArray## ary i-        = go (i-1) (f x acc)-    in go (sizeofSmallArray ary - 1) z-  {-# INLINE foldr' #-}-  foldl' f = \z !ary ->-    let-      !sz = sizeofSmallArray ary-      go i !acc-        | i == sz = acc-        | (# x #) <- indexSmallArray## ary i-        = go (i+1) (f acc x)-    in go 0 z-  {-# INLINE foldl' #-}-  null a = sizeofSmallArray a == 0-  {-# INLINE null #-}-  length = sizeofSmallArray-  {-# INLINE length #-}-  maximum ary | sz == 0   = die "maximum" "Empty SmallArray"-              | (# frst #) <- indexSmallArray## ary 0-              = go 1 frst-   where-     sz = sizeofSmallArray ary-     go i !e-       | i == sz = e-       | (# x #) <- indexSmallArray## ary i-       = go (i+1) (max e x)-  {-# INLINE maximum #-}-  minimum ary | sz == 0   = die "minimum" "Empty SmallArray"-              | (# frst #) <- indexSmallArray## ary 0-              = go 1 frst-   where sz = sizeofSmallArray ary-         go i !e-           | i == sz = e-           | (# x #) <- indexSmallArray## ary i-           = go (i+1) (min e x)-  {-# INLINE minimum #-}-  sum = foldl' (+) 0-  {-# INLINE sum #-}-  product = foldl' (*) 1-  {-# INLINE product #-}--newtype STA a = STA {_runSTA :: forall s. SmallMutableArray# s a -> ST s (SmallArray a)}--runSTA :: Int -> STA a -> SmallArray a-runSTA !sz = \ (STA m) -> runST $ newSmallArray_ sz >>=-                        \ (SmallMutableArray ar#) -> m ar#-{-# INLINE runSTA #-}--newSmallArray_ :: Int -> ST s (SmallMutableArray s a)-newSmallArray_ !n = newSmallArray n badTraverseValue--badTraverseValue :: a-badTraverseValue = die "traverse" "bad indexing"-{-# NOINLINE badTraverseValue #-}--instance Traversable SmallArray where-  traverse f = traverseSmallArray f-  {-# INLINE traverse #-}--traverseSmallArray-  :: Applicative f-  => (a -> f b) -> SmallArray a -> f (SmallArray b)-traverseSmallArray f = \ !ary ->-  let-    !len = sizeofSmallArray ary-    go !i-      | i == len-      = pure $ STA $ \mary -> unsafeFreezeSmallArray (SmallMutableArray mary)-      | (# x #) <- indexSmallArray## ary i-      = liftA2 (\b (STA m) -> STA $ \mary ->-                  writeSmallArray (SmallMutableArray mary) i b >> m mary)-               (f x) (go (i + 1))-  in if len == 0-     then pure emptySmallArray-     else runSTA len <$> go 0-{-# INLINE [1] traverseSmallArray #-}--{-# RULES-"traverse/ST" forall (f :: a -> ST s b). traverseSmallArray f = traverseSmallArrayP f-"traverse/IO" forall (f :: a -> IO b). traverseSmallArray f = traverseSmallArrayP f-"traverse/Id" forall (f :: a -> Identity b). traverseSmallArray f =-   (coerce :: (SmallArray a -> SmallArray (Identity b))-           -> SmallArray a -> Identity (SmallArray b)) (fmap f)- #-}---instance Functor SmallArray where-  fmap f sa = createSmallArray (length sa) (die "fmap" "impossible") $ \smb ->-    fix ? 0 $ \go i ->-      when (i < length sa) $ do-        x <- indexSmallArrayM sa i-        writeSmallArray smb i (f x) *> go (i+1)-  {-# INLINE fmap #-}--  x <$ sa = createSmallArray (length sa) x noOp--instance Applicative SmallArray where-  pure x = createSmallArray 1 x noOp--  sa *> sb = createSmallArray (la*lb) (die "*>" "impossible") $ \smb ->-    fix ? 0 $ \go i ->-      when (i < la) $-        copySmallArray smb 0 sb 0 lb *> go (i+1)-   where-   la = length sa ; lb = length sb--  a <* b = createSmallArray (sza*szb) (die "<*" "impossible") $ \ma ->-    let fill off i e = when (i < szb) $-                         writeSmallArray ma (off+i) e >> fill off (i+1) e-        go i = when (i < sza) $ do-                 x <- indexSmallArrayM a i-                 fill (i*szb) 0 x-                 go (i+1)-     in go 0-   where sza = sizeofSmallArray a ; szb = sizeofSmallArray b--  ab <*> a = createSmallArray (szab*sza) (die "<*>" "impossible") $ \mb ->-    let go1 i = when (i < szab) $-            do-              f <- indexSmallArrayM ab i-              go2 (i*sza) f 0-              go1 (i+1)-        go2 off f j = when (j < sza) $-            do-              x <- indexSmallArrayM a j-              writeSmallArray mb (off + j) (f x)-              go2 off f (j + 1)-    in go1 0-   where szab = sizeofSmallArray ab ; sza = sizeofSmallArray a--instance Alternative SmallArray where-  empty = emptySmallArray--  sl <|> sr =-    createSmallArray (length sl + length sr) (die "<|>" "impossible") $ \sma ->-      copySmallArray sma 0 sl 0 (length sl)-        *> copySmallArray sma (length sl) sr 0 (length sr)--  many sa | null sa   = pure []-          | otherwise = die "many" "infinite arrays are not well defined"--  some sa | null sa   = emptySmallArray-          | otherwise = die "some" "infinite arrays are not well defined"--data ArrayStack a-  = PushArray !(SmallArray a) !(ArrayStack a)-  | EmptyStack--- TODO: This isn't terribly efficient. It would be better to wrap--- ArrayStack with a type like------ data NES s a = NES !Int !(SmallMutableArray s a) !(ArrayStack a)------ We'd copy incoming arrays into the mutable array until we would--- overflow it. Then we'd freeze it, push it on the stack, and continue.--- Any sufficiently large incoming arrays would go straight on the stack.--- Such a scheme would make the stack much more compact in the case--- of many small arrays.--instance Monad SmallArray where-  return = pure-  (>>) = (*>)--  sa >>= f = collect 0 EmptyStack (la-1)-   where-   la = length sa-   collect sz stk i-     | i < 0 = createSmallArray sz (die ">>=" "impossible") $ fill 0 stk-     | (# x #) <- indexSmallArray## sa i-     , let sb = f x-           lsb = length sb-       -- If we don't perform this check, we could end up allocating-       -- a stack full of empty arrays if someone is filtering most-       -- things out. So we refrain from pushing empty arrays.-     = if lsb == 0-       then collect sz stk (i-1)-       else collect (sz + lsb) (PushArray sb stk) (i-1)--   fill _ EmptyStack _ = return ()-   fill off (PushArray sb sbs) smb =-     copySmallArray smb off sb 0 (length sb)-       *> fill (off + length sb) sbs smb--#if !(MIN_VERSION_base(4,13,0)) && MIN_VERSION_base(4,9,0)-  fail = Fail.fail-#endif--#if MIN_VERSION_base(4,9,0)-instance Fail.MonadFail SmallArray where-  fail _ = emptySmallArray-#endif--instance MonadPlus SmallArray where-  mzero = empty-  mplus = (<|>)--zipW :: String -> (a -> b -> c) -> SmallArray a -> SmallArray b -> SmallArray c-zipW nm = \f sa sb -> let mn = length sa `min` length sb in-  createSmallArray mn (die nm "impossible") $ \mc ->-    fix ? 0 $ \go i -> when (i < mn) $ do-      x <- indexSmallArrayM sa i-      y <- indexSmallArrayM sb i-      writeSmallArray mc i (f x y)-      go (i+1)-{-# INLINE zipW #-}--instance MonadZip SmallArray where-  mzip = zipW "mzip" (,)-  mzipWith = zipW "mzipWith"-  {-# INLINE mzipWith #-}-  munzip sab = runST $ do-    let sz = length sab-    sma <- newSmallArray sz $ die "munzip" "impossible"-    smb <- newSmallArray sz $ die "munzip" "impossible"-    fix ? 0 $ \go i ->-      when (i < sz) $ case indexSmallArray sab i of-        (x, y) -> do writeSmallArray sma i x-                     writeSmallArray smb i y-                     go $ i+1-    (,) <$> unsafeFreezeSmallArray sma-        <*> unsafeFreezeSmallArray smb--instance MonadFix SmallArray where-  mfix f = createSmallArray (sizeofSmallArray (f err))-                            (die "mfix" "impossible") $ flip fix 0 $-    \r !i !mary -> when (i < sz) $ do-                      writeSmallArray mary i (fix (\xi -> f xi `indexSmallArray` i))-                      r (i + 1) mary-    where-      sz = sizeofSmallArray (f err)-      err = error "mfix for Data.Primitive.SmallArray applied to strict function."--#if MIN_VERSION_base(4,9,0)--- | @since 0.6.3.0-instance Sem.Semigroup (SmallArray a) where-  (<>) = (<|>)-  sconcat = mconcat . toList-#endif--instance Monoid (SmallArray a) where-  mempty = empty-#if !(MIN_VERSION_base(4,11,0))-  mappend = (<|>)-#endif-  mconcat l = createSmallArray n (die "mconcat" "impossible") $ \ma ->-    let go !_  [    ] = return ()-        go off (a:as) =-          copySmallArray ma off a 0 (sizeofSmallArray a) >> go (off + sizeofSmallArray a) as-     in go 0 l-   where n = sum . fmap length $ l--instance IsList (SmallArray a) where-  type Item (SmallArray a) = a-  fromListN = smallArrayFromListN-  fromList = smallArrayFromList-  toList = Foldable.toList--smallArrayLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> SmallArray a -> ShowS-smallArrayLiftShowsPrec elemShowsPrec elemListShowsPrec p sa = showParen (p > 10) $-  showString "fromListN " . shows (length sa) . showString " "-    . listLiftShowsPrec elemShowsPrec elemListShowsPrec 11 (toList sa)---- this need to be included for older ghcs-listLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> [a] -> ShowS-listLiftShowsPrec _ sl _ = sl--instance Show a => Show (SmallArray a) where-  showsPrec p sa = smallArrayLiftShowsPrec showsPrec showList p sa--#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)--- | @since 0.6.4.0-instance Show1 SmallArray where-#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)-  liftShowsPrec = smallArrayLiftShowsPrec-#else-  showsPrec1 = smallArrayLiftShowsPrec showsPrec showList-#endif-#endif--smallArrayLiftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (SmallArray a)-smallArrayLiftReadsPrec _ listReadsPrec p = readParen (p > 10) . readP_to_S $ do-  () <$ string "fromListN"-  skipSpaces-  n <- readS_to_P reads-  skipSpaces-  l <- readS_to_P listReadsPrec-  return $ smallArrayFromListN n l--instance Read a => Read (SmallArray a) where-  readsPrec = smallArrayLiftReadsPrec readsPrec readList--#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0)--- | @since 0.6.4.0-instance Read1 SmallArray where-#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0)-  liftReadsPrec = smallArrayLiftReadsPrec-#else-  readsPrec1 = smallArrayLiftReadsPrec readsPrec readList-#endif-#endif----smallArrayDataType :: DataType-smallArrayDataType =-  mkDataType "Data.Primitive.SmallArray.SmallArray" [fromListConstr]--fromListConstr :: Constr-fromListConstr = mkConstr smallArrayDataType "fromList" [] Prefix--instance Data a => Data (SmallArray a) where-  toConstr _ = fromListConstr-  dataTypeOf _ = smallArrayDataType-  gunfold k z c = case constrIndex c of-    1 -> k (z fromList)-    _ -> die "gunfold" "SmallArray"-  gfoldl f z m = z fromList `f` toList m--instance (Typeable s, Typeable a) => Data (SmallMutableArray s a) where-  toConstr _ = die "toConstr" "SmallMutableArray"-  gunfold _ _ = die "gunfold" "SmallMutableArray"-  dataTypeOf _ = mkNoRepType "Data.Primitive.SmallArray.SmallMutableArray"---- | Create a 'SmallArray' from a list of a known length. If the length---   of the list does not match the given length, this throws an exception.-smallArrayFromListN :: Int -> [a] -> SmallArray a-smallArrayFromListN n l =-  createSmallArray n-      (die "smallArrayFromListN" "uninitialized element") $ \sma ->-  let go !ix [] = if ix == n-        then return ()-        else die "smallArrayFromListN" "list length less than specified size"-      go !ix (x : xs) = if ix < n-        then do-          writeSmallArray sma ix x-          go (ix+1) xs-        else die "smallArrayFromListN" "list length greater than specified size"-  in go 0 l---- | Create a 'SmallArray' from a list.-smallArrayFromList :: [a] -> SmallArray a-smallArrayFromList l = smallArrayFromListN (length l) l
src/Streamly/Internal/Data/Stream/Ahead.hs view
@@ -1,27 +1,30 @@-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE ConstraintKinds           #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE GeneralizedNewtypeDeriving#-}-{-# LANGUAGE InstanceSigs              #-}-{-# LANGUAGE MultiParamTypeClasses     #-}-{-# LANGUAGE UndecidableInstances      #-} -- XXX+{-# LANGUAGE UndecidableInstances #-}  -- | -- Module      : Streamly.Internal.Data.Stream.Ahead--- Copyright   : (c) 2017 Harendra Kumar+-- Copyright   : (c) 2017 Composewell Technologies -- -- License     : BSD3 -- Maintainer  : streamly@composewell.com -- Stability   : experimental -- Portability : GHC --+-- To run examples in this module: --+-- >>> import qualified Streamly.Prelude as Stream+-- >>> import Control.Concurrent (threadDelay)+-- >>> :{+--  delay n = do+--      threadDelay (n * 1000000)   -- sleep for n seconds+--      putStrLn (show n ++ " sec") -- print "n sec"+--      return n                    -- IO Int+-- :}+-- module Streamly.Internal.Data.Stream.Ahead     (       AheadT     , Ahead-    , aheadly+    , fromAhead     , ahead     ) where@@ -49,15 +52,27 @@  import Streamly.Internal.Data.Stream.SVar (fromSVar) import Streamly.Internal.Data.SVar-import Streamly.Internal.Data.Stream.StreamK+import Streamly.Internal.Data.Stream.StreamK.Type        (IsStream(..), Stream, mkStream, foldStream, foldStreamShared)-import qualified Streamly.Internal.Data.Stream.StreamK as K-import qualified Streamly.Internal.Data.Stream.StreamD as D +import qualified Streamly.Internal.Data.Stream.StreamK as K (withLocal)+import qualified Streamly.Internal.Data.Stream.StreamK.Type as K+import qualified Streamly.Internal.Data.Stream.StreamD.Type as D+ import Prelude hiding (map)  #include "Instances.hs" +-- $setup+-- >>> import qualified Streamly.Prelude as Stream+-- >>> import Control.Concurrent (threadDelay)+-- >>> :{+--  delay n = do+--      threadDelay (n * 1000000)   -- sleep for n seconds+--      putStrLn (show n ++ " sec") -- print "n sec"+--      return n                    -- IO Int+-- :}+ ------------------------------------------------------------------------------- -- Ahead -------------------------------------------------------------------------------@@ -246,11 +261,14 @@                 -- transferring available results from heap to outputQueue.                 void $ liftIO $ send sv (ChildYield a)                 nextHeap seqNo-            AheadEntryStream r ->+            AheadEntryStream (RunInIO runin, r) ->                 if stopping                 then stopIfNeeded ent seqNo r-                else runStreamWithYieldLimit True seqNo r+                else do+                    res <- liftIO $ runin (runStreamWithYieldLimit True seqNo r)+                    restoreM res +     nextHeap prevSeqNo = do         res <- liftIO $ dequeueFromHeapSeq heap (prevSeqNo + 1)         case res of@@ -306,11 +324,13 @@                           (singleStreamFromHeap seqNo)                           stop                           r-        else liftIO $ do-            let ent = Entry seqNo (AheadEntryStream r)-            liftIO $ requeueOnHeapTop heap ent seqNo-            incrementYieldLimit sv-            sendStop sv winfo+        else do+            runIn <- captureMonadState+            let ent = Entry seqNo (AheadEntryStream (runIn, r))+            liftIO $ do+                requeueOnHeapTop heap ent seqNo+                incrementYieldLimit sv+                sendStop sv winfo      yieldStreamFromHeap seqNo a r = do         continue <- liftIO $ sendYield sv winfo (ChildYield a)@@ -359,7 +379,9 @@      r <- liftIO $ mrun $             foldStreamShared st-                (\a r -> toHeap $ AheadEntryStream $ K.cons a r)+                (\a r -> do+                    runIn <- captureMonadState+                    toHeap $ AheadEntryStream (runIn, K.cons a r))                 (toHeap . AheadEntryPure)                 stop                 m@@ -461,7 +483,8 @@                           stop                           r         else do-            let ent = Entry seqNo (AheadEntryStream r)+            runIn <- captureMonadState+            let ent = Entry seqNo (AheadEntryStream (runIn, r))             liftIO $ requeueOnHeapTop heap ent seqNo             liftIO $ incrementYieldLimit sv             return TokenSuspend@@ -586,19 +609,61 @@         foldStream st yld sng stp (fromSVar sv)     where     concurrently ma mb = mkStream $ \st yld sng stp -> do-        liftIO $ enqueue (fromJust $ streamVar st) mb+        runInIO <- captureMonadState+        liftIO $ enqueue (fromJust $ streamVar st) (runInIO, mb)         foldStream st yld sng stp ma --- | Polymorphic version of the 'Semigroup' operation '<>' of 'AheadT'.--- Merges two streams sequentially but with concurrent lookahead.+infixr 6 `ahead`++-- | Appends two streams, both the streams may be evaluated concurrently but+-- the outputs are used in the same order as the corresponding actions in the+-- original streams, side effects will happen in the order in which the streams+-- are evaluated: ----- @since 0.3.0+-- >>> import Streamly.Prelude (ahead, SerialT)+-- >>> stream1 = Stream.fromEffect (delay 4) :: SerialT IO Int+-- >>> stream2 = Stream.fromEffect (delay 2) :: SerialT IO Int+-- >>> Stream.toList $ stream1 `ahead` stream2 :: IO [Int]+-- 2 sec+-- 4 sec+-- [4,2]+--+-- Multiple streams can be combined. With enough threads, all of them can be+-- scheduled simultaneously:+--+-- >>> stream3 = Stream.fromEffect (delay 1)+-- >>> Stream.toList $ stream1 `ahead` stream2 `ahead` stream3+-- 1 sec+-- 2 sec+-- 4 sec+-- [4,2,1]+--+-- With 2 threads, only two can be scheduled at a time, when one of those+-- finishes, the third one gets scheduled:+--+-- >>> Stream.toList $ Stream.maxThreads 2 $ stream1 `ahead` stream2 `ahead` stream3+-- 2 sec+-- 1 sec+-- 4 sec+-- [4,2,1]+--+-- Only streams are scheduled for ahead evaluation, how actions within a stream+-- are evaluated depends on the stream type. If it is a concurrent stream they+-- will be evaluated concurrently. It may not make much sense combining serial+-- streams using 'ahead'.+--+-- 'ahead' can be safely used to fold an infinite lazy container of streams.+--+-- /Since: 0.3.0 ("Streamly")/+--+-- @since 0.8.0 {-# INLINE ahead #-} ahead :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a ahead m1 m2 = mkStream $ \st yld sng stp ->     case streamVar st of         Just sv | svarStyle sv == AheadVar -> do-            liftIO $ enqueue sv (toStream m2)+            runInIO <- captureMonadState+            liftIO $ enqueue sv (runInIO, toStream m2)             -- Always run the left side on a new SVar to avoid complexity in             -- sequencing results. This means the left side cannot further             -- split into more ahead computations on the same SVar.@@ -610,68 +675,73 @@ {-# INLINE consMAhead #-} {-# SPECIALIZE consMAhead :: IO a -> AheadT IO a -> AheadT IO a #-} consMAhead :: MonadAsync m => m a -> AheadT m a -> AheadT m a-consMAhead m r = fromStream $ K.yieldM m `ahead` (toStream r)+consMAhead m r = fromStream $ K.fromEffect m `ahead` (toStream r)  ------------------------------------------------------------------------------ -- AheadT ------------------------------------------------------------------------------ --- | The 'Semigroup' operation for 'AheadT' appends two streams. The combined--- stream behaves like a single stream with the actions from the second stream--- appended to the first stream. The combined stream is evaluated in the--- speculative style.  This operation can be used to fold an infinite lazy--- container of streams.+-- | For 'AheadT' streams: -- -- @--- import "Streamly"--- import qualified "Streamly.Prelude" as S--- import Control.Concurrent------ main = do---  xs \<- S.'toList' . 'aheadly' $ (p 1 |: p 2 |: nil) <> (p 3 |: p 4 |: nil)---  print xs---  where p n = threadDelay 1000000 >> return n--- @--- @--- [1,2,3,4]+-- (<>) = 'Streamly.Prelude.ahead'+-- (>>=) = flip . 'Streamly.Prelude.concatMapWith' 'Streamly.Prelude.ahead' -- @ ----- Any exceptions generated by a constituent stream are propagated to the--- output stream.+-- A single 'Monad' bind behaves like a @for@ loop with iterations executed+-- concurrently, ahead of time, producing side effects of iterations out of+-- order, but results in order: ----- The monad instance of 'AheadT' may run each monadic continuation (bind)--- concurrently in a speculative manner, performing side effects in a partially--- ordered manner but producing the outputs in an ordered manner like--- 'SerialT'.+-- >>> :{+-- Stream.toList $ Stream.fromAhead $ do+--      x <- Stream.fromList [2,1] -- foreach x in stream+--      Stream.fromEffect $ delay x+-- :}+-- 1 sec+-- 2 sec+-- [2,1] ----- @--- main = S.drain . 'aheadly' $ do---     n <- return 3 \<\> return 2 \<\> return 1---     S.yieldM $ do---          threadDelay (n * 1000000)---          myThreadId >>= \\tid -> putStrLn (show tid ++ ": Delay " ++ show n)--- @--- @--- ThreadId 40: Delay 1--- ThreadId 39: Delay 2--- ThreadId 38: Delay 3--- @+-- Nested monad binds behave like nested @for@ loops with nested iterations+-- executed concurrently, ahead of time: ----- @since 0.3.0+-- >>> :{+-- Stream.toList $ Stream.fromAhead $ do+--     x <- Stream.fromList [1,2] -- foreach x in stream+--     y <- Stream.fromList [2,4] -- foreach y in stream+--     Stream.fromEffect $ delay (x + y)+-- :}+-- 3 sec+-- 4 sec+-- 5 sec+-- 6 sec+-- [3,5,4,6]+--+-- The behavior can be explained as follows. All the iterations corresponding+-- to the element @1@ in the first stream constitute one output stream and all+-- the iterations corresponding to @2@ constitute another output stream and+-- these two output streams are merged using 'ahead'.+--+-- /Since: 0.3.0 ("Streamly")/+--+-- @since 0.8.0 newtype AheadT m a = AheadT {getAheadT :: Stream m a}     deriving (MonadTrans)  -- | A serial IO stream of elements of type @a@ with concurrent lookahead.  See -- 'AheadT' documentation for more details. ----- @since 0.3.0+-- /Since: 0.3.0 ("Streamly")/+--+-- @since 0.8.0 type Ahead = AheadT IO  -- | Fix the type of a polymorphic stream as 'AheadT'. ----- @since 0.3.0-aheadly :: IsStream t => AheadT m a -> t m a-aheadly = K.adapt+-- /Since: 0.3.0 ("Streamly")/+--+-- @since 0.8.0+fromAhead :: IsStream t => AheadT m a -> t m a+fromAhead = K.adapt  instance IsStream AheadT where     toStream = getAheadT@@ -717,7 +787,7 @@  instance (Monad m, MonadAsync m) => Applicative (AheadT m) where     {-# INLINE pure #-}-    pure = AheadT . K.yield+    pure = AheadT . K.fromPure     {-# INLINE (<*>) #-}     (<*>) = apAhead
src/Streamly/Internal/Data/Stream/Async.hs view
@@ -1,31 +1,32 @@-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE ConstraintKinds           #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE GeneralizedNewtypeDeriving#-}-{-# LANGUAGE InstanceSigs              #-}-{-# LANGUAGE LambdaCase                #-}-{-# LANGUAGE MultiParamTypeClasses     #-}-{-# LANGUAGE ScopedTypeVariables       #-}-{-# LANGUAGE UndecidableInstances      #-} -- XXX+{-# LANGUAGE UndecidableInstances #-}  #include "inline.hs"  -- | -- Module      : Streamly.Internal.Data.Stream.Async--- Copyright   : (c) 2017 Harendra Kumar+-- Copyright   : (c) 2017 Composewell Technologies -- -- License     : BSD3 -- Maintainer  : streamly@composewell.com -- Stability   : experimental -- Portability : GHC --+-- To run examples in this module: --+-- >>> import qualified Streamly.Prelude as Stream+-- >>> import Control.Concurrent (threadDelay)+-- >>> :{+--  delay n = do+--      threadDelay (n * 1000000)   -- sleep for n seconds+--      putStrLn (show n ++ " sec") -- print "n sec"+--      return n                    -- IO Int+-- :}+-- module Streamly.Internal.Data.Stream.Async     (       AsyncT     , Async-    , asyncly+    , fromAsync     , async     , (<|)             --deprecated     , mkAsync@@ -33,7 +34,7 @@      , WAsyncT     , WAsync-    , wAsyncly+    , fromWAsync     , wAsync     ) where@@ -59,15 +60,28 @@ import qualified Data.Set as S  import Streamly.Internal.Data.Atomics (atomicModifyIORefCAS)-import Streamly.Internal.Data.Stream.SVar (fromSVar)+import Streamly.Internal.Data.Stream.SVar (fromSVar, fromSVarD) import Streamly.Internal.Data.SVar-import Streamly.Internal.Data.Stream.StreamK+import Streamly.Internal.Data.Stream.StreamK.Type        (IsStream(..), Stream, mkStream, foldStream, adapt, foldStreamShared)-import qualified Streamly.Internal.Data.Stream.StreamK as K-import qualified Streamly.Internal.Data.Stream.StreamD as D +import qualified Streamly.Internal.Data.Stream.StreamK as K (withLocal)+import qualified Streamly.Internal.Data.Stream.StreamK.Type as K+import qualified Streamly.Internal.Data.Stream.StreamD.Type as D+ #include "Instances.hs" +-- $setup+-- >>> import qualified Streamly.Prelude as Stream+-- >>> import Control.Concurrent (threadDelay)+-- >>> :{+--  delay n = do+--      threadDelay (n * 1000000)   -- sleep for n seconds+--      putStrLn (show n ++ " sec") -- print "n sec"+--      return n                    -- IO Int+-- :}+--+ ------------------------------------------------------------------------------- -- Async -------------------------------------------------------------------------------@@ -77,7 +91,7 @@ {-# INLINE workLoopLIFO #-} workLoopLIFO     :: (MonadIO m, MonadBaseControl IO m)-    => IORef [Stream m a]+    => IORef [(RunInIO m, Stream m a)]     -> State Stream m a     -> SVar Stream m a     -> Maybe WorkerInfo@@ -86,13 +100,12 @@      where -    mrun = runInIO $ svarMrun sv+    stop = liftIO $ sendStop sv winfo     run = do         work <- dequeue-        let stop = liftIO $ sendStop sv winfo         case work of             Nothing -> stop-            Just m -> do+            Just (RunInIO runin, m) -> do                 -- XXX when we finish we need to send the monadic state back to                 -- the parent so that the state can be merged back. We capture                 -- and return the state in the stop continuation.@@ -100,7 +113,7 @@                 -- Instead of using the run function we can just restore the                 -- monad state here. That way it can work easily for                 -- distributed case as well.-                r <- liftIO $ mrun $+                r <- liftIO $ runin $                         foldStreamShared st yieldk single (return Continue) m                 res <- restoreM r                 case res of@@ -115,9 +128,9 @@         res <- liftIO $ sendYield sv winfo (ChildYield a)         if res         then foldStreamShared st yieldk single (return Continue) r-        else liftIO $ do-            -- XXX we also need to save the monadic state here-            enqueueLIFO sv q r+        else do+            runInIO <- captureMonadState+            liftIO $ enqueueLIFO sv q (runInIO, r)             return Suspend      dequeue = liftIO $ atomicModifyIORefCAS q $ \case@@ -131,8 +144,8 @@ -- make a check every time. {-# INLINE workLoopLIFOLimited #-} workLoopLIFOLimited-    :: (MonadIO m, MonadBaseControl IO m)-    => IORef [Stream m a]+    :: forall m a. (MonadIO m, MonadBaseControl IO m)+    => IORef [(RunInIO m, Stream m a)]     -> State Stream m a     -> SVar Stream m a     -> Maybe WorkerInfo@@ -141,14 +154,13 @@      where -    mrun = runInIO $ svarMrun sv     incrContinue = liftIO (incrementYieldLimit sv) >> return Continue+    stop = liftIO $ sendStop sv winfo     run = do         work <- dequeue-        let stop = liftIO $ sendStop sv winfo         case work of             Nothing -> stop-            Just m -> do+            Just (RunInIO runin, m) -> do                 -- XXX This is just a best effort minimization of concurrency                 -- to the yield limit. If the stream is made of concurrent                 -- streams we do not reserve the yield limit in the constituent@@ -158,7 +170,7 @@                 yieldLimitOk <- liftIO $ decrementYieldLimit sv                 if yieldLimitOk                 then do-                    r <- liftIO $ mrun $+                    r <- liftIO $ runin $                             foldStreamShared st yieldk single incrContinue m                     res <- restoreM r                     case res of@@ -167,7 +179,7 @@                 -- Avoid any side effects, undo the yield limit decrement if we                 -- never yielded anything.                 else liftIO $ do-                    enqueueLIFO sv q m+                    enqueueLIFO sv q (RunInIO runin, m)                     incrementYieldLimit sv                     sendStop sv winfo @@ -182,9 +194,10 @@         yieldLimitOk <- liftIO $ decrementYieldLimit sv         if res && yieldLimitOk         then foldStreamShared st yieldk single incrContinue r-        else liftIO $ do-            incrementYieldLimit sv-            enqueueLIFO sv q r+        else do+            runInIO <- captureMonadState+            liftIO $ incrementYieldLimit sv+            liftIO $ enqueueLIFO sv q (runInIO, r)             return Suspend      dequeue = liftIO $ atomicModifyIORefCAS q $ \case@@ -200,7 +213,7 @@ {-# INLINE workLoopFIFO #-} workLoopFIFO     :: (MonadIO m, MonadBaseControl IO m)-    => LinkedQueue (Stream m a)+    => LinkedQueue (RunInIO m, Stream m a)     -> State Stream m a     -> SVar Stream m a     -> Maybe WorkerInfo@@ -209,14 +222,13 @@      where -    mrun = runInIO $ svarMrun sv+    stop = liftIO $ sendStop sv winfo     run = do         work <- liftIO $ tryPopR q-        let stop = liftIO $ sendStop sv winfo         case work of             Nothing -> stop-            Just m -> do-                r <- liftIO $ mrun $+            Just (RunInIO runin, m) -> do+                r <- liftIO $ runin $                         foldStreamShared st yieldk single (return Continue) m                 res <- restoreM r                 case res of@@ -233,13 +245,14 @@     -- yielding.     yieldk a r = do         res <- liftIO $ sendYield sv winfo (ChildYield a)-        liftIO $ enqueueFIFO sv q r+        runInIO <- captureMonadState+        liftIO $ enqueueFIFO sv q (runInIO, r)         return $ if res then Continue else Suspend  {-# INLINE workLoopFIFOLimited #-} workLoopFIFOLimited-    :: (MonadIO m, MonadBaseControl IO m)-    => LinkedQueue (Stream m a)+    :: forall m a. (MonadIO m, MonadBaseControl IO m)+    => LinkedQueue (RunInIO m, Stream m a)     -> State Stream m a     -> SVar Stream m a     -> Maybe WorkerInfo@@ -248,25 +261,24 @@      where -    mrun = runInIO $ svarMrun sv+    stop = liftIO $ sendStop sv winfo     incrContinue = liftIO (incrementYieldLimit sv) >> return Continue     run = do         work <- liftIO $ tryPopR q-        let stop = liftIO $ sendStop sv winfo         case work of             Nothing -> stop-            Just m -> do+            Just (RunInIO runin, m) -> do                 yieldLimitOk <- liftIO $ decrementYieldLimit sv                 if yieldLimitOk                 then do-                    r <- liftIO $ mrun $+                    r <- liftIO $ runin $                             foldStreamShared st yieldk single incrContinue m                     res <- restoreM r                     case res of                         Continue -> run                         Suspend -> stop                 else liftIO $ do-                    enqueueFIFO sv q m+                    enqueueFIFO sv q (RunInIO runin, m)                     incrementYieldLimit sv                     sendStop sv winfo @@ -276,7 +288,8 @@      yieldk a r = do         res <- liftIO $ sendYield sv winfo (ChildYield a)-        liftIO $ enqueueFIFO sv q r+        runInIO <- captureMonadState+        liftIO $ enqueueFIFO sv q (runInIO, r)         yieldLimitOk <- liftIO $ decrementYieldLimit sv         if res && yieldLimitOk         then return Continue@@ -301,7 +314,7 @@     active  <- newIORef 0     wfw     <- newIORef False     running <- newIORef S.empty-    q       <- newIORef []+    q       <- newIORef ([] :: [(RunInIO m, Stream m a)])     yl      <- case getYieldLimit st of                 Nothing -> return Nothing                 Just x -> Just <$> newIORef x@@ -326,7 +339,7 @@             -> (SVar Stream m a -> m [ChildEvent a])             -> (SVar Stream m a -> m Bool)             -> (SVar Stream m a -> IO Bool)-            -> (IORef [Stream m a]+            -> (IORef [(RunInIO m, Stream m a)]                 -> State Stream m a                 -> SVar Stream m a                 -> Maybe WorkerInfo@@ -423,7 +436,7 @@             -> (SVar Stream m a -> m [ChildEvent a])             -> (SVar Stream m a -> m Bool)             -> (SVar Stream m a -> IO Bool)-            -> (LinkedQueue (Stream m a)+            -> (LinkedQueue (RunInIO m, Stream m a)                 -> State Stream m a                 -> SVar Stream m a                 -> Maybe WorkerInfo@@ -499,7 +512,7 @@ -- | Generate a stream asynchronously to keep it buffered, lazily consume -- from the buffer. ----- /Internal/+-- /Pre-release/ -- {-# INLINABLE mkAsyncK #-} mkAsyncK :: (IsStream t, MonadAsync m) => t m a -> t m a@@ -514,7 +527,7 @@      step gst Nothing = do         sv <- newAsyncVar gst (D.fromStreamD m)-        return $ D.Skip $ Just $ D.fromSVar sv+        return $ D.Skip $ Just $ fromSVarD sv      step gst (Just (D.UnStream step1 st)) = do         r <- step1 gst st@@ -523,6 +536,7 @@             D.Skip s    -> D.Skip (Just $ D.Stream step1 s)             D.Stop      -> D.Stop +-- -- This is slightly faster than the CPS version above -- -- | Make the stream producer and consumer run concurrently by introducing a@@ -531,8 +545,10 @@ -- kicked off again to evaluate the remaining stream when there is space in the -- buffer.  The consumer consumes the stream lazily from the buffer. ----- /Internal/+-- /Since: 0.2.0 (Streamly)/ --+-- @since 0.8.0+-- {-# INLINE_NORMAL mkAsync #-} mkAsync :: (K.IsStream t, MonadAsync m) => t m a -> t m a mkAsync = D.fromStreamD . mkAsyncD . D.toStreamD@@ -620,7 +636,8 @@     foldStream st yld sng stp $ fromSVar sv     where     concurrently ma mb = mkStream $ \st yld sng stp -> do-        liftIO $ enqueue (fromJust $ streamVar st) mb+        runInIO <- captureMonadState+        liftIO $ enqueue (fromJust $ streamVar st) $ (runInIO, mb)         foldStreamShared st yld sng stp ma  {-# INLINE joinStreamVarAsync #-}@@ -629,7 +646,8 @@ joinStreamVarAsync style m1 m2 = mkStream $ \st yld sng stp ->     case streamVar st of         Just sv | svarStyle sv == style -> do-            liftIO $ enqueue sv (toStream m2)+            runInIO <- captureMonadState+            liftIO $ enqueue sv $ (runInIO, toStream m2)             foldStreamShared st yld sng stp m1         _ -> foldStreamShared st yld sng stp (forkSVarAsync style m1 m2) @@ -637,11 +655,69 @@ -- Semigroup and Monoid style compositions for parallel actions ------------------------------------------------------------------------------ --- | Polymorphic version of the 'Semigroup' operation '<>' of 'AsyncT'.--- Merges two streams possibly concurrently, preferring the--- elements from the left one when available.+infixr 6 `async`++-- | Merges two streams, both the streams may be evaluated concurrently,+-- outputs from both are used as they arrive: ----- @since 0.2.0+-- >>> import Streamly.Prelude (async)+-- >>> stream1 = Stream.fromEffect (delay 4)+-- >>> stream2 = Stream.fromEffect (delay 2)+-- >>> Stream.toList $ stream1 `async` stream2+-- 2 sec+-- 4 sec+-- [2,4]+--+-- Multiple streams can be combined. With enough threads, all of them can be+-- scheduled simultaneously:+--+-- >>> stream3 = Stream.fromEffect (delay 1)+-- >>> Stream.toList $ stream1 `async` stream2 `async` stream3+-- ...+-- [1,2,4]+--+-- With 2 threads, only two can be scheduled at a time, when one of those+-- finishes, the third one gets scheduled:+--+-- >>> Stream.toList $ Stream.maxThreads 2 $ stream1 `async` stream2 `async` stream3+-- ...+-- [2,1,4]+--+-- With a single thread, it becomes serial:+--+-- >>> Stream.toList $ Stream.maxThreads 1 $ stream1 `async` stream2 `async` stream3+-- ...+-- [4,2,1]+--+-- Only streams are scheduled for async evaluation, how actions within a+-- stream are evaluated depends on the stream type. If it is a concurrent+-- stream they will be evaluated concurrently.+--+-- In the following example, both the streams are scheduled for concurrent+-- evaluation but each individual stream is evaluated serially:+--+-- >>> stream1 = Stream.fromListM $ Prelude.map delay [3,3] -- SerialT IO Int+-- >>> stream2 = Stream.fromListM $ Prelude.map delay [1,1] -- SerialT IO Int+-- >>> Stream.toList $ stream1 `async` stream2 -- IO [Int]+-- ...+-- [1,1,3,3]+--+-- If total threads are 2, the third stream is scheduled only after one of the+-- first two has finished:+--+-- >>> stream3 = Stream.fromListM $ Prelude.map delay [2,2] -- SerialT IO Int+-- >>> Stream.toList $ Stream.maxThreads 2 $ stream1 `async` stream2 `async` stream3 -- IO [Int]+-- ...+-- [1,1,3,2,3,2]+--+-- Thus 'async' goes deep in first few streams rather than going wide in all+-- streams. It prefers to evaluate the leftmost streams as much as possible.+-- Because of this behavior, 'async' can be safely used to fold an infinite+-- lazy container of streams.+--+-- /Since: 0.2.0 ("Streamly")/+--+-- @since 0.8.0 {-# INLINE async #-} async :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a async = joinStreamVarAsync AsyncVar@@ -663,74 +739,73 @@ {-# INLINE consMAsync #-} {-# SPECIALIZE consMAsync :: IO a -> AsyncT IO a -> AsyncT IO a #-} consMAsync :: MonadAsync m => m a -> AsyncT m a -> AsyncT m a-consMAsync m r = fromStream $ K.yieldM m `async` (toStream r)+consMAsync m r = fromStream $ K.fromEffect m `async` (toStream r)  ------------------------------------------------------------------------------ -- AsyncT ------------------------------------------------------------------------------ --- | The 'Semigroup' operation (@<>@) for 'AsyncT' merges two streams--- concurrently with priority given to the first stream. In @s1 <> s2 <> s3--- ...@ the streams s1, s2 and s3 are scheduled for execution in that order.--- Multiple scheduled streams may be executed concurrently and the elements--- generated by them are served to the consumer as and when they become--- available. This behavior is similar to the scheduling and execution behavior--- of actions in a single async stream.------ Since only a finite number of streams are executed concurrently, this--- operation can be used to fold an infinite lazy container of streams.+-- | For 'AsyncT' streams: -- -- @--- import "Streamly"--- import qualified "Streamly.Prelude" as S--- import Control.Concurrent------ main = (S.toList . 'asyncly' $ (S.fromList [1,2]) \<> (S.fromList [3,4])) >>= print--- @--- @--- [1,2,3,4]+-- (<>) = 'Streamly.Prelude.async'+-- (>>=) = flip . 'Streamly.Prelude.concatMapWith' 'Streamly.Prelude.async' -- @ ----- Any exceptions generated by a constituent stream are propagated to the--- output stream. The output and exceptions from a single stream are guaranteed--- to arrive in the same order in the resulting stream as they were generated--- in the input stream. However, the relative ordering of elements from--- different streams in the resulting stream can vary depending on scheduling--- and generation delays.+-- A single 'Monad' bind behaves like a @for@ loop with iterations of the loop+-- executed concurrently a la the 'async' combinator, producing results and+-- side effects of iterations out of order: ----- Similarly, the monad instance of 'AsyncT' /may/ run each iteration--- concurrently based on demand.  More concurrent iterations are started only--- if the previous iterations are not able to produce enough output for the--- consumer.+-- >>> :{+-- Stream.toList $ Stream.fromAsync $ do+--      x <- Stream.fromList [2,1] -- foreach x in stream+--      Stream.fromEffect $ delay x+-- :}+-- 1 sec+-- 2 sec+-- [1,2] ----- @--- main = 'drain' . 'asyncly' $ do---     n <- return 3 \<\> return 2 \<\> return 1---     S.yieldM $ do---          threadDelay (n * 1000000)---          myThreadId >>= \\tid -> putStrLn (show tid ++ ": Delay " ++ show n)--- @--- @--- ThreadId 40: Delay 1--- ThreadId 39: Delay 2--- ThreadId 38: Delay 3--- @+-- Nested monad binds behave like nested @for@ loops with nested iterations+-- executed concurrently, a la the 'async' combinator: ----- @since 0.1.0+-- >>> :{+-- Stream.toList $ Stream.fromAsync $ do+--     x <- Stream.fromList [1,2] -- foreach x in stream+--     y <- Stream.fromList [2,4] -- foreach y in stream+--     Stream.fromEffect $ delay (x + y)+-- :}+-- 3 sec+-- 4 sec+-- 5 sec+-- 6 sec+-- [3,4,5,6]+--+-- The behavior can be explained as follows. All the iterations corresponding+-- to the element @1@ in the first stream constitute one output stream and all+-- the iterations corresponding to @2@ constitute another output stream and+-- these two output streams are merged using 'async'.+--+-- /Since: 0.1.0 ("Streamly")/+--+-- @since 0.8.0 newtype AsyncT m a = AsyncT {getAsyncT :: Stream m a}     deriving (MonadTrans)  -- | A demand driven left biased parallely composing IO stream of elements of -- type @a@.  See 'AsyncT' documentation for more details. ----- @since 0.2.0+-- /Since: 0.2.0 ("Streamly")/+--+-- @since 0.8.0 type Async = AsyncT IO  -- | Fix the type of a polymorphic stream as 'AsyncT'. ----- @since 0.1.0-asyncly :: IsStream t => AsyncT m a -> t m a-asyncly = adapt+-- /Since: 0.1.0 ("Streamly")/+--+-- @since 0.8.0+fromAsync :: IsStream t => AsyncT m a -> t m a+fromAsync = adapt  instance IsStream AsyncT where     toStream = getAsyncT@@ -773,7 +848,7 @@  instance (Monad m, MonadAsync m) => Applicative (AsyncT m) where     {-# INLINE pure #-}-    pure = AsyncT . K.yield+    pure = AsyncT . K.fromPure     {-# INLINE (<*>) #-}     (<*>) = apAsync @@ -809,34 +884,135 @@ {-# INLINE consMWAsync #-} {-# SPECIALIZE consMWAsync :: IO a -> WAsyncT IO a -> WAsyncT IO a #-} consMWAsync :: MonadAsync m => m a -> WAsyncT m a -> WAsyncT m a-consMWAsync m r = fromStream $ K.yieldM m `wAsync` (toStream r)+consMWAsync m r = fromStream $ K.fromEffect m `wAsync` (toStream r) --- | Polymorphic version of the 'Semigroup' operation '<>' of 'WAsyncT'.--- Merges two streams concurrently choosing elements from both fairly.+infixr 6 `wAsync`++-- | For singleton streams, 'wAsync' is the same as 'async'.  See 'async' for+-- singleton stream behavior. For multi-element streams, while 'async' is left+-- biased i.e. it tries to evaluate the left side stream as much as possible,+-- 'wAsync' tries to schedule them both fairly. In other words, 'async' goes+-- deep while 'wAsync' goes wide. However, outputs are always used as they+-- arrive. ----- @since 0.2.0+-- With a single thread, 'async' starts behaving like 'serial' while 'wAsync'+-- starts behaving like 'wSerial'.+--+-- >>> import Streamly.Prelude (wAsync)+-- >>> stream1 = Stream.fromList [1,2,3]+-- >>> stream2 = Stream.fromList [4,5,6]+-- >>> Stream.toList $ Stream.fromAsync $ Stream.maxThreads 1 $ stream1 `async` stream2+-- [1,2,3,4,5,6]+--+-- >>> Stream.toList $ Stream.fromWAsync $ Stream.maxThreads 1 $ stream1 `wAsync` stream2+-- [1,4,2,5,3,6]+--+-- With two threads available, and combining three streams:+--+-- >>> stream3 = Stream.fromList [7,8,9]+-- >>> Stream.toList $ Stream.fromAsync $ Stream.maxThreads 2 $ stream1 `async` stream2 `async` stream3+-- [1,2,3,4,5,6,7,8,9]+--+-- >>> Stream.toList $ Stream.fromWAsync $ Stream.maxThreads 2 $ stream1 `wAsync` stream2 `wAsync` stream3+-- [1,4,2,7,5,3,8,6,9]+--+-- This operation cannot be used to fold an infinite lazy container of streams,+-- because it schedules all the streams in a round robin manner.+--+-- Note that 'WSerialT' and single threaded 'WAsyncT' both interleave streams+-- but the exact scheduling is slightly different in both cases.+--+-- @since 0.8.0+--+-- /Since: 0.2.0 ("Streamly")/++-- Scheduling details:+--+-- This is how the execution of the above example proceeds:+--+-- 1. The scheduler queue is initialized with @[S.fromList [1,2,3],+-- (S.fromList [4,5,6]) \<> (S.fromList [7,8,9])]@ assuming the head of the+-- queue is represented by the  rightmost item.+-- 2. @S.fromList [1,2,3]@ is executed, yielding the element @1@ and putting+-- @[2,3]@ at the back of the scheduler queue. The scheduler queue now looks+-- like @[(S.fromList [4,5,6]) \<> (S.fromList [7,8,9]), S.fromList [2,3]]@.+-- 3. Now @(S.fromList [4,5,6]) \<> (S.fromList [7,8,9])@ is picked up for+-- execution, @S.fromList [7,8,9]@ is added at the back of the queue and+-- @S.fromList [4,5,6]@ is executed, yielding the element @4@ and adding+-- @S.fromList [5,6]@ at the back of the queue. The queue now looks like+-- @[S.fromList [2,3], S.fromList [7,8,9], S.fromList [5,6]]@.+-- 4. Note that the scheduler queue expands by one more stream component in+-- every pass because one more @<>@ is broken down into two components. At this+-- point there are no more @<>@ operations to be broken down further and the+-- queue has reached its maximum size. Now these streams are scheduled in+-- round-robin fashion yielding @[2,7,5,3,8,6,9]@.+--+-- As we see above, in a right associated expression composed with @<>@, only+-- one @<>@ operation is broken down into two components in one execution,+-- therefore, if we have @n@ streams composed using @<>@ it will take @n@+-- scheduler passes to expand the whole expression.  By the time @n-th@+-- component is added to the scheduler queue, the first component would have+-- received @n@ scheduler passes.+-- {-# INLINE wAsync #-} wAsync :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a wAsync = joinStreamVarAsync WAsyncVar --- | 'WAsyncT' is similar to 'WSerialT' but with concurrent execution.--- The 'Semigroup' operation (@<>@) for 'WAsyncT' merges two streams--- concurrently interleaving the actions from both the streams.  In @s1--- <> s2 <> s3 ...@, the individual actions from streams @s1@, @s2@ and @s3@--- are scheduled for execution in a round-robin fashion.  Multiple scheduled--- actions may be executed concurrently, the results from concurrent executions--- are consumed in the order in which they become available.+-- | For 'WAsyncT' streams: --+-- @+-- (<>) = 'Streamly.Prelude.wAsync'+-- (>>=) = flip . 'Streamly.Prelude.concatMapWith' 'Streamly.Prelude.wAsync'+-- @ --+-- A single 'Monad' bind behaves like a @for@ loop with iterations of the loop+-- executed concurrently a la the 'wAsync' combinator, producing results and+-- side effects of iterations out of order:+--+-- >>> :{+-- Stream.toList $ Stream.fromWAsync $ do+--      x <- Stream.fromList [2,1] -- foreach x in stream+--      Stream.fromEffect $ delay x+-- :}+-- 1 sec+-- 2 sec+-- [1,2]+--+-- Nested monad binds behave like nested @for@ loops with nested iterations+-- executed concurrently, a la the 'wAsync' combinator:+--+-- >>> :{+-- Stream.toList $ Stream.fromWAsync $ do+--     x <- Stream.fromList [1,2] -- foreach x in stream+--     y <- Stream.fromList [2,4] -- foreach y in stream+--     Stream.fromEffect $ delay (x + y)+-- :}+-- 3 sec+-- 4 sec+-- 5 sec+-- 6 sec+-- [3,4,5,6]+--+-- The behavior can be explained as follows. All the iterations corresponding+-- to the element @1@ in the first stream constitute one 'WAsyncT' output+-- stream and all the iterations corresponding to @2@ constitute another+-- 'WAsyncT' output stream and these two output streams are merged using+-- 'wAsync'.+-- -- The @W@ in the name stands for @wide@ or breadth wise scheduling in -- contrast to the depth wise scheduling behavior of 'AsyncT'. --+-- /Since: 0.2.0 ("Streamly")/+--+-- @since 0.8.0++-- XXX This documentation is redundant, need to be cleaned up/removed.+-- -- @--- import "Streamly" -- import qualified "Streamly.Prelude" as S -- import Control.Concurrent ----- main = (S.toList . 'wAsyncly' . maxThreads 1 $ (S.fromList [1,2]) \<> (S.fromList [3,4])) >>= print+-- main = (S.toList . S.'fromWAsync' . S.maxThreads 1 $ (S.fromList [1,2]) \<> (S.fromList [3,4])) >>= print -- @ -- @ -- [1,3,2,4]@@ -847,7 +1023,7 @@ -- now take a more general example: -- -- @--- main = (S.toList . 'wAsyncly' . maxThreads 1 $ (S.fromList [1,2,3]) \<> (S.fromList [4,5,6]) \<> (S.fromList [7,8,9])) >>= print+-- main = (S.toList . S.'fromWAsync' . S.maxThreads 1 $ (S.fromList [1,2,3]) \<> (S.fromList [4,5,6]) \<> (S.fromList [7,8,9])) >>= print -- @ -- @ -- [1,4,2,7,5,3,8,6,9]@@ -870,7 +1046,7 @@ -- every pass because one more @<>@ is broken down into two components. At this -- point there are no more @<>@ operations to be broken down further and the -- queue has reached its maximum size. Now these streams are scheduled in--- round-robin fashion yielding @[2,7,5,3,8,8,9]@.+-- round-robin fashion yielding @[2,7,5,3,8,6,9]@. -- -- As we see above, in a right associated expression composed with @<>@, only -- one @<>@ operation is broken down into two components in one execution,@@ -903,9 +1079,9 @@ -- concurrently using a round robin scheduling. -- -- @--- main = 'drain' . 'wAsyncly' $ do+-- main = S.'drain' . S.'fromWAsync' $ do --     n <- return 3 \<\> return 2 \<\> return 1---     S.yieldM $ do+--     S.fromEffect $ do --          threadDelay (n * 1000000) --          myThreadId >>= \\tid -> putStrLn (show tid ++ ": Delay " ++ show n) -- @@@ -915,21 +1091,24 @@ -- ThreadId 38: Delay 3 -- @ ----- @since 0.2.0 newtype WAsyncT m a = WAsyncT {getWAsyncT :: Stream m a}     deriving (MonadTrans)  -- | A round robin parallely composing IO stream of elements of type @a@. -- See 'WAsyncT' documentation for more details. ----- @since 0.2.0+-- /Since: 0.2.0 ("Streamly")/+--+-- @since 0.8.0 type WAsync = WAsyncT IO  -- | Fix the type of a polymorphic stream as 'WAsyncT'. ----- @since 0.2.0-wAsyncly :: IsStream t => WAsyncT m a -> t m a-wAsyncly = adapt+-- /Since: 0.2.0 ("Streamly")/+--+-- @since 0.8.0+fromWAsync :: IsStream t => WAsyncT m a -> t m a+fromWAsync = adapt  instance IsStream WAsyncT where     toStream = getWAsyncT@@ -971,7 +1150,7 @@ -- GHC: if we specify arguments in the definition of (<*>) we see a significant -- performance degradation (~2x). instance (Monad m, MonadAsync m) => Applicative (WAsyncT m) where-    pure = WAsyncT . K.yield+    pure = WAsyncT . K.fromPure     (<*>) = apWAsync  ------------------------------------------------------------------------------
− src/Streamly/Internal/Data/Stream/Combinators.hs 
@@ -1,220 +0,0 @@-{-# LANGUAGE CPP                       #-}--#include "inline.hs"---- |--- Module      : Streamly.Internal.Data.Stream.Combinators--- Copyright   : (c) 2017 Harendra Kumar------ License     : BSD3--- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC-------module Streamly.Internal.Data.Stream.Combinators-    ( maxThreads-    , maxBuffer-    , maxYields-    , rate-    , avgRate-    , minRate-    , maxRate-    , constRate-    , inspectMode-    , printState-    )-where--import Control.Monad.IO.Class (MonadIO(liftIO))-import Data.Int (Int64)--import Streamly.Internal.Data.SVar-import Streamly.Internal.Data.Stream.StreamK-import Streamly.Internal.Data.Stream.Serial (SerialT)------------------------------------------------------------------------------------ Concurrency control-------------------------------------------------------------------------------------- XXX need to write these in direct style otherwise they will break fusion.------ | Specify the maximum number of threads that can be spawned concurrently for--- any concurrent combinator in a stream.--- A value of 0 resets the thread limit to default, a negative value means--- there is no limit. The default value is 1500. 'maxThreads' does not affect--- 'ParallelT' streams as they can use unbounded number of threads.------ When the actions in a stream are IO bound, having blocking IO calls, this--- option can be used to control the maximum number of in-flight IO requests.--- When the actions are CPU bound this option can be used to--- control the amount of CPU used by the stream.------ @since 0.4.0-{-# INLINE_NORMAL maxThreads #-}-maxThreads :: IsStream t => Int -> t m a -> t m a-maxThreads n m = mkStream $ \st stp sng yld ->-    foldStreamShared (setMaxThreads n st) stp sng yld m--{--{-# RULES "maxThreadsSerial serial" maxThreads = maxThreadsSerial #-}-maxThreadsSerial :: Int -> SerialT m a -> SerialT m a-maxThreadsSerial _ = id--}---- | Specify the maximum size of the buffer for storing the results from--- concurrent computations. If the buffer becomes full we stop spawning more--- concurrent tasks until there is space in the buffer.--- A value of 0 resets the buffer size to default, a negative value means--- there is no limit. The default value is 1500.------ CAUTION! using an unbounded 'maxBuffer' value (i.e. a negative value)--- coupled with an unbounded 'maxThreads' value is a recipe for disaster in--- presence of infinite streams, or very large streams.  Especially, it must--- not be used when 'pure' is used in 'ZipAsyncM' streams as 'pure' in--- applicative zip streams generates an infinite stream causing unbounded--- concurrent generation with no limit on the buffer or threads.------ @since 0.4.0-{-# INLINE_NORMAL maxBuffer #-}-maxBuffer :: IsStream t => Int -> t m a -> t m a-maxBuffer n m = mkStream $ \st stp sng yld ->-    foldStreamShared (setMaxBuffer n st) stp sng yld m--{--{-# RULES "maxBuffer serial" maxBuffer = maxBufferSerial #-}-maxBufferSerial :: Int -> SerialT m a -> SerialT m a-maxBufferSerial _ = id--}---- | Specify the pull rate of a stream.--- A 'Nothing' value resets the rate to default which is unlimited.  When the--- rate is specified, concurrent production may be ramped up or down--- automatically to achieve the specified yield rate. The specific behavior for--- different styles of 'Rate' specifications is documented under 'Rate'.  The--- effective maximum production rate achieved by a stream is governed by:------ * The 'maxThreads' limit--- * The 'maxBuffer' limit--- * The maximum rate that the stream producer can achieve--- * The maximum rate that the stream consumer can achieve------ @since 0.5.0-{-# INLINE_NORMAL rate #-}-rate :: IsStream t => Maybe Rate -> t m a -> t m a-rate r m = mkStream $ \st stp sng yld ->-    case r of-        Just (Rate low goal _ _) | goal < low ->-            error "rate: Target rate cannot be lower than minimum rate."-        Just (Rate _ goal high _) | goal > high ->-            error "rate: Target rate cannot be greater than maximum rate."-        Just (Rate low _ high _) | low > high ->-            error "rate: Minimum rate cannot be greater than maximum rate."-        _ -> foldStreamShared (setStreamRate r st) stp sng yld m---- XXX implement for serial streams as well, as a simple delay--{--{-# RULES "rate serial" rate = yieldRateSerial #-}-yieldRateSerial :: Double -> SerialT m a -> SerialT m a-yieldRateSerial _ = id--}---- | Same as @rate (Just $ Rate (r/2) r (2*r) maxBound)@------ Specifies the average production rate of a stream in number of yields--- per second (i.e.  @Hertz@).  Concurrent production is ramped up or down--- automatically to achieve the specified average yield rate. The rate can--- go down to half of the specified rate on the lower side and double of--- the specified rate on the higher side.------ @since 0.5.0-avgRate :: IsStream t => Double -> t m a -> t m a-avgRate r = rate (Just $ Rate (r/2) r (2*r) maxBound)---- | Same as @rate (Just $ Rate r r (2*r) maxBound)@------ Specifies the minimum rate at which the stream should yield values. As--- far as possible the yield rate would never be allowed to go below the--- specified rate, even though it may possibly go above it at times, the--- upper limit is double of the specified rate.------ @since 0.5.0-minRate :: IsStream t => Double -> t m a -> t m a-minRate r = rate (Just $ Rate r r (2*r) maxBound)---- | Same as @rate (Just $ Rate (r/2) r r maxBound)@------ Specifies the maximum rate at which the stream should yield values. As--- far as possible the yield rate would never be allowed to go above the--- specified rate, even though it may possibly go below it at times, the--- lower limit is half of the specified rate. This can be useful in--- applications where certain resource usage must not be allowed to go--- beyond certain limits.------ @since 0.5.0-maxRate :: IsStream t => Double -> t m a -> t m a-maxRate r = rate (Just $ Rate (r/2) r r maxBound)---- | Same as @rate (Just $ Rate r r r 0)@------ Specifies a constant yield rate. If for some reason the actual rate--- goes above or below the specified rate we do not try to recover it by--- increasing or decreasing the rate in future.  This can be useful in--- applications like graphics frame refresh where we need to maintain a--- constant refresh rate.------ @since 0.5.0-constRate :: IsStream t => Double -> t m a -> t m a-constRate r = rate (Just $ Rate r r r 0)---- | Specify the average latency, in nanoseconds, of a single threaded action--- in a concurrent composition. Streamly can measure the latencies, but that is--- possible only after at least one task has completed. This combinator can be--- used to provide a latency hint so that rate control using 'rate' can take--- that into account right from the beginning. When not specified then a--- default behavior is chosen which could be too slow or too fast, and would be--- restricted by any other control parameters configured.--- A value of 0 indicates default behavior, a negative value means there is no--- limit i.e. zero latency.--- This would normally be useful only in high latency and high throughput--- cases.----{-# INLINE_NORMAL _serialLatency #-}-_serialLatency :: IsStream t => Int -> t m a -> t m a-_serialLatency n m = mkStream $ \st stp sng yld ->-    foldStreamShared (setStreamLatency n st) stp sng yld m--{--{-# RULES "serialLatency serial" _serialLatency = serialLatencySerial #-}-serialLatencySerial :: Int -> SerialT m a -> SerialT m a-serialLatencySerial _ = id--}---- Stop concurrent dispatches after this limit. This is useful in API's like--- "take" where we want to dispatch only upto the number of elements "take"--- needs.  This value applies only to the immediate next level and is not--- inherited by everything in enclosed scope.-{-# INLINE_NORMAL maxYields #-}-maxYields :: IsStream t => Maybe Int64 -> t m a -> t m a-maxYields n m = mkStream $ \st stp sng yld ->-    foldStreamShared (setYieldLimit n st) stp sng yld m--{-# RULES "maxYields serial" maxYields = maxYieldsSerial #-}-maxYieldsSerial :: Maybe Int64 -> SerialT m a -> SerialT m a-maxYieldsSerial _ = id--printState :: MonadIO m => State Stream m a -> m ()-printState st = liftIO $ do-    let msv = streamVar st-    case msv of-        Just sv -> dumpSVar sv >>= putStrLn-        Nothing -> putStrLn "No SVar"---- | Print debug information about an SVar when the stream ends------ /Internal/----inspectMode :: IsStream t => t m a -> t m a-inspectMode m = mkStream $ \st stp sng yld ->-     foldStreamShared (setInspectMode st) stp sng yld m
− src/Streamly/Internal/Data/Stream/Enumeration.hs 
@@ -1,550 +0,0 @@-{-# LANGUAGE CPP                       #-}---- |--- Module      : Streamly.Internal.Data.Stream.Enumeration--- Copyright   : (c) 2018 Harendra Kumar------ 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.--module Streamly.Internal.Data.Stream.Enumeration-    (-      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.StreamD (fromStreamD)-import Streamly.Internal.Data.Stream.StreamK (IsStream(..))--import qualified Streamly.Internal.Data.Stream.StreamD as D-import qualified Streamly.Internal.Data.Stream.Serial as Serial------------------------------------------------------------------------------------ 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.------ @--- > S.toList $ S.take 4 $ S.enumerateFromStepIntegral 0 2--- [0,2,4,6]--- > S.toList $ S.take 3 $ S.enumerateFromStepIntegral 0 (-2)--- [0,-2,-4]--- @------ @since 0.6.0-{-# INLINE enumerateFromStepIntegral #-}-enumerateFromStepIntegral-    :: (IsStream t, Monad m, Integral a)-    => a -> a -> t 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.------ @--- > S.toList $ S.take 4 $ S.enumerateFromIntegral (0 :: Int)--- [0,1,2,3]--- @------ @since 0.6.0-{-# INLINE enumerateFromIntegral #-}-enumerateFromIntegral-    :: (IsStream t, Monad m, Integral a, Bounded a)-    => a -> t 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.------ @--- > S.toList $ S.take 4 $ S.enumerateFromThenIntegral (0 :: Int) 2--- [0,2,4,6]--- > S.toList $ S.take 4 $ S.enumerateFromThenIntegral (0 :: Int) (-2)--- [0,-2,-4,-6]--- @------ @since 0.6.0-{-# INLINE enumerateFromThenIntegral #-}-enumerateFromThenIntegral-    :: (IsStream t, Monad m, Integral a, Bounded a)-    => a -> a -> t 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@.------ @--- > S.toList $ S.enumerateFromToIntegral 0 4--- [0,1,2,3,4]--- @------ @since 0.6.0-{-# INLINE enumerateFromToIntegral #-}-enumerateFromToIntegral :: (IsStream t, Monad m, Integral a) => a -> a -> t 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@.------ @--- > S.toList $ S.enumerateFromThenToIntegral 0 2 6--- [0,2,4,6]--- > S.toList $ S.enumerateFromThenToIntegral 0 (-2) (-6)--- [0,-2,-4,-6]--- @------ @since 0.6.0-{-# INLINE enumerateFromThenToIntegral #-}-enumerateFromThenToIntegral-    :: (IsStream t, Monad m, Integral a)-    => a -> a -> a -> t 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:------ @--- > S.toList $ S.take 4 $ S.enumerateFromFractional 1.1--- [1.1,2.1,3.1,4.1]--- @--------- @since 0.6.0-{-# INLINE enumerateFromFractional #-}-enumerateFromFractional :: (IsStream t, Monad m, Fractional a) => a -> t m a-enumerateFromFractional from = fromStreamD $ D.numFrom 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:------ @--- > S.toList $ S.take 4 $ S.enumerateFromThenFractional 1.1 2.1--- [1.1,2.1,3.1,4.1]--- > S.toList $ S.take 4 $ S.enumerateFromThenFractional 1.1 (-2.1)--- [1.1,-2.1,-5.300000000000001,-8.500000000000002]--- @------ @since 0.6.0-{-# INLINE enumerateFromThenFractional #-}-enumerateFromThenFractional-    :: (IsStream t, Monad m, Fractional a)-    => a -> a -> t m a-enumerateFromThenFractional from next = fromStreamD $ D.numFromThen 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:------ @--- > S.toList $ S.enumerateFromToFractional 1.1 4--- [1.1,2.1,3.1,4.1]--- > S.toList $ S.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.------ @since 0.6.0-{-# INLINE enumerateFromToFractional #-}-enumerateFromToFractional-    :: (IsStream t, Monad m, Fractional a, Ord a)-    => a -> a -> t 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:------ @--- > S.toList $ S.enumerateFromThenToFractional 0.1 2 6--- [0.1,2.0,3.9,5.799999999999999]--- > S.toList $ S.enumerateFromThenToFractional 0.1 (-2) (-6)--- [0.1,-2.0,-4.1000000000000005,-6.200000000000001]--- @--------- @since 0.6.0-{-# INLINE enumerateFromThenToFractional #-}-enumerateFromThenToFractional-    :: (IsStream t, Monad m, Fractional a, Ord a)-    => a -> a -> a -> t 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'.------ @since 0.6.0-{-# INLINE enumerateFromToSmall #-}-enumerateFromToSmall :: (IsStream t, Monad m, Enum a) => a -> a -> t m a-enumerateFromToSmall from to = Serial.map toEnum $-    enumerateFromToIntegral (fromEnum from) (fromEnum to)---- | 'enumerateFromThenTo' for 'Enum' types not larger than 'Int'.------ @since 0.6.0-{-# INLINE enumerateFromThenToSmall #-}-enumerateFromThenToSmall :: (IsStream t, Monad m, Enum a)-    => a -> a -> a -> t m a-enumerateFromThenToSmall from next to = Serial.map 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.------ @since 0.6.0-{-# INLINE enumerateFromThenSmallBounded #-}-enumerateFromThenSmallBounded :: (IsStream t, Monad m, Enumerable a, Bounded a)-    => a -> a -> t m a-enumerateFromThenSmallBounded from next =-    case fromEnum next >= fromEnum from of-        True -> enumerateFromThenTo from next maxBound-        False -> 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.------ @since 0.6.0-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'.-    ---    -- @-    -- > S.toList $ S.take 4 $ S.enumerateFrom (0 :: Int)-    -- [0,1,2,3]-    -- @-    ---    -- For 'Fractional' types, enumeration is numerically stable. However, no-    -- overflow or underflow checks are performed.-    ---    -- @-    -- > S.toList $ S.take 4 $ S.enumerateFrom 1.1-    -- [1.1,2.1,3.1,4.1]-    -- @-    ---    -- @since 0.6.0-    enumerateFrom :: (IsStream t, Monad m) => a -> t 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.-    ---    -- @-    -- > S.toList $ S.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.-    ---    -- @-    -- > S.toList $ S.enumerateFromTo 1.1 4-    -- [1.1,2.1,3.1,4.1]-    -- > S.toList $ S.enumerateFromTo 1.1 4.6-    -- [1.1,2.1,3.1,4.1,5.1]-    -- @-    ---    -- @since 0.6.0-    enumerateFromTo :: (IsStream t, Monad m) => a -> a -> t 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.-    ---    -- @-    -- > S.toList $ S.take 4 $ S.enumerateFromThen 0 2-    -- [0,2,4,6]-    -- > S.toList $ S.take 4 $ S.enumerateFromThen 0 (-2)-    -- [0,-2,-4,-6]-    -- @-    ---    -- @since 0.6.0-    enumerateFromThen :: (IsStream t, Monad m) => a -> a -> t 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@.-    ---    -- @-    -- > S.toList $ S.enumerateFromThenTo 0 2 6-    -- [0,2,4,6]-    -- > S.toList $ S.enumerateFromThenTo 0 (-2) (-6)-    -- [0,-2,-4,-6]-    -- @-    ---    -- @since 0.6.0-    enumerateFromThenTo :: (IsStream t, Monad m) => a -> a -> a -> t 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'------ @since 0.6.0-{-# INLINE enumerate #-}-enumerate :: (IsStream t, Monad m, Bounded a, Enumerable a) => t m a-enumerate = enumerateFrom minBound---- |--- > enumerateTo = enumerateFromTo minBound------ Enumerate a 'Bounded' type from its 'minBound' to specified value.------ @since 0.6.0-{-# INLINE enumerateTo #-}-enumerateTo :: (IsStream t, Monad m, Bounded a, Enumerable a) => a -> t m a-enumerateTo = enumerateFromTo minBound---- |--- > enumerateFromBounded = enumerateFromTo from maxBound------ 'enumerateFrom' for 'Bounded' 'Enum' types.------ @since 0.6.0-{-# INLINE enumerateFromBounded #-}-enumerateFromBounded :: (IsStream t, Monad m, Enumerable a, Bounded a)-    => a -> t 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)--#if __GLASGOW_HASKELL__ >= 800-instance Enumerable a => Enumerable (Identity a) where-    {-# INLINE enumerateFrom #-}-    enumerateFrom (Identity from) = Serial.map Identity $-        enumerateFrom from-    {-# INLINE enumerateFromThen #-}-    enumerateFromThen (Identity from) (Identity next) = Serial.map Identity $-        enumerateFromThen from next-    {-# INLINE enumerateFromTo #-}-    enumerateFromTo (Identity from) (Identity to) = Serial.map Identity $-        enumerateFromTo from to-    {-# INLINE enumerateFromThenTo #-}-    enumerateFromThenTo (Identity from) (Identity next) (Identity to) =-        Serial.map Identity $ enumerateFromThenTo from next to-#endif---- 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)--}
src/Streamly/Internal/Data/Stream/Instances.hs view
@@ -7,10 +7,12 @@  #define MONADPARALLEL , MonadAsync m -#define MONAD_COMMON_INSTANCES(STREAM,CONSTRAINT)                            \-instance Monad m => Functor (STREAM m) where { \-    {-# INLINE fmap #-}; \-    fmap f (STREAM m) = D.fromStreamD $ D.mapM (return . f) $ D.toStreamD m }; \+#define MONAD_COMMON_INSTANCES(STREAM,CONSTRAINT)                             \+instance Monad m => Functor (STREAM m) where {                                \+    {-# INLINE fmap #-};                                                      \+    fmap f (STREAM m) = D.fromStreamD $ D.mapM (return . f) $ D.toStreamD m;  \+    {-# INLINE (<$) #-};                                                      \+    (<$) =  fmap . const };                                                   \                                                                               \ instance (MonadBase b m, Monad m CONSTRAINT) => MonadBase b (STREAM m) where {\     liftBase = liftBaseDefault };                                             \@@ -33,8 +35,11 @@     local f m = fromStream $ K.withLocal f (toStream m) };                    \                                                                               \ instance (MonadState s m CONSTRAINT) => MonadState s (STREAM m) where {       \+    {-# INLINE get #-}; \     get     = lift get;                                                       \+    {-# INLINE put #-}; \     put x   = lift (put x);                                                   \+    {-# INLINE state #-}; \     state k = lift (state k) }  ------------------------------------------------------------------------------@@ -127,7 +132,7 @@                                                                               \     {-# INLINE foldl' #-};                                                    \     foldl' f z0 xs = foldr f' id xs z0                                        \-          where { f' x k z = k $! f z x};                                     \+        where {f' x k = oneShot $ \z -> k $! f z x};                          \                                                                               \     {-# INLINE length #-};                                                    \     length = foldl' (\n _ -> n + 1) 0;                                        \
+ src/Streamly/Internal/Data/Stream/IsStream.hs view
@@ -0,0 +1,34 @@+-- |+-- Module      : Streamly.Internal.Data.Stream.IsStream+-- Copyright   : (c) 2017 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : pre-release+-- Portability : GHC+--+-- This is an internal module which is a superset of the corresponding released+-- module "Streamly.Prelude". It contains some additional unreleased or+-- experimental APIs.++module Streamly.Internal.Data.Stream.IsStream+    ( module Streamly.Internal.Data.Stream.IsStream.Types+    , module Streamly.Internal.Data.Stream.IsStream.Generate+    , module Streamly.Internal.Data.Stream.IsStream.Eliminate+    , module Streamly.Internal.Data.Stream.IsStream.Transform+    , module Streamly.Internal.Data.Stream.IsStream.Expand+    , module Streamly.Internal.Data.Stream.IsStream.Reduce+    , module Streamly.Internal.Data.Stream.IsStream.Exception+    , module Streamly.Internal.Data.Stream.IsStream.Lift+    , module Streamly.Internal.Data.Stream.IsStream.Top+    )+where++import Streamly.Internal.Data.Stream.IsStream.Top+import Streamly.Internal.Data.Stream.IsStream.Eliminate+import Streamly.Internal.Data.Stream.IsStream.Exception+import Streamly.Internal.Data.Stream.IsStream.Generate+import Streamly.Internal.Data.Stream.IsStream.Lift+import Streamly.Internal.Data.Stream.IsStream.Expand+import Streamly.Internal.Data.Stream.IsStream.Reduce+import Streamly.Internal.Data.Stream.IsStream.Transform+import Streamly.Internal.Data.Stream.IsStream.Types
+ src/Streamly/Internal/Data/Stream/IsStream/Combinators.hs view
@@ -0,0 +1,231 @@+-- |+-- Module      : Streamly.Internal.Data.Stream.Combinators+-- Copyright   : (c) 2017 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+--+module Streamly.Internal.Data.Stream.IsStream.Combinators+    ( maxThreads+    , maxBuffer+    , maxYields+    , rate+    , avgRate+    , minRate+    , maxRate+    , constRate+    , inspectMode+    , printState+    )+where++#include "inline.hs"++import Control.Monad.IO.Class (MonadIO(liftIO))+import Data.Int (Int64)++import Streamly.Internal.Data.SVar+import Streamly.Internal.Data.Stream.StreamK.Type+import Streamly.Internal.Data.Stream.Serial (SerialT)++-------------------------------------------------------------------------------+-- Concurrency control+-------------------------------------------------------------------------------+--+-- XXX need to write these in direct style otherwise they will break fusion.+--+-- | Specify the maximum number of threads that can be spawned concurrently for+-- any concurrent combinator in a stream.+-- A value of 0 resets the thread limit to default, a negative value means+-- there is no limit. The default value is 1500. 'maxThreads' does not affect+-- 'ParallelT' streams as they can use unbounded number of threads.+--+-- When the actions in a stream are IO bound, having blocking IO calls, this+-- option can be used to control the maximum number of in-flight IO requests.+-- When the actions are CPU bound this option can be used to+-- control the amount of CPU used by the stream.+--+-- /Since: 0.4.0 ("Streamly")/+--+-- @since 0.8.0+{-# INLINE_NORMAL maxThreads #-}+maxThreads :: IsStream t => Int -> t m a -> t m a+maxThreads n m = mkStream $ \st stp sng yld ->+    foldStreamShared (setMaxThreads n st) stp sng yld m++{-+{-# RULES "maxThreadsSerial serial" maxThreads = maxThreadsSerial #-}+maxThreadsSerial :: Int -> SerialT m a -> SerialT m a+maxThreadsSerial _ = id+-}++-- | Specify the maximum size of the buffer for storing the results from+-- concurrent computations. If the buffer becomes full we stop spawning more+-- concurrent tasks until there is space in the buffer.+-- A value of 0 resets the buffer size to default, a negative value means+-- there is no limit. The default value is 1500.+--+-- CAUTION! using an unbounded 'maxBuffer' value (i.e. a negative value)+-- coupled with an unbounded 'maxThreads' value is a recipe for disaster in+-- presence of infinite streams, or very large streams.  Especially, it must+-- not be used when 'pure' is used in 'ZipAsyncM' streams as 'pure' in+-- applicative zip streams generates an infinite stream causing unbounded+-- concurrent generation with no limit on the buffer or threads.+--+-- /Since: 0.4.0 ("Streamly")/+--+-- @since 0.8.0+{-# INLINE_NORMAL maxBuffer #-}+maxBuffer :: IsStream t => Int -> t m a -> t m a+maxBuffer n m = mkStream $ \st stp sng yld ->+    foldStreamShared (setMaxBuffer n st) stp sng yld m++{-+{-# RULES "maxBuffer serial" maxBuffer = maxBufferSerial #-}+maxBufferSerial :: Int -> SerialT m a -> SerialT m a+maxBufferSerial _ = id+-}++-- | Specify the pull rate of a stream.+-- A 'Nothing' value resets the rate to default which is unlimited.  When the+-- rate is specified, concurrent production may be ramped up or down+-- automatically to achieve the specified yield rate. The specific behavior for+-- different styles of 'Rate' specifications is documented under 'Rate'.  The+-- effective maximum production rate achieved by a stream is governed by:+--+-- * The 'maxThreads' limit+-- * The 'maxBuffer' limit+-- * The maximum rate that the stream producer can achieve+-- * The maximum rate that the stream consumer can achieve+--+-- /Since: 0.5.0 ("Streamly")/+--+-- @since 0.8.0+{-# INLINE_NORMAL rate #-}+rate :: IsStream t => Maybe Rate -> t m a -> t m a+rate r m = mkStream $ \st stp sng yld ->+    case r of+        Just (Rate low goal _ _) | goal < low ->+            error "rate: Target rate cannot be lower than minimum rate."+        Just (Rate _ goal high _) | goal > high ->+            error "rate: Target rate cannot be greater than maximum rate."+        Just (Rate low _ high _) | low > high ->+            error "rate: Minimum rate cannot be greater than maximum rate."+        _ -> foldStreamShared (setStreamRate r st) stp sng yld m++-- XXX implement for serial streams as well, as a simple delay++{-+{-# RULES "rate serial" rate = yieldRateSerial #-}+yieldRateSerial :: Double -> SerialT m a -> SerialT m a+yieldRateSerial _ = id+-}++-- | Same as @rate (Just $ Rate (r/2) r (2*r) maxBound)@+--+-- Specifies the average production rate of a stream in number of yields+-- per second (i.e.  @Hertz@).  Concurrent production is ramped up or down+-- automatically to achieve the specified average yield rate. The rate can+-- go down to half of the specified rate on the lower side and double of+-- the specified rate on the higher side.+--+-- /Since: 0.5.0 ("Streamly")/+--+-- @since 0.8.0+avgRate :: IsStream t => Double -> t m a -> t m a+avgRate r = rate (Just $ Rate (r/2) r (2*r) maxBound)++-- | Same as @rate (Just $ Rate r r (2*r) maxBound)@+--+-- Specifies the minimum rate at which the stream should yield values. As+-- far as possible the yield rate would never be allowed to go below the+-- specified rate, even though it may possibly go above it at times, the+-- upper limit is double of the specified rate.+--+-- /Since: 0.5.0 ("Streamly")/+--+-- @since 0.8.0+minRate :: IsStream t => Double -> t m a -> t m a+minRate r = rate (Just $ Rate r r (2*r) maxBound)++-- | Same as @rate (Just $ Rate (r/2) r r maxBound)@+--+-- Specifies the maximum rate at which the stream should yield values. As+-- far as possible the yield rate would never be allowed to go above the+-- specified rate, even though it may possibly go below it at times, the+-- lower limit is half of the specified rate. This can be useful in+-- applications where certain resource usage must not be allowed to go+-- beyond certain limits.+--+-- /Since: 0.5.0 ("Streamly")/+--+-- @since 0.8.0+maxRate :: IsStream t => Double -> t m a -> t m a+maxRate r = rate (Just $ Rate (r/2) r r maxBound)++-- | Same as @rate (Just $ Rate r r r 0)@+--+-- Specifies a constant yield rate. If for some reason the actual rate+-- goes above or below the specified rate we do not try to recover it by+-- increasing or decreasing the rate in future.  This can be useful in+-- applications like graphics frame refresh where we need to maintain a+-- constant refresh rate.+--+-- /Since: 0.5.0 ("Streamly")/+--+-- @since 0.8.0+constRate :: IsStream t => Double -> t m a -> t m a+constRate r = rate (Just $ Rate r r r 0)++-- | Specify the average latency, in nanoseconds, of a single threaded action+-- in a concurrent composition. Streamly can measure the latencies, but that is+-- possible only after at least one task has completed. This combinator can be+-- used to provide a latency hint so that rate control using 'rate' can take+-- that into account right from the beginning. When not specified then a+-- default behavior is chosen which could be too slow or too fast, and would be+-- restricted by any other control parameters configured.+-- A value of 0 indicates default behavior, a negative value means there is no+-- limit i.e. zero latency.+-- This would normally be useful only in high latency and high throughput+-- cases.+--+{-# INLINE_NORMAL _serialLatency #-}+_serialLatency :: IsStream t => Int -> t m a -> t m a+_serialLatency n m = mkStream $ \st stp sng yld ->+    foldStreamShared (setStreamLatency n st) stp sng yld m++{-+{-# RULES "serialLatency serial" _serialLatency = serialLatencySerial #-}+serialLatencySerial :: Int -> SerialT m a -> SerialT m a+serialLatencySerial _ = id+-}++-- Stop concurrent dispatches after this limit. This is useful in API's like+-- "take" where we want to dispatch only upto the number of elements "take"+-- needs.  This value applies only to the immediate next level and is not+-- inherited by everything in enclosed scope.+{-# INLINE_NORMAL maxYields #-}+maxYields :: IsStream t => Maybe Int64 -> t m a -> t m a+maxYields n m = mkStream $ \st stp sng yld ->+    foldStreamShared (setYieldLimit n st) stp sng yld m++{-# RULES "maxYields serial" maxYields = maxYieldsSerial #-}+maxYieldsSerial :: Maybe Int64 -> SerialT m a -> SerialT m a+maxYieldsSerial _ = id++printState :: MonadIO m => State Stream m a -> m ()+printState st = liftIO $ do+    let msv = streamVar st+    case msv of+        Just sv -> dumpSVar sv >>= putStrLn+        Nothing -> putStrLn "No SVar"++-- | Print debug information about an SVar when the stream ends+--+-- /Pre-release/+--+inspectMode :: IsStream t => t m a -> t m a+inspectMode m = mkStream $ \st stp sng yld ->+     foldStreamShared (setInspectMode st) stp sng yld m
+ src/Streamly/Internal/Data/Stream/IsStream/Common.hs view
@@ -0,0 +1,568 @@+{-# OPTIONS_GHC -Wno-orphans  #-}++-- |+-- Module      : Streamly.Internal.Data.Stream.IsStream.Common+-- Copyright   : (c) 2017 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- Bottom level IsStream module that can be used by all other upper level+-- IsStream modules.++module Streamly.Internal.Data.Stream.IsStream.Common+    (+    -- * Generation+      fromPure+    , fromEffect+    , repeatM+    , timesWith+    , absTimesWith+    , relTimesWith++    -- * Elimination+    , fold+    , fold_++    -- * Transformation+    , scanlMAfter'+    , postscanlM'+    , smapM+    -- $smapM_Notes+    , take+    , takeWhile+    , drop+    , findIndices+    , intersperseM+    , interjectSuffix+    , reverse+    , reverse'++    -- * Nesting+    , concatM+    , concatMapM+    , concatMap+    , splitOnSeq++    -- * Deprecated+    , yield+    , yieldM+    )+where++#include "inline.hs"++import Control.Concurrent (threadDelay)+import Control.Monad.IO.Class (MonadIO(..))+import Foreign.Storable (Storable)+import Streamly.Internal.Data.Array.Foreign.Type (Array)+import Streamly.Internal.Data.Fold.Type (Fold (..))+import Streamly.Internal.Data.Stream.IsStream.Combinators (maxYields)+import Streamly.Internal.Data.Stream.Prelude (fromStreamS, toStreamS)+import Streamly.Internal.Data.Stream.Serial (SerialT)+import Streamly.Internal.Data.Stream.StreamD.Type (fromStreamD, toStreamD)+import Streamly.Internal.Data.Stream.StreamK.Type (IsStream())+import Streamly.Internal.Data.SVar (MonadAsync)+import Streamly.Internal.Data.Time.Units (AbsTime, RelTime64, addToAbsTime64)++import qualified Streamly.Internal.Data.Stream.Parallel as Par+import qualified Streamly.Internal.Data.Stream.Serial as Serial+import qualified Streamly.Internal.Data.Stream.StreamK as K (repeatM)+import qualified Streamly.Internal.Data.Stream.StreamK.Type as K+import qualified Streamly.Internal.Data.Stream.StreamD as D+#ifdef USE_STREAMK_ONLY+import qualified Streamly.Internal.Data.Stream.StreamK as S+#else+import qualified Streamly.Internal.Data.Stream.StreamD as S+#endif++import Prelude hiding (take, takeWhile, drop, reverse, concatMap)++--+-- $setup+-- >>> :m+-- >>> import Prelude hiding (take, takeWhile, drop, reverse)+-- >>> import qualified Streamly.Prelude as Stream+-- >>> import Streamly.Internal.Data.Stream.IsStream as Stream+-- >>> import qualified Streamly.Data.Fold as Fold+-- >>> import qualified Streamly.Data.Array.Foreign as Array++------------------------------------------------------------------------------+-- Generation+------------------------------------------------------------------------------++-- Faster than fromEffect because there is no bind.+--+-- |+-- @+-- fromPure a = a \`cons` nil+-- @+--+-- Create a singleton stream from a pure value.+--+-- The following holds in monadic streams, but not in Zip streams:+--+-- @+-- fromPure = pure+-- fromPure = fromEffect . pure+-- @+--+-- In Zip applicative streams 'fromPure' is not the same as 'pure' because in that+-- case 'pure' is equivalent to 'repeat' instead. 'fromPure' and 'pure' are+-- equally efficient, in other cases 'fromPure' may be slightly more efficient+-- than the other equivalent definitions.+--+-- /Since: 0.8.0 (Renamed yield to fromPure)/+--+{-# INLINE fromPure #-}+fromPure :: IsStream t => a -> t m a+fromPure = K.fromPure++-- | Same as 'fromPure'+--+-- @since 0.4.0+{-# DEPRECATED yield "Please use fromPure instead." #-}+{-# INLINE yield #-}+yield :: IsStream t => a -> t m a+yield = fromPure++-- |+-- @+-- fromEffect m = m \`consM` nil+-- @+--+-- Create a singleton stream from a monadic action.+--+-- @+-- > Stream.toList $ Stream.fromEffect getLine+-- hello+-- ["hello"]+-- @+--+-- /Since: 0.8.0 (Renamed yieldM to fromEffect)/+--+{-# INLINE fromEffect #-}+fromEffect :: (Monad m, IsStream t) => m a -> t m a+fromEffect = K.fromEffect++-- | Same as 'fromEffect'+--+-- @since 0.4.0+{-# DEPRECATED yieldM "Please use fromEffect instead." #-}+{-# INLINE yieldM #-}+yieldM :: (Monad m, IsStream t) => m a -> t m a+yieldM = fromEffect+-- |+-- @+-- repeatM = fix . consM+-- repeatM = cycle1 . fromEffect+-- @+--+-- Generate a stream by repeatedly executing a monadic action forever.+--+-- @+-- drain $ fromSerial $ S.take 10 $ S.repeatM $ (threadDelay 1000000 >> print 1)+-- drain $ fromAsync  $ S.take 10 $ S.repeatM $ (threadDelay 1000000 >> print 1)+-- @+--+-- /Concurrent, infinite (do not use with 'fromParallel')/+--+-- @since 0.2.0+{-# INLINE_EARLY repeatM #-}+repeatM :: (IsStream t, MonadAsync m) => m a -> t m a+repeatM = K.repeatM++{-# RULES "repeatM serial" repeatM = repeatMSerial #-}+{-# INLINE repeatMSerial #-}+repeatMSerial :: MonadAsync m => m a -> SerialT m a+repeatMSerial = fromStreamS . S.repeatM++------------------------------------------------------------------------------+-- 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)+-- >>> import Streamly.Internal.Data.Stream.IsStream.Common as Stream (timesWith)+-- >>> Stream.mapM_ (\x -> print x >> threadDelay 1000000) $ 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 :: (IsStream t, MonadAsync m) => Double -> t m (AbsTime, RelTime64)+timesWith g = fromStreamD $ D.times 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.+--+-- >>> Stream.mapM_ print $ Stream.delayPre 1 $ Stream.take 3 $ 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 :: (IsStream t, MonadAsync m, Functor (t m))+    => Double -> t 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.+--+-- >>> Stream.mapM_ print $ 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 :: (IsStream t, MonadAsync m, Functor (t m))+    => Double -> t m RelTime64+relTimesWith = fmap snd . timesWith++------------------------------------------------------------------------------+-- Elimination - Running a Fold+------------------------------------------------------------------------------++-- | 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.+--+-- >>> Stream.fold Fold.sum (Stream.enumerateFromTo 1 100)+-- 5050+--+-- Folds never fail, therefore, they produce a default value even when no input+-- is provided. It means we can always fold an empty stream and get a valid+-- result.  For example:+--+-- >>> Stream.fold Fold.sum Stream.nil+-- 0+--+-- However, 'foldMany' on an empty stream results in an empty stream.+-- Therefore, @Stream.fold f@ is not the same as @Stream.head . Stream.foldMany+-- f@.+--+-- @fold f = Stream.parse (Parser.fromFold f)@+--+-- @since 0.7.0+{-# INLINE fold #-}+fold :: Monad m => Fold m a b -> SerialT m a -> m b+fold fl strm = do+    (b, _) <- fold_ fl strm+    return $! b++{-# INLINE fold_ #-}+fold_ :: Monad m => Fold m a b -> SerialT m a -> m (b, SerialT m a)+fold_ fl strm = do+    (b, str) <- D.fold_ fl $ D.toStreamD strm+    return $! (b, D.fromStreamD str)++------------------------------------------------------------------------------+-- Transformation+------------------------------------------------------------------------------++-- | @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' :: (IsStream t, Monad m)+    => (b -> a -> m b) -> m b -> (b -> m b) -> t m a -> t m b+scanlMAfter' step initial done stream =+    fromStreamD $ D.scanlMAfter' step initial done $ toStreamD stream++-- XXX this needs to be concurrent+-- | Like 'postscanl'' but with a monadic step function and a monadic seed.+--+-- /Since: 0.7.0/+--+-- /Since: 0.8.0 (signature change)/+{-# INLINE postscanlM' #-}+postscanlM' :: (IsStream t, Monad m) => (b -> a -> m b) -> m b -> t m a -> t m b+postscanlM' step z m = fromStreamD $ D.postscanlM' step z $ toStreamD m++-- $smapM_Notes+--+-- The stateful step function can be simplified to @(s -> a -> m b)@ to provide+-- a read-only environment. However, that would just be 'mapM'.+--+-- The initial action could be @m (s, Maybe b)@, and we can also add a final+-- action @s -> m (Maybe b)@. This can be used to get pre/post scan like+-- functionality and also to flush the state in the end like scanlMAfter'.+-- We can also use it along with a fusible version of bracket to get+-- scanlMAfter' like functionality. See issue #677.+--+-- This can be further generalized to a type similar to Fold/Parser, giving it+-- filtering and parsing capability as well (this is in fact equivalent to+-- parseMany):+--+-- smapM :: (s -> a -> m (Step s b)) -> m s -> t m a -> t m b+--++-- | A stateful '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: 'scanlM''+--+-- /Pre-release/+--+{-# INLINE smapM #-}+smapM :: (IsStream t, Monad m) =>+       (s -> a -> m (s, b))+    -> m s+    -> t m a+    -> t m b+smapM step initial stream =+    -- XXX implement this directly instead of using scanlM'+    -- Once we have postscanlM' with monadic initial we can use this code+    -- let r = postscanlM'+    --              (\(s, _) a -> step s a)+    --              (fmap (,undefined) initial)+    --              stream+    let r = postscanlM'+                (\(s, _) a -> step s a)+                (fmap (,undefined) initial)+                stream+     in Serial.map snd r++------------------------------------------------------------------------------+-- Transformation - Trimming+------------------------------------------------------------------------------++-- | Take first 'n' elements from the stream and discard the rest.+--+-- @since 0.1.0+{-# INLINE take #-}+take :: (IsStream t, Monad m) => Int -> t m a -> t m a+take n m = fromStreamS $ S.take n $ toStreamS+    (maxYields (Just (fromIntegral n)) m)++-- | End the stream as soon as the predicate fails on an element.+--+-- @since 0.1.0+{-# INLINE takeWhile #-}+takeWhile :: (IsStream t, Monad m) => (a -> Bool) -> t m a -> t m a+takeWhile p m = fromStreamS $ S.takeWhile p $ toStreamS m++-- | Discard first 'n' elements from the stream and take the rest.+--+-- @since 0.1.0+{-# INLINE drop #-}+drop :: (IsStream t, Monad m) => Int -> t m a -> t m a+drop n m = fromStreamS $ S.drop n $ toStreamS m++------------------------------------------------------------------------------+-- Searching+------------------------------------------------------------------------------++-- | Find all the indices where the element in the stream satisfies the given+-- predicate.+--+-- > findIndices = fold Fold.findIndices+--+-- @since 0.5.0+{-# INLINE findIndices #-}+findIndices :: (IsStream t, Monad m) => (a -> Bool) -> t m a -> t m Int+findIndices p m = fromStreamS $ S.findIndices p (toStreamS m)++------------------------------------------------------------------------------+-- Transformation by Inserting+------------------------------------------------------------------------------++-- intersperseM = intersperseBySpan 1++-- | Insert an effect and its output before consuming an element of a stream+-- except the first one.+--+-- >>> Stream.toList $ Stream.trace putChar $ Stream.intersperseM (putChar '.' >> return ',') $ Stream.fromList "hello"+-- h.,e.,l.,l.,o"h,e,l,l,o"+--+-- @since 0.5.0+{-# INLINE intersperseM #-}+intersperseM :: (IsStream t, MonadAsync m) => m a -> t m a -> t m a+intersperseM m = fromStreamS . S.intersperseM m . toStreamS++-- | Intersperse a monadic action into the input stream after every @n@+-- seconds.+--+-- @+-- > import Control.Concurrent (threadDelay)+-- > Stream.drain $ Stream.interjectSuffix 1 (putChar ',') $ Stream.mapM (\x -> threadDelay 1000000 >> putChar x) $ Stream.fromList "hello"+-- h,e,l,l,o+-- @+--+-- /Pre-release/+{-# INLINE interjectSuffix #-}+interjectSuffix+    :: (IsStream t, MonadAsync m)+    => Double -> m a -> t m a -> t m a+interjectSuffix n f xs = xs `Par.parallelFst` repeatM timed+    where timed = liftIO (threadDelay (round $ n * 1000000)) >> f++------------------------------------------------------------------------------+-- 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.+--+-- > reverse = S.foldlT (flip S.cons) S.nil+--+-- | Returns the elements of the stream in reverse order.  The stream must be+-- finite. Note that this necessarily buffers the entire stream in memory.+--+-- /Since 0.7.0 (Monad m constraint)/+--+-- /Since: 0.1.1/+{-# INLINE reverse #-}+reverse :: (IsStream t, Monad m) => t m a -> t m a+reverse s = fromStreamS $ S.reverse $ toStreamS s++-- | Like 'reverse' but several times faster, requires a 'Storable' instance.+--+-- /Pre-release/+{-# INLINE reverse' #-}+reverse' :: (IsStream t, MonadIO m, Storable a) => t m a -> t m a+reverse' s = fromStreamD $ D.reverse' $ toStreamD s++------------------------------------------------------------------------------+-- 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.+--+-- @since 0.6.0+{-# INLINE concatMapM #-}+concatMapM :: (IsStream t, Monad m) => (a -> m (t m b)) -> t m a -> t 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 = 'concatMapM' (return . f)+-- concatMap = 'concatMapWith' 'Serial.serial'+-- concatMap f = 'concat . map f'+-- concatMap f = 'unfoldMany' (UF.lmap f UF.fromStream)+-- @+--+-- @since 0.6.0+{-# INLINE concatMap #-}+concatMap ::(IsStream t, Monad m) => (a -> t m b) -> t m a -> t m b+concatMap f m = fromStreamD $ D.concatMap (toStreamD . f) (toStreamD m)++-- | Given a stream value in the underlying monad, lift and join the underlying+-- monad with the stream monad.+--+-- @+-- concatM = concat . fromEffect+-- concatM = concat . lift    -- requires @(MonadTrans t)@+-- concatM = join . lift      -- requires @(MonadTrans t@, @Monad (t m))@+-- @+--+-- See also: 'concat', 'sequence'+--+--  /Internal/+--+{-# INLINE concatM #-}+concatM :: (IsStream t, Monad m) => m (t m a) -> t m a+concatM generator = concatMapM (\() -> generator) (fromPure ())++------------------------------------------------------------------------------+-- Split stream and fold+------------------------------------------------------------------------------++-- | Like 'splitOn' but the separator is a sequence of elements instead of a+-- single element.+--+-- For illustration, let's define a function that operates on pure lists:+--+-- >>> splitOnSeq' pat xs = Stream.toList $ Stream.splitOnSeq (Array.fromList pat) Fold.toList (Stream.fromList xs)+--+-- >>> splitOnSeq' "" "hello"+-- ["h","e","l","l","o"]+--+-- >>> splitOnSeq' "hello" ""+-- [""]+--+-- >>> splitOnSeq' "hello" "hello"+-- ["",""]+--+-- >>> splitOnSeq' "x" "hello"+-- ["hello"]+--+-- >>> splitOnSeq' "h" "hello"+-- ["","ello"]+--+-- >>> splitOnSeq' "o" "hello"+-- ["hell",""]+--+-- >>> splitOnSeq' "e" "hello"+-- ["h","llo"]+--+-- >>> splitOnSeq' "l" "hello"+-- ["he","","o"]+--+-- >>> splitOnSeq' "ll" "hello"+-- ["he","o"]+--+-- 'splitOnSeq' is an inverse of 'intercalate'. The following law always holds:+--+-- > intercalate . splitOn == id+--+-- The following law holds when the separator is non-empty and contains none of+-- the elements present in the input lists:+--+-- > splitOn . intercalate == id+--+-- /Pre-release/++-- XXX We can use a polymorphic vector implemented by Array# to represent the+-- sequence, that way we can avoid the Storable constraint. If we still need+-- Storable Array for performance, we can use a separate splitOnArray API for+-- that. We can also have an API where the sequence itself is a lazy stream, so+-- that we can search files in files for example.+{-# INLINE splitOnSeq #-}+splitOnSeq+    :: (IsStream t, MonadIO m, Storable a, Enum a, Eq a)+    => Array a -> Fold m a b -> t m a -> t m b+splitOnSeq patt f m = D.fromStreamD $ D.splitOnSeq patt f (D.toStreamD m)
+ src/Streamly/Internal/Data/Stream/IsStream/Eliminate.hs view
@@ -0,0 +1,1021 @@+-- |+-- Module      : Streamly.Internal.Data.Stream.IsStream.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:+--+-- @+-- t m a -> m b+-- @+--+-- We call them stream folding functions, they reduce a stream @t m a@ to a+-- monadic value @m b@.++module Streamly.Internal.Data.Stream.IsStream.Eliminate+    (+    -- * Running Examples+    -- $setup++    -- * Running a 'Fold'+    --  See "Streamly.Internal.Data.Fold".+      fold+    , fold_++    -- * Running a 'Parser'+    -- "Streamly.Internal.Data.Parser".+    , parse+    , parseK+    , parseD+    , parse_+    , parseD_++    -- * 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++    -- * Right Folds+    , foldrM+    , foldr++    -- * Left Folds+    , foldl'+    , foldl1'+    , foldlM'++    -- * Specific Fold Functions+    -- | Folds as functions of the shape @t m a -> m b@.+    --+    -- These functions are good to run individually but they do not compose+    -- well. Prefer writing folds as the 'Fold' data type. Use folds from+    -- "Streamly.Internal.Data.Fold" instead of using the functions in this+    -- section.+    --+    -- This section can possibly be removed in future.  Are these better in+    -- some case compared to 'Fold'? When the input stream is in CPS style+    -- (StreamK) we may want to rewrite the function call to CPS implementation+    -- of the fold through these definitions. Will that be more efficient for+    -- StreamK?++    -- ** Full Folds++    -- -- ** To Summary (Full Folds)+    , mapM_+    , drain+    , last+    , length+    , sum+    , product+    , mconcat++    -- -- ** To Summary (Maybe) (Full Folds)+    , maximumBy+    , maximum+    , minimumBy+    , minimum+    , the++    -- ** Partial Folds++    -- -- ** To Elements (Partial Folds)+    , drainN+    , drainWhile++    -- -- | Folds that extract selected elements of a stream or their properties.+    , (!!)+    , head+    , headElse+    , tail+    , init+    , findM+    , find+    , findIndex+    , elemIndex+    , lookup++    -- -- ** To Boolean (Partial Folds)+    , null+    , elem+    , notElem+    , all+    , any+    , and+    , or++    -- -- ** Lazy Folds+    -- ** To Containers+    , toList+    , toListRev+    , toStream+    , toStreamRev++    -- * Concurrent Folds+    , foldAsync+    , (|$.)+    , (|&.)++    -- * Multi-Stream folds+    -- Full equivalence+    , eqBy+    , cmpBy++    -- finding subsequences+    , isPrefixOf+    , isInfixOf+    , isSuffixOf+    , isSubsequenceOf++    -- trimming sequences+    , stripPrefix+    -- , stripInfix+    , stripSuffix++    -- * Deprecated+    , foldx+    , foldxM+    , foldr1+    , runStream+    , runN+    , runWhile+    , toHandle+    )+where++#include "inline.hs"++import Control.Monad.Catch (MonadThrow)+import Control.Monad.IO.Class (MonadIO(..))+import Data.Functor.Identity (Identity (..))+import Foreign.Storable (Storable)+import Streamly.Internal.Data.Parser (Parser (..))+import Streamly.Internal.Data.SVar (MonadAsync, defState)+import Streamly.Internal.Data.Stream.IsStream.Common+    ( fold, fold_, drop, findIndices, reverse, splitOnSeq, take+    , takeWhile)+import Streamly.Internal.Data.Stream.Prelude (toStreamS)+import Streamly.Internal.Data.Stream.StreamD (fromStreamD, toStreamD)+import Streamly.Internal.Data.Stream.StreamK (IsStream)+import Streamly.Internal.Data.Stream.Serial (SerialT)++import qualified Streamly.Internal.Data.Array.Foreign.Type as A+import qualified Streamly.Internal.Data.Fold as FL+import qualified Streamly.Internal.Data.Stream.Parallel as Par+import qualified Streamly.Internal.Data.Stream.Prelude as P+import qualified Streamly.Internal.Data.Stream.StreamD as D+import qualified Streamly.Internal.Data.Stream.StreamK as K+import qualified Streamly.Internal.Data.Parser.ParserD as PRD+import qualified Streamly.Internal.Data.Parser.ParserK.Type as PRK+import qualified System.IO as IO+#ifdef USE_STREAMK_ONLY+import qualified Streamly.Internal.Data.Stream.StreamK as S+#else+import qualified Streamly.Internal.Data.Stream.StreamD as S+#endif++import Prelude hiding+       ( drop, take, takeWhile, foldr , foldl, mapM_, sequence, all, any, sum+       , product, elem, notElem, maximum, minimum, head, last, tail, length+       , null , reverse, init, and, or, lookup, foldr1, (!!) , splitAt, break+       , mconcat)++-- $setup+-- >>> :m+-- >>> import Streamly.Prelude (SerialT)+-- >>> import qualified Streamly.Prelude as Stream+-- >>> import qualified Streamly.Internal.Data.Stream.IsStream as Stream+-- >>> import qualified Streamly.Internal.Data.Parser as Parser+-- >>> import qualified Streamly.Data.Fold as Fold++------------------------------------------------------------------------------+-- 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.+--+-- This is a brute force primitive. Avoid using it as long as possible, use it+-- when no other combinator can do the job. This can be used to do pretty much+-- anything in an imperative manner, 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+-- the specific implementations are generally more efficient.+--+-- @since 0.1.0+{-# INLINE uncons #-}+uncons :: (IsStream t, Monad m) => SerialT m a -> m (Maybe (a, t m a))+uncons m = K.uncons (K.adapt 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:+--+-- >>> Stream.foldrM (\x xs -> if odd x then return True else xs) (return False) $ Stream.fromList (2:4:5:undefined)+-- True+--+-- /Since: 0.7.0 (signature changed)/+--+-- /Since: 0.2.0 (signature changed)/+--+-- /Since: 0.1.0/+{-# INLINE foldrM #-}+foldrM :: Monad m => (a -> m b -> m b) -> m b -> SerialT m a -> m b+foldrM = P.foldrM++-- | 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.+--+-- @since 0.1.0+{-# INLINE foldr #-}+foldr :: Monad m => (a -> b -> b) -> b -> SerialT m a -> m b+foldr = P.foldr++-- XXX This seems to be of limited use as it cannot be used to construct+-- recursive structures and for reduction foldl1' is better.+--+-- | Lazy right fold for non-empty streams, using first element as the starting+-- value. Returns 'Nothing' if the stream is empty.+--+-- @since 0.5.0+{-# INLINE foldr1 #-}+{-# DEPRECATED foldr1 "Use foldrM instead." #-}+foldr1 :: Monad m => (a -> a -> a) -> SerialT m a -> m (Maybe a)+foldr1 f m = S.foldr1 f (toStreamS m)++------------------------------------------------------------------------------+-- Left Folds+------------------------------------------------------------------------------++-- | 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.+--+-- @since 0.2.0+{-# DEPRECATED foldx "Please use foldl' followed by fmap instead." #-}+{-# INLINE foldx #-}+foldx :: Monad m => (x -> a -> x) -> x -> (x -> b) -> SerialT m a -> m b+foldx = P.foldlx'++-- | Left associative/strict push fold. @foldl' reduce initial stream@ invokes+-- @reduce@ with the accumulator and the next input in the input stream, using+-- @initial@ as the initial value of the current value of the accumulator. When+-- the input is exhausted the current value of the accumulator is returned.+-- Make sure to use a strict data structure for accumulator to not build+-- unnecessary lazy expressions unless that's what you want. See the previous+-- section for more details.+--+-- @since 0.2.0+{-# INLINE foldl' #-}+foldl' :: Monad m => (b -> a -> b) -> b -> SerialT m a -> m b+foldl' = P.foldl'++-- | Strict left fold, for non-empty streams, using first element as the+-- starting value. Returns 'Nothing' if the stream is empty.+--+-- @since 0.5.0+{-# INLINE foldl1' #-}+foldl1' :: Monad m => (a -> a -> a) -> SerialT m a -> m (Maybe a)+foldl1' step m = do+    r <- uncons m+    case r of+        Nothing -> return Nothing+        Just (h, t) -> do+            res <- foldl' step h t+            return $ Just res++-- | Like 'foldx', but with a monadic step function.+--+-- @since 0.2.0+{-# DEPRECATED foldxM "Please use foldlM' followed by fmap instead." #-}+{-# INLINE foldxM #-}+foldxM :: Monad m => (x -> a -> m x) -> m x -> (x -> m b) -> SerialT m a -> m b+foldxM = P.foldlMx'++-- | Like 'foldl'' but with a monadic step function.+--+-- /Since: 0.2.0/+--+-- /Since: 0.8.0 (signature change)/+{-# INLINE foldlM' #-}+foldlM' :: Monad m => (b -> a -> m b) -> m b -> SerialT m a -> m b+foldlM' step begin m = S.foldlM' step begin $ toStreamS m++------------------------------------------------------------------------------+-- Running a sink+------------------------------------------------------------------------------++{-+-- | Drain a stream to a 'Sink'.+{-# INLINE runSink #-}+runSink :: Monad m => Sink m a -> SerialT m a -> m ()+runSink = fold . toFold+-}++------------------------------------------------------------------------------+-- Running a Parser+------------------------------------------------------------------------------++-- | Parse a stream using the supplied ParserD 'PRD.Parser'.+--+-- /Internal/+--+{-# INLINE_NORMAL parseD #-}+parseD :: MonadThrow m => PRD.Parser m a b -> SerialT m a -> m b+parseD p = D.parse p . toStreamD++-- | Parse a stream using the supplied ParserK 'PRK.Parser'.+--+-- /Internal/+{-# INLINE parseK #-}+parseK :: MonadThrow m => PRK.Parser m a b -> SerialT m a -> m b+parseK = parse++-- | Parse a stream using the supplied 'Parser'.+--+-- 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+-- *** Exception: ParseError "takeEQ: Expecting exactly 1 elements, input terminated on 0"+--+-- Note:+--+-- @+-- fold f = Stream.parse (Parser.fromFold f)+-- @+--+-- @parse p@ is not the same as  @head . parseMany p@ on an empty stream.+--+-- /Pre-release/+--+{-# INLINE [3] parse #-}+parse :: MonadThrow m => Parser m a b -> SerialT m a -> m b+parse = parseD . PRK.fromParserK++{-# INLINE_NORMAL parseD_ #-}+parseD_ :: MonadThrow m => PRD.Parser m a b -> SerialT m a -> m (b, SerialT m a)+parseD_ parser strm = do+    (b, strmD) <- D.parse_ parser (toStreamD strm)+    return $! (b, fromStreamD strmD)++-- | Parse a stream using the supplied 'Parser'.+--+-- /Internal/+--+{-# INLINE [3] parse_ #-}+parse_ :: MonadThrow m => Parser m a b -> SerialT m a -> m (b, SerialT m a)+parse_ = parseD_ . PRK.fromParserK++------------------------------------------------------------------------------+-- Specific Fold Functions+------------------------------------------------------------------------------++-- XXX this can utilize parallel mapping if we implement it as drain . mapM+-- |+-- > mapM_ = Stream.drain . Stream.mapM+--+-- Apply a monadic action to each element of the stream and discard the output+-- of the action. This is not really a pure transformation operation but a+-- transformation followed by fold.+--+-- @since 0.1.0+{-# INLINE mapM_ #-}+mapM_ :: Monad m => (a -> m b) -> SerialT m a -> m ()+mapM_ f m = S.mapM_ f $ toStreamS m++-- |+-- > drain = mapM_ (\_ -> return ())+-- > drain = Stream.fold Fold.drain+--+-- Run a stream, discarding the results. By default it interprets the stream+-- as 'SerialT', to run other types of streams use the type adapting+-- combinators for example @Stream.drain . 'fromAsync'@.+--+-- @since 0.7.0+{-# INLINE drain #-}+drain :: Monad m => SerialT m a -> m ()+drain = P.drain++-- |+-- > drainN n = Stream.drain . Stream.take n+-- > drainN n = Stream.fold (Fold.take n Fold.drain)+--+-- Run maximum up to @n@ iterations of a stream.+--+-- @since 0.7.0+{-# INLINE drainN #-}+drainN :: Monad m => Int -> SerialT m a -> m ()+drainN n = drain . take n++-- |+-- > runN n = runStream . take n+--+-- Run maximum up to @n@ iterations of a stream.+--+-- @since 0.6.0+{-# DEPRECATED runN "Please use \"drainN\" instead" #-}+{-# INLINE runN #-}+runN :: Monad m => Int -> SerialT m a -> m ()+runN = drainN++-- |+-- > drainWhile p = Stream.drain . Stream.takeWhile p+--+-- Run a stream as long as the predicate holds true.+--+-- @since 0.7.0+{-# INLINE drainWhile #-}+drainWhile :: Monad m => (a -> Bool) -> SerialT m a -> m ()+drainWhile p = drain . takeWhile p++-- |+-- > runWhile p = runStream . takeWhile p+--+-- Run a stream as long as the predicate holds true.+--+-- @since 0.6.0+{-# DEPRECATED runWhile "Please use \"drainWhile\" instead" #-}+{-# INLINE runWhile #-}+runWhile :: Monad m => (a -> Bool) -> SerialT m a -> m ()+runWhile = drainWhile++-- | Run a stream, discarding the results. By default it interprets the stream+-- as 'SerialT', to run other types of streams use the type adapting+-- combinators for example @runStream . 'fromAsync'@.+--+-- @since 0.2.0+{-# DEPRECATED runStream "Please use \"drain\" instead" #-}+{-# INLINE runStream #-}+runStream :: Monad m => SerialT m a -> m ()+runStream = drain++-- | Determine whether the stream is empty.+--+-- > null = Stream.fold Fold.null+--+-- @since 0.1.1+{-# INLINE null #-}+null :: Monad m => SerialT m a -> m Bool+null = S.null . toStreamS++-- | Extract the first element of the stream, if any.+--+-- > head = (!! 0)+-- > head = Stream.fold Fold.head+--+-- @since 0.1.0+{-# INLINE head #-}+head :: Monad m => SerialT m a -> m (Maybe a)+head = S.head . toStreamS++-- | Extract the first element of the stream, if any, otherwise use the+-- supplied default value. It can help avoid one branch in high performance+-- code.+--+-- /Pre-release/+{-# INLINE headElse #-}+headElse :: Monad m => a -> SerialT m a -> m a+headElse x = D.headElse x . toStreamD++-- |+-- > tail = fmap (fmap snd) . Stream.uncons+--+-- Extract all but the first element of the stream, if any.+--+-- @since 0.1.1+{-# INLINE tail #-}+tail :: (IsStream t, Monad m) => SerialT m a -> m (Maybe (t m a))+tail m = K.tail (K.adapt m)++-- | Extract all but the last element of the stream, if any.+--+-- @since 0.5.0+{-# INLINE init #-}+init :: (IsStream t, Monad m) => SerialT m a -> m (Maybe (t m a))+init m = K.init (K.adapt m)++-- | Extract the last element of the stream, if any.+--+-- > last xs = xs !! (Stream.length xs - 1)+-- > last = Stream.fold Fold.last+--+-- @since 0.1.1+{-# INLINE last #-}+last :: Monad m => SerialT m a -> m (Maybe a)+last m = S.last $ toStreamS m++-- | Determine whether an element is present in the stream.+--+-- > elem = Stream.fold Fold.elem+--+-- @since 0.1.0+{-# INLINE elem #-}+elem :: (Monad m, Eq a) => a -> SerialT m a -> m Bool+elem e m = S.elem e (toStreamS m)++-- | Determine whether an element is not present in the stream.+--+-- > notElem = Stream.fold Fold.length+--+-- @since 0.1.0+{-# INLINE notElem #-}+notElem :: (Monad m, Eq a) => a -> SerialT m a -> m Bool+notElem e m = S.notElem e (toStreamS m)++-- | Determine the length of the stream.+--+-- @since 0.1.0+{-# INLINE length #-}+length :: Monad m => SerialT m a -> m Int+length = foldl' (\n _ -> n + 1) 0++-- | Determine whether all elements of a stream satisfy a predicate.+--+-- > all = Stream.fold Fold.all+--+-- @since 0.1.0+{-# INLINE all #-}+all :: Monad m => (a -> Bool) -> SerialT m a -> m Bool+all p m = S.all p (toStreamS m)++-- | Determine whether any of the elements of a stream satisfy a predicate.+--+-- > any = Stream.fold Fold.any+--+-- @since 0.1.0+{-# INLINE any #-}+any :: Monad m => (a -> Bool) -> SerialT m a -> m Bool+any p m = S.any p (toStreamS m)++-- | Determines if all elements of a boolean stream are True.+--+-- > and = Stream.fold Fold.and+--+-- @since 0.5.0+{-# INLINE and #-}+and :: Monad m => SerialT m Bool -> m Bool+and = all (==True)++-- | Determines whether at least one element of a boolean stream is True.+--+-- > or = Stream.fold Fold.or+--+-- @since 0.5.0+{-# INLINE or #-}+or :: Monad m => SerialT m Bool -> m Bool+or = any (==True)++-- | Determine the sum of all elements of a stream of numbers. Returns @0@ when+-- the stream is empty. Note that this is not numerically stable for floating+-- point numbers.+--+-- > sum = Stream.fold Fold.sum+--+-- @since 0.1.0+{-# INLINE sum #-}+sum :: (Monad m, Num a) => SerialT m a -> m a+sum = foldl' (+) 0++-- | Determine the product of all elements of a stream of numbers. Returns @1@+-- when the stream is empty.+--+-- > product = Stream.fold Fold.product+--+-- @since 0.1.1+{-# INLINE product #-}+product :: (Monad m, Num a) => SerialT m a -> m a+product = foldl' (*) 1++-- | Fold a stream of monoid elements by appending them.+--+-- > mconcat = Stream.fold Fold.mconcat+--+-- /Pre-release/+{-# INLINE mconcat #-}+mconcat :: (Monad m, Monoid a) => SerialT m a -> m a+mconcat = foldr mappend mempty++-- |+-- @+-- minimum = 'minimumBy' compare+ -- minimum = Stream.fold Fold.minimum+-- @+--+-- Determine the minimum element in a stream.+--+-- @since 0.1.0+{-# INLINE minimum #-}+minimum :: (Monad m, Ord a) => SerialT m a -> m (Maybe a)+minimum m = S.minimum (toStreamS m)++-- | Determine the minimum element in a stream using the supplied comparison+-- function.+--+-- > minimumBy = Stream.fold Fold.minimumBy+--+-- @since 0.6.0+{-# INLINE minimumBy #-}+minimumBy :: Monad m => (a -> a -> Ordering) -> SerialT m a -> m (Maybe a)+minimumBy cmp m = S.minimumBy cmp (toStreamS m)++-- |+-- @+-- maximum = 'maximumBy' compare+-- maximum = Stream.fold Fold.maximum+-- @+--+-- Determine the maximum element in a stream.+--+-- @since 0.1.0+{-# INLINE maximum #-}+maximum :: (Monad m, Ord a) => SerialT m a -> m (Maybe a)+maximum = P.maximum++-- | Determine the maximum element in a stream using the supplied comparison+-- function.+--+-- > maximumBy = Stream.fold Fold.maximumBy+--+-- @since 0.6.0+{-# INLINE maximumBy #-}+maximumBy :: Monad m => (a -> a -> Ordering) -> SerialT m a -> m (Maybe a)+maximumBy cmp m = S.maximumBy cmp (toStreamS m)++-- | Ensures that all the elements of the stream are identical and then returns+-- that unique element.+--+-- @since 0.6.0+{-# INLINE the #-}+the :: (Eq a, Monad m) => SerialT m a -> m (Maybe a)+the m = S.the (toStreamS m)++------------------------------------------------------------------------------+-- Searching+------------------------------------------------------------------------------++-- | Lookup the element at the given index.+--+-- @since 0.6.0+{-# INLINE (!!) #-}+(!!) :: Monad m => SerialT m a -> Int -> m (Maybe a)+m !! i = toStreamS m S.!! i++-- | 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@.+--+-- > lookup = snd <$> Stream.find ((==) . fst)+-- > lookup = Stream.fold Fold.lookup+--+-- @since 0.5.0+{-# INLINE lookup #-}+lookup :: (Monad m, Eq a) => a -> SerialT m (a, b) -> m (Maybe b)+lookup a m = S.lookup a (toStreamS m)++-- | Like 'findM' but with a non-monadic predicate.+--+-- > find p = findM (return . p)+-- > find = Stream.fold Fold.find+--+-- @since 0.5.0+{-# INLINE find #-}+find :: Monad m => (a -> Bool) -> SerialT m a -> m (Maybe a)+find p m = S.find p (toStreamS m)++-- | Returns the first element that satisfies the given predicate.+--+-- > findM = Stream.fold Fold.findM+--+-- @since 0.6.0+{-# INLINE findM #-}+findM :: Monad m => (a -> m Bool) -> SerialT m a -> m (Maybe a)+findM p m = S.findM p (toStreamS m)++-- | Returns the first index that satisfies the given predicate.+--+-- > findIndex = Stream.fold Fold.findIndex+--+-- @since 0.5.0+{-# INLINE findIndex #-}+findIndex :: Monad m => (a -> Bool) -> SerialT m a -> m (Maybe Int)+findIndex p = head . findIndices p++-- | Returns the first index where a given value is found in the stream.+--+-- > elemIndex a = Stream.findIndex (== a)+--+-- @since 0.5.0+{-# INLINE elemIndex #-}+elemIndex :: (Monad m, Eq a) => a -> SerialT m a -> m (Maybe Int)+elemIndex a = findIndex (== a)++------------------------------------------------------------------------------+-- To containers+------------------------------------------------------------------------------++-- |+-- @+-- toList = Stream.foldr (:) []+-- @+--+-- 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.Array" instead.+--+-- @since 0.1.0+{-# INLINE toList #-}+toList :: Monad m => SerialT m a -> m [a]+toList = P.toList++-- |+-- @+-- toListRev = Stream.foldl' (flip (:)) []+-- @+--+-- Convert a stream into a list in reverse order in the underlying monad.+--+-- /Warning!/ working on large lists accumulated as buffers in memory could be+-- very inefficient, consider using "Streamly.Array" instead.+--+-- /Pre-release/+{-# INLINE toListRev #-}+toListRev :: Monad m => SerialT m a -> m [a]+toListRev = D.toListRev . toStreamD++-- |+-- @+-- toHandle h = S.mapM_ $ hPutStrLn h+-- @+--+-- Write a stream of Strings to an IO Handle.+--+-- @since 0.1.0+{-# DEPRECATED toHandle+   "Please use Streamly.FileSystem.Handle module (see the changelog)" #-}+toHandle :: MonadIO m => IO.Handle -> SerialT m String -> m ()+toHandle h = go+    where+    go m1 =+        let stop = return ()+            single a = liftIO (IO.hPutStrLn h a)+            yieldk a r = liftIO (IO.hPutStrLn h a) >> go r+        in K.foldStream defState yieldk single stop m1++-- | Convert a stream to a pure stream.+--+-- @+-- toStream = Stream.foldr Stream.cons Stream.nil+-- @+--+-- /Pre-release/+--+{-# INLINE toStream #-}+toStream :: Monad m => SerialT m a -> m (SerialT Identity a)+toStream = foldr K.cons K.nil++-- | Convert a stream to a pure stream in reverse order.+--+-- @+-- toStreamRev = Stream.foldl' (flip Stream.cons) Stream.nil+-- @+--+-- /Pre-release/+--+{-# INLINE toStreamRev #-}+toStreamRev :: Monad m => SerialT m a -> m (SerialT Identity a)+toStreamRev = foldl' (flip K.cons) K.nil++------------------------------------------------------------------------------+-- Concurrent Application+------------------------------------------------------------------------------++-- | Parallel fold application operator; applies a fold function @t m a -> m b@+-- to a stream @t m a@ concurrently; The the input stream is evaluated+-- asynchronously in an independent thread yielding elements to a buffer and+-- the folding action runs in another thread consuming the input from the+-- buffer.+--+-- If you read the signature as @(t m a -> m b) -> (t m a -> m b)@ you can look+-- at it as a transformation that converts a fold function to a buffered+-- concurrent fold function.+--+-- The @.@ at the end of the operator is a mnemonic for termination of the+-- stream.+--+-- In the example below, each stage introduces a delay of 1 sec but output is+-- printed every second because both stages are concurrent.+--+-- >>> import Control.Concurrent (threadDelay)+-- >>> import Streamly.Prelude ((|$.))+-- >>> :{+--  Stream.foldlM' (\_ a -> threadDelay 1000000 >> print a) (return ())+--      |$. Stream.replicateM 3 (threadDelay 1000000 >> return 1)+-- :}+-- 1+-- 1+-- 1+--+-- /Concurrent/+--+-- /Since: 0.3.0 ("Streamly")/+--+-- @since 0.8.0+{-# INLINE (|$.) #-}+(|$.) :: (IsStream t, MonadAsync m) => (t m a -> m b) -> (t m a -> m b)+-- (|$.) f = f . Async.mkAsync+(|$.) f = f . Par.mkParallel++infixr 0 |$.++-- | Same as '|$.'.+--+--  /Internal/+--+{-# INLINE foldAsync #-}+foldAsync :: (IsStream t, MonadAsync m) => (t m a -> m b) -> (t m a -> m b)+foldAsync = (|$.)++-- | Same as '|$.' but with arguments reversed.+--+-- > (|&.) = flip (|$.)+--+-- /Concurrent/+--+-- /Since: 0.3.0 ("Streamly")/+--+-- @since 0.8.0+{-# INLINE (|&.) #-}+(|&.) :: (IsStream t, MonadAsync m) => t m a -> (t m a -> m b) -> m b+x |&. f = f |$. x++infixl 1 |&.++------------------------------------------------------------------------------+-- 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" :: SerialT IO Char)+-- True+--+-- @since 0.6.0+{-# INLINE isPrefixOf #-}+isPrefixOf :: (Eq a, IsStream t, Monad m) => t m a -> t 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.+--+-- > Stream.isInfixOf (Stream.fromList "hello") (Stream.fromList "hello" :: SerialT IO Char)+-- 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)+    => SerialT m a -> SerialT m a -> m Bool+isInfixOf infx stream = do+    arr <- fold A.write infx+    -- XXX can use breakOnSeq instead (when available)+    r <- null $ drop 1 $ splitOnSeq arr FL.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" :: SerialT 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) => SerialT m a -> SerialT 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" :: SerialT IO Char)+-- True+--+-- @since 0.6.0+{-# INLINE isSubsequenceOf #-}+isSubsequenceOf :: (Eq a, IsStream t, Monad m) => t m a -> t 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 stream@ strips @prefix@ from @stream@ if it is a+-- prefix of stream. Returns 'Nothing' if the stream does not start with the+-- given prefix, stripped stream otherwise. Returns @Just nil@ when the prefix+-- is the same as the stream.+--+-- See also "Streamly.Internal.Data.Stream.IsStream.Nesting.dropPrefix".+--+-- Space: @O(1)@+--+-- @since 0.6.0+{-# INLINE stripPrefix #-}+stripPrefix+    :: (Eq a, IsStream t, Monad m)+    => t m a -> t m a -> m (Maybe (t 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.IsStream.Nesting.dropSuffix".+--+-- Space: @O(n)@, buffers the entire input stream as well as the suffix+--+-- /Pre-release/+{-# INLINE stripSuffix #-}+stripSuffix+    :: (Monad m, Eq a)+    => SerialT m a -> SerialT m a -> m (Maybe (SerialT m a))+stripSuffix m1 m2 = fmap reverse <$> stripPrefix (reverse m1) (reverse m2)++------------------------------------------------------------------------------+-- Comparison+------------------------------------------------------------------------------++-- | Compare two streams for equality using an equality function.+--+-- @since 0.6.0+{-# INLINABLE eqBy #-}+eqBy :: (IsStream t, Monad m) => (a -> b -> Bool) -> t m a -> t m b -> m Bool+eqBy = P.eqBy++-- | Compare two streams lexicographically using a comparison function.+--+-- @since 0.6.0+{-# INLINABLE cmpBy #-}+cmpBy+    :: (IsStream t, Monad m)+    => (a -> b -> Ordering) -> t m a -> t m b -> m Ordering+cmpBy = P.cmpBy
+ src/Streamly/Internal/Data/Stream/IsStream/Enumeration.hs view
@@ -0,0 +1,574 @@+-- |+-- Module      : Streamly.Internal.Data.Stream.Enumeration+-- 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.++module Streamly.Internal.Data.Stream.IsStream.Enumeration+    (+      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.StreamD.Type (fromStreamD)+import Streamly.Internal.Data.Stream.StreamK.Type (IsStream(..))++import qualified Streamly.Internal.Data.Stream.StreamD.Generate as D+import qualified Streamly.Internal.Data.Stream.Serial as Serial (map)++-- $setup+-- >>> import Streamly.Prelude as Stream+-- >>> import Streamly.Internal.Data.Stream.IsStream.Enumeration 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.toList $ Stream.take 4 $ Stream.enumerateFromStepIntegral 0 2+-- [0,2,4,6]+--+-- >>> Stream.toList $ Stream.take 3 $ Stream.enumerateFromStepIntegral 0 (-2)+-- [0,-2,-4]+--+-- @+--+-- @since 0.6.0+{-# INLINE enumerateFromStepIntegral #-}+enumerateFromStepIntegral+    :: (IsStream t, Monad m, Integral a)+    => a -> a -> t 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.toList $ Stream.take 4 $ Stream.enumerateFromIntegral (0 :: Int)+-- [0,1,2,3]+--+-- @+--+-- @since 0.6.0+{-# INLINE enumerateFromIntegral #-}+enumerateFromIntegral+    :: (IsStream t, Monad m, Integral a, Bounded a)+    => a -> t 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.toList $ Stream.take 4 $ Stream.enumerateFromThenIntegral (0 :: Int) 2+-- [0,2,4,6]+--+-- >>> Stream.toList $ Stream.take 4 $ Stream.enumerateFromThenIntegral (0 :: Int) (-2)+-- [0,-2,-4,-6]+--+-- @+--+-- @since 0.6.0+{-# INLINE enumerateFromThenIntegral #-}+enumerateFromThenIntegral+    :: (IsStream t, Monad m, Integral a, Bounded a)+    => a -> a -> t 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.toList $ Stream.enumerateFromToIntegral 0 4+-- [0,1,2,3,4]+--+-- @+--+-- @since 0.6.0+{-# INLINE enumerateFromToIntegral #-}+enumerateFromToIntegral :: (IsStream t, Monad m, Integral a) => a -> a -> t 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.toList $ Stream.enumerateFromThenToIntegral 0 2 6+-- [0,2,4,6]+--+-- >>> Stream.toList $ Stream.enumerateFromThenToIntegral 0 (-2) (-6)+-- [0,-2,-4,-6]+--+-- @+--+-- @since 0.6.0+{-# INLINE enumerateFromThenToIntegral #-}+enumerateFromThenToIntegral+    :: (IsStream t, Monad m, Integral a)+    => a -> a -> a -> t 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.toList $ Stream.take 4 $ Stream.enumerateFromFractional 1.1+-- [1.1,2.1,3.1,4.1]+--+-- @+--+--+-- @since 0.6.0+{-# INLINE enumerateFromFractional #-}+enumerateFromFractional :: (IsStream t, Monad m, Fractional a) => a -> t m a+enumerateFromFractional from = fromStreamD $ D.numFrom 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.toList $ Stream.take 4 $ Stream.enumerateFromThenFractional 1.1 2.1+-- [1.1,2.1,3.1,4.1]+--+-- >>> Stream.toList $ Stream.take 4 $ Stream.enumerateFromThenFractional 1.1 (-2.1)+-- [1.1,-2.1,-5.300000000000001,-8.500000000000002]+--+-- @+--+-- @since 0.6.0+{-# INLINE enumerateFromThenFractional #-}+enumerateFromThenFractional+    :: (IsStream t, Monad m, Fractional a)+    => a -> a -> t m a+enumerateFromThenFractional from next = fromStreamD $ D.numFromThen 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.toList $ Stream.enumerateFromToFractional 1.1 4+-- [1.1,2.1,3.1,4.1]+--+-- >>> Stream.toList $ Stream.enumerateFromToFractional 1.1 4.6+-- [1.1,2.1,3.1,4.1,5.1]+--+-- @+--+-- Notice that the last element is equal to the specified @to@ value after+-- rounding to the nearest integer.+--+-- @since 0.6.0+{-# INLINE enumerateFromToFractional #-}+enumerateFromToFractional+    :: (IsStream t, Monad m, Fractional a, Ord a)+    => a -> a -> t 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.toList $ Stream.enumerateFromThenToFractional 0.1 2 6+-- [0.1,2.0,3.9,5.799999999999999]+--+-- >>> Stream.toList $ Stream.enumerateFromThenToFractional 0.1 (-2) (-6)+-- [0.1,-2.0,-4.1000000000000005,-6.200000000000001]+--+-- @+--+--+-- @since 0.6.0+{-# INLINE enumerateFromThenToFractional #-}+enumerateFromThenToFractional+    :: (IsStream t, Monad m, Fractional a, Ord a)+    => a -> a -> a -> t 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'.+--+-- @since 0.6.0+{-# INLINE enumerateFromToSmall #-}+enumerateFromToSmall :: (IsStream t, Monad m, Enum a) => a -> a -> t m a+enumerateFromToSmall from to = Serial.map toEnum $+    enumerateFromToIntegral (fromEnum from) (fromEnum to)++-- | 'enumerateFromThenTo' for 'Enum' types not larger than 'Int'.+--+-- @since 0.6.0+{-# INLINE enumerateFromThenToSmall #-}+enumerateFromThenToSmall :: (IsStream t, Monad m, Enum a)+    => a -> a -> a -> t m a+enumerateFromThenToSmall from next to = Serial.map 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.+--+-- @since 0.6.0+{-# INLINE enumerateFromThenSmallBounded #-}+enumerateFromThenSmallBounded :: (IsStream t, Monad m, Enumerable a, Bounded a)+    => a -> a -> t 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.+--+-- @since 0.6.0+class Enum a => Enumerable a where+    -- | @enumerateFrom from@ generates a stream starting with the element+    -- @from@, enumerating up to 'maxBound' when the type is 'Bounded' or+    -- generating an infinite stream when the type is not 'Bounded'.+    --+    -- @+    -- >>> Stream.toList $ Stream.take 4 $ Stream.enumerateFrom (0 :: Int)+    -- [0,1,2,3]+    --+    -- @+    --+    -- For 'Fractional' types, enumeration is numerically stable. However, no+    -- overflow or underflow checks are performed.+    --+    -- @+    -- >>> Stream.toList $ Stream.take 4 $ Stream.enumerateFrom 1.1+    -- [1.1,2.1,3.1,4.1]+    --+    -- @+    --+    -- @since 0.6.0+    enumerateFrom :: (IsStream t, Monad m) => a -> t m a++    -- | Generate a finite stream starting with the element @from@, enumerating+    -- the type up to the value @to@. If @to@ is smaller than @from@ then an+    -- empty stream is returned.+    --+    -- @+    -- >>> Stream.toList $ Stream.enumerateFromTo 0 4+    -- [0,1,2,3,4]+    --+    -- @+    --+    -- For 'Fractional' types, the last element is equal to the specified @to@+    -- value after rounding to the nearest integral value.+    --+    -- @+    -- >>> Stream.toList $ Stream.enumerateFromTo 1.1 4+    -- [1.1,2.1,3.1,4.1]+    --+    -- >>> Stream.toList $ Stream.enumerateFromTo 1.1 4.6+    -- [1.1,2.1,3.1,4.1,5.1]+    --+    -- @+    --+    -- @since 0.6.0+    enumerateFromTo :: (IsStream t, Monad m) => a -> a -> t m a++    -- | @enumerateFromThen from then@ generates a stream whose first element+    -- is @from@, the second element is @then@ and the successive elements are+    -- in increments of @then - from@.  Enumeration can occur downwards or+    -- upwards depending on whether @then@ comes before or after @from@. For+    -- 'Bounded' types the stream ends when 'maxBound' is reached, for+    -- unbounded types it keeps enumerating infinitely.+    --+    -- @+    -- >>> Stream.toList $ Stream.take 4 $ Stream.enumerateFromThen 0 2+    -- [0,2,4,6]+    --+    -- >>> Stream.toList $ Stream.take 4 $ Stream.enumerateFromThen 0 (-2)+    -- [0,-2,-4,-6]+    --+    -- @+    --+    -- @since 0.6.0+    enumerateFromThen :: (IsStream t, Monad m) => a -> a -> t m a++    -- | @enumerateFromThenTo from then to@ generates a finite stream whose+    -- first element is @from@, the second element is @then@ and the successive+    -- elements are in increments of @then - from@ up to @to@. Enumeration can+    -- occur downwards or upwards depending on whether @then@ comes before or+    -- after @from@.+    --+    -- @+    -- >>> Stream.toList $ Stream.enumerateFromThenTo 0 2 6+    -- [0,2,4,6]+    --+    -- >>> Stream.toList $ Stream.enumerateFromThenTo 0 (-2) (-6)+    -- [0,-2,-4,-6]+    --+    -- @+    --+    -- @since 0.6.0+    enumerateFromThenTo :: (IsStream t, Monad m) => a -> a -> a -> t 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'+--+-- @since 0.6.0+{-# INLINE enumerate #-}+enumerate :: (IsStream t, Monad m, Bounded a, Enumerable a) => t m a+enumerate = enumerateFrom minBound++-- |+-- > enumerateTo = enumerateFromTo minBound+--+-- Enumerate a 'Bounded' type from its 'minBound' to specified value.+--+-- @since 0.6.0+{-# INLINE enumerateTo #-}+enumerateTo :: (IsStream t, Monad m, Bounded a, Enumerable a) => a -> t m a+enumerateTo = enumerateFromTo minBound++-- |+-- > enumerateFromBounded = enumerateFromTo from maxBound+--+-- 'enumerateFrom' for 'Bounded' 'Enum' types.+--+-- @since 0.6.0+{-# INLINE enumerateFromBounded #-}+enumerateFromBounded :: (IsStream t, Monad m, Enumerable a, Bounded a)+    => a -> t 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) = Serial.map Identity $+        enumerateFrom from+    {-# INLINE enumerateFromThen #-}+    enumerateFromThen (Identity from) (Identity next) = Serial.map Identity $+        enumerateFromThen from next+    {-# INLINE enumerateFromTo #-}+    enumerateFromTo (Identity from) (Identity to) = Serial.map Identity $+        enumerateFromTo from to+    {-# INLINE enumerateFromThenTo #-}+    enumerateFromThenTo (Identity from) (Identity next) (Identity to) =+        Serial.map 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)+-}
+ src/Streamly/Internal/Data/Stream/IsStream/Exception.hs view
@@ -0,0 +1,202 @@+-- |+-- Module      : Streamly.Internal.Data.Stream.IsStream.Exception+-- Copyright   : (c) 2019 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Internal.Data.Stream.IsStream.Exception+    (+      before+    , after_+    , after+    , bracket_+    , bracket+    , onException+    , finally_+    , finally+    , ghandle+    , handle+    )+where++import Control.Exception (Exception)+import Control.Monad.Catch (MonadCatch)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.Control (MonadBaseControl)+import Streamly.Internal.Data.Stream.StreamD (toStreamD)+import Streamly.Internal.Data.Stream.StreamK (IsStream)+import Streamly.Internal.Data.SVar (MonadAsync)++import qualified Streamly.Internal.Data.Stream.StreamD as D++------------------------------------------------------------------------------+-- Exceptions+------------------------------------------------------------------------------++-- | Run the action @m b@ before the stream yields its first element.+--+-- > before action xs = 'nilM' action <> xs+--+-- @since 0.7.0+{-# INLINE before #-}+before :: (IsStream t, Monad m) => m b -> t m a -> t m a+before action xs = D.fromStreamD $ D.before action $ D.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:+--+-- > after_ action xs = xs <> 'nilM' action+--+-- /Pre-release/+--+{-# INLINE after_ #-}+after_ :: (IsStream t, Monad m) => m b -> t m a -> t m a+after_ action xs = D.fromStreamD $ D.after_ action $ D.toStreamD xs++-- | Run the action @m b@ whenever the stream @t m a@ stops normally, or if it+-- is garbage collected after a partial lazy evaluation.+--+-- The semantics of the action @m b@ are similar to the semantics of cleanup+-- action in 'bracket'.+--+-- /See also 'after_'/+--+-- @since 0.7.0+--+{-# INLINE after #-}+after :: (IsStream t, MonadIO m, MonadBaseControl IO m)+    => m b -> t m a -> t m a+after action xs = D.fromStreamD $ D.after action $ D.toStreamD xs++-- | Run the action @m b@ if the stream aborts due to an exception. The+-- exception is not caught, simply rethrown.+--+-- /Inhibits stream fusion/+--+-- @since 0.7.0+{-# INLINE onException #-}+onException :: (IsStream t, MonadCatch m) => m b -> t m a -> t m a+onException action xs = D.fromStreamD $ D.onException action $ D.toStreamD xs++-- | Like 'finally' with following differences:+--+-- * action @m b@ won't run if the stream is garbage collected+--   after partial evaluation.+-- * does not require a 'MonadAsync' constraint.+-- * has slightly better performance than 'finally'.+--+-- /Inhibits stream fusion/+--+-- /Pre-release/+--+{-# INLINE finally_ #-}+finally_ :: (IsStream t, MonadCatch m) => m b -> t m a -> t m a+finally_ action xs = D.fromStreamD $ D.finally_ action $ D.toStreamD xs++-- | Run the action @m b@ whenever the stream @t m a@ stops normally, aborts+-- due to an exception or if it is garbage collected after a partial lazy+-- evaluation.+--+-- The semantics of running the action @m b@ are similar to the cleanup action+-- semantics described in 'bracket'.+--+-- @+-- finally release = bracket (return ()) (const release)+-- @+--+-- /See also 'finally_'/+--+-- /Inhibits stream fusion/+--+-- @since 0.7.0+--+{-# INLINE finally #-}+finally :: (IsStream t, MonadAsync m, MonadCatch m) => m b -> t m a -> t m a+finally action xs = D.fromStreamD $ D.finally action $ D.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.+-- * does not require a 'MonadAsync' constraint.+-- * has slightly better performance than 'bracket'.+--+-- /Inhibits stream fusion/+--+-- /Pre-release/+--+{-# INLINE bracket_ #-}+bracket_ :: (IsStream t, MonadCatch m)+    => m b -> (b -> m c) -> (b -> t m a) -> t m a+bracket_ bef aft bet = D.fromStreamD $+    D.bracket_ bef aft (toStreamD . bet)++-- | Run the alloc action @m b@ with async exceptions disabled but keeping+-- blocking operations interruptible (see 'Control.Exception.mask').  Use the+-- output @b@ as input to @b -> t m a@ to generate an output stream.+--+-- @b@ is usually a resource under the state of monad @m@, e.g. a file+-- handle, that requires a cleanup after use. The cleanup action @b -> m 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.+--+-- '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_'/+--+-- /Inhibits stream fusion/+--+-- @since 0.7.0+--+{-# INLINE bracket #-}+bracket :: (IsStream t, MonadAsync m, MonadCatch m)+    => m b -> (b -> m c) -> (b -> t m a) -> t m a+bracket bef aft bet = D.fromStreamD $+    D.bracket bef aft (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 :: (IsStream t, MonadCatch m, Exception e)+    => (e -> t m a -> t m a) -> t m a -> t m a+ghandle handler =+      D.fromStreamD+    . D.ghandle (\e xs -> D.toStreamD $ handler e (D.fromStreamD xs))+    . D.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/+--+-- @since 0.7.0+{-# INLINE handle #-}+handle :: (IsStream t, MonadCatch m, Exception e)+    => (e -> t m a) -> t m a -> t m a+handle handler xs =+    D.fromStreamD $ D.handle (D.toStreamD . handler) $ D.toStreamD xs
+ src/Streamly/Internal/Data/Stream/IsStream/Expand.hs view
@@ -0,0 +1,816 @@+-- |+-- Module      : Streamly.Internal.Data.Stream.IsStream.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.IsStream.Expand+    (+    -- * Binary Combinators (Linear)+    -- | Functions ending in the shape:+    --+    -- @t m a -> t m a -> t 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 'concatPairsWith' which combines streams as a+    -- binary tree).++      serial+    , ahead+    , async+    , wAsync+    , parallel+    , Par.parallelFst+    , Par.parallelMin++    -- * 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 'concatPairsWith' giving a @n * log n@ complexity.  Avoid+    -- using these with 'concatMapWith' when combining a large or infinite+    -- number of streams.++    -- ** Append+    , append++    -- ** wSerial+    -- | 'wSerial' is a CPS based stream interleaving functions. It can be+    -- used with 'concatMapWith' as well, however, the interleaving behavior of+    -- @n@ streams would be asymmetric giving exponentially more weightage to+    -- streams that come earlier in the composition.+    --+    , wSerial+    , Serial.wSerialFst+    , Serial.wSerialMin++    -- ** Interleave+    -- | 'interleave' is like 'wSerial'  but using a direct style+    -- implementation instead of CPS. It is faster than 'wSerial' due to stream+    -- fusion but has worse efficiency when used with 'concatMapWith' for large+    -- number of streams.+    , interleave+    , interleaveMin+    , interleaveSuffix+    , interleaveInfix++    -- ** Round Robin+    , roundrobin++    -- ** Zip+    , Z.zipWith+    , Z.zipWithM+    , Z.zipAsyncWith+    , Z.zipAsyncWithM++    -- ** Merge+    -- , merge+    , mergeBy+    , mergeByM+    , mergeAsyncBy+    , mergeAsyncByM++    -- * 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 -> t m a -> t m b@++    -- ** Append Many (Unfold)+    -- | Unfold and flatten streams.+    , unfoldMany+    , unfoldManyInterleave+    , unfoldManyRoundRobin++    -- ** 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++    -- * Append Many (concatMap)+    -- | Map and serially append streams. 'concatMapM' is a generalization of+    -- the binary append operation to append many streams.+    , concatMapM+    , concatMap+    , concatM+    , concat++    -- * Flatten Containers+    -- | Flatten 'Foldable' containers using the binary stream merging+    -- operations.+    , concatFoldableWith+    , concatMapFoldableWith+    , concatForFoldableWith++    -- * 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 'concatPairsWith' would be more+    -- efficient. These cases include operations like 'mergeBy' or 'zipWith'.++    , concatMapWith+    , K.bindWith+    , concatSmapMWith++    -- * ConcatPairsWith+    -- | See the notes about suitable merge functions in the 'concatMapWith'+    -- section.+    , concatPairsWith++    -- * IterateMap+    -- | Map and flatten Trees of Streams+    , iterateMapWith+    , iterateSmapMWith+    , iterateMapLeftsWith++    -- * Deprecated+    , concatUnfold+    )+where++#include "inline.hs"++import Streamly.Internal.Data.Stream.Ahead (ahead)+import Streamly.Internal.Data.Stream.Async (async, wAsync)+import Streamly.Internal.Data.Stream.IsStream.Common+    (concatM, concatMapM, concatMap, smapM, fromPure, fromEffect)+import Streamly.Internal.Data.Stream.Parallel (parallel)+import Streamly.Internal.Data.Stream.Prelude+       ( concatFoldableWith, concatMapFoldableWith+       , concatForFoldableWith, fromStreamS, toStreamS)+import Streamly.Internal.Data.Stream.Serial (serial, wSerial)+import Streamly.Internal.Data.Stream.StreamD (fromStreamD, toStreamD)+import Streamly.Internal.Data.Stream.StreamK (IsStream)+import Streamly.Internal.Data.SVar (MonadAsync)+import Streamly.Internal.Data.Unfold.Type (Unfold)++import qualified Streamly.Internal.Data.Stream.Parallel as Par+import qualified Streamly.Internal.Data.Stream.Serial as Serial+import qualified Streamly.Internal.Data.Stream.StreamD as D+import qualified Streamly.Internal.Data.Stream.StreamK as K+#ifdef USE_STREAMK_ONLY+import qualified Streamly.Internal.Data.Stream.StreamK as S+#else+import qualified Streamly.Internal.Data.Stream.StreamD as S+#endif+import qualified Streamly.Internal.Data.Stream.Zip as Z++import Prelude hiding (concat, concatMap)++-- $setup+-- >>> :m+-- >>> import Data.IORef+-- >>> import Prelude hiding (zipWith, concatMap, concat)+-- >>> import qualified Streamly.Prelude as Stream+-- >>> import Streamly.Internal.Data.Stream.IsStream 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.Foreign as Array++-------------------------------------------------------------------------------+-- Appending+-------------------------------------------------------------------------------++-- XXX Reconcile the names "serial" and "append".+--+-- | Append the outputs of two streams, yielding all the elements from the+-- first stream and then yielding all the elements from the second stream.+--+-- IMPORTANT NOTE: This could be 100x faster than @serial/<>@ for appending a+-- few (say 100) streams because it can fuse via stream fusion. However, it+-- does not scale for a large number of streams (say 1000s) and becomes+-- qudartically slow. Therefore use this for custom appending of a few streams+-- but use 'concatMap' or 'concatMapWith serial' for appending @n@ streams or+-- infinite containers of streams.+--+-- /Pre-release/+{-# INLINE append #-}+append ::(IsStream t, Monad m) => t m b -> t m b -> t m b+append m1 m2 = fromStreamD $ D.append (toStreamD m1) (toStreamD m2)++-------------------------------------------------------------------------------+-- Interleaving+-------------------------------------------------------------------------------++-- XXX Same as 'wSerial'. We should perhaps rename wSerial to interleave.+-- XXX Document the interleaving behavior of side effects in all the+-- interleaving combinators.+-- XXX Write time-domain equivalents of these. In the time domain we can+-- interleave two streams such that the value of second stream is always taken+-- from its last value even if no new value is being yielded, like+-- zipWithLatest. It would be something like interleaveWithLatest.+--+-- | Interleaves the outputs of two streams, yielding elements from each stream+-- alternately, starting from the first stream. If any of the streams finishes+-- early the other stream continues alone until it too finishes.+--+-- >>> :set -XOverloadedStrings+-- >>> import Data.Functor.Identity (Identity)+-- >>> Stream.interleave "ab" ",,,," :: Stream.SerialT Identity Char+-- fromList "a,b,,,"+--+-- >>> Stream.interleave "abcd" ",," :: Stream.SerialT Identity Char+-- fromList "a,b,cd"+--+-- 'interleave' is dual to 'interleaveMin', it can be called @interleaveMax@.+--+-- Do not use at scale in concatMapWith.+--+-- /Pre-release/+{-# INLINE interleave #-}+interleave ::(IsStream t, Monad m) => t m b -> t m b -> t m b+interleave m1 m2 = fromStreamD $ D.interleave (toStreamD m1) (toStreamD m2)++-- | 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.interleaveSuffix "abc" ",,,," :: Stream.SerialT Identity Char+-- fromList "a,b,c,"+-- >>> Stream.interleaveSuffix "abc" "," :: Stream.SerialT Identity Char+-- fromList "a,bc"+--+-- 'interleaveSuffix' is a dual of 'interleaveInfix'.+--+-- Do not use at scale in concatMapWith.+--+-- /Pre-release/+{-# INLINE interleaveSuffix #-}+interleaveSuffix ::(IsStream t, Monad m) => t m b -> t m b -> t m b+interleaveSuffix m1 m2 =+    fromStreamD $ D.interleaveSuffix (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.interleaveInfix "abc" ",,,," :: Stream.SerialT Identity Char+-- fromList "a,b,c"+-- >>> Stream.interleaveInfix "abc" "," :: Stream.SerialT Identity Char+-- fromList "a,bc"+--+-- 'interleaveInfix' is a dual of 'interleaveSuffix'.+--+-- Do not use at scale in concatMapWith.+--+-- /Pre-release/+{-# INLINE interleaveInfix #-}+interleaveInfix ::(IsStream t, Monad m) => t m b -> t m b -> t m b+interleaveInfix m1 m2 =+    fromStreamD $ D.interleaveInfix (toStreamD m1) (toStreamD m2)++-- | Interleaves the outputs of two streams, yielding elements from each stream+-- alternately, starting from the first stream. The output stops as soon as any+-- of the two streams finishes, discarding the remaining part of the other+-- stream. The last element of the resulting stream would be from the longer+-- stream.+--+-- >>> :set -XOverloadedStrings+-- >>> import Data.Functor.Identity (Identity)+-- >>> Stream.interleaveMin "ab" ",,,," :: Stream.SerialT Identity Char+-- fromList "a,b,"+-- >>> Stream.interleaveMin "abcd" ",," :: Stream.SerialT Identity Char+-- fromList "a,b,c"+--+-- 'interleaveMin' is dual to 'interleave'.+--+-- Do not use at scale in concatMapWith.+--+-- /Pre-release/+{-# INLINE interleaveMin #-}+interleaveMin ::(IsStream t, Monad m) => t m b -> t m b -> t m b+interleaveMin m1 m2 = fromStreamD $ D.interleaveMin (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 ::(IsStream t, Monad m) => t m b -> t m b -> t 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.+--+-- @+-- >>> Stream.toList $ Stream.mergeBy compare (Stream.fromList [1,3,5]) (Stream.fromList [2,4,6,8])+-- [1,2,3,4,5,6,8]+--+-- @+--+-- @since 0.6.0+{-# INLINABLE mergeBy #-}+mergeBy ::+       (IsStream t, Monad m) => (a -> a -> Ordering) -> t m a -> t m a -> t m a+mergeBy f m1 m2 = fromStreamS $ S.mergeBy f (toStreamS m1) (toStreamS 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 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.toList $ Stream.mergeByM f (Stream.fromList [1,1,1,1,1,1]) (Stream.fromList [2,2,2])+--  print xs+-- :}+-- [1,1,2,1,1,2,1,1,2]+--+-- @+--+-- @since 0.6.0+{-# INLINABLE mergeByM #-}+mergeByM+    :: (IsStream t, Monad m)+    => (a -> a -> m Ordering) -> t m a -> t m a -> t m a+mergeByM f m1 m2 = fromStreamS $ S.mergeByM f (toStreamS m1) (toStreamS m2)++{-+-- | Like 'mergeByM' but stops merging as soon as any of the two streams stops.+{-# INLINABLE mergeEndByAny #-}+mergeEndByAny+    :: (IsStream t, Monad m)+    => (a -> a -> m Ordering) -> t m a -> t m a -> t m a+mergeEndByAny f m1 m2 = fromStreamD $+    D.mergeEndByAny f (toStreamD m1) (toStreamD m2)++-- Like 'mergeByM' but stops merging as soon as the first stream stops.+{-# INLINABLE mergeEndByFirst #-}+mergeEndByFirst+    :: (IsStream t, Monad m)+    => (a -> a -> m Ordering) -> t m a -> t m a -> t m a+mergeEndByFirst f m1 m2 = fromStreamS $+    D.mergeEndByFirst f (toStreamD m1) (toStreamD m2)++-- Holding this back for now, we may want to use the name "merge" differently+-- | Same as @'mergeBy' 'compare'@.+--+-- @+-- >>> Stream.toList $ Stream.merge (Stream.fromList [1,3,5]) (Stream.fromList [2,4,6,8])+-- [1,2,3,4,5,6,8]+-- @+--+-- @since 0.6.0+{-# INLINABLE merge #-}+merge ::+       (IsStream t, Monad m, Ord a) => t m a -> t m a -> t m a+merge = mergeBy compare+-}++-- | Like 'mergeBy' but merges concurrently (i.e. both the elements being+-- merged are generated concurrently).+--+-- @since 0.6.0+{-# INLINE mergeAsyncBy #-}+mergeAsyncBy :: (IsStream t, MonadAsync m)+    => (a -> a -> Ordering) -> t m a -> t m a -> t m a+mergeAsyncBy f = mergeAsyncByM (\a b -> return $ f a b)++-- | Like 'mergeByM' but merges concurrently (i.e. both the elements being+-- merged are generated concurrently).+--+-- @since 0.6.0+{-# INLINE mergeAsyncByM #-}+mergeAsyncByM :: (IsStream t, MonadAsync m)+    => (a -> a -> m Ordering) -> t m a -> t m a -> t m a+mergeAsyncByM f m1 m2 =+    fromStreamD $+        let par = Par.mkParallelD . toStreamD+        in D.mergeByM f (par m1) (par m2)+++-- @since 0.7.0+{-# DEPRECATED concatUnfold "Please use unfoldMany instead." #-}+{-# INLINE concatUnfold #-}+concatUnfold ::(IsStream t, Monad m) => Unfold m a b -> t m a -> t m b+concatUnfold u m = fromStreamD $ D.unfoldMany u (toStreamD m)++------------------------------------------------------------------------------+-- 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.+--+-- @since 0.8.0+{-# INLINE unfoldMany #-}+unfoldMany ::(IsStream t, Monad m) => Unfold m a b -> t m a -> t m b+unfoldMany u m = fromStreamD $ D.unfoldMany u (toStreamD m)++-- | Like 'unfoldMany' but interleaves the streams in the same way as+-- 'interleave' behaves instead of appending them.+--+-- /Pre-release/+{-# INLINE unfoldManyInterleave #-}+unfoldManyInterleave ::(IsStream t, Monad m)+    => Unfold m a b -> t m a -> t m b+unfoldManyInterleave u m =+    fromStreamD $ D.unfoldManyInterleave u (toStreamD m)++-- | Like 'unfoldMany' but executes the streams in the same way as+-- 'roundrobin'.+--+-- /Pre-release/+{-# INLINE unfoldManyRoundRobin #-}+unfoldManyRoundRobin ::(IsStream t, Monad m)+    => Unfold m a b -> t m a -> t m b+unfoldManyRoundRobin u m =+    fromStreamD $ D.unfoldManyRoundRobin 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 = S.interpose ' '+--+-- /Pre-release/+{-# INLINE interpose #-}+interpose :: (IsStream t, Monad m)+    => c -> Unfold m b c -> t m b -> t m c+interpose x unf str =+    D.fromStreamD $ D.interpose (return x) unf (D.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 = S.interposeSuffix '\n'+--+-- /Pre-release/+{-# INLINE interposeSuffix #-}+interposeSuffix :: (IsStream t, Monad m)+    => c -> Unfold m b c -> t m b -> t m c+interposeSuffix x unf str =+    D.fromStreamD $ D.interposeSuffix (return x) unf (D.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 ())+--+-- | 'interleaveInfix' followed by unfold and concat.+--+-- /Pre-release/+{-# INLINE gintercalate #-}+gintercalate+    :: (IsStream t, Monad m)+    => Unfold m a c -> t m a -> Unfold m b c -> t m b -> t m c+gintercalate unf1 str1 unf2 str2 =+    D.fromStreamD $ D.gintercalate+        unf1 (D.toStreamD str1)+        unf2 (D.toStreamD str2)++-- > intercalate unf seed str = gintercalate unf str unf (repeatM seed)+--+-- | 'intersperse' followed by unfold and concat.+--+-- > intercalate unf a str = unfoldMany unf $ intersperse a str+-- > intersperse = intercalate (Unfold.function id)+-- > unwords = intercalate Unfold.fromList " "+--+-- >>> Stream.toList $ Stream.intercalate Unfold.fromList " " $ Stream.fromList ["abc", "def", "ghi"]+-- "abc def ghi"+--+-- @since 0.8.0+{-# INLINE intercalate #-}+intercalate :: (IsStream t, Monad m)+    => Unfold m b c -> b -> t m b -> t m c+intercalate unf seed str = D.fromStreamD $+    D.unfoldMany unf $ D.intersperse seed (toStreamD str)++-- | 'interleaveSuffix' followed by unfold and concat.+--+-- /Pre-release/+{-# INLINE gintercalateSuffix #-}+gintercalateSuffix+    :: (IsStream t, Monad m)+    => Unfold m a c -> t m a -> Unfold m b c -> t m b -> t m c+gintercalateSuffix unf1 str1 unf2 str2 =+    D.fromStreamD $ D.gintercalateSuffix+        unf1 (D.toStreamD str1)+        unf2 (D.toStreamD str2)++-- > intercalateSuffix unf seed str = gintercalateSuffix unf str unf (repeatM seed)+--+-- | 'intersperseSuffix' followed by unfold and concat.+--+-- > intercalateSuffix unf a str = unfoldMany unf $ intersperseSuffix a str+-- > intersperseSuffix = intercalateSuffix (Unfold.function id)+-- > unlines = intercalateSuffix Unfold.fromList "\n"+--+-- >>> Stream.toList $ Stream.intercalateSuffix Unfold.fromList "\n" $ Stream.fromList ["abc", "def", "ghi"]+-- "abc\ndef\nghi\n"+--+-- @since 0.8.0+{-# INLINE intercalateSuffix #-}+intercalateSuffix :: (IsStream t, Monad m)+    => Unfold m b c -> b -> t m b -> t m c+intercalateSuffix unf seed str = fromStreamD $ D.unfoldMany unf+    $ D.intersperseSuffix (return seed) (D.toStreamD str)++{-+{-# INLINE iterateUnfold #-}+iterateUnfold :: (IsStream t, MonadAsync m)+    => Unfold m a a -> t m a -> t m a+iterateUnfold unf xs = undefined+-}++------------------------------------------------------------------------------+-- Combine N Streams - concatMap+------------------------------------------------------------------------------++-- | Flatten a stream of streams to a single stream.+--+-- @+-- concat = concatMap id+-- @+--+-- /Pre-release/+{-# INLINE concat #-}+concat :: (IsStream t, Monad m) => t m (t m a) -> t m a+concat = concatMap id++------------------------------------------------------------------------------+-- Combine N Streams - concatMap+------------------------------------------------------------------------------++-- | @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.+--+-- Note we can merge streams concurrently by using a concurrent merge function.+--+-- /Since: 0.7.0/+--+-- /Since: 0.8.0 (signature change)/+{-# INLINE concatMapWith #-}+concatMapWith+    :: IsStream t+    => (t m b -> t m b -> t m b)+    -> (a -> t m b)+    -> t m a+    -> t m b+concatMapWith = K.concatMapBy++-- | Like 'concatMapWith' but carries a state which can be used to share+-- information across multiple steps of concat.+--+-- @+-- concatSmapMWith combine f initial = concatMapWith combine id . smapM f initial+-- @+--+-- /Pre-release/+--+{-# INLINE concatSmapMWith #-}+concatSmapMWith+    :: (IsStream t, Monad m)+    => (t m b -> t m b -> t m b)+    -> (s -> a -> m (s, t m b))+    -> m s+    -> t m a+    -> t m b+concatSmapMWith combine f initial = concatMapWith combine id . smapM f initial++-- 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+    :: -- (IsStream t, MonadAsync m) =>+       (forall x. t m x -> t m x -> t m x)+    -> (a -> t m (Either (t m b) b))+    -> t m a+    -> t m b+concatMapEitherWith = undefined+-}++-- XXX Implement a StreamD version for fusion.+--+-- | Combine streams in pairs using a binary stream combinator, then combine+-- the resulting streams in pairs recursively until we get to a single combined+-- stream.+--+-- For example, you can sort a stream using merge sort like this:+--+-- >>> Stream.toList $ Stream.concatPairsWith (Stream.mergeBy compare) Stream.fromPure $ Stream.fromList [5,1,7,9,2]+-- [1,2,5,7,9]+--+-- /Caution: the stream of streams must be finite/+--+-- /Pre-release/+--+{-# INLINE concatPairsWith #-}+concatPairsWith :: IsStream t =>+       (t m b -> t m b -> t m b)+    -> (a -> t m b)+    -> t m a+    -> t m b+concatPairsWith = K.concatPairsWith++------------------------------------------------------------------------------+-- IterateMap - Map and flatten Trees of Streams+------------------------------------------------------------------------------++-- | Like 'iterateM' but iterates after mapping a stream generator on the+-- output.+--+-- Yield an input element in the output stream, map a stream generator on it+-- and then do the same on the resulting stream. This can be used for a depth+-- first traversal of a tree like structure.+--+-- Note that 'iterateM' is a special case of 'iterateMapWith':+--+-- @+-- iterateM f = iterateMapWith serial (fromEffect . f) . fromEffect+-- @+--+-- It can be used to traverse a tree structure.  For example, to list a+-- directory tree:+--+-- @+-- Stream.iterateMapWith Stream.serial+--     (either Dir.toEither (const nil))+--     (fromPure (Left "tmp"))+-- @+--+-- /Pre-release/+--+{-# INLINE iterateMapWith #-}+iterateMapWith+    :: IsStream t+    => (t m a -> t m a -> t m a)+    -> (a -> t m a)+    -> t m a+    -> t m a+iterateMapWith combine f = concatMapWith combine go+    where+    go x = fromPure x `combine` concatMapWith combine go (f x)++{-+{-# INLINE iterateUnfold #-}+iterateUnfold :: (IsStream t, MonadAsync m)+    => Unfold m a a -> t m a -> t m a+iterateUnfold unf xs = undefined+-}++------------------------------------------------------------------------------+-- 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 iterateSmapMWith #-}+iterateSmapMWith+    :: (IsStream t, Monad m)+    => (t m a -> t m a -> t m a)+    -> (b -> a -> m (b, t m a))+    -> m b+    -> t m a+    -> t m a+iterateSmapMWith combine f initial stream =+    concatMap (\b -> concatMapWith combine (go b) stream) (fromEffect initial)++    where++    go b a = fromPure a `combine` feedback b a++    feedback b a =+        concatMap+            (\(b1, s) -> concatMapWith combine (go b1) s)+            (fromEffect $ f b a)++------------------------------------------------------------------------------+-- iterateMap - Either streams+------------------------------------------------------------------------------++-- | In an 'Either' stream iterate on 'Left's.  This is a special case of+-- 'iterateMapWith':+--+-- @+-- iterateMapLeftsWith combine f = iterateMapWith combine (either f (const nil))+-- @+--+-- To traverse a directory tree:+--+-- @+-- iterateMapLeftsWith serial Dir.toEither (fromPure (Left "tmp"))+-- @+--+-- /Pre-release/+--+{-# INLINE iterateMapLeftsWith #-}+iterateMapLeftsWith+    :: IsStream t+    => (t m (Either a b) -> t m (Either a b) -> t m (Either a b))+    -> (a -> t m (Either a b))+    -> t m (Either a b)+    -> t m (Either a b)+iterateMapLeftsWith combine f = iterateMapWith combine (either f (const K.nil))
+ src/Streamly/Internal/Data/Stream/IsStream/Generate.hs view
@@ -0,0 +1,572 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- |+-- Module      : Streamly.Internal.Data.Stream.IsStream.Generate+-- Copyright   : (c) 2017 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- Most of the combinators in this module can be implemented as unfolds. Some+-- of them however can only be expressed in terms StreamK e.g. cons/consM,+-- fromFoldable, mfix. We can possibly remove those from this module which can+-- be expressed as unfolds. Unless we want to use rewrite rules to rewrite them+-- as StreamK when StreamK is used, avoiding conversion to StreamD. Will that+-- help? Are there any other reasons to keep these and not use unfolds?++module Streamly.Internal.Data.Stream.IsStream.Generate+    (+    -- * Primitives+      K.nil+    , K.nilM+    , K.cons+    , (K..:)++    , consM+    , (|:)++    -- * From 'Unfold'+    , unfold+    , unfold0++    -- * Unfolding+    , unfoldr+    , unfoldrM++    -- * From Values+    , fromPure+    , fromEffect+    , repeat+    , repeatM+    , replicate+    , replicateM++    -- * Enumeration+    , Enumerable (..)+    , enumerate+    , enumerateTo++    -- * Time Enumeration+    , times+    , absTimes+    , absTimesWith+    , relTimes+    , relTimesWith+    , durations+    , ticks+    , timeout++    -- * From Generators+    , fromIndices+    , fromIndicesM+    -- , generate+    -- , generateM++    -- * Iteration+    , iterate+    , iterateM++    -- * Cyclic Elements+    , K.mfix++    -- * From Containers+    , P.fromList+    , fromListM+    , K.fromFoldable+    , fromFoldableM+    , fromCallback++    -- * Deprecated+    , K.once+    , yield+    , yieldM+    , each+    , fromHandle+    , currentTime+    )+where++#include "inline.hs"++import Control.Monad.IO.Class (MonadIO(..))+import Data.Void (Void)+import Streamly.Internal.Data.Unfold.Type (Unfold)+import Streamly.Internal.Data.SVar (MonadAsync, Rate (..))+import Streamly.Internal.Data.Stream.IsStream.Enumeration+    (Enumerable(..), enumerate, enumerateTo)+import Streamly.Internal.Data.Stream.IsStream.Common+    ( absTimesWith, concatM, relTimesWith, timesWith, fromPure, fromEffect+    , yield, yieldM, repeatM)+import Streamly.Internal.Data.Stream.Prelude (fromStreamS)+import Streamly.Internal.Data.Stream.StreamD (fromStreamD)+import Streamly.Internal.Data.Stream.StreamK (IsStream((|:), consM))+import Streamly.Internal.Data.Stream.Serial (SerialT, WSerialT)+import Streamly.Internal.Data.Stream.Zip (ZipSerialM)+import Streamly.Internal.Data.Time.Units (AbsTime , RelTime64, addToAbsTime64)++import qualified Streamly.Internal.Data.Stream.Parallel as Par+import qualified Streamly.Internal.Data.Stream.Prelude as P+import qualified Streamly.Internal.Data.Stream.Serial as Serial+import qualified Streamly.Internal.Data.Stream.StreamD.Generate as D+import qualified Streamly.Internal.Data.Stream.StreamK as K+#ifdef USE_STREAMK_ONLY+import qualified Streamly.Internal.Data.Stream.StreamK as S+#else+import qualified Streamly.Internal.Data.Stream.StreamD.Generate as S+#endif+import qualified System.IO as IO++import Prelude hiding (iterate, replicate, repeat)++-- $setup+-- >>> :m+-- >>> import Prelude hiding (iterate, replicate, repeat)+-- >>> import qualified Streamly.Prelude as Stream+-- >>> import qualified Streamly.Internal.Data.Stream.IsStream as Stream+-- >>> import qualified Streamly.Internal.Data.Unfold as Unfold+-- >>> import Control.Concurrent (threadDelay)++------------------------------------------------------------------------------+-- From Unfold+------------------------------------------------------------------------------++-- | Convert an 'Unfold' into a stream by supplying it an input seed.+--+-- >>> Stream.drain $ Stream.unfold (Unfold.replicateM 3) (putStrLn "hello")+-- hello+-- hello+-- hello+--+-- /Since: 0.7.0/+{-# INLINE unfold #-}+unfold :: (IsStream t, Monad m) => Unfold m a b -> a -> t m b+unfold unf x = fromStreamD $ D.unfold unf x++-- | Convert an 'Unfold' with a closed input end into a stream.+--+-- /Pre-release/+{-# INLINE unfold0 #-}+unfold0 :: (IsStream t, Monad m) => Unfold m Void b -> t m b+unfold0 unf = unfold unf (error "unfold0: unexpected void evaluation")++------------------------------------------------------------------------------+-- Generation by Unfolding+------------------------------------------------------------------------------++-- |+-- @+-- unfoldr step s =+--     case step s of+--         Nothing -> 'K.nil'+--         Just (a, b) -> a \`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 > 3+--         then Nothing+--         else Just (b, b + 1)+-- in Stream.toList $ Stream.unfoldr f 0+-- :}+-- [0,1,2,3]+--+-- @+--+-- @since 0.1.0+{-# INLINE_EARLY unfoldr #-}+unfoldr :: (Monad m, IsStream t) => (b -> Maybe (a, b)) -> b -> t m a+unfoldr step seed = fromStreamS (S.unfoldr step seed)+{-# RULES "unfoldr fallback to StreamK" [1]+    forall a b. S.toStreamK (S.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 > 3+--         then return Nothing+--         else return (Just (b, b + 1))+-- in Stream.toList $ Stream.unfoldrM f 0+-- :}+-- [0,1,2,3]+--+-- @+-- When run concurrently, the next unfold step can run concurrently with the+-- processing of the output of the previous step.  Note that more than one step+-- cannot run concurrently as the next step depends on the output of the+-- previous step.+--+-- @+-- (fromAsync $ S.unfoldrM (\\n -> liftIO (threadDelay 1000000) >> return (Just (n, n + 1))) 0)+--     & S.foldlM' (\\_ a -> threadDelay 1000000 >> print a) ()+-- @+--+-- /Concurrent/+--+-- /Since: 0.1.0/+{-# INLINE_EARLY unfoldrM #-}+unfoldrM :: (IsStream t, MonadAsync m) => (b -> m (Maybe (a, b))) -> b -> t m a+unfoldrM = K.unfoldrM++{-# RULES "unfoldrM serial" unfoldrM = unfoldrMSerial #-}+{-# INLINE_EARLY unfoldrMSerial #-}+unfoldrMSerial :: MonadAsync m => (b -> m (Maybe (a, b))) -> b -> SerialT m a+unfoldrMSerial = Serial.unfoldrM++{-# RULES "unfoldrM wSerial" unfoldrM = unfoldrMWSerial #-}+{-# INLINE_EARLY unfoldrMWSerial #-}+unfoldrMWSerial :: MonadAsync m => (b -> m (Maybe (a, b))) -> b -> WSerialT m a+unfoldrMWSerial = Serial.unfoldrM++{-# RULES "unfoldrM zipSerial" unfoldrM = unfoldrMZipSerial #-}+{-# INLINE_EARLY unfoldrMZipSerial #-}+unfoldrMZipSerial :: MonadAsync m => (b -> m (Maybe (a, b))) -> b -> ZipSerialM m a+unfoldrMZipSerial = Serial.unfoldrM++------------------------------------------------------------------------------+-- From Values+------------------------------------------------------------------------------++-- |+-- Generate an infinite stream by repeating a pure value.+--+-- @since 0.4.0+{-# INLINE_NORMAL repeat #-}+repeat :: (IsStream t, Monad m) => a -> t m a+repeat = fromStreamS . S.repeat++-- |+-- @+-- replicate = take n . repeat+-- @+--+-- Generate a stream of length @n@ by repeating a value @n@ times.+--+-- @since 0.6.0+{-# INLINE_NORMAL replicate #-}+replicate :: (IsStream t, Monad m) => Int -> a -> t m a+replicate n = fromStreamS . S.replicate n++-- |+-- @+-- replicateM = take n . repeatM+-- @+--+-- Generate a stream by performing a monadic action @n@ times. Same as:+--+-- @+-- drain $ fromSerial $ S.replicateM 10 $ (threadDelay 1000000 >> print 1)+-- drain $ fromAsync  $ S.replicateM 10 $ (threadDelay 1000000 >> print 1)+-- @+--+-- /Concurrent/+--+-- @since 0.1.1+{-# INLINE_EARLY replicateM #-}+replicateM :: (IsStream t, MonadAsync m) => Int -> m a -> t m a+replicateM = K.replicateM++{-# RULES "replicateM serial" replicateM = replicateMSerial #-}+{-# INLINE replicateMSerial #-}+replicateMSerial :: MonadAsync m => Int -> m a -> SerialT m a+replicateMSerial n = fromStreamS . S.replicateM 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.+--+-- >>> Stream.mapM_ (\x -> print x >> threadDelay 1000000) $ 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 :: (IsStream t, MonadAsync m) => t m (AbsTime, RelTime64)+times = timesWith 0.01++-- | @absTimes@ returns a stream of absolute timestamps using a clock of 10 ms+-- granularity.+--+-- >>> Stream.mapM_ print $ 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 :: (IsStream t, MonadAsync m, Functor (t m)) => t m AbsTime+absTimes = fmap (uncurry addToAbsTime64) times++{-# DEPRECATED currentTime "Please use absTimes instead" #-}+{-# INLINE currentTime #-}+currentTime :: (IsStream t, MonadAsync m, Functor (t m))+    => Double -> t m AbsTime+currentTime = absTimesWith++-- | @relTimes@ returns a stream of relative time values starting from 0,+-- using a clock of granularity 10 ms.+--+-- >>> Stream.mapM_ print $ 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 :: (IsStream t, MonadAsync m, Functor (t m)) => t 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 :: -- (IsStream t, MonadAsync m) =>+    Double -> t m RelTime64+durations = undefined++-- | Generate ticks at the specified rate. The rate is adaptive, the tick+-- generation speed can be increased or decreased at different times to achieve+-- the specified rate.  The specific behavior for different styles of 'Rate'+-- specifications is documented under 'Rate'.  The effective maximum rate+-- achieved by a stream is governed by the processor speed.+--+-- /Unimplemented/+--+{-# INLINE ticks #-}+ticks :: -- (IsStream t, MonadAsync m) =>+    Rate -> t m ()+ticks = 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 :: -- (IsStream t, MonadAsync m) =>+    AbsTime -> t m ()+timeout = undefined++------------------------------------------------------------------------------+-- From Generator functions+------------------------------------------------------------------------------++-- XXX we can remove it and recommend the definition in terms of enumerate and+-- map. Check performance equivalence.+--+-- |+-- @+-- fromIndices f = fmap f $ Stream.enumerateFrom 0+-- fromIndices f = let g i = f i \`cons` g (i + 1) in g 0+-- @+--+-- Generate an infinite stream, whose values are the output of a function @f@+-- applied on the corresponding index.  Index starts at 0.+--+-- >>> Stream.toList $ Stream.take 5 $ Stream.fromIndices id+-- [0,1,2,3,4]+--+-- @since 0.6.0+{-# INLINE fromIndices #-}+fromIndices :: (IsStream t, Monad m) => (Int -> a) -> t m a+fromIndices = fromStreamS . S.fromIndices++--+-- |+-- @+-- fromIndicesM f = Stream.mapM f $ Stream.enumerateFrom 0+-- fromIndicesM f = let g i = f i \`consM` g (i + 1) in g 0+-- @+--+-- Generate an infinite stream, whose values are the output of a monadic+-- function @f@ applied on the corresponding index. Index starts at 0.+--+-- /Concurrent/+--+-- @since 0.6.0+{-# INLINE_EARLY fromIndicesM #-}+fromIndicesM :: (IsStream t, MonadAsync m) => (Int -> m a) -> t m a+fromIndicesM = K.fromIndicesM++{-# RULES "fromIndicesM serial" fromIndicesM = fromIndicesMSerial #-}+{-# INLINE fromIndicesMSerial #-}+fromIndicesMSerial :: MonadAsync m => (Int -> m a) -> SerialT m a+fromIndicesMSerial = fromStreamS . S.fromIndicesM++------------------------------------------------------------------------------+-- Iterating functions+------------------------------------------------------------------------------++-- |+-- @+-- iterate f x = x \`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.toList $ Stream.take 5 $ Stream.iterate (+1) 1+-- [1,2,3,4,5]+--+-- @+--+-- @since 0.1.2+{-# INLINE_NORMAL iterate #-}+iterate :: (IsStream t, Monad m) => (a -> a) -> a -> t m a+iterate step = fromStreamS . S.iterate step++-- |+-- @+-- iterateM f m = m >>= \a -> return a \`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.+--+-- When run concurrently, the next iteration can run concurrently with the+-- processing of the previous iteration. Note that more than one iteration+-- cannot run concurrently as the next iteration depends on the output of the+-- previous iteration.+--+-- @+-- drain $ fromSerial $ S.take 10 $ S.iterateM+--      (\\x -> threadDelay 1000000 >> print x >> return (x + 1)) (return 0)+--+-- drain $ fromAsync  $ S.take 10 $ S.iterateM+--      (\\x -> threadDelay 1000000 >> print x >> return (x + 1)) (return 0)+-- @+--+-- /Concurrent/+--+-- /Since: 0.1.2/+--+-- /Since: 0.7.0 (signature change)/+{-# INLINE_EARLY iterateM #-}+iterateM :: (IsStream t, MonadAsync m) => (a -> m a) -> m a -> t m a+iterateM = K.iterateM++{-# RULES "iterateM serial" iterateM = iterateMSerial #-}+{-# INLINE iterateMSerial #-}+iterateMSerial :: MonadAsync m => (a -> m a) -> m a -> SerialT m a+iterateMSerial step = fromStreamS . S.iterateM step++------------------------------------------------------------------------------+-- Conversions+------------------------------------------------------------------------------++-- |+-- @+-- fromFoldableM = 'Prelude.foldr' 'consM' 'K.nil'+-- @+--+-- Construct a stream from a 'Foldable' containing monadic actions.+--+-- @+-- drain $ fromSerial $ S.fromFoldableM $ replicateM 10 (threadDelay 1000000 >> print 1)+-- drain $ fromAsync  $ S.fromFoldableM $ replicateM 10 (threadDelay 1000000 >> print 1)+-- @+--+-- /Concurrent (do not use with 'fromParallel' on infinite containers)/+--+-- @since 0.3.0+{-# INLINE fromFoldableM #-}+fromFoldableM :: (IsStream t, MonadAsync m, Foldable f) => f (m a) -> t m a+fromFoldableM = Prelude.foldr consM K.nil++-- |+-- @+-- fromListM = 'Prelude.foldr' 'K.consM' 'K.nil'+-- @+--+-- Construct a stream from a list of monadic actions. This is more efficient+-- than 'fromFoldableM' for serial streams.+--+-- @since 0.4.0+{-# INLINE_EARLY fromListM #-}+fromListM :: (MonadAsync m, IsStream t) => [m a] -> t m a+fromListM = fromFoldableM+{-# RULES "fromListM fallback to StreamK" [1]+    forall a. D.toStreamK (D.fromListM a) = fromFoldableM a #-}++{-# RULES "fromListM serial" fromListM = fromListMSerial #-}+{-# INLINE_EARLY fromListMSerial #-}+fromListMSerial :: MonadAsync m => [m a] -> SerialT m a+fromListMSerial = fromStreamD . D.fromListM++-- | Same as 'fromFoldable'.+--+-- @since 0.1.0+{-# DEPRECATED each "Please use fromFoldable instead." #-}+{-# INLINE each #-}+each :: (IsStream t, Foldable f) => f a -> t m a+each = K.fromFoldable++-- | Read lines from an IO Handle into a stream of Strings.+--+-- @since 0.1.0+{-# DEPRECATED fromHandle+   "Please use Streamly.FileSystem.Handle module (see the changelog)" #-}+fromHandle :: (IsStream t, MonadIO m) => IO.Handle -> t m String+fromHandle h = go+  where+  go = K.mkStream $ \_ yld _ stp -> do+        eof <- liftIO $ IO.hIsEOF h+        if eof+        then stp+        else do+            str <- liftIO $ IO.hGetLine h+            yld str go++-- XXX This should perhaps be moved to Parallel+--+-- | Takes a callback setter function and provides it with a callback.  The+-- callback when invoked adds a value at the tail of the stream. Returns a+-- stream of values generated by the callback.+--+-- /Pre-release/+--+{-# INLINE fromCallback #-}+fromCallback :: MonadAsync m => ((a -> m ()) -> m ()) -> SerialT m a+fromCallback setCallback = concatM $ do+    (callback, stream) <- Par.newCallbackStream+    setCallback callback+    return stream
+ src/Streamly/Internal/Data/Stream/IsStream/Lift.hs view
@@ -0,0 +1,153 @@+-- |+-- Module      : Streamly.Internal.Data.Stream.IsStream.Lift+-- Copyright   : (c) 2019 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Internal.Data.Stream.IsStream.Lift+    (+    -- * Generalize Inner Monad+      hoist+    , generally++    -- * Transform Inner Monad+    , liftInner+    , usingReaderT+    , runReaderT+    , evalStateT+    , usingStateT+    , runStateT+    )+where++#include "inline.hs"++import Control.Monad.Trans.Reader (ReaderT)+import Control.Monad.Trans.State.Strict (StateT)+import Control.Monad.Trans.Class (MonadTrans(..))+import Data.Functor.Identity (Identity (..))+import Streamly.Internal.Data.Stream.Prelude (fromStreamS, toStreamS)+import Streamly.Internal.Data.Stream.Serial (SerialT)+import Streamly.Internal.Data.Stream.StreamD (fromStreamD, toStreamD)+import Streamly.Internal.Data.Stream.StreamK (IsStream)++import qualified Streamly.Internal.Data.Stream.StreamD as D+#ifdef USE_STREAMK_ONLY+import qualified Streamly.Internal.Data.Stream.StreamK as S+#else+import qualified Streamly.Internal.Data.Stream.StreamD as S+#endif++------------------------------------------------------------------------------+-- Generalize the underlying monad+------------------------------------------------------------------------------++-- | Transform the inner monad of a stream using a natural transformation.+--+-- / Internal/+--+{-# INLINE hoist #-}+hoist :: (Monad m, Monad n)+    => (forall x. m x -> n x) -> SerialT m a -> SerialT n a+hoist f xs = fromStreamS $ S.hoist f (toStreamS xs)++-- | Generalize the inner monad of the stream from 'Identity' to any monad.+--+-- / Internal/+--+{-# INLINE generally #-}+generally :: (IsStream t, Monad m) => t Identity a -> t m a+generally xs = fromStreamS $ S.hoist (return . runIdentity) (toStreamS xs)++------------------------------------------------------------------------------+-- Add and remove a monad transformer+------------------------------------------------------------------------------++-- | Lift the inner monad @m@ of a stream @t m a@ to @tr m@ using the monad+-- transformer @tr@.+--+-- @since 0.8.0+--+{-# INLINE liftInner #-}+liftInner :: (Monad m, IsStream t, MonadTrans tr, Monad (tr m))+    => t m a -> t (tr 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'.+--+-- @since 0.8.0+--+{-# INLINE runReaderT #-}+runReaderT :: (IsStream t, Monad m) => m s -> t (ReaderT s m) a -> t 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, IsStream t)+    => m r+    -> (t (ReaderT r m) a -> t (ReaderT r m) a)+    -> t m a+    -> t 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'.+--+-- This is supported only for 'SerialT' as concurrent state updation may not be+-- safe.+--+-- > evalStateT s = Stream.map snd . Stream.runStateT s+--+-- / Internal/+--+{-# INLINE evalStateT #-}+evalStateT ::  Monad m => m s -> SerialT (StateT s m) a -> SerialT 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.+--+-- This is supported only for 'SerialT' as concurrent state updation may not be+-- safe.+--+-- > usingStateT s f = evalStateT s . f . liftInner+--+-- See also: 'scanl''+--+-- / Internal/+--+{-# INLINE usingStateT #-}+usingStateT+    :: Monad m+    => m s+    -> (SerialT (StateT s m) a -> SerialT (StateT s m) a)+    -> SerialT m a+    -> SerialT 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.+--+-- This is supported only for 'SerialT' as concurrent state updation may not be+-- safe.+--+-- @since 0.8.0+--+{-# INLINE runStateT #-}+runStateT :: Monad m => m s -> SerialT (StateT s m) a -> SerialT m (s, a)+runStateT s xs = fromStreamD $ D.runStateT s (toStreamD xs)
+ src/Streamly/Internal/Data/Stream/IsStream/Reduce.hs view
@@ -0,0 +1,1527 @@+-- |+-- Module      : Streamly.Internal.Data.Stream.IsStream.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.IsStream.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) -> t m a -> t m b+    -- f (Parser m a b) -> t m a -> t m b+    -- @++    -- ** Generic Folding+    -- | Apply folds on a stream.+    , foldMany+    , foldManyPost+    , foldSequence+    , foldIterateM++    -- ** Chunking+    -- | Element unaware grouping.+    , chunksOf+    , arraysOf+    , intervalsOf++    -- ** Splitting+    -- | Streams can be sliced 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).++    -- -- *** Using Element Separators+    , splitOn+    , splitOnSuffix+    , splitOnPrefix++    -- , splitBy+    , splitWithSuffix+    -- , splitByPrefix++    -- -- *** Splitting By Sequences+    , splitBySeq+    , splitOnSeq+    , splitOnSuffixSeq+    -- , splitOnPrefixSeq++    -- Keeping the delimiters+    , splitWithSuffixSeq+    -- , splitByPrefixSeq+    -- , wordsBySeq++    -- Splitting using multiple sequence separators+    -- , splitOnAnySeq+    -- , splitOnAnySuffixSeq+    -- , splitOnAnyPrefixSeq++    -- -- *** Splitting By Streams+    -- -- | Splitting a stream using another stream as separator.++    -- ** Keyed Window Classification++    -- | Split the stream into chunks or windows by position 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+    -- window termination can be dynamically controlled by the fold.+    --+    -- The term "chunk" is used for a window defined by position of elements+    -- and the term "session" is used for a time window.++    -- *** Tumbling Windows+    -- | A new window starts after the previous window is finished.++    -- , classifyChunksOf+    , classifySessionsBy+    , 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+    -}++    -- * Reduce By Parsers+    -- ** Generic Parsing+    -- | Apply parsers on a stream.+    , parseMany+    , parseManyD+    , parseManyTill+    , parseSequence+    , parseIterate++    -- ** Grouping+    -- 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.++    , wordsBy -- stripAndCompactBy+    , groups+    , groupsBy+    , groupsByRolling++    -- -- *** Searching Sequences+    -- , seqIndices -- search a sequence in the stream++    -- -- *** Searching Multiple Sequences+    -- , seqIndicesAny -- search any of the given sequence in the stream++    -- -- -- ** Searching Streams+    -- -- | Finding a stream within another stream.++    -- * Nested splitting+    , splitInnerBy+    , splitInnerBySuffix++     -- * Fold2+    , chunksOf2+    )+where++#include "inline.hs"++import Control.Concurrent (threadDelay)+import Control.Exception (assert)+import Control.Monad.Catch (MonadThrow)+import Control.Monad.IO.Class (MonadIO(..))+import Data.Heap (Entry(..))+import Data.Kind (Type)+import Data.Maybe (isNothing)+import Foreign.Storable (Storable)+import Streamly.Internal.Data.Fold.Type (Fold (..), Fold2 (..))+import Streamly.Internal.Data.Parser (Parser (..))+import Streamly.Internal.Data.Array.Foreign.Type (Array)+import Streamly.Internal.Data.SVar (MonadAsync)+import Streamly.Internal.Data.Stream.IsStream.Common+    ( concatMap+    , fold+    , interjectSuffix+    , intersperseM+    , repeatM+    , scanlMAfter'+    , splitOnSeq+    , fromPure)+import Streamly.Internal.Data.Stream.StreamK (IsStream)+import Streamly.Internal.Data.Time.Units+       ( AbsTime, MilliSecond64(..), addToAbsTime, toRelTime+       , toAbsTime)+import Streamly.Internal.Data.Tuple.Strict (Tuple'(..))++import qualified Data.Heap as H+import qualified Data.Map.Strict as Map+import qualified Streamly.Internal.Data.Array.Foreign.Type as A+import qualified Streamly.Internal.Data.Fold as FL+import qualified Streamly.Internal.Data.Parser.ParserK.Type as PRK+import qualified Streamly.Internal.Data.Parser.ParserD as PRD+import qualified Streamly.Internal.Data.Stream.Parallel as Par+import qualified Streamly.Internal.Data.Stream.Serial as Serial+import qualified Streamly.Internal.Data.Stream.StreamD as D+import qualified Streamly.Internal.Data.Stream.StreamK as K++import Prelude hiding (concatMap)++-- $setup+-- >>> :m+-- >>> import Prelude hiding (zipWith, concatMap, concat)+-- >>> import qualified Streamly.Prelude as Stream+-- >>> import Streamly.Internal.Data.Stream.IsStream 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.Foreign as Array++------------------------------------------------------------------------------+-- Trimming+------------------------------------------------------------------------------++-- | Drop prefix from the input stream if present.+--+-- Space: @O(1)@+--+-- /Unimplemented/ - Help wanted.+{-# INLINE dropPrefix #-}+dropPrefix ::+    -- (Eq a, IsStream t, Monad m) =>+    t m a -> t m a -> t 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/ - Help wanted.+{-# INLINE dropInfix #-}+dropInfix ::+    -- (Eq a, IsStream t, Monad m) =>+    t m a -> t m a -> t 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/ - Help wanted.+{-# INLINE dropSuffix #-}+dropSuffix ::+    -- (Eq a, IsStream t, Monad m) =>+    t m a -> t m a -> t m a+dropSuffix = error "Not implemented yet!"++------------------------------------------------------------------------------+-- Folding+------------------------------------------------------------------------------++-- Splitting operations that take a predicate and a Fold can be+-- expressed using parseMany. Operations like chunksOf, intervalsOf, split*,+-- can be expressed using parseMany when used with an appropriate Parser.+--+-- XXX We need takeGE/takeBetween to implement "some" using "many".++-- | Like 'foldMany' but appends empty fold output if the fold and stream+-- termination aligns:+--+-- >>> f = Fold.take 2 Fold.sum+-- >>> Stream.toList $ Stream.foldManyPost f $ Stream.fromList []+-- [0]+-- >>> Stream.toList $ Stream.foldManyPost f $ Stream.fromList [1..9]+-- [3,7,11,15,9]+-- >>> Stream.toList $ Stream.foldManyPost f $ Stream.fromList [1..10]+-- [3,7,11,15,19,0]+--+-- /Pre-release/+--+{-# INLINE foldManyPost #-}+foldManyPost+    :: (IsStream t, Monad m)+    => Fold m a b+    -> t m a+    -> t m b+foldManyPost f m = D.fromStreamD $ D.foldManyPost f (D.toStreamD m)++-- | Apply a 'Fold' repeatedly on a stream and emit the fold outputs in the+-- output stream.+--+-- To sum every two contiguous elements in a stream:+--+-- >>> f = Fold.take 2 Fold.sum+-- >>> Stream.toList $ Stream.foldMany f $ Stream.fromList [1..10]+-- [3,7,11,15,19]+--+-- On an empty stream the output is empty:+--+-- >>> Stream.toList $ Stream.foldMany f $ Stream.fromList []+-- []+--+-- Note @Stream.foldMany (Fold.take 0)@ would result in an infinite loop in a+-- non-empty stream.+--+-- @since 0.8.0+--+{-# INLINE foldMany #-}+foldMany+    :: (IsStream t, Monad m)+    => Fold m a b+    -> t m a+    -> t m b+foldMany f m = D.fromStreamD $ D.foldMany f (D.toStreamD m)++-- | Apply a stream of folds to an input stream and emit the results in the+-- output stream.+--+-- /Pre-release/+--+{-# INLINE foldSequence #-}+foldSequence+       :: -- (IsStream t, Monad m) =>+       t m (Fold m a b)+    -> t m a+    -> t 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 = Stream.map Sum $ Stream.fromList [1..10]+-- >>> Stream.toList $ Stream.map getSum $ Stream.foldIterateM f 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 ::+       (IsStream t, Monad m) => (b -> m (Fold m a b)) -> b -> t m a -> t m b+foldIterateM f i m = D.fromStreamD $ D.foldIterateM f i (D.toStreamD m)++------------------------------------------------------------------------------+-- Parsing+------------------------------------------------------------------------------++-- | Apply a 'Parser' repeatedly on a stream and emit the parsed values in the+-- output stream.+--+-- This is the streaming equivalent of the 'Streamly.Internal.Data.Parser.many'+-- parse combinator.+--+-- >>> Stream.toList $ Stream.parseMany (Parser.takeBetween 0 2 Fold.sum) $ Stream.fromList [1..10]+-- [3,7,11,15,19]+--+-- @+-- > Stream.toList $ Stream.parseMany (Parser.line Fold.toList) $ Stream.fromList "hello\\nworld"+-- ["hello\\n","world"]+--+-- @+--+-- @+-- foldMany f = parseMany (fromFold f)+-- @+--+-- Known Issues: When the parser fails there is no way to get the remaining+-- stream.+--+-- /Pre-release/+--+{-# INLINE parseMany #-}+parseMany+    :: (IsStream t, MonadThrow m)+    => Parser m a b+    -> t m a+    -> t m b+parseMany p m =+    D.fromStreamD $ D.parseMany (PRK.fromParserK p) (D.toStreamD m)++{-# INLINE parseManyD #-}+parseManyD+    :: (IsStream t, MonadThrow m)+    => PRD.Parser m a b+    -> t m a+    -> t m b+parseManyD p m =+    D.fromStreamD $ D.parseMany p (D.toStreamD m)++-- | Apply a stream of parsers to an input stream and emit the results in the+-- output stream.+--+-- /Pre-release/+--+{-# INLINE parseSequence #-}+parseSequence+       :: -- (IsStream t, Monad m) =>+       t m (Parser m a b)+    -> t m a+    -> t 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 ::+    -- (IsStream t, MonadThrow m) =>+       Parser m a b+    -> Parser m a 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(..))+-- >>> Stream.toList $ Stream.map getSum $ Stream.parseIterate (\b -> Parser.takeBetween 0 2 (Fold.sconcat b)) 0 $ Stream.map Sum $ Stream.fromList [1..10]+-- [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+    :: (IsStream t, MonadThrow m)+    => (b -> Parser m a b)+    -> b+    -> t m a+    -> t m b+parseIterate f i m = D.fromStreamD $+    D.parseIterate (PRK.fromParserK . f) i (D.toStreamD m)++------------------------------------------------------------------------------+-- Generalized grouping+------------------------------------------------------------------------------++-- This combinator is the most general grouping combinator and can be used to+-- implement all other grouping combinators.+--+-- XXX check if this can implement the splitOn combinator i.e. we can slide in+-- new elements, slide out old elements and incrementally compute the hash.+-- Also, can we implement the windowed classification combinators using this?+--+-- In fact this is a parse. Instead of using a special return value in the fold+-- we are using a mapping function.+--+-- Note that 'scanl'' (usually followed by a map to extract the desired value+-- from the accumulator) can be used to realize many implementations e.g. a+-- sliding window implementation. A scan followed by a mapMaybe is also a good+-- pattern to express many problems where we want to emit a filtered output and+-- not emit an output on every input.+--+-- Passing on of the initial accumulator value to the next fold is equivalent+-- to returning the leftover concept.++{-+-- | @groupScan splitter fold stream@ folds the input stream using @fold@.+-- @splitter@ is applied on the accumulator of the fold every time an item is+-- consumed by the fold. The fold continues until @splitter@ returns a 'Just'+-- value.  A 'Just' result from the @splitter@ specifies a result to be emitted+-- in the output stream and the initial value of the accumulator for the next+-- group's fold. This allows us to control whether to start fresh for the next+-- fold or to continue from the previous fold's output.+--+{-# INLINE groupScan #-}+groupScan+    :: (IsStream t, Monad m)+    => (x -> m (Maybe (b, x))) -> Fold m a x -> t m a -> t m b+groupScan split fold m = undefined+-}++------------------------------------------------------------------------------+-- Grouping+------------------------------------------------------------------------------++-- | @groupsBy cmp f $ S.fromList [a,b,c,...]@ assigns the element @a@ to the+-- first group, if @b \`cmp` a@ is 'True' then @b@ is also assigned to the same+-- group.  If @c \`cmp` a@ is 'True' then @c@ is also assigned to the same+-- group and so on. When the comparison fails a new group is started. Each+-- group is folded using the fold @f@ and the result of the fold is emitted in+-- the output stream.+--+-- >>> Stream.toList $ Stream.groupsBy (>) Fold.toList $ Stream.fromList [1,3,7,0,2,5]+-- [[1,3,7],[0,2,5]]+--+-- @since 0.7.0+{-# INLINE groupsBy #-}+groupsBy+    :: (IsStream t, Monad m)+    => (a -> a -> Bool)+    -> Fold m a b+    -> t m a+    -> t m b+groupsBy cmp f m = D.fromStreamD $ D.groupsBy cmp f (D.toStreamD m)++-- | Unlike @groupsBy@ this function performs a rolling comparison of two+-- successive elements in the input stream. @groupsByRolling cmp f $ S.fromList+-- [a,b,c,...]@ assigns the element @a@ to the first group, if @a \`cmp` b@ is+-- 'True' then @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 a new group is started. Each group is folded using the fold+-- @f@.+--+-- >>> Stream.toList $ Stream.groupsByRolling (\a b -> a + 1 == b) Fold.toList $ Stream.fromList [1,2,3,7,8,9]+-- [[1,2,3],[7,8,9]]+--+-- @since 0.7.0+{-# INLINE groupsByRolling #-}+groupsByRolling+    :: (IsStream t, Monad m)+    => (a -> a -> Bool)+    -> Fold m a b+    -> t m a+    -> t m b+groupsByRolling cmp f m =  D.fromStreamD $ D.groupsRollingBy cmp f (D.toStreamD m)++-- |+-- > groups = groupsBy (==)+-- > groups = groupsByRolling (==)+--+-- Groups contiguous spans of equal elements together in individual groups.+--+-- >>> Stream.toList $ Stream.groups Fold.toList $ Stream.fromList [1,1,2,2]+-- [[1,1],[2,2]]+--+-- @since 0.7.0+{-# INLINE groups #-}+groups :: (IsStream t, Monad m, Eq a) => Fold m a b -> t m a -> t m b+groups = groupsBy (==)++------------------------------------------------------------------------------+-- Splitting - by a predicate+------------------------------------------------------------------------------++-- In general we can use deintercalate for splitting.  Then we can also use+-- uniqBy to condense the separators.  One way to generalize splitting is to+-- output:+--+-- data Segment a b = Empty | Segment b | Separator a+--+-- XXX splitOn and splitOnSuffix have a different behavior on an empty stream,+-- is that desirable?++-- | 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.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+--+-- @since 0.7.0++{-# INLINE splitOn #-}+splitOn+    :: (IsStream t, Monad m)+    => (a -> Bool) -> Fold m a b -> t m a -> t 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)++-- | Split on a suffixed separator element, dropping the separator.  The+-- supplied 'Fold' is applied on the split segments.+--+-- >>> splitOnSuffix' p xs = Stream.toList $ Stream.splitOnSuffix p Fold.toList (Stream.fromList xs)+-- >>> splitOnSuffix' (== '.') "a.b."+-- ["a","b"]+--+-- >>> splitOnSuffix' (== '.') "a."+-- ["a"]+--+-- An empty stream results in an empty output stream:+--+-- >>> splitOnSuffix' (== '.') ""+-- []+--+-- An empty segment consisting of only a suffix is folded to the default output+-- of the fold:+--+-- >>> splitOnSuffix' (== '.') "."+-- [""]+--+-- >>> splitOnSuffix' (== '.') "a..b.."+-- ["a","","b",""]+--+-- A suffix is optional at the end of the stream:+--+-- >>> splitOnSuffix' (== '.') "a"+-- ["a"]+--+-- >>> splitOnSuffix' (== '.') ".a"+-- ["","a"]+--+-- >>> splitOnSuffix' (== '.') "a.b"+-- ["a","b"]+--+-- > lines = splitOnSuffix (== '\n')+--+-- 'splitOnSuffix' is an inverse of 'intercalateSuffix' with a single element:+--+-- > Stream.intercalateSuffix (Stream.fromPure '.') Unfold.fromList . Stream.splitOnSuffix (== '.') Fold.toList === id+--+-- Assuming the input stream does not contain the separator:+--+-- > Stream.splitOnSuffix (== '.') Fold.toList . Stream.intercalateSuffix (Stream.fromPure '.') Unfold.fromList === id+--+-- @since 0.7.0++{-# INLINE splitOnSuffix #-}+splitOnSuffix+    :: (IsStream t, Monad m)+    => (a -> Bool) -> Fold m a b -> t m a -> t m b+splitOnSuffix predicate f = foldMany (FL.takeEndBy_ predicate f)++-- | 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 -> t m a -> t m b+splitOnPrefix _predicate _f = undefined+    -- parseMany (Parser.sliceBeginBy predicate f)++-- | Like 'splitOn' after stripping leading, trailing, and repeated separators.+-- Therefore, @".a..b."@ with '.' as the separator would be parsed as+-- @["a","b"]@.  In other words, its like parsing words from whitespace+-- separated text.+--+-- >>> wordsBy' p xs = Stream.toList $ Stream.wordsBy p Fold.toList (Stream.fromList xs)+--+-- >>> wordsBy' (== ',') ""+-- []+--+-- >>> wordsBy' (== ',') ","+-- []+--+-- >>> wordsBy' (== ',') ",a,,b,"+-- ["a","b"]+--+-- > words = wordsBy isSpace+--+-- @since 0.7.0++-- It is equivalent to splitting in any of the infix/prefix/suffix styles+-- followed by removal of empty segments.+{-# INLINE wordsBy #-}+wordsBy+    :: (IsStream t, Monad m)+    => (a -> Bool) -> Fold m a b -> t m a -> t m b+wordsBy predicate f m =+    D.fromStreamD $ D.wordsBy predicate f (D.toStreamD m)++-- | Like 'splitOnSuffix' but keeps the suffix attached to the resulting+-- splits.+--+-- >>> splitWithSuffix' p xs = Stream.toList $ splitWithSuffix p Fold.toList (Stream.fromList xs)+--+-- >>> splitWithSuffix' (== '.') ""+-- []+--+-- >>> splitWithSuffix' (== '.') "."+-- ["."]+--+-- >>> splitWithSuffix' (== '.') "a"+-- ["a"]+--+-- >>> splitWithSuffix' (== '.') ".a"+-- [".","a"]+--+-- >>> splitWithSuffix' (== '.') "a."+-- ["a."]+--+-- >>> splitWithSuffix' (== '.') "a.b"+-- ["a.","b"]+--+-- >>> splitWithSuffix' (== '.') "a.b."+-- ["a.","b."]+--+-- >>> splitWithSuffix' (== '.') "a..b.."+-- ["a.",".","b.","."]+--+-- @since 0.7.0++{-# INLINE splitWithSuffix #-}+splitWithSuffix+    :: (IsStream t, Monad m)+    => (a -> Bool) -> Fold m a b -> t m a -> t m b+splitWithSuffix predicate f = foldMany (FL.takeEndBy predicate f)++------------------------------------------------------------------------------+-- Splitting - on a delimiter sequence+------------------------------------------------------------------------------++-- 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.+{-# INLINE splitOnAny #-}+splitOnAny+    :: (IsStream t, Monad m, Storable a, Integral a)+    => [Array a] -> Fold m a b -> t m a -> t m b+splitOnAny subseq f m = undefined -- D.fromStreamD $ D.splitOnAny f subseq (D.toStreamD m)+-}++-- XXX use a non-monadic intersperse to remove the MonadAsync constraint.+-- XXX Use two folds, one ring buffer fold for separator sequence and the other+-- split consumer fold. The input is fed to the ring fold first and the+-- rejected input is fed to the split fold. If the separator matches, the ring+-- fold would consume all.+--+-- | Like 'splitOnSeq' but splits the separator as well, as an infix token.+--+-- >>> splitOn'_ pat xs = Stream.toList $ Stream.splitBySeq (Array.fromList pat) Fold.toList (Stream.fromList xs)+--+-- >>> splitOn'_ "" "hello"+-- ["h","","e","","l","","l","","o"]+--+-- >>> splitOn'_ "hello" ""+-- [""]+--+-- >>> splitOn'_ "hello" "hello"+-- ["","hello",""]+--+-- >>> splitOn'_ "x" "hello"+-- ["hello"]+--+-- >>> splitOn'_ "h" "hello"+-- ["","h","ello"]+--+-- >>> splitOn'_ "o" "hello"+-- ["hell","o",""]+--+-- >>> splitOn'_ "e" "hello"+-- ["h","e","llo"]+--+-- >>> splitOn'_ "l" "hello"+-- ["he","l","","l","o"]+--+-- >>> splitOn'_ "ll" "hello"+-- ["he","ll","o"]+--+-- /Pre-release/+{-# INLINE splitBySeq #-}+splitBySeq+    :: (IsStream t, MonadAsync m, Storable a, Enum a, Eq a)+    => Array a -> Fold m a b -> t m a -> t m b+splitBySeq patt f m =+    intersperseM (fold f (A.toStream patt)) $ splitOnSeq patt f m++-- | Like 'splitSuffixBy' but the separator is a sequence of elements, instead+-- of a predicate for a single element.+--+-- >>> splitOnSuffixSeq_ pat xs = Stream.toList $ Stream.splitOnSuffixSeq (Array.fromList pat) Fold.toList (Stream.fromList xs)+--+-- >>> splitOnSuffixSeq_ "." ""+-- []+--+-- >>> splitOnSuffixSeq_ "." "."+-- [""]+--+-- >>> splitOnSuffixSeq_ "." "a"+-- ["a"]+--+-- >>> splitOnSuffixSeq_ "." ".a"+-- ["","a"]+--+-- >>> splitOnSuffixSeq_ "." "a."+-- ["a"]+--+-- >>> splitOnSuffixSeq_ "." "a.b"+-- ["a","b"]+--+-- >>> splitOnSuffixSeq_ "." "a.b."+-- ["a","b"]+--+-- >>> splitOnSuffixSeq_ "." "a..b.."+-- ["a","","b",""]+--+-- > lines = splitOnSuffixSeq "\n"+--+-- 'splitOnSuffixSeq' is an inverse of 'intercalateSuffix'. The following law+-- always holds:+--+-- > intercalateSuffix . splitOnSuffixSeq == id+--+-- The following law holds when the separator is non-empty and contains none of+-- the elements present in the input lists:+--+-- > splitSuffixOn . intercalateSuffix == id+--+-- /Pre-release/+{-# INLINE splitOnSuffixSeq #-}+splitOnSuffixSeq+    :: (IsStream t, MonadIO m, Storable a, Enum a, Eq a)+    => Array a -> Fold m a b -> t m a -> t m b+splitOnSuffixSeq patt f m =+    D.fromStreamD $ D.splitOnSuffixSeq False patt f (D.toStreamD m)++{-+-- | Like 'splitOn' but drops any empty splits.+--+{-# INLINE wordsOn #-}+wordsOn+    :: (IsStream t, Monad m, Storable a, Eq a)+    => Array a -> Fold m a b -> t m a -> t m b+wordsOn subseq f m = undefined -- D.fromStreamD $ D.wordsOn f subseq (D.toStreamD m)+-}++-- | Like 'splitOnSuffixSeq' but keeps the suffix intact in the splits.+--+-- >>> splitWithSuffixSeq' pat xs = Stream.toList $ Stream.splitWithSuffixSeq (Array.fromList pat) Fold.toList (Stream.fromList xs)+--+-- >>> splitWithSuffixSeq' "." ""+-- []+--+-- >>> splitWithSuffixSeq' "." "."+-- ["."]+--+-- >>> splitWithSuffixSeq' "." "a"+-- ["a"]+--+-- >>> splitWithSuffixSeq' "." ".a"+-- [".","a"]+--+-- >>> splitWithSuffixSeq' "." "a."+-- ["a."]+--+-- >>> splitWithSuffixSeq' "." "a.b"+-- ["a.","b"]+--+-- >>> splitWithSuffixSeq' "." "a.b."+-- ["a.","b."]+--+-- >>> splitWithSuffixSeq' "." "a..b.."+-- ["a.",".","b.","."]+--+-- /Pre-release/+{-# INLINE splitWithSuffixSeq #-}+splitWithSuffixSeq+    :: (IsStream t, MonadIO m, Storable a, Enum a, Eq a)+    => Array a -> Fold m a b -> t m a -> t m b+splitWithSuffixSeq patt f m =+    D.fromStreamD $ D.splitOnSuffixSeq True patt f (D.toStreamD m)++{-+-- This can be implemented easily using Rabin Karp+-- | Split post any one of the given patterns.+{-# INLINE splitOnSuffixSeqAny #-}+splitOnSuffixSeqAny+    :: (IsStream t, Monad m, Storable a, Integral a)+    => [Array a] -> Fold m a b -> t m a -> t m b+splitOnSuffixSeqAny subseq f m = undefined+    -- D.fromStreamD $ D.splitPostAny f subseq (D.toStreamD m)+-}++------------------------------------------------------------------------------+-- Chunking+------------------------------------------------------------------------------++-- | Group the input stream into groups of @n@ elements each and then fold each+-- group using the provided fold function.+--+-- >>> Stream.toList $ Stream.chunksOf 2 Fold.sum (Stream.enumerateFromTo 1 10)+-- [3,7,11,15,19]+--+-- This can be considered as an n-fold version of 'take' where we apply+-- 'take' repeatedly on the leftover stream until the stream exhausts.+--+-- @chunksOf n f = foldMany (FL.take n f)@+--+-- @since 0.7.0+{-# INLINE chunksOf #-}+chunksOf+    :: (IsStream t, Monad m)+    => Int -> Fold m a b -> t m a -> t m b+chunksOf n f = D.fromStreamD . D.chunksOf n f . D.toStreamD++-- |+--+-- /Pre-release/+{-# INLINE chunksOf2 #-}+chunksOf2+    :: (IsStream t, Monad m)+    => Int -> m c -> Fold2 m c a b -> t m a -> t m b+chunksOf2 n action f m = D.fromStreamD $ D.groupsOf2 n action f (D.toStreamD m)++-- | @arraysOf n stream@ groups the elements in the input stream into arrays of+-- @n@ elements each.+--+-- Same as the following but may be more efficient:+--+-- > arraysOf n = Stream.foldMany (A.writeN n)+--+-- /Pre-release/+{-# INLINE arraysOf #-}+arraysOf :: (IsStream t, MonadIO m, Storable a)+    => Int -> t m a -> t m (Array a)+arraysOf n = D.fromStreamD . A.arraysOf n . D.toStreamD++-- XXX we can implement this by repeatedly applying the 'lrunFor' fold.+-- XXX add this example after fixing the serial stream rate control+--+-- | Group the input stream into windows of @n@ second each and then fold each+-- group using the provided fold function.+--+-- >>> Stream.toList $ Stream.take 5 $ Stream.intervalsOf 1 Fold.sum $ Stream.constRate 2 $ Stream.enumerateFrom 1+-- [...,...,...,...,...]+--+-- @since 0.7.0+{-# INLINE intervalsOf #-}+intervalsOf+    :: (IsStream t, MonadAsync m)+    => Double -> Fold m a b -> t m a -> t m b+intervalsOf n f xs =+    splitWithSuffix isNothing (FL.catMaybes f)+        (interjectSuffix n (return Nothing) (Serial.map Just xs))++------------------------------------------------------------------------------+-- Windowed classification+------------------------------------------------------------------------------++-- We divide the stream into windows or chunks in space or time and 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 can be split into+-- windows by size or by using a split predicate on the elements in the stream.+-- For example, when we receive a closing flag, we can close the window.+--+-- A "chunk" is a space window and a "session" is a time window. Are there any+-- other better short words to describe them. An alternative is to use+-- "swindow" and "twindow". Another word for "session" could be "spell".+--+-- TODO: To mark the position in space or time we can have Indexed or+-- TimeStamped types. That can make it easy to deal with the position indices+-- or timestamps.++------------------------------------------------------------------------------+-- Keyed Sliding Windows+------------------------------------------------------------------------------++{-+{-# INLINABLE classifySlidingChunks #-}+classifySlidingChunks+    :: (IsStream t, MonadAsync m, Ord k)+    => Int              -- ^ window size+    -> Int              -- ^ window slide+    -> Fold m a b       -- ^ Fold to be applied to window events+    -> t m (k, a, Bool) -- ^ window key, data, close event+    -> t m (k, b)+classifySlidingChunks wsize wslide (Fold step initial extract) str+    = undefined++-- XXX Another variant could be to slide the window on an event, e.g. in TCP we+-- slide the send window when an ack is received and we slide the receive+-- window when a sequence is complete. Sliding is stateful in case of TCP,+-- sliding releases the send buffer or makes data available to the user from+-- the receive buffer.+{-# INLINABLE classifySlidingSessions #-}+classifySlidingSessions+    :: (IsStream t, MonadAsync m, Ord k)+    => Double         -- ^ timer tick in seconds+    -> Double         -- ^ time window size+    -> Double         -- ^ window slide+    -> Fold m a b     -- ^ Fold to be applied to window events+    -> t m (k, a, Bool, AbsTime) -- ^ window key, data, close flag, timestamp+    -> t m (k, b)+classifySlidingSessions tick interval slide (Fold step initial extract) str+    = undefined+-}++------------------------------------------------------------------------------+-- Sliding Window Buffers+------------------------------------------------------------------------------++-- These buffered versions could be faster than concurrent incremental folds of+-- all overlapping windows as in many cases we may not need all the values to+-- compute the fold, we can just compute the result using the old value and new+-- value.  However, we may need the buffer once in a while, for example for+-- string search we usually compute the hash incrementally but when the hash+-- matches the hash of the pattern we need to compare the whole string.+--+-- XXX we should be able to implement sequence based splitting combinators+-- using this combinator.++{-+-- | Buffer n elements of the input in a ring buffer. When t new elements are+-- collected, slide the window to remove the same number of oldest elements,+-- insert the new elements, and apply an incremental fold on the sliding+-- window, supplying the outgoing elements, the new ring buffer as arguments.+slidingChunkBuffer+    :: (IsStream t, Monad m, Ord a, Storable a)+    => Int -- window size+    -> Int -- window slide+    -> Fold m (Ring a, Array a) b+    -> t m a+    -> t m b+slidingChunkBuffer = undefined++-- Buffer n seconds worth of stream elements of the input in a radix tree.+-- Every t seconds, remove the items that are older than n seconds, and apply+-- an incremental fold on the sliding window, supplying the outgoing elements,+-- and the new radix tree buffer as arguments.+slidingSessionBuffer+    :: (IsStream t, Monad m, Ord a, Storable a)+    => Int    -- window size+    -> Int    -- tick size+    -> Fold m (RTree a, Array a) b+    -> t m a+    -> t m b+slidingSessionBuffer = undefined+-}++------------------------------------------------------------------------------+-- Keyed Session Windows+------------------------------------------------------------------------------++{-+-- | Keyed variable size space windows. Close the window if we do not receive a+-- window event in the next "spaceout" elements.+{-# INLINABLE classifyChunksBy #-}+classifyChunksBy+    :: (IsStream t, MonadAsync m, Ord k)+    => Int   -- ^ window spaceout (spread)+    -> Bool  -- ^ reset the spaceout when a chunk window element is received+    -> Fold m a b       -- ^ Fold to be applied to chunk window elements+    -> t m (k, a, Bool) -- ^ chunk key, data, last element+    -> t m (k, b)+classifyChunksBy spanout reset (Fold step initial extract) str = undefined++-- | Like 'classifyChunksOf' but the chunk size is reset if an element is+-- received within the chunk size window. The chunk gets closed only if no+-- element is received within the chunk window.+--+{-# INLINABLE classifyKeepAliveChunks #-}+classifyKeepAliveChunks+    :: (IsStream t, MonadAsync m, Ord k)+    => Int   -- ^ window spaceout (spread)+    -> Fold m a b       -- ^ Fold to be applied to chunk window elements+    -> t m (k, a, Bool) -- ^ chunk key, data, last element+    -> t m (k, b)+classifyKeepAliveChunks spanout = classifyChunksBy spanout True+-}++data SessionState t m k a b = SessionState+    { sessionCurTime :: !AbsTime  -- ^ time since last event+    , sessionEventTime :: !AbsTime -- ^ time as per last event+    , sessionCount :: !Int -- ^ total number sessions in progress+    , sessionTimerHeap :: H.Heap (H.Entry AbsTime k) -- ^ heap for timeouts+    , sessionKeyValueMap :: Map.Map k a -- ^ Stored sessions for keys+    , sessionOutputStream :: t (m :: Type -> Type) (k, b) -- ^ Completed sessions+    }++-- | @classifySessionsBy tick keepalive predicate timeout fold stream@+-- classifies an input event @stream@ consisting of  @(timestamp, (key,+-- value))@ into sessions based on the @key@, folding all the values+-- corresponding to the same key into a session using the supplied @fold@.+--+-- When the fold terminates or a @timeout@ occurs, a tuple consisting of the+-- session key and the folded value is emitted in the output stream. The+-- timeout is measured from the first event in the session.  If the @keepalive@+-- option is set to 'True' the timeout is reset to 0 whenever an event is+-- received.+--+-- The @timestamp@ in the input stream is an absolute time from some epoch,+-- characterizing the time when the input event was generated.  The notion of+-- current time is maintained by a monotonic event time clock using the+-- timestamps seen in the input stream. The latest timestamp seen till now is+-- used as the base for the current time.  When no new events are seen, a timer+-- is started with a clock resolution of @tick@ seconds. This timer is used to+-- detect session timeouts in the absence of new events.+--+-- To ensure an upper bound on the memory used the number of sessions can be+-- limited to an upper bound. If the ejection @predicate@ returns 'True', the+-- oldest session is ejected before inserting a new session.+--+-- >>> :{+-- Stream.mapM_ print+--     $ Stream.classifySessionsBy 1 False (const (return False)) 3 (Fold.take 3 Fold.toList)+--     $ Stream.timestamped+--     $ Stream.delay 0.1+--     $ (,) <$> Stream.fromList [1,2,3] <*> Stream.fromList ['a','b','c']+-- :}+-- (1,"abc")+-- (2,"abc")+-- (3,"abc")+--+-- /Pre-release/+--+{-# INLINABLE classifySessionsBy #-}+classifySessionsBy+    :: (IsStream t, MonadAsync m, Ord k)+    => Double         -- ^ timer tick in seconds+    -> Bool           -- ^ reset the timer when an event is received+    -> (Int -> m Bool) -- ^ predicate to eject sessions based on session count+    -> Double         -- ^ session timeout in seconds+    -> Fold m a b  -- ^ Fold to be applied to session data+    -> t m (AbsTime, (k, a)) -- ^ timestamp, (session key, session data)+    -> t m (k, b) -- ^ session key, fold result+classifySessionsBy tick reset ejectPred tmout+    (Fold step initial extract) str =+    concatMap sessionOutputStream $+        scanlMAfter' sstep (return szero) flush stream++    where++    timeoutMs = toRelTime (round (tmout * 1000) :: MilliSecond64)+    tickMs = toRelTime (round (tick * 1000) :: MilliSecond64)+    szero = SessionState+        { sessionCurTime = toAbsTime (0 :: MilliSecond64)+        , sessionEventTime = toAbsTime (0 :: MilliSecond64)+        , sessionCount = 0+        , sessionTimerHeap = H.empty+        , sessionKeyValueMap = Map.empty+        , sessionOutputStream = K.nil+        }++    -- We can eject sessions based on the current session count to limit+    -- memory consumption. There are two possible strategies:+    --+    -- 1) Eject old sessions or sessions beyond a certain/lower timeout+    -- threshold even before timeout, effectively reduce the timeout.+    -- 2) Drop creation of new sessions but keep accepting new events for the+    -- old ones.+    --+    -- We use the first strategy as of now.++    -- Got a new stream input element+    sstep session@SessionState{..} (Just (timestamp, (key, value))) = do+        -- XXX we should use a heap in pinned memory to scale it to a large+        -- size+        --+        -- To detect session inactivity we keep a timestamp of the latest event+        -- in the Map along with the fold result.  When we purge the session+        -- from the heap we match the timestamp in the heap with the timestamp+        -- in the Map, if the latest timestamp is newer and has not expired we+        -- reinsert the key in the heap.+        --+        -- XXX if the key is an Int, we can also use an IntMap for slightly+        -- better performance.+        --+        let curTime = max sessionEventTime timestamp+            mOld = Map.lookup key sessionKeyValueMap+        let done fb = do+                -- deleting a key from the heap is expensive, so we never+                -- delete a key from heap, we just purge it from the Map and it+                -- gets purged from the heap on timeout. We just need an extra+                -- lookup in the Map when the key is purged from the heap, that+                -- should not be expensive.+                --+                let (mp, cnt) = case mOld of+                        Nothing -> (sessionKeyValueMap, sessionCount)+                        Just _ -> (Map.delete key sessionKeyValueMap+                                  , sessionCount - 1)+                return $ session+                    { sessionCurTime = curTime+                    , sessionEventTime = curTime+                    , sessionCount = cnt+                    , sessionKeyValueMap = mp+                    , sessionOutputStream = fromPure (key, fb)+                    }+            partial fs1 = do+                let acc = Tuple' timestamp fs1+                (hp1, mp1, out1, cnt1) <- do+                        let vars = (sessionTimerHeap, sessionKeyValueMap,+                                           K.nil, sessionCount)+                        case mOld of+                            -- inserting new entry+                            Nothing -> do+                                -- Eject a session from heap and map is needed+                                eject <- ejectPred sessionCount+                                (hp, mp, out, cnt) <-+                                    if eject+                                    then ejectOne vars+                                    else return vars++                                -- Insert the new session in heap+                                let expiry = addToAbsTime timestamp timeoutMs+                                    hp' = H.insert (Entry expiry key) hp+                                 in return (hp', mp, out, cnt + 1)+                            -- updating old entry+                            Just _ -> return vars++                let mp2 = Map.insert key acc mp1+                return $ SessionState+                    { sessionCurTime = curTime+                    , sessionEventTime = curTime+                    , sessionCount = cnt1+                    , sessionTimerHeap = hp1+                    , sessionKeyValueMap = mp2+                    , sessionOutputStream = out1+                    }+        res0 <- do+            case mOld of+                Nothing -> initial+                Just (Tuple' _ acc) -> return $ FL.Partial acc+        case res0 of+            FL.Done fb -> done fb+            FL.Partial fs -> do+                res <- step fs value+                case res of+                    FL.Done fb -> done fb+                    FL.Partial fs1 -> partial fs1++    -- Got a timer tick event+    sstep sessionState@SessionState{..} Nothing =+        let curTime = addToAbsTime sessionCurTime tickMs+        in ejectExpired sessionState curTime++    flush session@SessionState{..} = do+        (hp', mp', out, count) <-+            ejectAll+                ( sessionTimerHeap+                , sessionKeyValueMap+                , K.nil+                , sessionCount+                )+        return $ session+            { sessionCount = count+            , sessionTimerHeap = hp'+            , sessionKeyValueMap = mp'+            , sessionOutputStream = out+            }++    -- delete from map and output the fold accumulator+    ejectEntry hp mp out cnt acc key = do+        sess <- extract acc+        let out1 = (key, sess) `K.cons` out+        let mp1 = Map.delete key mp+        return (hp, mp1, out1, cnt - 1)++    ejectAll (hp, mp, out, !cnt) = do+        let hres = H.uncons hp+        case hres of+            Just (Entry _ key, hp1) -> do+                r <- case Map.lookup key mp of+                    Nothing -> return (hp1, mp, out, cnt)+                    Just (Tuple' _ acc) -> ejectEntry hp1 mp out cnt acc key+                ejectAll r+            Nothing -> do+                assert (Map.null mp) (return ())+                return (hp, mp, out, cnt)++    ejectOne (hp, mp, out, !cnt) = do+        let hres = H.uncons hp+        case hres of+            Just (Entry expiry key, hp1) ->+                case Map.lookup key mp of+                    Nothing -> ejectOne (hp1, mp, out, cnt)+                    Just (Tuple' latestTS acc) -> do+                        let expiry1 = addToAbsTime latestTS timeoutMs+                        if not reset || expiry1 <= expiry+                        then ejectEntry hp1 mp out cnt acc key+                        else+                            -- reset the session timeout and continue+                            let hp2 = H.insert (Entry expiry1 key) hp1+                            in ejectOne (hp2, mp, out, cnt)+            Nothing -> do+                assert (Map.null mp) (return ())+                return (hp, mp, out, cnt)++    ejectExpired session@SessionState{..} curTime = do+        (hp', mp', out, count) <-+            ejectLoop sessionTimerHeap sessionKeyValueMap K.nil sessionCount+        return $ session+            { sessionCurTime = curTime+            , sessionCount = count+            , sessionTimerHeap = hp'+            , sessionKeyValueMap = mp'+            , sessionOutputStream = out+            }++        where++        ejectLoop hp mp out !cnt = do+            let hres = H.uncons hp+            case hres of+                Just (Entry expiry key, hp1) -> do+                    (eject, force) <-+                        if curTime >= expiry+                        then return (True, False)+                        else do+                            r <- ejectPred cnt+                            return (r, r)+                    if eject+                    then+                        case Map.lookup key mp of+                            Nothing -> ejectLoop hp1 mp out cnt+                            Just (Tuple' latestTS acc) -> do+                                let expiry1 = addToAbsTime latestTS timeoutMs+                                if expiry1 <= curTime || not reset || force+                                then do+                                    (hp2,mp1,out1,cnt1) <-+                                        ejectEntry hp1 mp out cnt acc key+                                    ejectLoop hp2 mp1 out1 cnt1+                                else+                                    -- reset the session timeout and continue+                                    let hp2 = H.insert (Entry expiry1 key) hp1+                                    in ejectLoop hp2 mp out cnt+                    else return (hp, mp, out, cnt)+                Nothing -> do+                    assert (Map.null mp) (return ())+                    return (hp, mp, out, cnt)++    -- merge timer events in the stream+    stream = Serial.map Just str `Par.parallelFst` repeatM timer+    timer = do+        liftIO $ threadDelay (round $ tick * 1000000)+        return Nothing++-- | Same as 'classifySessionsBy' with a timer tick of 1 second and keepalive+-- option set to 'True'.+--+-- @+-- classifyKeepAliveSessions = classifySessionsBy 1 True+-- @+--+-- /Pre-release/+--+{-# INLINABLE classifyKeepAliveSessions #-}+classifyKeepAliveSessions ::+       (IsStream t, MonadAsync m, Ord k)+    => (Int -> m Bool) -- ^ predicate to eject sessions on session count+    -> Double -- ^ session inactive timeout+    -> Fold m a b -- ^ Fold to be applied to session payload data+    -> t m (AbsTime, (k, a)) -- ^ timestamp, (session key, session data)+    -> t m (k, b)+classifyKeepAliveSessions = classifySessionsBy 1 True++------------------------------------------------------------------------------+-- Keyed tumbling windows+------------------------------------------------------------------------------++-- Tumbling windows is a special case of sliding windows where the window slide+-- is the same as the window size. Or it can be a special case of session+-- windows where the reset flag is set to False.++-- XXX instead of using the early termination flag in the stream, we can use an+-- early terminating fold instead.++{-+-- | Split the stream into fixed size chunks of specified size. Within each+-- such chunk fold the elements in buckets identified by the keys. A particular+-- bucket fold can be terminated early if a closing flag is encountered in an+-- element for that key.+--+-- @since 0.7.0+{-# INLINABLE classifyChunksOf #-}+classifyChunksOf+    :: (IsStream t, MonadAsync m, Ord k)+    => Int              -- ^ window size+    -> Fold m a b       -- ^ Fold to be applied to window events+    -> t m (k, a, Bool) -- ^ window key, data, close event+    -> t m (k, b)+classifyChunksOf wsize = classifyChunksBy wsize False+-}++-- | Same as 'classifySessionsBy' with a timer tick of 1 second and keepalive+-- option set to 'False'.+--+-- @+-- classifySessionsOf = classifySessionsBy 1 False+-- @+--+-- /Pre-release/+--+{-# INLINABLE classifySessionsOf #-}+classifySessionsOf ::+       (IsStream t, MonadAsync m, Ord k)+    => (Int -> m Bool) -- ^ predicate to eject sessions on session count+    -> Double -- ^ time window size+    -> Fold m a b -- ^ Fold to be applied to session data+    -> t m (AbsTime, (k, a)) -- ^ timestamp, (session key, session data)+    -> t m (k, b)+classifySessionsOf = classifySessionsBy 1 False++------------------------------------------------------------------------------+-- Nested Split+------------------------------------------------------------------------------++-- | @splitInnerBy splitter joiner stream@ splits the inner containers @f a@ of+-- an input stream @t m (f a)@ using the @splitter@ function. Container+-- elements @f a@ are collected until a split occurs, then all the elements+-- before the split are joined using the @joiner@ function.+--+-- For example, if we have a stream of @Array Word8@, we may want to split the+-- stream into arrays representing lines separated by '\n' byte such that the+-- resulting stream after a split would be one array for each line.+--+-- CAUTION! This is not a true streaming function as the container size after+-- the split and merge may not be bounded.+--+-- /Pre-release/+{-# INLINE splitInnerBy #-}+splitInnerBy+    :: (IsStream t, Monad m)+    => (f a -> m (f a, Maybe (f a)))  -- splitter+    -> (f a -> f a -> m (f a))        -- joiner+    -> t m (f a)+    -> t m (f a)+splitInnerBy splitter joiner xs =+    D.fromStreamD $ D.splitInnerBy splitter joiner $ D.toStreamD xs++-- | Like 'splitInnerBy' but splits assuming the separator joins the segment in+-- a suffix style.+--+-- /Pre-release/+{-# INLINE splitInnerBySuffix #-}+splitInnerBySuffix+    :: (IsStream t, 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+    -> t m (f a)+    -> t m (f a)+splitInnerBySuffix splitter joiner xs =+    D.fromStreamD $ D.splitInnerBySuffix splitter joiner $ D.toStreamD xs
+ src/Streamly/Internal/Data/Stream/IsStream/Top.hs view
@@ -0,0 +1,608 @@+-- |+-- Module      : Streamly.Internal.Data.Stream.IsStream.Top+-- Copyright   : (c) 2020 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- Top level IsStream module that can use all other lower level IsStream+-- modules.++module Streamly.Internal.Data.Stream.IsStream.Top+    (+    -- * Transformation+    -- ** Sampling+    -- | Value agnostic filtering.+      sampleFromThen+    , sampleIntervalStart+    , sampleIntervalEnd+    , sampleBurstStart+    , sampleBurstEnd++    -- ** Reordering+    , sortBy++    -- * Nesting+    -- ** Set like operations+    -- | These are not exactly set operations because streams are not+    -- necessarily sets, they may have duplicated elements.+    , intersectBy+    , mergeIntersectBy+    , differenceBy+    , mergeDifferenceBy+    , unionBy+    , mergeUnionBy++    -- ** Join operations+    , crossJoin+    , innerJoin+    , mergeInnerJoin+    , hashInnerJoin+    , leftJoin+    , mergeLeftJoin+    , hashLeftJoin+    , outerJoin+    , mergeOuterJoin+    , hashOuterJoin+    )+where++#include "inline.hs"++import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.State.Strict (get, put)+-- import Data.Hashable (Hashable)+import Data.IORef (newIORef, readIORef, modifyIORef')+import Data.Kind (Type)+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup (Semigroup(..))+#endif+import Streamly.Internal.Data.SVar (MonadAsync)+import Streamly.Internal.Data.Stream.IsStream.Common (concatM)+import Streamly.Internal.Data.Stream.Prelude (foldl', fromList)+import Streamly.Internal.Data.Stream.Serial (SerialT)+import Streamly.Internal.Data.Stream.StreamK (IsStream)+import Streamly.Internal.Data.Time.Units (NanoSecond64(..), toRelTime64)++import qualified Data.List as List+import qualified Streamly.Internal.Data.Array as Array+import qualified Streamly.Internal.Data.Fold as Fold+import qualified Streamly.Internal.Data.Stream.IsStream.Lift as Stream+import qualified Streamly.Internal.Data.Stream.IsStream.Eliminate as Stream+import qualified Streamly.Internal.Data.Stream.IsStream.Generate as Stream+import qualified Streamly.Internal.Data.Stream.IsStream.Expand as Stream+import qualified Streamly.Internal.Data.Stream.IsStream.Reduce as Stream+import qualified Streamly.Internal.Data.Stream.IsStream.Transform as Stream+import qualified Streamly.Internal.Data.Stream.StreamK as StreamK++import Prelude hiding (filter, zipWith, concatMap, concat)++-- $setup+-- >>> :m+-- >>> import Prelude hiding (filter, zipWith, concatMap, concat)+-- >>> import qualified Streamly.Prelude as Stream+-- >>> import qualified Streamly.Internal.Data.Stream.IsStream as Stream++------------------------------------------------------------------------------+-- Sampling+------------------------------------------------------------------------------++-- XXX We can implement this using addition instead of "mod" to make it more+-- efficient.+--+-- | @sampleFromthen offset stride@ samples the element at @offset@ index and+-- then every element at strides of @stride@.+--+-- >>> Stream.toList $ Stream.sampleFromThen 2 3 $ Stream.enumerateFromTo 0 10+-- [2,5,8]+--+-- /Pre-release/+--+{-# INLINE sampleFromThen #-}+sampleFromThen :: (IsStream t, Monad m, Functor (t m)) =>+    Int -> Int -> t m a -> t m a+sampleFromThen offset stride =+    Stream.with Stream.indexed Stream.filter+        (\(i, _) -> i >= offset && (i - offset) `mod` stride == 0)++-- | Continuously evaluate the input stream and sample the last event in time+-- window of @n@ seconds.+--+-- This is also known as @throttle@ in some libraries.+--+-- @+-- sampleIntervalEnd n = Stream.catMaybes . Stream.intervalsOf n Fold.last+-- @+--+-- /Pre-release/+--+{-# INLINE sampleIntervalEnd #-}+sampleIntervalEnd :: (IsStream t, MonadAsync m, Functor (t m)) =>+    Double -> t m a -> t m a+sampleIntervalEnd n = Stream.catMaybes . Stream.intervalsOf n Fold.last++-- | Like 'sampleInterval' but samples at the beginning of the time window.+--+-- @+-- sampleIntervalStart n = Stream.catMaybes . Stream.intervalsOf n Fold.head+-- @+--+-- /Pre-release/+--+{-# INLINE sampleIntervalStart #-}+sampleIntervalStart :: (IsStream t, MonadAsync m, Functor (t m)) =>+    Double -> t m a -> t m a+sampleIntervalStart n = Stream.catMaybes . Stream.intervalsOf n Fold.head++-- | Sample one event at the end of each burst of events.  A burst is a group+-- of events close together in time, it ends when an event is spaced by more+-- than the specified time interval from the previous event.+--+-- This is known as @debounce@ in some libraries.+--+-- The clock granularity is 10 ms.+--+-- /Pre-release/+--+{-# INLINE sampleBurstEnd #-}+sampleBurstEnd :: (IsStream t, MonadAsync m, Functor (t m)) =>+    Double -> t m a -> t m a+sampleBurstEnd gap =+    let f (t1, _) (t2, _) =+            t2 - t1 >= toRelTime64 (NanoSecond64 (round (gap * 10^(9::Int))))+    in Stream.map snd+        . Stream.catMaybes+        . Stream.groupsByRolling f Fold.last+        . Stream.timeIndexed++-- | Like 'sampleBurstEnd' but samples the event at the beginning of the burst+-- instead of at the end of it.+--+-- /Pre-release/+--+{-# INLINE sampleBurstStart #-}+sampleBurstStart :: (IsStream t, MonadAsync m, Functor (t m)) =>+    Double -> t m a -> t m a+sampleBurstStart gap =+    let f (t1, _) (t2, _) =+            t2 - t1 >= toRelTime64 (NanoSecond64 (round (gap * 10^(9::Int))))+    in Stream.map snd+        . Stream.catMaybes+        . Stream.groupsByRolling f Fold.head+        . Stream.timeIndexed++------------------------------------------------------------------------------+-- Reordering+------------------------------------------------------------------------------+--+-- We could possibly choose different algorithms depending on whether the+-- input stream is almost sorted (ascending/descending) or random. We could+-- serialize the stream to an array and use quicksort.+--+-- | Sort the input stream using a supplied comparison function.+--+-- /O(n) space/+--+-- Note: this is not the fastest possible implementation as of now.+--+-- /Pre-release/+--+{-# INLINE sortBy #-}+sortBy :: (IsStream t, Monad m) => (a -> a -> Ordering) -> t m a -> t m a+-- XXX creating StreamD and using D.mergeBy may be more efficient due to fusion+sortBy f = Stream.concatPairsWith (Stream.mergeBy f) Stream.fromPure++------------------------------------------------------------------------------+-- 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 maintianing+-- an offset in the handle).++-- XXX We can do this concurrently.+--+-- | This is the same as 'Streamly.Internal.Data.Unfold.outerProduct' but less+-- efficient.+--+-- The second stream is evaluated multiple times. If the second stream is+-- consume-once stream then it can be cached in an 'Data.Array.Array' before+-- calling this function. Caching may also improve performance if the stream is+-- expensive to evaluate.+--+-- Time: O(m x n)+--+-- /Pre-release/+{-# INLINE crossJoin #-}+crossJoin :: Monad (t m) => t m a -> t m b -> t m (a, b)+crossJoin s1 s2 = do+    -- XXX use concatMap instead?+    a <- s1+    b <- s2+    return (a, b)++-- 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).+--+-- | For all elements in @t m a@, for all elements in @t m b@ if @a@ and @b@+-- are equal by the given equality pedicate then return the tuple (a, b).+--+-- 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.+--+-- For space efficiency use the smaller stream as the second stream.+--+-- Space: O(n) assuming the second stream is cached in memory.+--+-- Time: O(m x n)+--+-- /Pre-release/+{-# INLINE innerJoin #-}+innerJoin ::+    forall (t :: (Type -> Type) -> Type -> Type) m a b.+    (IsStream t, Monad (t m)) =>+        (a -> b -> Bool) -> t m a -> t m b -> t m (a, b)+innerJoin eq s1 s2 = do+    -- XXX use concatMap instead?+    a <- s1+    b <- s2+    if a `eq` b+    then return (a, b)+    else StreamK.nil++-- If the second stream is too big it can be partitioned based on hashes and+-- then we can process one parition at a time.+--+-- | Like 'innerJoin' but uses a hashmap for efficiency.+--+-- For space efficiency use the smaller stream as the second stream.+--+-- Space: O(n)+--+-- Time: O(m + n)+--+-- /Unimplemented/+{-# INLINE hashInnerJoin #-}+hashInnerJoin :: -- Hashable b =>+    (a -> b -> Bool) -> t m a -> t m b -> t m (a, b)+hashInnerJoin = undefined++-- | Like 'innerJoin' but works only on sorted streams.+--+-- Space: O(1)+--+-- Time: O(m + n)+--+-- /Unimplemented/+{-# INLINE mergeInnerJoin #-}+mergeInnerJoin :: (a -> b -> Ordering) -> t m a -> t m b -> t m (a, b)+mergeInnerJoin = undefined++-- 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).+--+-- | For all elements in @t m a@, for all elements in @t m b@ if @a@ and @b@+-- are equal then return the tuple @(a, Just b)@.  If @a@ is not present in @t+-- m b@ then return @(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.+--+-- @+-- rightJoin = flip leftJoin+-- @+--+-- Space: O(n) assuming the second stream is cached in memory.+--+-- Time: O(m x n)+--+-- /Unimplemented/+{-# INLINE leftJoin #-}+leftJoin :: Monad m =>+    (a -> b -> Bool) -> SerialT m a -> SerialT m b -> SerialT m (a, Maybe b)+leftJoin eq s1 s2 = Stream.evalStateT (return False) $ do+    a <- 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?+    lift $ put False+    let final = do+            r <- lift get+            if r+            then StreamK.nil+            else StreamK.fromPure Nothing+    b <- fmap Just (Stream.liftInner s2) <> final+    case b of+        Just b1 ->+            if a `eq` b1+            then do+                lift $ put True+                return (a, Just b1)+            else StreamK.nil+        Nothing -> return (a, Nothing)++-- | Like 'outerJoin' but uses a hashmap for efficiency.+--+-- Space: O(n)+--+-- Time: O(m + n)+--+-- /Unimplemented/+{-# INLINE hashLeftJoin #-}+hashLeftJoin :: -- Hashable b =>+    (a -> b -> Bool) -> t m a -> t m b -> t m (a, Maybe b)+hashLeftJoin = undefined++-- | Like 'leftJoin' but works only on sorted streams.+--+-- Space: O(1)+--+-- Time: O(m + n)+--+-- /Unimplemented/+{-# INLINE mergeLeftJoin #-}+mergeLeftJoin :: -- Monad m =>+    (a -> b -> Ordering) -> t m a -> t m b -> t m (a, Maybe b)+mergeLeftJoin _eq _s1 _s2 = undefined++-- XXX We can do this concurrently.+--+-- | For all elements in @t m a@, for all elements in @t m b@ if @a@ and @b@+-- are equal by the given equality pedicate then return the tuple (Just a, Just+-- b).  If @a@ is not found in @t m b@ then return (a, Nothing), return+-- (Nothing, b) for vice-versa.+--+-- For space efficiency use the smaller stream as the second stream.+--+-- Space: O(n)+--+-- Time: O(m x n)+--+-- /Unimplemented/+{-# INLINE outerJoin #-}+outerJoin :: MonadIO m =>+       (a -> b -> Bool)+    -> SerialT m a+    -> SerialT m b+    -> SerialT m (Maybe a, Maybe b)+outerJoin eq s1 s =+    Stream.concatM $ do+        arr <- Array.fromStream $ fmap (,False) s+        return $ go arr <> leftOver arr++    where++    leftOver =+            fmap (\(x, _) -> (Nothing, Just x))+                . Stream.filter (not . snd)+                . Array.toStream++    go arr = Stream.evalStateT (return False) $ do+        a <- 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?+        lift $ put False+        let final = do+                r <- lift get+                if r+                then StreamK.nil+                else StreamK.fromPure Nothing+        (_i, b) <-+            Stream.indexed+                $ fmap Just (Stream.liftInner (Array.toStream arr)) <> final+        case b of+            Just (b1, _used) ->+                if a `eq` b1+                then do+                    lift $ put True+                    -- XXX Need to use a mutable array+                    -- when (not used) $ Array.writeIndex i True+                    return (Just a, Just b1)+                else StreamK.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 @t m b@ and find those that are not in that+-- hash to return (Nothing, b).+--+-- | Like 'outerJoin' but uses a hashmap for efficiency.+--+-- For space efficiency use the smaller stream as the second stream.+--+-- Space: O(n)+--+-- Time: O(m + n)+--+-- /Unimplemented/+{-# INLINE hashOuterJoin #-}+hashOuterJoin :: -- (Monad m, Hashable b) =>+    (a -> b -> Ordering) -> t m a -> t m b -> t m (Maybe a, Maybe b)+hashOuterJoin _eq _s1 _s2 = undefined++-- | Like 'outerJoin' but works only on sorted streams.+--+-- Space: O(1)+--+-- Time: O(m + n)+--+-- /Unimplemented/+{-# INLINE mergeOuterJoin #-}+mergeOuterJoin :: -- Monad m =>+    (a -> b -> Ordering) -> t m a -> t m b -> t m (Maybe a, Maybe b)+mergeOuterJoin _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.++-- | 'intersectBy' is essentially a filtering operation that retains only those+-- elements in the first stream that are present in the second stream.+--+-- >>> Stream.toList $ Stream.intersectBy (==) (Stream.fromList [1,2,2,4]) (Stream.fromList [2,1,1,3])+-- [1,2,2]+--+-- >>> Stream.toList $ Stream.intersectBy (==) (Stream.fromList [2,1,1,3]) (Stream.fromList [1,2,2,4])+-- [2,1,1]+--+-- 'intersectBy' is similar to but not the same as 'innerJoin':+--+-- >>> Stream.toList $ fmap fst $ Stream.innerJoin (==) (Stream.fromList [1,2,2,4]) (Stream.fromList [2,1,1,3])+-- [1,1,2,2]+--+-- Space: O(n) where @n@ is the number of elements in the second stream.+--+-- Time: O(m x n) where @m@ is the number of elements in the first stream and+-- @n@ is the number of elements in the second stream.+--+-- /Pre-release/+{-# INLINE intersectBy #-}+intersectBy :: (IsStream t, Monad m) =>+    (a -> a -> Bool) -> t m a -> t m a -> t m a+intersectBy eq s1 s2 =+    concatM+        $ do+            -- This may work well when s2 is small+            xs <- Stream.toListRev $ Stream.uniqBy eq $ StreamK.adapt s2+            return $ Stream.filter (\x -> List.any (eq x) xs) s1++-- | Like 'intersectBy' but works only on sorted streams.+--+-- Space: O(1)+--+-- Time: O(m+n)+--+-- /Unimplemented/+{-# INLINE mergeIntersectBy #-}+mergeIntersectBy :: -- (IsStream t, Monad m) =>+    (a -> a -> Ordering) -> t m a -> t m a -> t m a+mergeIntersectBy _eq _s1 _s2 = undefined++-- Roughly leftJoin s1 s2 = s1 `difference` s2 + s1 `intersection` s2++-- | Delete first occurrences of those elements from the first stream that are+-- present in the second stream. If an element occurs multiple times in the+-- second stream as many occurrences of it are deleted from the first stream.+--+-- >>> Stream.toList $ Stream.differenceBy (==) (Stream.fromList [1,2,2]) (Stream.fromList [1,2,3])+-- [2]+--+-- The following laws hold:+--+-- @+-- (s1 `serial` s2) `differenceBy eq` s1 === s2+-- (s1 `wSerial` s2) `differenceBy eq` s1 === s2+-- @+--+-- Same as the list 'Data.List.//' operation.+--+-- 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 differenceBy #-}+differenceBy :: (IsStream t, Monad m) =>+    (a -> a -> Bool) -> t m a -> t m a -> t m a+differenceBy eq s1 s2 =+    concatM+        $ 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.toList $ StreamK.adapt s1+            fmap fromList $ foldl' (flip (List.deleteBy eq)) xs s2++-- | Like 'differenceBy' but works only on sorted streams.+--+-- Space: O(1)+--+-- /Unimplemented/+{-# INLINE mergeDifferenceBy #-}+mergeDifferenceBy :: -- (IsStream t, Monad m) =>+    (a -> a -> Ordering) -> t m a -> t m a -> t m a+mergeDifferenceBy _eq _s1 _s2 = undefined++-- | This is essentially an append operation that appends all the extra+-- occurrences of elements from the second stream that are not already present+-- in the first stream.+--+-- >>> Stream.toList $ Stream.unionBy (==) (Stream.fromList [1,2,2,4]) (Stream.fromList [1,1,2,3])+-- [1,2,2,4,3]+--+-- Equivalent to the following except that @s1@ is evaluated only once:+--+-- @+-- unionBy eq s1 s2 = s1 \`serial` (s2 `differenceBy eq` s1)+-- @+--+-- Similar to 'outerJoin' but not the same.+--+-- Space: O(n)+--+-- Time: O(m x n)+--+-- /Pre-release/+{-# INLINE unionBy #-}+unionBy :: (IsStream t, MonadAsync m, Semigroup (t m a)) =>+    (a -> a -> Bool) -> t m a -> t m a -> t m a+unionBy eq s1 s2 =+    concatM+        $ do+            xs <- Stream.toList $ StreamK.adapt s2+            -- 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 = concatM+                        $ do+                            xs1 <- liftIO $ readIORef ref+                            return $ fromList xs1+            return $ Stream.mapM f s1 <> s3++-- | Like 'unionBy' but works only on sorted streams.+--+-- Space: O(1)+--+-- /Unimplemented/+{-# INLINE mergeUnionBy #-}+mergeUnionBy :: -- (IsStream t, Monad m) =>+    (a -> a -> Ordering) -> t m a -> t m a -> t m a+mergeUnionBy _eq _s1 _s2 = undefined
+ src/Streamly/Internal/Data/Stream/IsStream/Transform.hs view
@@ -0,0 +1,1571 @@+-- |+-- Module      : Streamly.Internal.Data.Stream.IsStream.Transform+-- Copyright   : (c) 2017 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Internal.Data.Stream.IsStream.Transform+    (+    -- * Piping+    -- | Pass through a 'Pipe'.+      transform++    -- * Folding+    , foldrS+    , foldrT++    -- * Mapping+    -- | Stateless one-to-one maps.+    , Serial.map+    , sequence+    , mapM+    , smapM++    -- * Mapping Side Effects (Observation)+    -- | See also the intersperse*_ combinators.+    , trace+    , trace_+    , tap+    , tapOffsetEvery+    , tapAsync+    , tapRate+    , pollCounts++    -- * Scanning By 'Fold'+    , scan+    , postscan++    -- * Scanning+    -- | Left scans. Stateful, mostly one-to-one maps.+    , scanl'+    , scanlM'+    , scanlMAfter'+    , postscanl'+    , postscanlM'+    , prescanl'+    , prescanlM'+    , scanl1'+    , scanl1M'++    -- XXX Once we have pipes the contravariant transformations can be+    -- represented by attaching pipes before a transformation.+    --+    -- , lscanl'+    -- , lscanlM'+    -- , lscanl1'+    -- , lscanl1M'+    --+    -- , lpostscanl'+    -- , lpostscanlM'+    -- , lprescanl'+    -- , lprescanlM'++    -- * 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.++    , with+    , deleteBy+    , filter+    , filterM+    , uniq+    , uniqBy+    , nubBy+    , nubWindowBy+    , prune+    , repeated++    -- * Trimming+    -- | Produce a subset of the stream trimmed at ends.++    , take+    , takeInterval+    , takeLast+    , takeLastInterval+    , takeWhile+    , takeWhileM+    , takeWhileLast+    , takeWhileAround+    , drop+    , dropInterval+    , dropLast+    , dropLastInterval+    , dropWhile+    , dropWhileM+    , dropWhileLast+    , dropWhileAround++    -- * 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+    , intersperseBySpan++    , intersperseSuffix+    , intersperseSuffixBySpan+    , interjectSuffix++    -- , interspersePrefix+    -- , interspersePrefixBySpan++    -- * Inserting Side Effects/Time+    , intersperseM_ -- XXX naming+    , delay+    , intersperseSuffix_+    , delayPost+    , interspersePrefix_+    , delayPre++    -- * Element Aware Insertion+    -- | Opposite of filtering+    , insertBy+    -- , intersperseByBefore+    -- , intersperseByAfter++    -- * Reordering+    , reverse+    , reverse'+    , reassembleBy++    -- * Position Indexing+    , indexed+    , indexedR++    -- * Time Indexing+    , timestamped+    , timestampWith+    -- , timestampedR -- timer+    , timeIndexed+    , timeIndexWith++    -- * Searching+    , findIndices -- XXX indicesBy+    , elemIndices -- XXX indicesOf++    -- * Rolling map+    -- | Map using the previous element.+    , rollingMapM+    , rollingMap++    -- * Maybe Streams+    -- Move these to Streamly.Data.Maybe.Stream?+    , catMaybes -- XXX justs (like lefts/rights)+    , mapMaybe+    , mapMaybeM++    -- * Either Streams+    -- Move these to Streamly.Data.Either.Stream?+    , lefts+    , rights++    -- * Concurrent Evaluation+    -- ** Concurrent Pipelines+    -- | Run streaming stages concurrently.++    , Par.mkParallel+    , applyAsync+    , (|$)+    , (|&)++    -- ** Concurrency Control+    , maxThreads++    -- ** Buffering and Sampling+    -- | Evaluate strictly using a buffer of results.  When the buffer becomes+    -- full we can block, drop the new elements, drop the oldest element and+    -- insert the new at the end or keep dropping elements uniformly to match+    -- the rate of the consumer.+    , maxBuffer+    , sampleOld+    , sampleNew+    , sampleRate++    -- ** Rate Limiting+    -- | Evaluate the stream at uniform intervals to maintain a specified+    -- evaluation rate.+    , Rate (..)+    , rate+    , avgRate+    , minRate+    , maxRate+    , constRate++    -- * Diagnostics+    , inspectMode++    -- * Deprecated+    , scanx+    )+where++#include "inline.hs"++import Control.Concurrent (threadDelay)+import Control.Monad (void)+import Control.Monad.Catch (MonadCatch)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.Class (MonadTrans(..))+import Data.Either (isLeft, isRight)+import Data.Kind (Type)+import Data.Maybe (isJust, fromJust)+import Streamly.Internal.BaseCompat (fromLeft, fromRight)+import Streamly.Internal.Data.Fold.Type (Fold (..))+import Streamly.Internal.Data.Pipe.Type (Pipe (..))+import Streamly.Internal.Data.Stream.IsStream.Combinators+      ( inspectMode, maxBuffer, maxThreads, rate, avgRate, minRate+      , maxRate, constRate)+import Streamly.Internal.Data.Stream.IsStream.Common+    ( absTimesWith+    , drop+    , findIndices+    , postscanlM'+    , relTimesWith+    , reverse+    , reverse'+    , scanlMAfter'+    , smapM+    , take+    , takeWhile+    , interjectSuffix+    , intersperseM+    )+import Streamly.Internal.Data.Stream.Prelude (fromStreamS, toStreamS)+import Streamly.Internal.Data.Stream.Serial (SerialT)+import Streamly.Internal.Data.Stream.StreamD (fromStreamD, toStreamD)+import Streamly.Internal.Data.Stream.StreamK (IsStream)+import Streamly.Internal.Data.SVar (MonadAsync, Rate(..))+import Streamly.Internal.Data.Time.Units (TimeUnit64, AbsTime, RelTime64)++import qualified Streamly.Internal.Data.Fold as FL+import qualified Streamly.Internal.Data.Stream.Parallel as Par+import qualified Streamly.Internal.Data.Stream.Prelude as P+import qualified Streamly.Internal.Data.Stream.Serial as Serial+import qualified Streamly.Internal.Data.Stream.StreamD as D+import qualified Streamly.Internal.Data.Stream.StreamK as K+import qualified Streamly.Internal.Data.Stream.Zip as Z+#ifdef USE_STREAMK_ONLY+import qualified Streamly.Internal.Data.Stream.StreamK as S+#else+import qualified Streamly.Internal.Data.Stream.StreamD as S+#endif++import Prelude hiding+       ( filter, drop, dropWhile, take, takeWhile, foldr, map, mapM, sequence+       , reverse, foldr1 , scanl, scanl1)++--+-- $setup+-- >>> :m+-- >>> import Control.Concurrent (threadDelay)+-- >>> import Data.Function ((&))+-- >>> import Streamly.Prelude ((|$))+-- >>> import Prelude hiding ( filter, drop, dropWhile, take, takeWhile, foldr, map, mapM, sequence, reverse, foldr1 , scanl, scanl1)+-- >>> import qualified Streamly.Prelude as Stream+-- >>> import Streamly.Internal.Data.Stream.IsStream as Stream+-- >>> import qualified Streamly.Data.Fold as Fold+-- >>> import qualified Streamly.Internal.Data.Fold as Fold++------------------------------------------------------------------------------+-- Piping+------------------------------------------------------------------------------++-- | Use a 'Pipe' to transform a stream.+--+-- /Pre-release/+--+{-# INLINE transform #-}+transform :: (IsStream t, Monad m) => Pipe m a b -> t m a -> t 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.+--+-- >>> Stream.toList $ Stream.foldrS Stream.cons Stream.nil $ Stream.fromList [1..5]+-- [1,2,3,4,5]+--+-- Find if any element in the stream is 'True':+--+-- >>> Stream.toList $ Stream.foldrS (\x xs -> if odd x then return True else xs) (return False) $ (Stream.fromList (2:4:5:undefined) :: Stream.SerialT IO Int)+-- [True]+--+-- Map (+2) on odd elements and filter out the even elements:+--+-- >>> Stream.toList $ Stream.foldrS (\x xs -> if odd x then (x + 2) `Stream.cons` xs else xs) Stream.nil $ (Stream.fromList [1..5] :: Stream.SerialT IO Int)+-- [3,5,7]+--+-- 'foldrM' can also be represented in terms of 'foldrS', however, the former+-- is much more efficient:+--+-- > foldrM f z s = runIdentityT $ foldrS (\x xs -> lift $ f x (runIdentityT xs)) (lift z) s+--+-- /Pre-release/+{-# INLINE foldrS #-}+foldrS :: IsStream t => (a -> t m b -> t m b) -> t m b -> t m a -> t m b+foldrS = K.foldrS++-- | 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 = foldrT+-- > foldrM f z s = runIdentityT $ foldrT (\x xs -> lift $ f x (runIdentityT xs)) (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 :: (IsStream t, Monad m, Monad (s m), MonadTrans s)+    => (a -> s m b -> s m b) -> s m b -> t m a -> s m b+foldrT f z s = S.foldrT f z (toStreamS s)++------------------------------------------------------------------------------+-- Transformation by Mapping+------------------------------------------------------------------------------++-- |+-- @+-- mapM f = sequence . map f+-- @+--+-- Apply a monadic function to each element of the stream and replace it with+-- the output of the resulting action.+--+-- @+-- >>> drain $ Stream.mapM putStr $ Stream.fromList ["a", "b", "c"]+-- abc+--+-- >>> :{+--    drain $ Stream.replicateM 10 (return 1)+--      & (fromSerial . Stream.mapM (\x -> threadDelay 1000000 >> print x))+-- :}+-- 1+-- ...+-- 1+--+-- > drain $ Stream.replicateM 10 (return 1)+--  & (fromAsync . Stream.mapM (\x -> threadDelay 1000000 >> print x))+-- @+--+-- /Concurrent (do not use with 'fromParallel' on infinite streams)/+--+-- @since 0.1.0+{-# INLINE_EARLY mapM #-}+mapM :: (IsStream t, MonadAsync m) => (a -> m b) -> t m a -> t m b+mapM = K.mapM++{-# RULES "mapM serial" mapM = mapMSerial #-}+{-# INLINE mapMSerial #-}+mapMSerial :: Monad m => (a -> m b) -> SerialT m a -> SerialT m b+mapMSerial = Serial.mapM++-- |+-- @+-- sequence = mapM id+-- @+--+-- Replace the elements of a stream of monadic actions with the outputs of+-- those actions.+--+-- @+-- >>> drain $ Stream.sequence $ Stream.fromList [putStr "a", putStr "b", putStrLn "c"]+-- abc+--+-- >>> :{+-- drain $ Stream.replicateM 10 (return $ threadDelay 1000000 >> print 1)+--  & (fromSerial . Stream.sequence)+-- :}+-- 1+-- ...+-- 1+--+-- >>> :{+-- drain $ Stream.replicateM 10 (return $ threadDelay 1000000 >> print 1)+--  & (fromAsync . Stream.sequence)+-- :}+-- 1+-- ...+-- 1+--+-- @+--+-- /Concurrent (do not use with 'fromParallel' on infinite streams)/+--+-- @since 0.1.0+{-# INLINE sequence #-}+sequence :: (IsStream t, MonadAsync m) => t m (m a) -> t m a+sequence m = fromStreamS $ S.sequence (toStreamS m)++------------------------------------------------------------------------------+-- 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-----+--+-- @+--+-- >>> Stream.drain $ Stream.tap (Fold.drainBy print) (Stream.enumerateFromTo 1 2)+-- 1+-- 2+--+-- Compare with 'trace'.+--+-- @since 0.7.0+{-# INLINE tap #-}+tap :: (IsStream t, Monad m) => FL.Fold m a b -> t m a -> t m a+tap f xs = D.fromStreamD $ D.tap f (D.toStreamD xs)++-- XXX Remove this. It can be expressed in terms of Fold.sampleFromThen.+--+-- | @tapOffsetEvery offset n@ taps every @n@th element in the stream+-- starting at @offset@. @offset@ can be between @0@ and @n - 1@. Offset 0+-- means start at the first element in the stream. If the offset is outside+-- this range then @offset `mod` n@ is used as offset.+--+-- >>> Stream.drain $ Stream.tapOffsetEvery 0 2 (Fold.rmapM print Fold.toList) $ Stream.enumerateFromTo 0 10+-- [0,2,4,6,8,10]++--+-- /Pre-release/+--+{-# INLINE tapOffsetEvery #-}+tapOffsetEvery :: (IsStream t, Monad m)+    => Int -> Int -> FL.Fold m a b -> t m a -> t m a+tapOffsetEvery offset n f xs =+    D.fromStreamD $ D.tapOffsetEvery offset n f (D.toStreamD xs)++-- | Redirect a copy of the stream to a supplied fold and run it concurrently+-- in an independent thread. The fold may buffer some elements. The buffer size+-- is determined by the prevailing 'maxBuffer' setting.+--+-- @+--               Stream m a -> m b+--                       |+-- -----stream m a ---------------stream m a-----+--+-- @+--+-- @+-- >>> Stream.drain $ Stream.tapAsync (Fold.drainBy print) (Stream.enumerateFromTo 1 2)+-- 1+-- 2+--+-- @+--+-- Exceptions from the concurrently running fold are propagated to the current+-- computation.  Note that, because of buffering in the fold, exceptions may be+-- delayed and may not correspond to the current element being processed in the+-- parent stream, but we guarantee that before the parent stream stops the tap+-- finishes and all exceptions from it are drained.+--+--+-- Compare with 'tap'.+--+-- /Pre-release/+{-# INLINE tapAsync #-}+tapAsync :: (IsStream t, MonadAsync m) => FL.Fold m a b -> t m a -> t m a+tapAsync f xs = D.fromStreamD $ Par.tapAsyncF f (D.toStreamD xs)++-- | @pollCounts predicate transform fold stream@ counts those elements in the+-- stream that pass the @predicate@. The resulting count stream is sent to+-- another thread which transforms it using @transform@ and then folds it using+-- @fold@.  The thread is automatically cleaned up if the stream stops or+-- aborts due to exception.+--+-- For example, to print the count of elements processed every second:+--+-- @+-- > Stream.drain $ Stream.pollCounts (const True) (Stream.rollingMap (-) . Stream.delayPost 1) (FLold.drainBy print)+--           $ Stream.enumerateFrom 0+-- @+--+-- Note: This may not work correctly on 32-bit machines.+--+-- /Pre-release/+--+{-# INLINE pollCounts #-}+pollCounts ::+       (IsStream t, MonadAsync m)+    => (a -> Bool)+    -> (t m Int -> t m Int)+    -> Fold m Int b+    -> t m a+    -> t m a+pollCounts predicate transf f xs =+      D.fromStreamD+    $ D.pollCounts predicate (D.toStreamD . transf . D.fromStreamD) f+    $ D.toStreamD xs++-- | Calls the supplied function with the number of elements consumed+-- every @n@ seconds. The given function is run in a separate thread+-- until the end of the stream. In case there is an exception in the+-- stream the thread is killed during the next major GC.+--+-- Note: The action is not guaranteed to run if the main thread exits.+--+-- @+-- > delay n = threadDelay (round $ n * 1000000) >> return n+-- > Stream.toList $ Stream.tapRate 2 (\n -> print $ show n ++ " elements processed") (delay 1 Stream.|: delay 0.5 Stream.|: delay 0.5 Stream.|: Stream.nil)+-- "2 elements processed"+-- [1.0,0.5,0.5]+-- "1 elements processed"+-- @+--+-- Note: This may not work correctly on 32-bit machines.+--+-- /Pre-release/+{-# INLINE tapRate #-}+tapRate ::+       (IsStream t, MonadAsync m, MonadCatch m)+    => Double+    -> (Int -> m b)+    -> t m a+    -> t m a+tapRate n f xs = D.fromStreamD $ D.tapRate n f $ D.toStreamD xs++-- | Apply a monadic function to each element flowing through the stream and+-- discard the results.+--+-- @+-- >>> Stream.drain $ Stream.trace print (Stream.enumerateFromTo 1 2)+-- 1+-- 2+--+-- @+--+-- Compare with 'tap'.+--+-- @since 0.7.0+{-# INLINE trace #-}+trace :: (IsStream t, MonadAsync m) => (a -> m b) -> t m a -> t 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.+--+-- @+-- >>> Stream.drain $ Stream.trace_ (print "got here") (Stream.enumerateFromTo 1 2)+-- "got here"+-- "got here"+--+-- @+--+-- Same as 'interspersePrefix_' but always serial.+--+-- See also: 'trace'+--+-- /Pre-release/+{-# INLINE trace_ #-}+trace_ :: (IsStream t, Monad m) => m b -> t m a -> t m a+trace_ eff = Serial.mapM (\x -> eff >> return x)++------------------------------------------------------------------------------+-- Scanning with a Fold+------------------------------------------------------------------------------++-- | Scan a stream using the given monadic fold.+--+-- >>> Stream.toList $ Stream.takeWhile (< 10) $ Stream.scan Fold.sum (Stream.fromList [1..10])+-- [0,1,3,6]+--+-- @since 0.7.0+{-# INLINE scan #-}+scan :: (IsStream t, Monad m) => Fold m a b -> t m a -> t m b+scan = P.scanOnce++-- | 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)+-- >>> :{+--  Stream.toList+--   $ Stream.map (fromJust . fst)+--   $ Stream.takeWhile (\(_,x) -> x <= 10)+--   $ Stream.postscan (Fold.tee Fold.last avg) (Stream.enumerateFromTo 1.0 100.0)+-- :}+-- [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]+--+-- @since 0.7.0+{-# INLINE postscan #-}+postscan :: (IsStream t, Monad m) => Fold m a b -> t m a -> t m b+postscan = P.postscanOnce++------------------------------------------------------------------------------+-- Scanning - Transformation by Folding+------------------------------------------------------------------------------++-- 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. Or we can change the signature of scanx to+-- accommodate this.+--+-- | Strict left scan with an extraction function. Like 'scanl'', but applies a+-- user supplied extraction function (the third argument) at each step. This is+-- designed to work with the @foldl@ library. The suffix @x@ is a mnemonic for+-- extraction.+--+-- /Since 0.2.0/+--+-- /Since: 0.7.0 (Monad m constraint)/+{-# DEPRECATED scanx "Please use scanl followed by map instead." #-}+{-# INLINE scanx #-}+scanx :: (IsStream t, Monad m) => (x -> a -> x) -> x -> (x -> b) -> t m a -> t m b+scanx = P.scanlx'++-- XXX this needs to be concurrent+-- XXX because of the use of D.cons for appending, scanlM' has quadratic+-- complexity when iterated over a stream. We should use StreamK style scanlM'+-- for linear performance on iteration.+--+-- | Like 'scanl'' but with a monadic step function and a monadic seed.+--+-- /Since: 0.4.0/+--+-- /Since: 0.8.0 (signature change)/+{-# INLINE scanlM' #-}+scanlM' :: (IsStream t, Monad m) => (b -> a -> m b) -> m b -> t m a -> t m b+scanlM' step begin m = fromStreamD $ D.scanlM' step begin $ toStreamD m++-- XXX because of the use of D.cons for appending, scanl' has quadratic+-- complexity when iterated over a stream. We should use StreamK style scanlM'+-- for linear performance on iteration.++-- | Strict left scan. Like 'map', 'scanl'' too is a one to one transformation,+-- however it adds an extra element.+--+-- @+-- >>> Stream.toList $ Stream.scanl' (+) 0 $ 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.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.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.+--+-- See also: 'usingStateT'+--+-- @since 0.2.0+{-# INLINE scanl' #-}+scanl' :: (IsStream t, Monad m) => (b -> a -> b) -> b -> t m a -> t m b+scanl' step z m = fromStreamS $ S.scanl' step z $ toStreamS m++-- | Like 'scanl'' but does not stream the initial value of the accumulator.+--+-- > postscanl' f z xs = Stream.drop 1 $ Stream.scanl' f z xs+--+-- @since 0.7.0+{-# INLINE postscanl' #-}+postscanl' :: (IsStream t, Monad m) => (b -> a -> b) -> b -> t m a -> t m b+postscanl' step z m = fromStreamD $ D.postscanl' step z $ toStreamD m++-- XXX prescanl does not sound very useful, enable only if there is a+-- compelling use case.+--+-- | Like scanl' but does not stream the final value of the accumulator.+--+-- /Pre-release/+{-# INLINE prescanl' #-}+prescanl' :: (IsStream t, Monad m) => (b -> a -> b) -> b -> t m a -> t m b+prescanl' step z m = fromStreamD $ D.prescanl' step z $ toStreamD m++-- XXX this needs to be concurrent+-- | Like prescanl' but with a monadic step function and a monadic seed.+--+-- /Pre-release/+{-# INLINE prescanlM' #-}+prescanlM' :: (IsStream t, Monad m) => (b -> a -> m b) -> m b -> t m a -> t m b+prescanlM' step z m = fromStreamD $ D.prescanlM' step z $ toStreamD m++-- XXX this needs to be concurrent+-- | Like 'scanl1'' but with a monadic step function.+--+-- @since 0.6.0+{-# INLINE scanl1M' #-}+scanl1M' :: (IsStream t, Monad m) => (a -> a -> m a) -> t m a -> t m a+scanl1M' step m = fromStreamD $ D.scanl1M' step $ toStreamD m++-- | 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' (+) $ fromList [1,2,3,4]+-- [1,3,6,10]+--+-- @+--+-- @since 0.6.0+{-# INLINE scanl1' #-}+scanl1' :: (IsStream t, Monad m) => (a -> a -> a) -> t m a -> t m a+scanl1' step m = fromStreamD $ D.scanl1' step $ toStreamD m++------------------------------------------------------------------------------+-- Filtering+------------------------------------------------------------------------------++-- | Modify a @t m a -> t m a@ stream transformation that accepts a predicate+-- @(a -> b)@ to accept @((s, a) -> b)@ instead, provided a transformation @t m+-- a -> t m (s, a)@. Convenient to filter with index or time.+--+-- @+-- filterWithIndex = with indexed filter+-- filterWithAbsTime = with timestamped filter+-- filterWithRelTime = with timeIndexed filter+-- @+--+-- /Pre-release/+{-# INLINE with #-}+with :: forall (t :: (Type -> Type) -> Type -> Type) m a b s. Functor (t m) =>+       (t m a -> t m (s, a))+    -> (((s, a) -> b) -> t m (s, a) -> t m (s, a))+    -> (((s, a) -> b) -> t m a -> t m a)+with f comb g = fmap snd . comb g . f++-- | Include only those elements that pass a predicate.+--+-- @since 0.1.0+{-# INLINE filter #-}+#if __GLASGOW_HASKELL__ != 802+-- GHC 8.2.2 crashes with this code, when used with "stack"+filter :: (IsStream t, Monad m) => (a -> Bool) -> t m a -> t m a+filter p m = fromStreamS $ S.filter p $ toStreamS m+#else+filter :: IsStream t => (a -> Bool) -> t m a -> t m a+filter = K.filter+#endif++-- | Same as 'filter' but with a monadic predicate.+--+-- @since 0.4.0+{-# INLINE filterM #-}+filterM :: (IsStream t, Monad m) => (a -> m Bool) -> t m a -> t 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 = uniqBy (==)+--+-- To strip duplicate path separators:+--+-- @+-- f x y = x == '/' && x == y+-- Stream.toList $ Stream.uniqBy f $ Stream.fromList "//a//b"+-- "/a/b"+-- @+--+-- Space: @O(1)@+--+-- See also: 'nubBy'.+--+-- /Pre-release/+--+{-# INLINE uniqBy #-}+uniqBy :: (IsStream t, Monad m, Functor (t m)) =>+    (a -> a -> Bool) -> t m a -> t m a+uniqBy eq =+    catMaybes . rollingMap (\x y -> if x `eq` y then Nothing else Just y)++-- | Drop repeated elements that are adjacent to each other.+--+-- @since 0.6.0+{-# INLINE uniq #-}+uniq :: (Eq a, IsStream t, Monad m) => t m a -> t m a+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 = dropWhileAround p $ uniqBy (x y -> p x && p y)+-- @+--+-- @+-- > Stream.prune isSpace (Stream.fromList "  hello      world!   ")+-- "hello world!"+--+-- @+--+-- Space: @O(1)@+--+-- /Unimplemented/+{-# INLINE prune #-}+prune ::+    -- (IsStream t, Monad m, Eq a) =>+    (a -> Bool) -> t m a -> t 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 :: -- (IsStream t, Monad m, Eq a) =>+    t m a -> t m a+repeated = undefined++-- We can have more efficient implementations for nubOrd and nubInt by using+-- Set and IntSet to find/remove duplication. For Hashable we can use a+-- hashmap. Use rewrite rules to specialize to more efficient impls.+--+-- | Drop repeated elements anywhere in the stream.+--+-- /Caution: not scalable for infinite streams/+--+-- /See also: nubWindowBy/+--+-- /Unimplemented/+--+{-# INLINE nubBy #-}+nubBy :: -- (IsStream t, Monad m) =>+    (a -> a -> Bool) -> t m a -> t m a+nubBy = undefined -- fromStreamD . D.nubBy . toStreamD++-- | Drop repeated elements within the specified tumbling window in the stream.+--+-- @nubBy = nubWindowBy maxBound@+--+-- /Unimplemented/+--+{-# INLINE nubWindowBy #-}+nubWindowBy :: -- (IsStream t, Monad m) =>+    Int -> (a -> a -> Bool) -> t m a -> t m a+nubWindowBy = undefined -- fromStreamD . D.nubWithinBy . toStreamD++-- | Deletes the first occurrence of the element in the stream that satisfies+-- the given equality predicate.+--+-- @+-- >>> Stream.toList $ Stream.deleteBy (==) 3 $ Stream.fromList [1,3,3,5]+-- [1,3,5]+--+-- @+--+-- @since 0.6.0+{-# INLINE deleteBy #-}+deleteBy :: (IsStream t, Monad m) => (a -> a -> Bool) -> a -> t m a -> t m a+deleteBy cmp x m = fromStreamS $ S.deleteBy cmp x (toStreamS m)++------------------------------------------------------------------------------+-- Lossy Buffering+------------------------------------------------------------------------------++-- XXX We could use 'maxBuffer Block/Drop/Rotate/Sample' instead. However we+-- may want to have the evaluation rate independent of the sampling rate. To+-- support that we can decouple evaluation and sampling in independent stages.+-- The sampling stage would strictly evaluate and sample, the evaluation stage+-- would control the evaluation rate.++-- | Evaluate the input stream continuously and keep only the oldest @n@+-- elements in the buffer, discard the new ones when the buffer is full.  When+-- the output stream is evaluated it consumes the values from the buffer in a+-- FIFO manner.+--+-- /Unimplemented/+--+{-# INLINE sampleOld #-}+sampleOld :: -- (IsStream t, Monad m) =>+    Int -> t m a -> t m a+sampleOld = undefined++-- | Evaluate the input stream continuously and keep only the latest @n@+-- elements in a ring buffer, keep discarding the older ones to make space for+-- the new ones.  When the output stream is evaluated it consumes the values+-- from the buffer in a FIFO manner.+--+-- /Unimplemented/+--+{-# INLINE sampleNew #-}+sampleNew :: -- (IsStream t, Monad m) =>+    Int -> t m a -> t m a+sampleNew = undefined++-- | Like 'sampleNew' but samples at uniform intervals to match the consumer+-- rate. Note that 'sampleNew' leads to non-uniform sampling depending on the+-- consumer pattern.+--+-- /Unimplemented/+--+{-# INLINE sampleRate #-}+sampleRate :: -- (IsStream t, Monad m) =>+    Double -> t m a -> t m a+sampleRate = undefined++------------------------------------------------------------------------------+-- Trimming+------------------------------------------------------------------------------++-- | Same as 'takeWhile' but with a monadic predicate.+--+-- @since 0.4.0+{-# INLINE takeWhileM #-}+takeWhileM :: (IsStream t, Monad m) => (a -> m Bool) -> t m a -> t m a+takeWhileM p m = fromStreamD $ D.takeWhileM p $ toStreamD m++-- See the lastN fold for impl hints. Use a Data.Array based ring buffer.+--+-- takeLast n = Stream.concatM . fmap Array.toStream . fold Fold.lastN+--+-- | Take @n@ elements at the end of the stream.+--+-- O(n) space, where n is the number elements taken.+--+-- /Unimplemented/+{-# INLINE takeLast #-}+takeLast :: -- (IsStream t, Monad m) =>+    Int -> t m a -> t m a+takeLast = undefined -- fromStreamD $ D.takeLast n $ toStreamD m++-- | Take time interval @i@ seconds at the end of the stream.+--+-- O(n) space, where n is the number elements taken.+--+-- /Unimplemented/+{-# INLINE takeLastInterval #-}+takeLastInterval :: -- (IsStream t, Monad m) =>+    Double -> t m a -> t m a+takeLastInterval = undefined -- fromStreamD $ D.takeLast n $ 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 :: -- (IsStream t, Monad m) =>+    (a -> Bool) -> t m a -> t 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 :: -- (IsStream t, Monad m) =>+    (a -> Bool) -> t m a -> t m a+takeWhileAround = undefined -- fromStreamD $ D.takeWhileAround n $ toStreamD m++-- | @takeInterval duration@ yields stream elements upto specified time+-- @duration@. The duration starts when the stream is evaluated for the first+-- time, before the first element is yielded. The time duration is checked+-- before generating each element, if the duration has expired the stream+-- stops.+--+-- The total time taken in executing the stream is guaranteed to be /at least/+-- @duration@, however, because the duration is checked before generating an+-- element, the upper bound is indeterminate and depends on the time taken in+-- generating and processing the last element.+--+-- No element is yielded if the duration is zero. At least one element is+-- yielded if the duration is non-zero.+--+-- /Pre-release/+--+{-# INLINE takeInterval #-}+takeInterval ::(MonadIO m, IsStream t, TimeUnit64 d) => d -> t m a -> t m a+takeInterval d = fromStreamD . D.takeByTime d . toStreamD++-- | Drop elements in the stream as long as the predicate succeeds and then+-- take the rest of the stream.+--+-- @since 0.1.0+{-# INLINE dropWhile #-}+dropWhile :: (IsStream t, Monad m) => (a -> Bool) -> t m a -> t m a+dropWhile p m = fromStreamS $ S.dropWhile p $ toStreamS m++-- | Same as 'dropWhile' but with a monadic predicate.+--+-- @since 0.4.0+{-# INLINE dropWhileM #-}+dropWhileM :: (IsStream t, Monad m) => (a -> m Bool) -> t m a -> t m a+dropWhileM p m = fromStreamD $ D.dropWhileM p $ toStreamD m++-- | @dropInterval duration@ drops stream elements until specified @duration@ has+-- passed.  The duration begins when the stream is evaluated for the first+-- time. The time duration is checked /after/ generating a stream element, the+-- element is yielded if the duration has expired otherwise it is dropped.+--+-- The time elapsed before starting to generate the first element is /at most/+-- @duration@, however, because the duration expiry is checked after the+-- element is generated, the lower bound is indeterminate and depends on the+-- time taken in generating an element.+--+-- All elements are yielded if the duration is zero.+--+-- /Pre-release/+--+{-# INLINE dropInterval #-}+dropInterval ::(MonadIO m, IsStream t, TimeUnit64 d) => d -> t m a -> t m a+dropInterval d = fromStreamD . D.dropByTime d . toStreamD++-- | Drop @n@ elements at the end of the stream.+--+-- O(n) space, where n is the number elements dropped.+--+-- /Unimplemented/+{-# INLINE dropLast #-}+dropLast :: -- (IsStream t, Monad m) =>+    Int -> t m a -> t m a+dropLast = undefined -- fromStreamD $ D.dropLast n $ toStreamD m++-- | Drop time interval @i@ seconds at the end of the stream.+--+-- O(n) space, where n is the number elements dropped.+--+-- /Unimplemented/+{-# INLINE dropLastInterval #-}+dropLastInterval :: -- (IsStream t, Monad m) =>+    Int -> t m a -> t m a+dropLastInterval = undefined++-- | 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 :: -- (IsStream t, Monad m) =>+    (a -> Bool) -> t m a -> t 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 :: -- (IsStream t, Monad m) =>+    (a -> Bool) -> t m a -> t 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 = 'mergeBy' cmp ('fromPure' x)+-- @+--+-- @+-- >>> Stream.toList $ Stream.insertBy compare 2 $ Stream.fromList [1,3,5]+-- [1,2,3,5]+--+-- @+--+-- @since 0.6.0+{-# INLINE insertBy #-}+insertBy ::+       (IsStream t, Monad m) => (a -> a -> Ordering) -> a -> t m a -> t m a+insertBy cmp x m = fromStreamS $ S.insertBy cmp x (toStreamS m)++-- | Insert a pure value between successive elements of a stream.+--+-- >>> Stream.toList $ Stream.intersperse ',' $ Stream.fromList "hello"+-- "h,e,l,l,o"+--+-- @since 0.7.0+{-# INLINE intersperse #-}+intersperse :: (IsStream t, MonadAsync m) => a -> t m a -> t m a+intersperse a = fromStreamS . S.intersperse a . toStreamS++-- | Insert a side effect before consuming an element of a stream except the+-- first one.+--+-- >>> Stream.drain $ Stream.trace putChar $ Stream.intersperseM_ (putChar '.') $ Stream.fromList "hello"+-- h.e.l.l.o+--+-- /Pre-release/+{-# INLINE intersperseM_ #-}+intersperseM_ :: (IsStream t, Monad m) => m b -> t m a -> t m a+intersperseM_ m = fromStreamD . D.intersperseM_ m . toStreamD++-- | Intersperse a monadic action into the input stream after every @n@+-- elements.+--+-- @+-- > Stream.toList $ Stream.intersperseBySpan 2 (return ',') $ Stream.fromList "hello"+-- "he,ll,o"+--+-- @+--+-- /Unimplemented/+{-# INLINE intersperseBySpan #-}+intersperseBySpan :: -- IsStream t =>+    Int -> m a -> t m a -> t m a+intersperseBySpan _n _f _xs = undefined++-- | Insert an effect and its output after consuming an element of a stream.+--+-- >>> Stream.toList $ Stream.trace putChar $ intersperseSuffix (putChar '.' >> return ',') $ Stream.fromList "hello"+-- h.,e.,l.,l.,o.,"h,e,l,l,o,"+--+-- /Pre-release/+{-# INLINE intersperseSuffix #-}+intersperseSuffix :: (IsStream t, Monad m) => m a -> t m a -> t m a+intersperseSuffix m = fromStreamD . D.intersperseSuffix m . toStreamD++-- | Insert a side effect after consuming an element of a stream.+--+-- @+-- >>> Stream.mapM_ putChar $ Stream.intersperseSuffix_ (threadDelay 1000000) $ Stream.fromList "hello"+-- hello+--+-- @+--+-- /Pre-release/+--+{-# INLINE intersperseSuffix_ #-}+intersperseSuffix_ :: (IsStream t, Monad m) => m b -> t m a -> t m a+intersperseSuffix_ m = fromStreamD . D.intersperseSuffix_ m . toStreamD++-- XXX Use an offset argument, like tapOffsetEvery+--+-- | Like 'intersperseSuffix' but intersperses an effectful action into the+-- input stream after every @n@ elements and after the last element.+--+-- >>> Stream.toList $ Stream.intersperseSuffixBySpan 2 (return ',') $ Stream.fromList "hello"+-- "he,ll,o,"+--+-- /Pre-release/+--+{-# INLINE intersperseSuffixBySpan #-}+intersperseSuffixBySpan :: (IsStream t, Monad m)+    => Int -> m a -> t m a -> t m a+intersperseSuffixBySpan n eff =+    fromStreamD . D.intersperseSuffixBySpan n eff . toStreamD++-- | Insert a side effect before consuming an element of a stream.+--+-- >>> Stream.toList $ Stream.trace putChar $ Stream.interspersePrefix_ (putChar '.' >> return ',') $ Stream.fromList "hello"+-- .h.e.l.l.o"hello"+--+-- Same as 'trace_' but may be concurrent.+--+-- /Concurrent/+--+-- /Pre-release/+--+{-# INLINE interspersePrefix_ #-}+interspersePrefix_ :: (IsStream t, MonadAsync m) => m b -> t m a -> t m a+interspersePrefix_ m = mapM (\x -> void m >> return x)++------------------------------------------------------------------------------+-- Inserting Time+------------------------------------------------------------------------------++-- Note: delay must be serial.+--+-- | Introduce a delay of specified seconds before consuming an element of the+-- stream except the first one.+--+-- >>> Stream.mapM_ print $ Stream.timestamped $ Stream.delay 1 $ Stream.enumerateFromTo 1 3+-- (AbsTime (TimeSpec {sec = ..., nsec = ...}),1)+-- (AbsTime (TimeSpec {sec = ..., nsec = ...}),2)+-- (AbsTime (TimeSpec {sec = ..., nsec = ...}),3)+--+-- @since 0.8.0+--+{-# INLINE delay #-}+delay :: (IsStream t, MonadIO m) => Double -> t m a -> t m a+delay n = intersperseM_ $ liftIO $ threadDelay $ round $ n * 1000000++-- Note: delay must be serial.+--+-- | Introduce a delay of specified seconds after consuming an element of a+-- stream.+--+-- >>> Stream.mapM_ print $ Stream.timestamped $ Stream.delayPost 1 $ Stream.enumerateFromTo 1 3+-- (AbsTime (TimeSpec {sec = ..., nsec = ...}),1)+-- (AbsTime (TimeSpec {sec = ..., nsec = ...}),2)+-- (AbsTime (TimeSpec {sec = ..., nsec = ...}),3)+--+-- /Pre-release/+--+{-# INLINE delayPost #-}+delayPost :: (IsStream t, MonadIO m) => Double -> t m a -> t m a+delayPost n = intersperseSuffix_ $ liftIO $ threadDelay $ round $ n * 1000000++-- Note: delay must be serial, that's why 'trace_' is used.+--+-- | Introduce a delay of specified seconds before consuming an element of a+-- stream.+--+-- >>> Stream.mapM_ print $ Stream.timestamped $ Stream.delayPre 1 $ Stream.enumerateFromTo 1 3+-- (AbsTime (TimeSpec {sec = ..., nsec = ...}),1)+-- (AbsTime (TimeSpec {sec = ..., nsec = ...}),2)+-- (AbsTime (TimeSpec {sec = ..., nsec = ...}),3)+--+-- /Pre-release/+--+{-# INLINE delayPre #-}+delayPre :: (IsStream t, MonadIO m) => Double -> t m a -> t m a+delayPre n = trace_ $ liftIO $ threadDelay $ round $ n * 1000000++------------------------------------------------------------------------------+-- 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+    :: -- (IsStream t, Monad m) =>+       Fold m a b+    -> (a -> a -> Int)+    -> t m a+    -> t m b+reassembleBy = undefined++------------------------------------------------------------------------------+-- Position Indexing+------------------------------------------------------------------------------++-- |+-- > indexed = Stream.postscanl' (\(i, _) x -> (i + 1, x)) (-1,undefined)+-- > indexed = Stream.zipWith (,) (Stream.enumerateFrom 0)+--+-- Pair each element in a stream with its index, starting from index 0.+--+-- >>> Stream.toList $ Stream.indexed $ Stream.fromList "hello"+-- [(0,'h'),(1,'e'),(2,'l'),(3,'l'),(4,'o')]+--+-- @since 0.6.0+{-# INLINE indexed #-}+indexed :: (IsStream t, Monad m) => t m a -> t m (Int, a)+indexed = fromStreamD . D.indexed . toStreamD++-- |+-- > indexedR n = Stream.postscanl' (\(i, _) x -> (i - 1, x)) (n + 1,undefined)+-- > indexedR n = Stream.zipWith (,) (Stream.enumerateFromThen n (n - 1))+--+-- Pair each element in a stream with its index, starting from the+-- given index @n@ and counting down.+--+-- >>> Stream.toList $ Stream.indexedR 10 $ Stream.fromList "hello"+-- [(10,'h'),(9,'e'),(8,'l'),(7,'l'),(6,'o')]+--+-- @since 0.6.0+{-# INLINE indexedR #-}+indexedR :: (IsStream t, Monad m) => Int -> t m a -> t m (Int, a)+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.mapM_ print $ 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.mapM_ print $ 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 :: (IsStream t, MonadAsync m, Functor (t m))+    => Double -> t m a -> t m (AbsTime, a)+timestampWith g stream = Z.zipWith (flip (,)) stream (absTimesWith g)++-- TBD: check performance vs a custom implementation without using zipWith.+--+-- /Pre-release/+--+{-# INLINE timestamped #-}+timestamped :: (IsStream t, MonadAsync m, Functor (t m))+    => t m a -> t 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.mapM_ print $ 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 :: (IsStream t, MonadAsync m, Functor (t m))+    => Double -> t m a -> t m (RelTime64, a)+timeIndexWith g stream = Z.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.mapM_ print $ Stream.timeIndexed $ Stream.delay 1 $ Stream.enumerateFromTo 1 3+-- (RelTime64 (NanoSecond64 ...),1)+-- (RelTime64 (NanoSecond64 ...),2)+-- (RelTime64 (NanoSecond64 ...),3)+--+-- /Pre-release/+--+{-# INLINE timeIndexed #-}+timeIndexed :: (IsStream t, MonadAsync m, Functor (t m))+    => t m a -> t 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 = findIndices (== a)+--+-- @since 0.5.0+{-# INLINE elemIndices #-}+elemIndices :: (IsStream t, Eq a, Monad m) => a -> t m a -> t 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. If the+-- stream consists of a single element the output is an empty stream.+--+-- This is the stream equivalent of the list idiom @zipWith f xs (tail xs)@.+--+-- /Pre-release/+--+{-# INLINE rollingMap #-}+rollingMap :: (IsStream t, Monad m) => (a -> a -> b) -> t m a -> t m b+rollingMap f m = fromStreamD $ D.rollingMap f $ toStreamD m++-- | Like 'rollingMap' but with an effectful map function.+--+-- /Pre-release/+--+{-# INLINE rollingMapM #-}+rollingMapM :: (IsStream t, Monad m) => (a -> a -> m b) -> t m a -> t m b+rollingMapM f m = fromStreamD $ D.rollingMapM 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.map 'fromJust' . Stream.filter 'isJust' . Stream.map f+-- @+--+-- @since 0.3.0+{-# INLINE mapMaybe #-}+mapMaybe :: (IsStream t, Monad m) => (a -> Maybe b) -> t m a -> t m b+mapMaybe f m = fromStreamS $ S.mapMaybe f $ toStreamS m++-- | Like 'mapMaybe' but maps a monadic function.+--+-- Equivalent to:+--+-- @+-- mapMaybeM f = Stream.map 'fromJust' . Stream.filter 'isJust' . Stream.mapM f+-- @+--+-- /Concurrent (do not use with 'fromParallel' on infinite streams)/+--+-- @since 0.3.0+{-# INLINE_EARLY mapMaybeM #-}+mapMaybeM :: (IsStream t, MonadAsync m, Functor (t m))+          => (a -> m (Maybe b)) -> t m a -> t m b+mapMaybeM f = fmap fromJust . filter isJust . K.mapM f++{-# RULES "mapMaybeM serial" mapMaybeM = mapMaybeMSerial #-}+{-# INLINE mapMaybeMSerial #-}+mapMaybeMSerial :: Monad m => (a -> m (Maybe b)) -> SerialT m a -> SerialT m b+mapMaybeMSerial f m = fromStreamD $ D.mapMaybeM f $ toStreamD m++-- | In a stream of 'Maybe's, discard 'Nothing's and unwrap 'Just's.+--+-- /Pre-release/+--+catMaybes :: (IsStream t, Monad m, Functor (t m)) => t m (Maybe a) -> t m a+catMaybes = fmap fromJust . filter isJust++------------------------------------------------------------------------------+-- Either streams+------------------------------------------------------------------------------++-- | Discard 'Right's and unwrap 'Left's in an 'Either' stream.+--+-- /Pre-release/+--+lefts :: (IsStream t, Monad m, Functor (t m)) => t m (Either a b) -> t m a+lefts = fmap (fromLeft undefined) . filter isLeft++-- | Discard 'Left's and unwrap 'Right's in an 'Either' stream.+--+-- /Pre-release/+--+rights :: (IsStream t, Monad m, Functor (t m)) => t m (Either a b) -> t m b+rights = fmap (fromRight undefined) . filter isRight++------------------------------------------------------------------------------+-- Concurrent Application+------------------------------------------------------------------------------++-- | Parallel transform application operator; applies a stream transformation+-- function @t m a -> t m b@ to a stream @t m a@ concurrently; the input stream+-- is evaluated asynchronously in an independent thread yielding elements to a+-- buffer and the transformation function runs in another thread consuming the+-- input from the buffer.  '|$' is just like regular function application+-- operator '$' except that it is concurrent.+--+-- If you read the signature as @(t m a -> t m b) -> (t m a -> t m b)@ you can+-- look at it as a transformation that converts a transform function to a+-- buffered concurrent transform function.+--+-- The following code prints a value every second even though each stage adds a+-- 1 second delay.+--+--+-- >>> :{+-- Stream.drain $+--    Stream.mapM (\x -> threadDelay 1000000 >> print x)+--      |$ Stream.replicateM 3 (threadDelay 1000000 >> return 1)+-- :}+-- 1+-- 1+-- 1+--+-- /Concurrent/+--+-- /Since: 0.3.0 ("Streamly")/+--+-- @since 0.8.0+{-# INLINE (|$) #-}+(|$) :: (IsStream t, MonadAsync m) => (t m a -> t m b) -> (t m a -> t m b)+-- (|$) f = f . Async.mkAsync+(|$) f = f . Par.mkParallel++infixr 0 |$++-- | Same as '|$'.+--+--  /Internal/+--+{-# INLINE applyAsync #-}+applyAsync :: (IsStream t, MonadAsync m)+    => (t m a -> t m b) -> (t m a -> t m b)+applyAsync = (|$)++-- | Same as '|$' but with arguments reversed.+--+-- (|&) = flip (|$)+--+-- /Concurrent/+--+-- /Since: 0.3.0 ("Streamly")/+--+-- @since 0.8.0+{-# INLINE (|&) #-}+(|&) :: (IsStream t, MonadAsync m) => t m a -> (t m a -> t m b) -> t m b+x |& f = f |$ x++infixl 1 |&
+ src/Streamly/Internal/Data/Stream/IsStream/Types.hs view
@@ -0,0 +1,74 @@+-- |+-- Module      : Streamly.Internal.Data.Stream.IsStream+-- Copyright   : (c) 2017 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- | This module contains different stream types and combinators to+-- interconvert between them.++module Streamly.Internal.Data.Stream.IsStream.Types+    (+    -- * Stream Types+    -- ** Serial Streams+      SerialT+    , Serial+    , WSerialT+    , WSerial++    -- ** Speculative Streams+    , AheadT+    , Ahead++    -- ** Asynchronous Streams+    , AsyncT+    , Async+    , WAsyncT+    , WAsync++    -- ** Parallel Streams+    -- | Ahead, Async and WAsync schedule actions concurrently on demand.+    -- Unlike those 'Parallel' streams schedule all actions concurrently+    -- upfront.+    , ParallelT+    , Parallel+    , mkAsync++    -- ** Zipping Streams+    , ZipSerialM+    , ZipSerial+    , ZipAsyncM+    , ZipAsync++    -- * Stream Type Adapters+    , IsStream ()++    , fromSerial+    , fromWSerial+    , fromAsync+    , fromAhead+    , fromWAsync+    , fromParallel+    , fromZipSerial+    , fromZipAsync+    , adapt++    -- * Type Synonyms+    , MonadAsync+    )+where++import Streamly.Internal.Data.Stream.Ahead (AheadT, Ahead, fromAhead)+import Streamly.Internal.Data.Stream.Async+       ( AsyncT, Async, WAsyncT, WAsync, mkAsync, fromAsync+       , fromWAsync)+import Streamly.Internal.Data.Stream.Parallel (ParallelT, Parallel, fromParallel)+import Streamly.Internal.Data.Stream.Serial+       ( SerialT, WSerialT, Serial, WSerial, fromSerial+       , fromWSerial)+import Streamly.Internal.Data.Stream.StreamK (IsStream(), adapt)+import Streamly.Internal.Data.Stream.Zip+       (ZipSerialM, ZipSerial, ZipAsyncM, ZipAsync, fromZipSerial, fromZipAsync)+import Streamly.Internal.Data.SVar (MonadAsync)
src/Streamly/Internal/Data/Stream/Parallel.hs view
@@ -1,30 +1,33 @@-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE ConstraintKinds           #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE GeneralizedNewtypeDeriving#-}-{-# LANGUAGE InstanceSigs              #-}-{-# LANGUAGE MultiParamTypeClasses     #-}-{-# LANGUAGE UndecidableInstances      #-} -- XXX+{-# LANGUAGE UndecidableInstances #-}  #include "inline.hs"  -- | -- Module      : Streamly.Internal.Data.Stream.Parallel--- Copyright   : (c) 2017 Harendra Kumar+-- Copyright   : (c) 2017 Composewell Technologies -- -- License     : BSD3 -- Maintainer  : streamly@composewell.com -- Stability   : experimental -- Portability : GHC --+-- To run examples in this module: --+-- >>> import qualified Streamly.Prelude as Stream+-- >>> import Control.Concurrent (threadDelay)+-- >>> :{+--  delay n = do+--      threadDelay (n * 1000000)   -- sleep for n seconds+--      putStrLn (show n ++ " sec") -- print "n sec"+--      return n                    -- IO Int+-- :}+-- module Streamly.Internal.Data.Stream.Parallel     (     -- * Parallel Stream Type       ParallelT     , Parallel-    , parallely+    , fromParallel      -- * Merge Concurrently     , parallel@@ -33,10 +36,16 @@      -- * Evaluate Concurrently     , mkParallel+    , mkParallelD+    , mkParallelK      -- * Tap Concurrently     , tapAsync+    , tapAsyncF     , distributeAsync_++    -- * Callbacks+    , newCallbackStream     ) where @@ -59,18 +68,31 @@  import qualified Data.Set as Set -import Streamly.Internal.Data.Stream.SVar-       (fromSVar, fromProducer, fromConsumer, pushToFold)+import Streamly.Internal.Data.Fold.Type (Fold)+import Streamly.Internal.Data.Stream.StreamD.Type (Step(..)) import Streamly.Internal.Data.Stream.StreamK        (IsStream(..), Stream, mkStream, foldStream, foldStreamShared, adapt)  import Streamly.Internal.Data.SVar -import qualified Streamly.Internal.Data.Stream.StreamK as K-import qualified Streamly.Internal.Data.Stream.StreamD as D+import qualified Streamly.Internal.Data.Stream.StreamK as K (withLocal)+import qualified Streamly.Internal.Data.Stream.StreamK.Type as K+import qualified Streamly.Internal.Data.Stream.StreamD.Type as D+import qualified Streamly.Internal.Data.Stream.SVar as SVar  #include "Instances.hs" +--+-- $setup+-- >>> import qualified Streamly.Prelude as Stream+-- >>> import Control.Concurrent (threadDelay)+-- >>> :{+--  delay n = do+--      threadDelay (n * 1000000)   -- sleep for n seconds+--      putStrLn (show n ++ " sec") -- print "n sec"+--      return n                    -- IO Int+-- :}+ ------------------------------------------------------------------------------- -- Parallel -------------------------------------------------------------------------------@@ -152,7 +174,7 @@             writeIORef (svarStopBy sv) $ Set.elemAt 0 set         _ -> return ()     pushWorkerPar sv (runOne st{streamVar = Just sv} $ toStream r)-    foldStream st yld sng stp (fromSVar sv)+    foldStream st yld sng stp (SVar.fromSVar sv)  {-# INLINE joinStreamVarPar #-} joinStreamVarPar :: (IsStream t, MonadAsync m)@@ -210,12 +232,36 @@ {-# INLINE consMParallel #-} {-# SPECIALIZE consMParallel :: IO a -> ParallelT IO a -> ParallelT IO a #-} consMParallel :: MonadAsync m => m a -> ParallelT m a -> ParallelT m a-consMParallel m r = fromStream $ K.yieldM m `parallel` (toStream r)+consMParallel m r = fromStream $ K.fromEffect m `parallel` (toStream r) --- | Polymorphic version of the 'Semigroup' operation '<>' of 'ParallelT'--- Merges two streams concurrently.+infixr 6 `parallel`++-- | Like 'Streamly.Prelude.async' except that the execution is much more+-- strict. There is no limit on the number of threads. While+-- 'Streamly.Prelude.async' may not schedule a stream if there is no demand+-- from the consumer, 'parallel' always evaluates both the streams immediately.+-- The only limit that applies to 'parallel' is 'Streamly.Prelude.maxBuffer'.+-- Evaluation may block if the output buffer becomes full. ----- @since 0.2.0+-- >>> import Streamly.Prelude (parallel)+-- >>> stream = Stream.fromEffect (delay 2) `parallel` Stream.fromEffect (delay 1)+-- >>> Stream.toList stream -- IO [Int]+-- 1 sec+-- 2 sec+-- [1,2]+--+-- 'parallel' guarantees that all the streams are scheduled for execution+-- immediately, therefore, we could use things like starting timers inside the+-- streams and relying on the fact that all timers were started at the same+-- time.+--+-- Unlike 'async' this operation cannot be used to fold an infinite lazy+-- container of streams, because it schedules all the streams strictly+-- concurrently.+--+-- /Since: 0.2.0 ("Streamly")/+--+-- @since 0.8.0 {-# INLINE parallel #-} parallel :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a parallel = joinStreamVarPar ParallelVar StopNone@@ -226,7 +272,7 @@ -- -- | Like `parallel` but stops the output as soon as the first stream stops. ----- /Internal/+-- /Pre-release/ {-# INLINE parallelFst #-} parallelFst :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a parallelFst = joinStreamVarPar ParallelVar StopBy@@ -236,7 +282,7 @@ -- | Like `parallel` but stops the output as soon as any of the two streams -- stops. ----- /Internal/+-- /Pre-release/ {-# INLINE parallelMin #-} parallelMin :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a parallelMin = joinStreamVarPar ParallelVar StopAny@@ -245,84 +291,63 @@ -- Convert a stream to parallel ------------------------------------------------------------------------------ --- | Generate a stream asynchronously to keep it buffered, lazily consume--- from the buffer.+-- | Like 'mkParallel' but uses StreamK internally. ----- /Internal/+-- /Pre-release/ ---mkParallel :: (IsStream t, MonadAsync m) => t m a -> t m a-mkParallel m = mkStream $ \st yld sng stp -> do+mkParallelK :: (IsStream t, MonadAsync m) => t m a -> t m a+mkParallelK m = mkStream $ \st yld sng stp -> do     sv <- newParallelVar StopNone (adaptState st)     -- pushWorkerPar sv (runOne st{streamVar = Just sv} $ toStream m)-    D.toSVarParallel st sv $ D.toStreamD m-    foldStream st yld sng stp $ fromSVar sv+    SVar.toSVarParallel st sv $ D.toStreamD m+    foldStream st yld sng stp $ SVar.fromSVar sv ---------------------------------------------------------------------------------- Clone and distribute a stream in parallel-------------------------------------------------------------------------------+-------------------------------------------------------------------------------+-- Concurrent application and fold+------------------------------------------------------------------------------- --- Tap a stream and send the elements to the specified SVar in addition to--- yielding them again.------ XXX this could be written in StreamD style for better efficiency with fusion.+-- | Same as 'mkParallel' but for StreamD stream. ---{-# INLINE teeToSVar #-}-teeToSVar :: (IsStream t, MonadAsync m) => SVar Stream m a -> t m a -> t m a-teeToSVar svr m = mkStream $ \st yld sng stp -> do-    foldStreamShared st yld sng stp (go False m)-+{-# INLINE_NORMAL mkParallelD #-}+mkParallelD :: MonadAsync m => D.Stream m a -> D.Stream m a+mkParallelD m = D.Stream step Nothing     where -    go False m0 = mkStream $ \st yld _ stp -> do-        let drain = do-                -- In general, a Stop event would come equipped with the result-                -- of the fold. It is not used here but it would be useful in-                -- applicative and distribute.-                done <- fromConsumer svr-                when (not done) $ do-                    liftIO $ withDiagMVar svr "teeToSVar: waiting to drain"-                           $ takeMVar (outputDoorBellFromConsumer svr)-                    drain--            stopFold = do-                liftIO $ sendStop svr Nothing-                -- drain/wait until a stop event arrives from the fold.-                drain--            stop       = stopFold >> stp-            single a   = do-                done <- pushToFold svr a-                yld a (go done (K.nilM stopFold))-            yieldk a r = pushToFold svr a >>= \done -> yld a (go done r)-         in foldStreamShared st yieldk single stop m0+    step gst Nothing = do+        sv <- newParallelVar StopNone gst+        SVar.toSVarParallel gst sv m+        -- XXX use unfold instead?+        return $ Skip $ Just $ SVar.fromSVarD sv -    go True m0 = m0+    step gst (Just (D.UnStream step1 st)) = do+        r <- step1 gst st+        return $ case r of+            Yield a s -> Yield a (Just $ D.Stream step1 s)+            Skip s    -> Skip (Just $ D.Stream step1 s)+            Stop      -> Stop --- In case of folds the roles of worker and parent on an SVar are reversed. The--- parent stream pushes values to an SVar instead of pulling from it and a--- worker thread running the fold pulls from the SVar and folds the stream. We--- keep a separate channel for pushing exceptions in the reverse direction i.e.--- from the fold to the parent stream.+-- Compare with mkAsync. mkAsync uses an Async style SVar whereas this uses a+-- parallel style SVar for evaluation. Currently, parallel style cannot use+-- rate control whereas Async style can use rate control. In async style SVar+-- the worker thread terminates when the buffer is full whereas in Parallel+-- style it blocks. ----- Note: If we terminate due to an exception, we do not actively terminate the--- fold. It gets cleaned up by the GC.---- | Create an SVar with a fold consumer that will fold any elements sent to it--- using the supplied fold function.-{-# INLINE newFoldSVar #-}-newFoldSVar :: (IsStream t, MonadAsync m)-    => State Stream m a -> (t m a -> m b) -> m (SVar Stream m a)-newFoldSVar stt f = do-    -- Buffer size for the SVar is derived from the current state-    sv <- newParallelVar StopAny (adaptState stt)--    -- Add the producer thread-id to the SVar.-    liftIO myThreadId >>= modifyThread sv+-- | Make the stream producer and consumer run concurrently by introducing a+-- buffer between them. The producer thread evaluates the input stream until+-- the buffer fills, it blocks if the buffer is full until there is space in+-- the buffer. The consumer consumes the stream lazily from the buffer.+--+-- @mkParallel = D.fromStreamD . mkParallelD . D.toStreamD@+--+-- /Pre-release/+--+{-# INLINE_NORMAL mkParallel #-}+mkParallel :: (K.IsStream t, MonadAsync m) => t m a -> t m a+mkParallel = D.fromStreamD . mkParallelD . D.toStreamD -    void $ doFork (void $ f $ fromStream $ fromProducer sv)-                  (svarMrun sv)-                  (handleFoldException sv)-    return sv+-------------------------------------------------------------------------------+-- Concurrent tap+-------------------------------------------------------------------------------  -- NOTE: In regular pull style streams, the consumer stream is pulling elements -- from the SVar and we have several workers producing elements and pushing to@@ -340,7 +365,7 @@ -- -- | Redirect a copy of the stream to a supplied fold and run it concurrently -- in an independent thread. The fold may buffer some elements. The buffer size--- is determined by the prevailing 'maxBuffer' setting.+-- is determined by the prevailing 'Streamly.Prelude.maxBuffer' setting. -- -- @ --               Stream m a -> m b@@ -364,23 +389,82 @@ -- -- Compare with 'tap'. ----- /Internal/+-- /Pre-release/ {-# INLINE tapAsync #-} tapAsync :: (IsStream t, MonadAsync m) => (t m a -> m b) -> t m a -> t m a tapAsync f m = mkStream $ \st yld sng stp -> do-    sv <- newFoldSVar st f-    foldStreamShared st yld sng stp (teeToSVar sv m)+    sv <- SVar.newFoldSVar st f+    foldStreamShared st yld sng stp (SVar.teeToSVar sv m) +data TapState fs st a = TapInit | Tapping !fs st | TapDone st++-- | Like 'tapAsync' but uses a 'Fold' instead of a fold function.+--+{-# INLINE_NORMAL tapAsyncF #-}+tapAsyncF :: MonadAsync m => Fold m a b -> D.Stream m a -> D.Stream m a+tapAsyncF f (D.Stream step1 state1) = D.Stream step TapInit+    where++    drainFold svr = do+            -- In general, a Stop event would come equipped with the result+            -- of the fold. It is not used here but it would be useful in+            -- applicative and distribute.+            done <- SVar.fromConsumer svr+            when (not done) $ do+                liftIO $ withDiagMVar svr "teeToSVar: waiting to drain"+                       $ takeMVar (outputDoorBellFromConsumer svr)+                drainFold svr++    stopFold svr = do+            liftIO $ sendStop svr Nothing+            -- drain/wait until a stop event arrives from the fold.+            drainFold svr++    {-# INLINE_LATE step #-}+    step gst TapInit = do+        sv <- SVar.newFoldSVarF gst f+        return $ Skip (Tapping sv state1)++    step gst (Tapping sv st) = do+        r <- step1 gst st+        case r of+            Yield a s ->  do+                done <- SVar.pushToFold sv a+                if done+                then do+                    -- XXX we do not need to wait synchronously here+                    stopFold sv+                    return $ Yield a (TapDone s)+                else return $ Yield a (Tapping sv s)+            Skip s -> return $ Skip (Tapping sv s)+            Stop -> do+                stopFold sv+                return Stop++    step gst (TapDone st) = do+        r <- step1 gst st+        return $ case r of+            Yield a s -> Yield a (TapDone s)+            Skip s    -> Skip (TapDone s)+            Stop      -> Stop+ -- | Concurrently distribute a stream to a collection of fold functions, -- discarding the outputs of the folds. ----- >>> S.drain $ distributeAsync_ [S.mapM_ print, S.mapM_ print] (S.enumerateFromTo 1 2)+-- @+-- > Stream.drain $ Stream.distributeAsync_ [Stream.mapM_ print, Stream.mapM_ print] (Stream.enumerateFromTo 1 2)+-- 1+-- 2+-- 1+-- 2 -- -- @+--+-- @ -- distributeAsync_ = flip (foldr tapAsync) -- @ ----- /Internal/+-- /Pre-release/ -- {-# INLINE distributeAsync_ #-} distributeAsync_ :: (Foldable f, IsStream t, MonadAsync m)@@ -391,88 +475,40 @@ -- ParallelT ------------------------------------------------------------------------------ --- | Async composition with strict concurrent execution of all streams.------ The 'Semigroup' instance of 'ParallelT' executes both the streams--- concurrently without any delay or without waiting for the consumer demand--- and /merges/ the results as they arrive. If the consumer does not consume--- the results, they are buffered upto a configured maximum, controlled by the--- 'maxBuffer' primitive. If the buffer becomes full the concurrent tasks will--- block until there is space in the buffer.------ Both 'WAsyncT' and 'ParallelT', evaluate the constituent streams fairly in a--- round robin fashion. The key difference is that 'WAsyncT' might wait for the--- consumer demand before it executes the tasks whereas 'ParallelT' starts--- executing all the tasks immediately without waiting for the consumer demand.--- For 'WAsyncT' the 'maxThreads' limit applies whereas for 'ParallelT' it does--- not apply. In other words, 'WAsyncT' can be lazy whereas 'ParallelT' is--- strict.------ 'ParallelT' is useful for cases when the streams are required to be--- evaluated simultaneously irrespective of how the consumer consumes them e.g.--- when we want to race two tasks and want to start both strictly at the same--- time or if we have timers in the parallel tasks and our results depend on--- the timers being started at the same time. If we do not have such--- requirements then 'AsyncT' or 'AheadT' are recommended as they can be more--- efficient than 'ParallelT'.+-- | For 'ParallelT' streams: -- -- @--- main = ('toList' . 'parallely' $ (fromFoldable [1,2]) \<> (fromFoldable [3,4])) >>= print--- @--- @--- [1,3,2,4]+-- (<>) = 'Streamly.Prelude.parallel'+-- (>>=) = flip . 'Streamly.Prelude.concatMapWith' 'Streamly.Prelude.parallel' -- @ ----- When streams with more than one element are merged, it yields whichever--- stream yields first without any bias, unlike the 'Async' style streams.------ Any exceptions generated by a constituent stream are propagated to the--- output stream. The output and exceptions from a single stream are guaranteed--- to arrive in the same order in the resulting stream as they were generated--- in the input stream. However, the relative ordering of elements from--- different streams in the resulting stream can vary depending on scheduling--- and generation delays.------ Similarly, the 'Monad' instance of 'ParallelT' runs /all/ iterations--- of the loop concurrently.------ @--- import "Streamly"--- import qualified "Streamly.Prelude" as S--- import Control.Concurrent------ main = 'drain' . 'parallely' $ do---     n <- return 3 \<\> return 2 \<\> return 1---     S.yieldM $ do---          threadDelay (n * 1000000)---          myThreadId >>= \\tid -> putStrLn (show tid ++ ": Delay " ++ show n)--- @--- @--- ThreadId 40: Delay 1--- ThreadId 39: Delay 2--- ThreadId 38: Delay 3--- @+-- See 'Streamly.Prelude.AsyncT', 'ParallelT' is similar except that all+-- iterations are strictly concurrent while in 'AsyncT' it depends on the+-- consumer demand and available threads. See 'parallel' for more details. ----- Note that parallel composition can only combine a finite number of--- streams as it needs to retain state for each unfinished stream.+-- /Since: 0.1.0 ("Streamly")/ -- -- /Since: 0.7.0 (maxBuffer applies to ParallelT streams)/ ----- /Since: 0.1.0/+-- @since 0.8.0 newtype ParallelT m a = ParallelT {getParallelT :: Stream m a}     deriving (MonadTrans)  -- | A parallely composing IO stream of elements of type @a@. -- See 'ParallelT' documentation for more details. ----- @since 0.2.0+-- /Since: 0.2.0 ("Streamly")/+--+-- @since 0.8.0 type Parallel = ParallelT IO  -- | Fix the type of a polymorphic stream as 'ParallelT'. ----- @since 0.1.0-parallely :: IsStream t => ParallelT m a -> t m a-parallely = adapt+-- /Since: 0.1.0 ("Streamly")/+--+-- @since 0.8.0+fromParallel :: IsStream t => ParallelT m a -> t m a+fromParallel = adapt  instance IsStream ParallelT where     toStream = getParallelT@@ -519,7 +555,7 @@  instance (Monad m, MonadAsync m) => Applicative (ParallelT m) where     {-# INLINE pure #-}-    pure = ParallelT . K.yield+    pure = ParallelT . K.fromPure     {-# INLINE (<*>) #-}     (<*>) = apParallel @@ -541,3 +577,31 @@ ------------------------------------------------------------------------------  MONAD_COMMON_INSTANCES(ParallelT, MONADPARALLEL)++-------------------------------------------------------------------------------+-- From callback+-------------------------------------------------------------------------------++-- Note: we can use another API with two callbacks stop and yield if we want+-- the callback to be able to indicate end of stream.+--+-- | Generates a callback and a stream pair. The callback returned is used to+-- queue values to the stream.  The stream is infinite, there is no way for the+-- callback to indicate that it is done now.+--+-- /Pre-release/+--+{-# INLINE_NORMAL newCallbackStream #-}+newCallbackStream :: (K.IsStream t, MonadAsync m) => m (a -> m (), t m a)+newCallbackStream = do+    sv <- newParallelVar StopNone defState++    -- XXX Add our own thread-id to the SVar as we can not know the callback's+    -- thread-id and the callback is not run in a managed worker. We need to+    -- handle this better.+    liftIO myThreadId >>= modifyThread sv++    let callback a = liftIO $ void $ send sv (ChildYield a)+    -- XXX we can return an SVar and then the consumer can unfold from the+    -- SVar?+    return (callback, D.fromStreamD (SVar.fromSVarD sv))
src/Streamly/Internal/Data/Stream/Prelude.hs view
@@ -1,14 +1,10 @@-{-# LANGUAGE CPP                       #-}--#if __GLASGOW_HASKELL__ >= 800 {-# OPTIONS_GHC -Wno-orphans #-}-#endif  #include "inline.hs"  -- | -- Module      : Streamly.Internal.Data.Stream.Prelude--- Copyright   : (c) 2017 Harendra Kumar+-- Copyright   : (c) 2017 Composewell Technologies -- -- License     : BSD3 -- Maintainer  : streamly@composewell.com@@ -37,8 +33,7 @@     , foldlx'     , foldlMx'     , foldl'-    , runFold-    , parselMx'+    , fold      -- Lazy left folds are useful only for reversing the stream     , foldlS@@ -48,6 +43,8 @@     , scanlMx'     , postscanlx'     , postscanlMx'+    , postscanOnce+    , scanOnce      -- * Zip style operations     , eqBy@@ -62,19 +59,17 @@     , K.concatMap      -- * Fold Utilities-    , foldWith-    , foldMapWith-    , forEachWith+    , concatFoldableWith+    , concatMapFoldableWith+    , concatForFoldableWith     ) where -import Control.Monad.Catch (MonadThrow)-import Control.Monad.Trans (MonadTrans(..))+import Control.Monad.Trans.Class (MonadTrans(..)) import Prelude hiding (foldr, minimum, maximum) import qualified Prelude -import Streamly.Internal.Data.Fold.Types (Fold (..))-import Streamly.Internal.Data.Parser.Types (Step)+import Streamly.Internal.Data.Fold.Type (Fold (..))  #ifdef USE_STREAMK_ONLY import qualified Streamly.Internal.Data.Stream.StreamK as S@@ -150,7 +145,7 @@  {-# INLINE foldr #-} foldr :: (Monad m, IsStream t) => (a -> b -> b) -> b -> t m a -> m b-foldr f z = foldrM (\a b -> b >>= return . f a) (return z)+foldr f z = foldrM (\a b -> f a <$> b) (return z)  -- | Like 'foldlx'', but with a monadic step function. --@@ -160,17 +155,6 @@     => (x -> a -> m x) -> m x -> (x -> m b) -> t m a -> m b foldlMx' step begin done m = S.foldlMx' step begin done $ toStreamS m -{-# INLINE parselMx' #-}-parselMx'-    :: (IsStream t, MonadThrow m)-    => (s -> a -> m (Step s b))-    -> m s-    -> (s -> m b)-    -> t m a-    -> m b-parselMx' step initial extract m =-    D.parselMx' step initial extract $ D.toStreamD m- -- | 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@@ -204,9 +188,9 @@     => (s m b -> a -> s m b) -> s m b -> t m a -> s m b foldlT f z s = S.foldlT f z (toStreamS s) -{-# INLINE runFold #-}-runFold :: (Monad m, IsStream t) => Fold m a b -> t m a -> m b-runFold (Fold step begin done) = foldlMx' step begin done+{-# INLINE fold #-}+fold :: (Monad m, IsStream t) => Fold m a b -> t m a -> m b+fold fld m = S.fold fld $ toStreamS m  ------------------------------------------------------------------------------ -- Scans@@ -234,6 +218,17 @@ scanlMx' step begin done m =     D.fromStreamD $ D.scanlMx' step begin done $ D.toStreamD m +{-# INLINE_NORMAL postscanOnce #-}+postscanOnce :: (IsStream t, Monad m)+    => Fold m a b -> t m a -> t m b+postscanOnce fld m =+    D.fromStreamD $ D.postscanOnce fld $ D.toStreamD m++{-# INLINE scanOnce #-}+scanOnce :: (IsStream t, Monad m)+    => Fold m a b -> t m a -> t m b+scanOnce fld m = D.fromStreamD $ D.scanOnce fld $ D.toStreamD m+ -- scanl followed by map -- -- | Strict left scan with an extraction function. Like 'scanl'', but applies a@@ -296,58 +291,62 @@ foldbWith f = K.foldb f K.nil -} --- /Since: 0.7.0 ("Streamly.Prelude")/---+ -- | A variant of 'Data.Foldable.fold' that allows you to fold a 'Foldable' -- container of streams using the specified stream sum operation. ----- @foldWith 'async' $ map return [1..3]@+-- @concatFoldableWith 'async' $ map return [1..3]@ -- -- Equivalent to: -- -- @--- foldWith f = S.foldMapWith f id+-- concatFoldableWith f = Prelude.foldr f S.nil+-- concatFoldableWith f = S.concatMapFoldableWith f id -- @ --+-- /Since: 0.8.0 (Renamed foldWith to concatFoldableWith)/+-- -- /Since: 0.1.0 ("Streamly")/-{-# INLINABLE foldWith #-}-foldWith :: (IsStream t, Foldable f)+{-# INLINABLE concatFoldableWith #-}+concatFoldableWith :: (IsStream t, Foldable f)     => (t m a -> t m a -> t m a) -> f (t m a) -> t m a-foldWith f = Prelude.foldr f K.nil+concatFoldableWith f = Prelude.foldr f K.nil --- /Since: 0.7.0 ("Streamly.Prelude")/--- -- | A variant of 'foldMap' that allows you to map a monadic streaming action -- on a 'Foldable' container and then fold it using the specified stream merge -- operation. ----- @foldMapWith 'async' return [1..3]@+-- @concatMapFoldableWith 'async' return [1..3]@ -- -- Equivalent to: -- -- @--- foldMapWith f g xs = S.concatMapWith f g (S.fromFoldable xs)+-- concatMapFoldableWith f g = Prelude.foldr (f . g) S.nil+-- concatMapFoldableWith f g xs = S.concatMapWith f g (S.fromFoldable xs) -- @ --+-- /Since: 0.8.0 (Renamed foldMapWith to concatMapFoldableWith)/+-- -- /Since: 0.1.0 ("Streamly")/-{-# INLINABLE foldMapWith #-}-foldMapWith :: (IsStream t, Foldable f)+{-# INLINABLE concatMapFoldableWith #-}+concatMapFoldableWith :: (IsStream t, Foldable f)     => (t m b -> t m b -> t m b) -> (a -> t m b) -> f a -> t m b-foldMapWith f g = Prelude.foldr (f . g) K.nil+concatMapFoldableWith f g = Prelude.foldr (f . g) K.nil --- /Since: 0.7.0 ("Streamly.Prelude")/------ | Like 'foldMapWith' but with the last two arguments reversed i.e. the+-- | Like 'concatMapFoldableWith' but with the last two arguments reversed i.e. the -- monadic streaming function is the last argument. -- -- Equivalent to: -- -- @--- forEachWith = flip S.foldMapWith+-- concatForFoldableWith f xs g = Prelude.foldr (f . g) S.nil xs+-- concatForFoldableWith = flip S.concatMapFoldableWith -- @ --+-- /Since: 0.8.0 (Renamed forEachWith to concatForFoldableWith)/+-- -- /Since: 0.1.0 ("Streamly")/-{-# INLINABLE forEachWith #-}-forEachWith :: (IsStream t, Foldable f)+{-# INLINABLE concatForFoldableWith #-}+concatForFoldableWith :: (IsStream t, Foldable f)     => (t m b -> t m b -> t m b) -> f a -> (a -> t m b) -> t m b-forEachWith f xs g = Prelude.foldr (f . g) K.nil xs+concatForFoldableWith f xs g = Prelude.foldr (f . g) K.nil xs
src/Streamly/Internal/Data/Stream/SVar.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE FlexibleContexts          #-}- #ifdef __HADDOCK_VERSION__ #undef INSPECTION #endif@@ -12,7 +9,7 @@  -- | -- Module      : Streamly.Internal.Data.Stream.SVar--- Copyright   : (c) 2017 Harendra Kumar+-- Copyright   : (c) 2017 Composewell Technologies -- -- License     : BSD3 -- Maintainer  : streamly@composewell.com@@ -21,26 +18,46 @@ -- -- module Streamly.Internal.Data.Stream.SVar-    ( fromSVar-    , fromStreamVar-    , fromProducer-    , fromConsumer+    (+    -- * Unfold streams from SVar+    -- $concurrentEval+      fromSVar+    , fromSVarD+    -- , fromStreamVar++    -- * Fold streams to SVar     , toSVar+    , toSVarParallel++    -- * Concurrent folds+    -- $concurrentFolds+    , fromConsumer     , pushToFold+    , teeToSVar+    , newFoldSVar+    , newFoldSVarF     ) where +#include "inline.hs"++import Control.Concurrent (myThreadId, takeMVar) import Control.Exception (fromException) import Control.Monad (when, void) import Control.Monad.Catch (throwM) import Control.Monad.IO.Class (MonadIO(liftIO)) import Data.IORef (newIORef, readIORef, mkWeakIORef, writeIORef) import Data.Maybe (isNothing)+import Streamly.Internal.Data.Atomics (atomicModifyIORefCAS_)+import Streamly.Internal.Data.Fold.Type (Fold(..)) import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime) import System.Mem (performMajorGC) +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 Streamly.Internal.Data.SVar-import Streamly.Internal.Data.Stream.StreamK hiding (reverse)  #if __GLASGOW_HASKELL__ < 810 #ifdef INSPECTION@@ -52,15 +69,39 @@ #endif #endif +------------------------------------------------------------------------------+-- Generating streams from SVar+------------------------------------------------------------------------------++-- $concurrentEval+--+-- Usually the SVar is used to concurrently evaluate multiple actions in a+-- stream using many worker threads that push the results to the SVar and a+-- single puller that pulls them from SVar generating the evaluated stream.+--+-- @+--                  input stream+--                       |+--     <-----------------|<--------worker+--     |  exceptions     |+-- output stream <------SVar<------worker+--                       |+--                       |<--------worker+--+-- @+--+-- The puller itself schedules the worker threads based on demand.+-- Exceptions are propagated from the worker threads to the puller.+ -- | Pull a stream from an SVar. {-# NOINLINE fromStreamVar #-}-fromStreamVar :: MonadAsync m => SVar Stream m a -> Stream m a-fromStreamVar sv = MkStream $ \st yld sng stp -> do+fromStreamVar :: MonadAsync m => SVar K.Stream m a -> K.Stream m a+fromStreamVar sv = K.MkStream $ \st yld sng stp -> do     list <- readOutputQ sv     -- Reversing the output is important to guarantee that we process the     -- outputs in the same order as they were generated by the constituent     -- streams.-    foldStream st yld sng stp $ processEvents $ reverse list+    K.foldStream st yld sng stp $ processEvents $ reverse list      where @@ -72,13 +113,13 @@         stp      {-# INLINE processEvents #-}-    processEvents [] = MkStream $ \st yld sng stp -> do+    processEvents [] = K.MkStream $ \st yld sng stp -> do         done <- postProcess sv         if done         then allDone stp-        else foldStream st yld sng stp $ fromStreamVar sv+        else K.foldStream st yld sng stp $ fromStreamVar sv -    processEvents (ev : es) = MkStream $ \st yld sng stp -> do+    processEvents (ev : es) = K.MkStream $ \st yld sng stp -> do         let rest = processEvents es         case ev of             ChildYield a -> yld a rest@@ -89,11 +130,11 @@                         stop <- shouldStop tid                         if stop                         then liftIO (cleanupSVar sv) >> allDone stp-                        else foldStream st yld sng stp rest+                        else K.foldStream st yld sng stp rest                     Just ex ->                         case fromException ex of                             Just ThreadAbort ->-                                foldStream st yld sng stp rest+                                K.foldStream st yld sng stp rest                             Nothing -> liftIO (cleanupSVar sv) >> throwM ex     shouldStop tid =         case svarStopStyle sv of@@ -101,7 +142,7 @@             StopAny -> return True             StopBy -> do                 sid <- liftIO $ readIORef (svarStopBy sv)-                return $ if tid == sid then True else False+                return $ tid == sid  #if __GLASGOW_HASKELL__ < 810 #ifdef INSPECTION@@ -123,17 +164,23 @@ #endif #endif +-- | Generate a stream from an SVar.  An unevaluated stream can be pushed to an+-- SVar using 'toSVar'.  As we pull a stream from the SVar the input stream+-- gets evaluated concurrently. The evaluation depends on the SVar style and+-- the configuration parameters e.g. using the maxBuffer/maxThreads+-- combinators.+-- {-# INLINE fromSVar #-}-fromSVar :: (MonadAsync m, IsStream t) => SVar Stream m a -> t m a+fromSVar :: (MonadAsync m, K.IsStream t) => SVar K.Stream m a -> t m a fromSVar sv =-    mkStream $ \st yld sng stp -> do+    K.mkStream $ \st yld sng stp -> do         ref <- liftIO $ newIORef ()         _ <- liftIO $ mkWeakIORef ref hook         -- We pass a copy of sv to fromStreamVar, so that we know that it has         -- no other references, when that copy gets garbage collected "ref"         -- will get garbage collected and our hook will be called.-        foldStreamShared st yld sng stp $-            fromStream $ fromStreamVar sv{svarRef = Just ref}+        K.foldStreamShared st yld sng stp $+            K.fromStream $ fromStreamVar sv{svarRef = Just ref}     where      hook = do@@ -146,27 +193,285 @@         -- them to be cleaned up quickly.         when (svarInspectMode sv) performMajorGC --- | Write a stream to an 'SVar' in a non-blocking manner. The stream can then--- be read back from the SVar using 'fromSVar'.-toSVar :: (IsStream t, MonadAsync m) => SVar Stream m a -> t m a -> m ()-toSVar sv m = toStreamVar sv (toStream m)+data FromSVarState t m a =+      FromSVarInit+    | FromSVarRead (SVar t m a)+    | FromSVarLoop (SVar t m a) [ChildEvent a]+    | FromSVarDone (SVar t m a) +-- | Like 'fromSVar' but generates a StreamD style stream instead of CPS.+--+{-# INLINE_NORMAL fromSVarD #-}+fromSVarD :: (MonadAsync m) => SVar t m a -> D.Stream m a+fromSVarD svar = D.Stream step FromSVarInit+    where++    {-# INLINE_LATE step #-}+    step _ FromSVarInit = do+        ref <- liftIO $ newIORef ()+        _ <- liftIO $ mkWeakIORef ref hook+        -- when this copy of svar gets garbage collected "ref" will get+        -- garbage collected and our GC hook will be called.+        let sv = svar{svarRef = Just ref}+        return $ D.Skip (FromSVarRead sv)++        where++        {-# NOINLINE hook #-}+        hook = do+            when (svarInspectMode svar) $ do+                r <- liftIO $ readIORef (svarStopTime (svarStats svar))+                when (isNothing r) $+                    printSVar svar "SVar Garbage Collected"+            cleanupSVar svar+            -- If there are any SVars referenced by this SVar a GC will prompt+            -- them to be cleaned up quickly.+            when (svarInspectMode svar) performMajorGC++    step _ (FromSVarRead sv) = do+        list <- readOutputQ sv+        -- Reversing the output is important to guarantee that we process the+        -- outputs in the same order as they were generated by the constituent+        -- streams.+        return $ D.Skip $ FromSVarLoop sv (Prelude.reverse list)++    step _ (FromSVarLoop sv []) = do+        done <- postProcess sv+        return $ D.Skip $ if done+                      then FromSVarDone sv+                      else FromSVarRead sv++    step _ (FromSVarLoop sv (ev : es)) = do+        case ev of+            ChildYield a -> return $ D.Yield a (FromSVarLoop sv es)+            ChildStop tid e -> do+                accountThread sv tid+                case e of+                    Nothing -> do+                        stop <- shouldStop tid+                        if stop+                        then do+                            liftIO (cleanupSVar sv)+                            return $ D.Skip (FromSVarDone sv)+                        else return $ D.Skip (FromSVarLoop sv es)+                    Just ex ->+                        case fromException ex of+                            Just ThreadAbort ->+                                return $ D.Skip (FromSVarLoop sv es)+                            Nothing -> liftIO (cleanupSVar sv) >> throwM ex+        where++        shouldStop tid =+            case svarStopStyle sv of+                StopNone -> return False+                StopAny -> return True+                StopBy -> do+                    sid <- liftIO $ readIORef (svarStopBy sv)+                    return $ tid == sid++    step _ (FromSVarDone sv) = do+        when (svarInspectMode sv) $ do+            t <- liftIO $ getTime Monotonic+            liftIO $ writeIORef (svarStopTime (svarStats sv)) (Just t)+            liftIO $ printSVar sv "SVar Done"+        return D.Stop++------------------------------------------------------------------------------+-- Writing streams to SVar+------------------------------------------------------------------------------++-- | Write a stream to an 'SVar' in a non-blocking manner. The stream is+-- evaluated concurrently as it is read back from the SVar using 'fromSVar'.+--+toSVar :: (K.IsStream t, MonadAsync m) => SVar K.Stream m a -> t m a -> m ()+toSVar sv m = toStreamVar sv $ K.toStream m+ -------------------------------------------------------------------------------+-- Concurrent application+-------------------------------------------------------------------------------++-- | A fold to write a stream to an SVar. Unlike 'toSVar' this does not allow+-- for concurrent evaluation of the stream, as the fold receives the input one+-- element at a time, it just forwards the elements to the SVar. However, we+-- can safely execute the fold in an independent thread, the SVar can act as a+-- buffer decoupling the sender from the receiver. Also, we can have multiple+-- folds running concurrently pusing the streams to the SVar.+--+{-# INLINE write #-}+write :: MonadIO m => SVar t m a -> Maybe WorkerInfo -> Fold m a ()+write svar winfo = Fold step initial extract++    where++    initial = return $ FL.Partial ()++    -- XXX we can have a separate fold for unlimited buffer case to avoid a+    -- branch in the step here.+    step () x =+        liftIO $ do+            decrementBufferLimit svar+            void $ send svar (ChildYield x)+            return $ FL.Partial ()++    extract () = liftIO $ sendStop svar winfo++-- | Like write, but applies a yield limit.+--+{-# INLINE writeLimited #-}+writeLimited :: MonadIO m+    => SVar t m a -> Maybe WorkerInfo -> Fold m a ()+writeLimited svar winfo = Fold step initial extract++    where++    initial = return $ FL.Partial True++    step True x =+        liftIO $ do+            yieldLimitOk <- decrementYieldLimit svar+            if yieldLimitOk+            then do+                decrementBufferLimit svar+                void $ send svar (ChildYield x)+                return $ FL.Partial True+            else do+                cleanupSVarFromWorker svar+                sendStop svar winfo+                return $ FL.Done ()+    step False _ = return $ FL.Done ()++    extract True = liftIO $ sendStop svar winfo+    extract False = return ()++-- Using StreamD the worker stream producing code can fuse with the code to+-- queue output to the SVar giving some perf boost.+--+-- Note that StreamD can only be used in limited situations, specifically, we+-- cannot implement joinStreamVarPar using this.+--+-- XXX make sure that the SVar passed is a Parallel style SVar.++-- | Fold the supplied stream to the SVar asynchronously using Parallel+-- concurrency style.+-- {-# INLINE_NORMAL toSVarParallel #-}+{-# INLINE toSVarParallel #-}+toSVarParallel :: MonadAsync m+    => State t m a -> SVar t m a -> D.Stream m a -> m ()+toSVarParallel st sv xs =+    if svarInspectMode sv+    then forkWithDiag+    else do+        tid <-+                case getYieldLimit st of+                    Nothing -> doFork (work Nothing)+                                      (svarMrun sv)+                                      (handleChildException sv)+                    Just _  -> doFork (workLim Nothing)+                                      (svarMrun sv)+                                      (handleChildException sv)+        modifyThread sv tid++    where++    {-# NOINLINE work #-}+    work info = D.fold (write sv info) xs++    {-# NOINLINE workLim #-}+    workLim info = D.fold (writeLimited sv info) xs++    {-# NOINLINE forkWithDiag #-}+    forkWithDiag = do+        -- We do not use workerCount in case of ParallelVar but still there is+        -- no harm in maintaining it correctly.+        liftIO $ atomicModifyIORefCAS_ (workerCount sv) $ \n -> n + 1+        recordMaxWorkers sv+        -- This allocation matters when significant number of workers are being+        -- sent. We allocate it only when needed. The overhead increases by 4x.+        winfo <-+            case yieldRateInfo sv of+                Nothing -> return Nothing+                Just _ -> liftIO $ do+                    cntRef <- newIORef 0+                    t <- getTime Monotonic+                    lat <- newIORef (0, t)+                    return $ Just WorkerInfo+                        { workerYieldMax = 0+                        , workerYieldCount = cntRef+                        , workerLatencyStart = lat+                        }+        tid <-+            case getYieldLimit st of+                Nothing -> doFork (work winfo)+                                  (svarMrun sv)+                                  (handleChildException sv)+                Just _  -> doFork (workLim winfo)+                                  (svarMrun sv)+                                  (handleChildException sv)+        modifyThread sv tid++-------------------------------------------------------------------------------+-- Support for running folds concurrently+-------------------------------------------------------------------------------++-- $concurrentFolds+--+-- To run folds concurrently, we need to decouple the fold execution from the+-- stream production. We use the SVar to do that, we have a single worker+-- pushing the stream elements to the SVar and on the consumer side a fold+-- driver pulls the values and folds them.+--+-- @+--+-- Fold worker <------SVar<------input stream+--     |  exceptions  |+--     --------------->+--+-- @+--+-- We need a channel for pushing exceptions from the fold worker to the stream+-- pusher. The stream may be pushed to multiple folds at the same time. For+-- that we need one SVar per fold:+--+-- @+--+-- Fold worker <------SVar<---+--                    |       |+-- Fold worker <------SVar<------input stream+--                    |       |+-- Fold worker <------SVar<---+--+-- @+--+-- Unlike in case concurrent stream evaluation, the puller does not drive the+-- scheduling and concurrent execution of the stream. The stream is simply+-- pushed by the stream producer at its own rate. The fold worker just pulls it+-- and folds it.+--+-- Note: If the stream pusher terminates due to an exception, we do not+-- actively terminate the fold. It gets cleaned up by the GC.++------------------------------------------------------------------------------- -- Process events received by a fold consumer from a stream producer ------------------------------------------------------------------------------- --- | Pull a stream from an SVar.+-- | Pull a stream from an SVar to fold it. Like 'fromSVar' except that it does+-- not drive the evaluation of the stream. It just pulls whatever is available+-- on the SVar. Also, when the fold stops it sends a notification to the stream+-- pusher/producer. No exceptions are expected to be propagated from the stream+-- pusher to the fold puller.+-- {-# NOINLINE fromProducer #-}-fromProducer :: MonadAsync m => SVar Stream m a -> Stream m a-fromProducer sv = mkStream $ \st yld sng stp -> do+fromProducer :: forall m a . MonadAsync m => SVar K.Stream m a -> K.Stream m a+fromProducer sv = K.mkStream $ \st yld sng stp -> do     list <- readOutputQ sv     -- Reversing the output is important to guarantee that we process the     -- outputs in the same order as they were generated by the constituent     -- streams.-    foldStream st yld sng stp $ processEvents $ reverse list+    K.foldStream st yld sng stp $ processEvents $ reverse list      where +    allDone :: m r -> m r     allDone stp = do         when (svarInspectMode sv) $ do             t <- liftIO $ getTime Monotonic@@ -176,10 +481,11 @@         stp      {-# INLINE processEvents #-}-    processEvents [] = mkStream $ \st yld sng stp -> do-        foldStream st yld sng stp $ fromProducer sv+    processEvents :: [ChildEvent a] -> K.Stream m a+    processEvents [] = K.mkStream $ \st yld sng stp -> do+        K.foldStream st yld sng stp $ fromProducer sv -    processEvents (ev : es) = mkStream $ \_ yld _ stp -> do+    processEvents (ev : es) = K.mkStream $ \_ yld _ stp -> do         let rest = processEvents es         case ev of             ChildYield a -> yld a rest@@ -189,6 +495,80 @@                     Nothing -> allDone stp                     Just _ -> error "Bug: fromProducer: received exception" +-- | Create a Fold style SVar that runs a supplied fold function as the+-- consumer.  Any elements sent to the SVar are consumed by the supplied fold+-- function.+--+{-# INLINE newFoldSVar #-}+newFoldSVar :: (K.IsStream t, MonadAsync m)+    => State K.Stream m a -> (t m a -> m b) -> m (SVar K.Stream m a)+newFoldSVar stt f = do+    -- Buffer size for the SVar is derived from the current state+    sv <- newParallelVar StopAny (adaptState stt)++    -- Add the producer thread-id to the SVar.+    liftIO myThreadId >>= modifyThread sv++    void $ doFork (void $ f $ K.fromStream $ fromProducer sv)+                  (svarMrun sv)+                  (handleFoldException sv)+    return sv++-- | Like 'fromProducer' but generates a StreamD style stream instead of+-- StreamK.+--+{-# INLINE_NORMAL fromProducerD #-}+fromProducerD :: (MonadAsync m) => SVar t m a -> D.Stream m a+fromProducerD svar = D.Stream step (FromSVarRead svar)+    where++    {-# INLINE_LATE step #-}+    step _ (FromSVarRead sv) = do+        list <- readOutputQ sv+        -- Reversing the output is important to guarantee that we process the+        -- outputs in the same order as they were generated by the constituent+        -- streams.+        return $ D.Skip $ FromSVarLoop sv (Prelude.reverse list)++    step _ (FromSVarLoop sv []) = return $ D.Skip $ FromSVarRead sv+    step _ (FromSVarLoop sv (ev : es)) = do+        case ev of+            ChildYield a -> return $ D.Yield a (FromSVarLoop sv es)+            ChildStop tid e -> do+                accountThread sv tid+                case e of+                    Nothing -> do+                        sendStopToProducer sv+                        return $ D.Skip (FromSVarDone sv)+                    Just _ -> error "Bug: fromProducer: received exception"++    step _ (FromSVarDone sv) = do+        when (svarInspectMode sv) $ do+            t <- liftIO $ getTime Monotonic+            liftIO $ writeIORef (svarStopTime (svarStats sv)) (Just t)+            liftIO $ printSVar sv "SVar Done"+        return D.Stop++    step _ FromSVarInit = undefined++-- | Like 'newFoldSVar' except that it uses a 'Fold' instead of a fold+-- function.+--+{-# INLINE newFoldSVarF #-}+newFoldSVarF :: MonadAsync m => State t m a -> Fold m a b -> m (SVar t m a)+newFoldSVarF stt f = do+    -- Buffer size for the SVar is derived from the current state+    sv <- newParallelVar StopAny (adaptState stt)+    -- Add the producer thread-id to the SVar.+    liftIO myThreadId >>= modifyThread sv+    void $ doFork (work sv) (svarMrun sv) (handleFoldException sv)+    return sv++    where++    {-# NOINLINE work #-}+    work sv = void $ D.fold f $ fromProducerD sv+ ------------------------------------------------------------------------------- -- Process events received by the producer thread from the consumer side -------------------------------------------------------------------------------@@ -198,8 +578,13 @@ -- generate exception more than once and the producer can ignore those -- exceptions or handle them and still keep driving the fold. --+-- | Poll for events sent by the fold consumer to the stream pusher. The fold+-- consumer can send a "Stop" event or an exception. When a "Stop" is received+-- this function returns 'True'. If an exception is recieved then it throws the+-- exception.+-- {-# NOINLINE fromConsumer #-}-fromConsumer :: MonadAsync m => SVar Stream m a -> m Bool+fromConsumer :: MonadAsync m => SVar K.Stream m a -> m Bool fromConsumer sv = do     (list, _) <- liftIO $ readOutputQBasic (outputQueueFromConsumer sv)     -- Reversing the output is important to guarantee that we process the@@ -219,9 +604,13 @@                     Just ex -> throwM ex             ChildYield _ -> error "Bug: fromConsumer: invalid ChildYield event" --- push values to a fold worker via an SVar. Returns whether the fold is done.+-- | Push values from a stream to a fold worker via an SVar. Before pushing a+-- value to the SVar it polls for events received from the fold consumer.  If a+-- stop event is received then it returns 'True' otherwise false.  Propagates+-- exceptions received from the fold consumer.+-- {-# INLINE pushToFold #-}-pushToFold :: MonadAsync m => SVar Stream m a -> a -> m Bool+pushToFold :: MonadAsync m => SVar K.Stream m a -> a -> m Bool pushToFold sv a = do     -- Check for exceptions before decrement so that we do not     -- block forever if the child already exited with an exception.@@ -242,3 +631,59 @@         decrementBufferLimit sv         void $ send sv (ChildYield a)         return False++------------------------------------------------------------------------------+-- Clone and distribute a stream in parallel+------------------------------------------------------------------------------++-- XXX this could be written in StreamD style for better efficiency with fusion.+--+-- | Tap a stream and send the elements to the specified SVar in addition to+-- yielding them again. The SVar runs a fold consumer. Elements are tapped and+-- sent to the SVar until the fold finishes. Any exceptions from the fold+-- evaluation are propagated in the current thread.+--+-- @+--+-- ------input stream---------output stream----->+--                    /|\\   |+--         exceptions  |    |  input+--                     |   \\|/+--                     ----SVar+--                          |+--                         Fold+--+-- @+--+{-# INLINE teeToSVar #-}+teeToSVar :: (K.IsStream t, MonadAsync m) =>+    SVar K.Stream m a -> t m a -> t m a+teeToSVar svr m = K.mkStream $ \st yld sng stp -> do+    K.foldStreamShared st yld sng stp (go False m)++    where++    go False m0 = K.mkStream $ \st yld _ stp -> do+        let drain = do+                -- In general, a Stop event would come equipped with the result+                -- of the fold. It is not used here but it would be useful in+                -- applicative and distribute.+                done <- fromConsumer svr+                when (not done) $ do+                    liftIO $ withDiagMVar svr "teeToSVar: waiting to drain"+                           $ takeMVar (outputDoorBellFromConsumer svr)+                    drain++            stopFold = do+                liftIO $ sendStop svr Nothing+                -- drain/wait until a stop event arrives from the fold.+                drain++            stop       = stopFold >> stp+            single a   = do+                done <- pushToFold svr a+                yld a (go done (K.nilM stopFold))+            yieldk a r = pushToFold svr a >>= \done -> yld a (go done r)+         in K.foldStreamShared st yieldk single stop m0++    go True m0 = m0
src/Streamly/Internal/Data/Stream/Serial.hs view
@@ -1,34 +1,25 @@-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE ConstraintKinds           #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE GeneralizedNewtypeDeriving#-}-{-# LANGUAGE InstanceSigs              #-}-{-# LANGUAGE MultiParamTypeClasses     #-}-{-# LANGUAGE TypeFamilies              #-}-{-# LANGUAGE UndecidableInstances      #-} -- XXX--#if MIN_VERSION_base(4,17,0)-{-# LANGUAGE TypeOperators             #-}-#endif+{-# LANGUAGE UndecidableInstances #-}  -- | -- Module      : Streamly.Internal.Data.Stream.Serial--- Copyright   : (c) 2017 Harendra Kumar+-- Copyright   : (c) 2017 Composewell Technologies -- -- License     : BSD3 -- Maintainer  : streamly@composewell.com -- Stability   : experimental -- Portability : GHC --+-- To run examples in this module: --+-- >>> import qualified Streamly.Prelude as Stream+-- module Streamly.Internal.Data.Stream.Serial     (     -- * Serial appending stream       SerialT     , Serial     , K.serial-    , serially+    , fromSerial      -- * Serial interleaving stream     , WSerialT@@ -36,7 +27,7 @@     , wSerial     , wSerialFst     , wSerialMin-    , wSerially+    , fromWSerial      -- * Construction     , unfoldrM@@ -60,7 +51,6 @@ #endif import Control.Monad.Base (MonadBase(..), liftBaseDefault) import Control.Monad.Catch (MonadThrow, throwM)--- import Control.Monad.Error.Class   (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Reader.Class (MonadReader(..)) import Control.Monad.State.Class (MonadState(..))@@ -73,89 +63,72 @@ import Data.Semigroup (Semigroup(..)) #endif import GHC.Exts (IsList(..), IsString(..))-import Text.Read (Lexeme(Ident), lexP, parens, prec, readPrec, readListPrec,-                  readListPrecDefault)-import Prelude hiding (map, mapM, errorWithoutStackTrace)+import Text.Read+       ( Lexeme(Ident), lexP, parens, prec, readPrec, readListPrec+       , readListPrecDefault)+import Streamly.Internal.BaseCompat ((#.), errorWithoutStackTrace, oneShot)+import Streamly.Internal.Data.Stream.StreamK.Type+       (IsStream(..), adapt, Stream, mkStream, foldStream)+import Streamly.Internal.Data.Maybe.Strict (Maybe'(..), toMaybe) -import Streamly.Internal.BaseCompat ((#.), errorWithoutStackTrace)-import Streamly.Internal.Data.Stream.StreamK (IsStream(..), adapt, Stream, mkStream,-                                 foldStream)-import Streamly.Internal.Data.Strict (Maybe'(..), toMaybe) import qualified Streamly.Internal.Data.Stream.Prelude as P-import qualified Streamly.Internal.Data.Stream.StreamK as K-import qualified Streamly.Internal.Data.Stream.StreamD as D+    (cmpBy, foldl', foldr, eqBy, fromList, toList)+import qualified Streamly.Internal.Data.Stream.StreamK as K (withLocal)+import qualified Streamly.Internal.Data.Stream.StreamK.Type as K+import qualified Streamly.Internal.Data.Stream.StreamD.Generate as D (unfoldrM)+import qualified Streamly.Internal.Data.Stream.StreamD.Type as D +import Prelude hiding (map, mapM, errorWithoutStackTrace)+ #include "Instances.hs" #include "inline.hs" +-- $setup+-- >>> import qualified Streamly.Prelude as Stream+ ------------------------------------------------------------------------------ -- SerialT ------------------------------------------------------------------------------ --- | The 'Semigroup' operation for 'SerialT' behaves like a regular append--- operation.  Therefore, when @a <> b@ is evaluated, stream @a@ is evaluated--- first until it exhausts and then stream @b@ is evaluated. In other words,--- the elements of stream @b@ are appended to the elements of stream @a@. This--- operation can be used to fold an infinite lazy container of streams.------ @--- import Streamly--- import qualified "Streamly.Prelude" as S------ main = (S.toList . 'serially' $ (S.fromList [1,2]) \<\> (S.fromList [3,4])) >>= print--- @--- @--- [1,2,3,4]--- @------ The 'Monad' instance runs the /monadic continuation/ for each--- element of the stream, serially.+-- | For 'SerialT' streams: -- -- @--- main = S.drain . 'serially' $ do---     x <- return 1 \<\> return 2---     S.yieldM $ print x--- @--- @--- 1--- 2+-- (<>) = 'Streamly.Prelude.serial'                       -- 'Semigroup'+-- (>>=) = flip . 'Streamly.Prelude.concatMapWith' 'Streamly.Prelude.serial' -- 'Monad' -- @ ----- 'SerialT' nests streams serially in a depth first manner.+-- A single 'Monad' bind behaves like a @for@ loop: ----- @--- main = S.drain . 'serially' $ do---     x <- return 1 \<\> return 2---     y <- return 3 \<\> return 4---     S.yieldM $ print (x, y)--- @--- @--- (1,3)--- (1,4)--- (2,3)--- (2,4)--- @+-- >>> :{+-- Stream.toList $ do+--      x <- Stream.fromList [1,2] -- foreach x in stream+--      return x+-- :}+-- [1,2] ----- We call the monadic code being run for each element of the stream a monadic--- continuation. In imperative paradigm we can think of this composition as--- nested @for@ loops and the monadic continuation is the body of the loop. The--- loop iterates for all elements of the stream.+-- Nested monad binds behave like nested @for@ loops: ----- Note that the behavior and semantics  of 'SerialT', including 'Semigroup'--- and 'Monad' instances are exactly like Haskell lists except that 'SerialT'--- can contain effectful actions while lists are pure.+-- >>> :{+-- Stream.toList $ do+--     x <- Stream.fromList [1,2] -- foreach x in stream+--     y <- Stream.fromList [3,4] -- foreach y in stream+--     return (x, y)+-- :}+-- [(1,3),(1,4),(2,3),(2,4)] ----- In the code above, the 'serially' combinator can be omitted as the default--- stream type is 'SerialT'.+-- /Since: 0.2.0 ("Streamly")/ ----- @since 0.2.0+-- @since 0.8.0 newtype SerialT m a = SerialT {getSerialT :: Stream m a}+    -- XXX when deriving do we inherit an INLINE?     deriving (Semigroup, Monoid, MonadTrans)  -- | A serial IO stream of elements of type @a@. See 'SerialT' documentation -- for more details. ----- @since 0.2.0+-- /Since: 0.2.0 ("Streamly")/+--+-- @since 0.8.0 type Serial = SerialT IO  -- |@@ -165,9 +138,11 @@  -- | Fix the type of a polymorphic stream as 'SerialT'. ----- @since 0.1.0-serially :: IsStream t => SerialT m a -> t m a-serially = adapt+-- /Since: 0.1.0 ("Streamly")/+--+-- @since 0.8.0+fromSerial :: IsStream t => SerialT m a -> t m a+fromSerial = adapt  {-# INLINE consMSerial #-} {-# SPECIALIZE consMSerial :: IO a -> SerialT IO a -> SerialT IO a #-}@@ -186,15 +161,23 @@  instance Monad m => Monad (SerialT m) where     return = pure++    -- Benchmarks better with StreamD bind and pure:+    -- toList, filterAllout, *>, *<, >> (~2x)+    --+    -- pure = SerialT . 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 (>>=) #-}     (>>=) = K.bindWith K.serial+     {-# INLINE (>>) #-}     (>>)  = (*>) -    -- StreamD based implementation-    -- return = SerialT . D.fromStreamD . D.yield-    -- m >>= f = D.fromStreamD $ D.concatMap (\a -> D.toStreamD (f a)) (D.toStreamD m)- ------------------------------------------------------------------------------ -- Other instances ------------------------------------------------------------------------------@@ -222,20 +205,42 @@  {-# INLINE apSerial #-} apSerial :: Monad m => SerialT m (a -> b) -> SerialT m a -> SerialT m b-apSerial (SerialT m1) (SerialT m2) = D.fromStreamD $ D.toStreamD m1 <*> D.toStreamD m2+apSerial (SerialT m1) (SerialT m2) =+    D.fromStreamD $ D.toStreamD m1 <*> D.toStreamD m2  {-# INLINE apSequence #-} apSequence :: Monad m => SerialT m a -> SerialT m b -> SerialT m b-apSequence (SerialT m1) (SerialT m2) = D.fromStreamD $ D.toStreamD m1 *> D.toStreamD m2+apSequence (SerialT m1) (SerialT m2) =+    D.fromStreamD $ D.toStreamD m1 *> D.toStreamD m2 +{-# INLINE apDiscardSnd #-}+apDiscardSnd :: Monad m => SerialT m a -> SerialT m b -> SerialT m a+apDiscardSnd (SerialT m1) (SerialT m2) =+    D.fromStreamD $ D.toStreamD m1 <* D.toStreamD m2++-- Note: we need to define all the typeclass operations because we want to+-- INLINE them. instance Monad m => Applicative (SerialT m) where     {-# INLINE pure #-}-    pure = SerialT . K.yield+    pure = SerialT . K.fromPure+     {-# INLINE (<*>) #-}     (<*>) = apSerial+    -- (<*>) = K.apSerial++#if MIN_VERSION_base(4,10,0)+    {-# INLINE liftA2 #-}+    liftA2 f x = (<*>) (fmap f x)+#endif+     {-# INLINE (*>) #-}     (*>)  = apSequence+    -- (*>)  = K.apSerialDiscardFst +    {-# INLINE (<*) #-}+    (<*) = apDiscardSnd+    -- (<*)  = K.apSerialDiscardSnd+ MONAD_COMMON_INSTANCES(SerialT,) LIST_INSTANCES(SerialT) NFDATA1_INSTANCE(SerialT)@@ -246,63 +251,58 @@ -- WSerialT ------------------------------------------------------------------------------ --- | The 'Semigroup' operation for 'WSerialT' interleaves the elements from the--- two streams.  Therefore, when @a <> b@ is evaluated, stream @a@ is evaluated--- first to produce the first element of the combined stream and then stream--- @b@ is evaluated to produce the next element of the combined stream, and--- then we go back to evaluating stream @a@ and so on. In other words, the--- elements of stream @a@ are interleaved with the elements of stream @b@.+-- | For 'WSerialT' streams: ----- Note that evaluation of @a <> b <> c@ does not schedule @a@, @b@ and @c@--- with equal priority.  This expression is equivalent to @a <> (b <> c)@,--- therefore, it fairly interleaves @a@ with the result of @b <> c@.  For--- example, @S.fromList [1,2] <> S.fromList [3,4] <> S.fromList [5,6] ::--- WSerialT Identity Int@ would result in [1,3,2,5,4,6].  In other words, the--- leftmost stream gets the same scheduling priority as the rest of the--- streams taken together. The same is true for each subexpression on the right.+-- @+-- (<>) = 'Streamly.Prelude.wSerial'                       -- 'Semigroup'+-- (>>=) = flip . 'Streamly.Prelude.concatMapWith' 'Streamly.Prelude.wSerial' -- 'Monad'+-- @ ----- Note that this operation cannot be used to fold a container of infinite--- streams as the state that it needs to maintain is proportional to the number--- of streams.+-- Note that '<>' is associative only if we disregard the ordering of elements+-- in the resulting stream. ----- The @W@ in the name stands for @wide@ or breadth wise scheduling in--- contrast to the depth wise scheduling behavior of 'SerialT'.+-- A single 'Monad' bind behaves like a @for@ loop: ----- @--- import Streamly--- import qualified "Streamly.Prelude" as S+-- >>> :{+-- Stream.toList $ Stream.fromWSerial $ do+--      x <- Stream.fromList [1,2] -- foreach x in stream+--      return x+-- :}+-- [1,2] ----- main = (S.toList . 'wSerially' $ (S.fromList [1,2]) \<\> (S.fromList [3,4])) >>= print--- @--- @--- [1,3,2,4]--- @+-- Nested monad binds behave like interleaved nested @for@ loops: ----- Similarly, the 'Monad' instance interleaves the iterations of the--- inner and the outer loop, nesting loops in a breadth first manner.+-- >>> :{+-- Stream.toList $ Stream.fromWSerial $ do+--     x <- Stream.fromList [1,2] -- foreach x in stream+--     y <- Stream.fromList [3,4] -- foreach y in stream+--     return (x, y)+-- :}+-- [(1,3),(2,3),(1,4),(2,4)] --+-- It is a result of interleaving all the nested iterations corresponding to+-- element @1@ in the first stream with all the nested iterations of element+-- @2@: ----- @--- main = S.drain . 'wSerially' $ do---     x <- return 1 \<\> return 2---     y <- return 3 \<\> return 4---     S.yieldM $ print (x, y)--- @--- @--- (1,3)--- (2,3)--- (1,4)--- (2,4)--- @+-- >>> import Streamly.Prelude (wSerial)+-- >>> Stream.toList $ Stream.fromList [(1,3),(1,4)] `wSerial` Stream.fromList [(2,3),(2,4)]+-- [(1,3),(2,3),(1,4),(2,4)] ----- @since 0.2.0+-- The @W@ in the name stands for @wide@ or breadth wise scheduling in+-- contrast to the depth wise scheduling behavior of 'SerialT'.+--+-- /Since: 0.2.0 ("Streamly")/+--+-- @since 0.8.0 newtype WSerialT m a = WSerialT {getWSerialT :: Stream m a}     deriving (MonadTrans)  -- | An interleaving serial IO stream of elements of type @a@. See 'WSerialT' -- documentation for more details. ----- @since 0.2.0+-- /Since: 0.2.0 ("Streamly")/+--+-- @since 0.8.0 type WSerial = WSerialT IO  -- |@@ -312,16 +312,18 @@  -- | Fix the type of a polymorphic stream as 'WSerialT'. ----- @since 0.2.0-wSerially :: IsStream t => WSerialT m a -> t m a-wSerially = adapt+-- /Since: 0.2.0 ("Streamly")/+--+-- @since 0.8.0+fromWSerial :: IsStream t => WSerialT m a -> t m a+fromWSerial = adapt --- | Same as 'wSerially'.+-- | Same as 'fromWSerial'. -- -- @since 0.1.0-{-# DEPRECATED interleaving "Please use wSerially instead." #-}+{-# DEPRECATED interleaving "Please use fromWSerial instead." #-} interleaving :: IsStream t => WSerialT m a -> t m a-interleaving = wSerially+interleaving = fromWSerial  consMWSerial :: Monad m => m a -> WSerialT m a -> WSerialT m a consMWSerial m ms = fromStream $ K.consMStream m (toStream ms)@@ -344,6 +346,8 @@ -- Semigroup ------------------------------------------------------------------------------ +infixr 6 `wSerial`+ -- 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@@ -351,12 +355,37 @@ -- -- Similar combinators can be implemented using WAhead style. --- | Polymorphic version of the 'Semigroup' operation '<>' of 'WSerialT'.--- 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.+-- | 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. ----- @since 0.2.0+-- >>> import Streamly.Prelude (wSerial)+-- >>> stream1 = Stream.fromList [1,2]+-- >>> stream2 = Stream.fromList [3,4]+-- >>> Stream.toList $ Stream.fromWSerial $ stream1 `wSerial` stream2+-- [1,3,2,4]+--+-- Note, for singleton streams 'wSerial' and 'serial' are identical.+--+-- Note that this operation cannot be used to fold a container of infinite+-- streams but it can be used for very large streams as the state that it needs+-- to maintain is proportional to the logarithm of the number of streams.+--+-- @since 0.8.0+--+-- /Since: 0.2.0 ("Streamly")/++-- Scheduling Notes:+--+-- Note that evaluation of @a \`wSerial` b \`wSerial` c@ does not interleave+-- @a@, @b@ and @c@ with equal priority.  This expression is equivalent to @a+-- \`wSerial` (b \`wSerial` c)@, therefore, it fairly interleaves @a@ with the+-- result of @b \`wSerial` c@.  For example, @Stream.fromList [1,2] \`wSerial`+-- Stream.fromList [3,4] \`wSerial` Stream.fromList [5,6]@ would result in+-- [1,3,2,5,4,6].  In other words, the leftmost stream gets the same scheduling+-- priority as the rest of the streams taken together. The same is true for+-- each subexpression on the right.+-- {-# INLINE wSerial #-} wSerial :: IsStream t => t m a -> t m a -> t m a wSerial m1 m2 = mkStream $ \st yld sng stp -> do@@ -388,10 +417,12 @@ -- @since 0.7.0 {-# INLINE wSerialMin #-} wSerialMin :: IsStream t => t m a -> t m a -> t m a-wSerialMin m1 m2 = mkStream $ \st yld sng stp -> do+wSerialMin m1 m2 = mkStream $ \st yld _ stp -> do     let stop       = stp-        single a   = sng a-        yieldk a r = yld a (wSerial m2 r)+        -- "single a" is defined as "yld a (wSerialMin m2 K.nil)" instead of+        -- "sng a" to keep the behaviour consistent with the yield continuation.+        single a   = yld a (wSerialMin m2 K.nil)+        yieldk a r = yld a (wSerialMin m2 r)     foldStream st yieldk single stop m1  instance Semigroup (WSerialT m a) where@@ -423,7 +454,7 @@  instance Monad m => Applicative (WSerialT m) where     {-# INLINE pure #-}-    pure = WSerialT . K.yield+    pure = WSerialT . K.fromPure     {-# INLINE (<*>) #-}     (<*>) = apWSerial @@ -469,7 +500,7 @@ --  3 -- @ ----- /Internal/+-- /Pre-release/ -- {-# INLINE unfoldrM #-} unfoldrM :: (IsStream t, Monad m) => (b -> m (Maybe (a, b))) -> b -> t m a
src/Streamly/Internal/Data/Stream/StreamD.hs view
@@ -1,4482 +1,36 @@-{-# LANGUAGE BangPatterns              #-}-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE ConstraintKinds           #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE MultiParamTypeClasses     #-}-{-# LANGUAGE PatternSynonyms           #-}-{-# LANGUAGE RecordWildCards           #-}-{-# LANGUAGE ScopedTypeVariables       #-}-{-# LANGUAGE ViewPatterns              #-}-{-# LANGUAGE RankNTypes                #-}-{-# LANGUAGE MagicHash                 #-}--#if __GLASGOW_HASKELL__ >= 801-{-# LANGUAGE TypeApplications          #-}-#endif--#include "inline.hs"---- |--- Module      : Streamly.Internal.Data.Stream.StreamD--- Copyright   : (c) 2018 Harendra Kumar---               (c) Roman Leshchinskiy 2008-2010---               (c) The University of Glasgow, 2009------ License     : BSD3--- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC------ Direct style re-implementation of CPS style stream in StreamK module.  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--- @---- Some of the functions in this file have been adapted from the vector--- library,  https://hackage.haskell.org/package/vector.--module Streamly.Internal.Data.Stream.StreamD-    (-    -- * The stream type-      Step (..)--#if __GLASGOW_HASKELL__ >= 800-    , Stream (Stream, UnStream)-#else-    , Stream (UnStream)-    , pattern Stream-#endif--    -- * Construction-    , nil-    , nilM-    , cons--    -- * Deconstruction-    , uncons--    -- * Generation-    -- ** Unfolds-    , unfoldr-    , unfoldrM-    , unfold--    -- ** Specialized Generation-    -- | Generate a monadic stream from a seed.-    , repeat-    , repeatM-    , replicate-    , replicateM-    , fromIndices-    , fromIndicesM-    , generate-    , generateM-    , iterate-    , iterateM--    -- ** Enumerations-    , enumerateFromStepIntegral-    , enumerateFromIntegral-    , enumerateFromThenIntegral-    , enumerateFromToIntegral-    , enumerateFromThenToIntegral--    , enumerateFromStepNum-    , numFrom-    , numFromThen-    , enumerateFromToFractional-    , enumerateFromThenToFractional--    -- ** Time-    , currentTime--    -- ** Conversions-    -- | Transform an input structure into a stream.-    -- | Direct style stream does not support @fromFoldable@.-    , yield-    , yieldM-    , fromList-    , fromListM-    , fromStreamK-    , fromStreamD-    , fromPrimVar-    , fromSVar--    -- * Elimination-    -- ** General Folds-    , foldrS-    , foldrT-    , foldrM-    , foldrMx-    , foldr-    , foldr1--    , foldl'-    , foldlM'-    , foldlS-    , foldlT-    , reverse-    , reverse'--    , foldlx'-    , foldlMx'-    , runFold--    , parselMx'-    , splitParse--    -- ** Specialized Folds-    , tap-    , tapOffsetEvery-    , tapAsync-    , tapRate-    , pollCounts-    , drain-    , null-    , head-    , headElse-    , tail-    , last-    , elem-    , notElem-    , all-    , any-    , maximum-    , maximumBy-    , minimum-    , minimumBy-    , findIndices-    , lookup-    , findM-    , find-    , (!!)-    , toSVarParallel--    -- ** Flattening nested streams-    , concatMapM-    , concatMap-    , ConcatMapUState (..)-    , concatMapU-    , ConcatUnfoldInterleaveState (..)-    , concatUnfoldInterleave-    , concatUnfoldRoundrobin-    , AppendState(..)-    , append-    , InterleaveState(..)-    , interleave-    , interleaveMin-    , interleaveSuffix-    , interleaveInfix-    , roundRobin -- interleaveFair?/ParallelFair-    , gintercalateSuffix-    , interposeSuffix-    , gintercalate-    , interpose--    -- ** Grouping-    , groupsOf-    , groupsOf2-    , groupsBy-    , groupsRollingBy--    -- ** Splitting-    , splitBy-    , splitSuffixBy-    , wordsBy-    , splitSuffixBy'--    , splitOn-    , splitSuffixOn--    , splitInnerBy-    , splitInnerBySuffix--    -- ** Substreams-    , isPrefixOf-    , isSubsequenceOf-    , stripPrefix--    -- ** Map and Fold-    , mapM_--    -- ** Conversions-    -- | Transform a stream into another type.-    , toList-    , toListRev-    , toStreamK-    , toStreamD--    , hoist-    , generally--    , liftInner-    , runReaderT-    , evalStateT-    , runStateT--    -- * Transformation-    , transform--    -- ** By folding (scans)-    , scanlM'-    , scanl'-    , scanlM-    , scanl-    , scanl1M'-    , scanl1'-    , scanl1M-    , scanl1--    , prescanl'-    , prescanlM'--    , postscanl-    , postscanlM-    , postscanl'-    , postscanlM'--    , postscanlx'-    , postscanlMx'-    , scanlMx'-    , scanlx'--    -- * Filtering-    , filter-    , filterM-    , uniq-    , take-    , takeByTime-    , takeWhile-    , takeWhileM-    , drop-    , dropByTime-    , dropWhile-    , dropWhileM--    -- * Mapping-    , map-    , mapM-    , sequence-    , rollingMap-    , rollingMapM--    -- * Inserting-    , intersperseM-    , intersperse-    , intersperseSuffix-    , intersperseSuffixBySpan-    , insertBy--    -- * Deleting-    , deleteBy--    -- ** Map and Filter-    , mapMaybe-    , mapMaybeM--    -- * Zipping-    , indexed-    , indexedR-    , zipWith-    , zipWithM--    -- * Comparisons-    , eqBy-    , cmpBy--    -- * Merging-    , mergeBy-    , mergeByM--    -- * Transformation comprehensions-    , the--    -- * Exceptions-    , newFinalizedIORef-    , runIORefFinalizer-    , clearIORefFinalizer-    , gbracket-    , before-    , after-    , afterIO-    , bracket-    , bracketIO-    , onException-    , finally-    , finallyIO-    , handle--    -- * Concurrent Application-    , mkParallel-    , mkParallelD-    , newCallbackStream--    , lastN-    )-where--import Control.Concurrent (killThread, myThreadId, takeMVar, threadDelay)-import Control.Exception-       (assert, Exception, SomeException, AsyncException, fromException, mask_)-import Control.Monad (void, when, forever)-import Control.Monad.Catch (MonadCatch, MonadThrow, throwM)-import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad.Reader (ReaderT)-import Control.Monad.State.Strict (StateT)-import Control.Monad.Trans (MonadTrans(lift))-import Control.Monad.Trans.Control (MonadBaseControl, liftBaseOp_)-import Data.Bits (shiftR, shiftL, (.|.), (.&.))-import Data.Functor.Identity (Identity(..))-import Data.Int (Int64)-import Data.IORef (newIORef, readIORef, mkWeakIORef, writeIORef, IORef)-import Data.Maybe (fromJust, isJust, isNothing)-import Data.Word (Word32)-import Foreign.Ptr (Ptr)-import Foreign.Storable (Storable(..))-import GHC.Types (SPEC(..))-import System.Mem (performMajorGC)-import Prelude-       hiding (map, mapM, mapM_, repeat, foldr, last, take, filter,-               takeWhile, drop, dropWhile, all, any, maximum, minimum, elem,-               notElem, null, head, tail, zipWith, lookup, foldr1, sequence,-               (!!), scanl, scanl1, concatMap, replicate, enumFromTo, concat,-               reverse, iterate, splitAt)--import qualified Control.Monad.Catch as MC-import qualified Control.Monad.Reader as Reader-import qualified Control.Monad.State.Strict as State-import qualified Prelude--import Fusion.Plugin.Types (Fuse(..))-import Streamly.Internal.Mutable.Prim.Var-       (Prim, Var, readVar, newVar, modifyVar')-import Streamly.Internal.Data.Time.Units-       (TimeUnit64, toRelTime64, diffAbsTime64)--import Streamly.Internal.Data.Atomics (atomicModifyIORefCAS_)-import Streamly.Internal.Memory.Array.Types (Array(..))-import Streamly.Internal.Data.Fold.Types (Fold(..))-import Streamly.Internal.Data.Parser.Types (Parser(..), ParseError(..))-import Streamly.Internal.Data.Pipe.Types (Pipe(..), PipeState(..))-import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime)-import Streamly.Internal.Data.Time.Units-       (MicroSecond64(..), fromAbsTime, toAbsTime, AbsTime)-import Streamly.Internal.Data.Unfold.Types (Unfold(..))-import Streamly.Internal.Data.Strict (Tuple3'(..))--import Streamly.Internal.Data.Stream.StreamD.Type-import Streamly.Internal.Data.SVar-import Streamly.Internal.Data.Stream.SVar (fromConsumer, pushToFold)--import qualified Streamly.Internal.Data.Pipe.Types as Pipe-import qualified Streamly.Internal.Memory.Array.Types as A-import qualified Streamly.Internal.Data.Fold as FL-import qualified Streamly.Memory.Ring as RB-import qualified Streamly.Internal.Data.Stream.StreamK as K-import qualified Streamly.Internal.Data.Parser.Types as PR----------------------------------------------------------------------------------- Construction----------------------------------------------------------------------------------- | An empty 'Stream'.-{-# INLINE_NORMAL nil #-}-nil :: Monad m => Stream m a-nil = Stream (\_ _ -> return Stop) ()---- | An empty 'Stream' with a side effect.-{-# INLINE_NORMAL nilM #-}-nilM :: Monad m => m b -> Stream m a-nilM m = Stream (\_ _ -> m >> return Stop) ()--{-# INLINE_NORMAL consM #-}-consM :: Monad m => m a -> Stream m a -> Stream m a-consM m (Stream step state) = Stream step1 Nothing-    where-    {-# INLINE_LATE step1 #-}-    step1 _ Nothing   = m >>= \x -> return $ Yield x (Just state)-    step1 gst (Just st) = do-        r <- step gst st-        return $-          case r of-            Yield a s -> Yield a (Just s)-            Skip  s   -> Skip (Just s)-            Stop      -> Stop---- XXX implement in terms of consM?--- cons x = consM (return x)------ | Can fuse but has O(n^2) complexity.-{-# INLINE_NORMAL cons #-}-cons :: Monad m => a -> Stream m a -> Stream m a-cons x (Stream step state) = Stream step1 Nothing-    where-    {-# INLINE_LATE step1 #-}-    step1 _ Nothing   = return $ Yield x (Just state)-    step1 gst (Just st) = do-        r <- step gst st-        return $-          case r of-            Yield a s -> Yield a (Just s)-            Skip  s   -> Skip (Just s)-            Stop      -> Stop------------------------------------------------------------------------------------ Deconstruction------------------------------------------------------------------------------------ Does not fuse, has the same performance as the StreamK version.-{-# INLINE_NORMAL uncons #-}-uncons :: Monad m => Stream m a -> m (Maybe (a, Stream m a))-uncons (UnStream step state) = go state-  where-    go st = do-        r <- step defState st-        case r of-            Yield x s -> return $ Just (x, Stream step s)-            Skip  s   -> go s-            Stop      -> return Nothing----------------------------------------------------------------------------------- Generation by unfold---------------------------------------------------------------------------------{-# INLINE_NORMAL unfoldrM #-}-unfoldrM :: Monad m => (s -> m (Maybe (a, s))) -> s -> Stream m a-unfoldrM next state = Stream step state-  where-    {-# INLINE_LATE step #-}-    step _ st = do-        r <- next st-        return $ case r of-            Just (x, s) -> Yield x s-            Nothing     -> Stop--{-# INLINE_LATE unfoldr #-}-unfoldr :: Monad m => (s -> Maybe (a, s)) -> s -> Stream m a-unfoldr f = unfoldrM (return . f)---- | Convert an 'Unfold' into a 'Stream' by supplying it a seed.----{-# INLINE_NORMAL unfold #-}-unfold :: Monad m => Unfold m a b -> a -> Stream m b-unfold (Unfold ustep inject) seed = Stream step Nothing-  where-    {-# INLINE_LATE step #-}-    step _ Nothing = inject seed >>= return . Skip . Just-    step _ (Just st) = do-        r <- ustep st-        return $ case r of-            Yield x s -> Yield x (Just s)-            Skip s    -> Skip (Just s)-            Stop      -> Stop----------------------------------------------------------------------------------- Specialized Generation---------------------------------------------------------------------------------{-# INLINE_NORMAL repeatM #-}-repeatM :: Monad m => m a -> Stream m a-repeatM x = Stream (\_ _ -> x >>= \r -> return $ Yield r ()) ()--{-# INLINE_NORMAL repeat #-}-repeat :: Monad m => a -> Stream m a-repeat x = Stream (\_ _ -> return $ Yield x ()) ()--{-# INLINE_NORMAL iterateM #-}-iterateM :: Monad m => (a -> m a) -> m a -> Stream m a-iterateM step = Stream (\_ st -> st >>= \x -> return $ Yield x (step x))--{-# INLINE_NORMAL iterate #-}-iterate :: Monad m => (a -> a) -> a -> Stream m a-iterate step st = iterateM (return . step) (return st)--{-# INLINE_NORMAL replicateM #-}-replicateM :: forall m a. Monad m => Int -> m a -> Stream m a-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)--{-# INLINE_NORMAL replicate #-}-replicate :: Monad m => Int -> a -> Stream m a-replicate n x = replicateM n (return x)---- This would not work properly for floats, therefore we put an Integral--- constraint.--- | Can be used to enumerate unbounded integrals. This does not check for--- overflow or underflow for bounded integrals.-{-# INLINE_NORMAL enumerateFromStepIntegral #-}-enumerateFromStepIntegral :: (Integral a, Monad m) => a -> a -> Stream m a-enumerateFromStepIntegral from stride =-    from `seq` stride `seq` Stream step from-    where-        {-# INLINE_LATE step #-}-        step _ !x = return $ Yield x $! (x + stride)---- We are assuming that "to" is constrained by the type to be within--- max/min bounds.-{-# INLINE enumerateFromToIntegral #-}-enumerateFromToIntegral :: (Monad m, Integral a) => a -> a -> Stream m a-enumerateFromToIntegral from to =-    takeWhile (<= to) $ enumerateFromStepIntegral from 1--{-# INLINE enumerateFromIntegral #-}-enumerateFromIntegral :: (Monad m, Integral a, Bounded a) => a -> Stream m a-enumerateFromIntegral from = enumerateFromToIntegral from maxBound--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--{-# INLINE_NORMAL enumerateFromThenToIntegral #-}-enumerateFromThenToIntegral-    :: (Monad m, Integral a)-    => a -> a -> a -> Stream m a-enumerateFromThenToIntegral from next to-    | next >= from = enumerateFromThenToIntegralUp from next to-    | otherwise    = enumerateFromThenToIntegralDn from next to--{-# INLINE_NORMAL enumerateFromThenIntegral #-}-enumerateFromThenIntegral-    :: (Monad m, Integral a, Bounded a)-    => a -> a -> Stream m a-enumerateFromThenIntegral from next =-    if next > from-    then enumerateFromThenToIntegralUp from next maxBound-    else enumerateFromThenToIntegralDn from next minBound---- 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-enumerateFromStepNum from stride = Stream step 0-    where-    {-# INLINE_LATE step #-}-    step _ !i = return $ (Yield $! (from + i * stride)) $! (i + 1)--{-# INLINE_NORMAL numFrom #-}-numFrom :: (Monad m, Num a) => a -> Stream m a-numFrom from = enumerateFromStepNum from 1--{-# INLINE_NORMAL numFromThen #-}-numFromThen :: (Monad m, Num a) => a -> a -> Stream m a-numFromThen from next = enumerateFromStepNum from (next - from)---- 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.-{-# 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--{-# INLINE_NORMAL enumerateFromThenToFractional #-}-enumerateFromThenToFractional-    :: (Monad m, Fractional a, Ord a)-    => a -> a -> a -> Stream m a-enumerateFromThenToFractional from next to =-    takeWhile predicate $ numFromThen from next-    where-    mid = (next - from) / 2-    predicate | next >= from  = (<= to + mid)-              | otherwise     = (>= to + mid)------------------------------------------------------------------------------------ Generation by Conversion----------------------------------------------------------------------------------{-# INLINE_NORMAL fromIndicesM #-}-fromIndicesM :: Monad m => (Int -> m a) -> Stream m a-fromIndicesM gen = Stream step 0-  where-    {-# INLINE_LATE step #-}-    step _ i = do-       x <- gen i-       return $ Yield x (i + 1)--{-# INLINE fromIndices #-}-fromIndices :: Monad m => (Int -> a) -> Stream m a-fromIndices gen = fromIndicesM (return . gen)--{-# 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)---- XXX we need the MonadAsync constraint because of a rewrite rule.--- | Convert a list of monadic actions to a 'Stream'-{-# INLINE_LATE fromListM #-}-fromListM :: MonadAsync m => [m a] -> Stream m a-fromListM = Stream step-  where-    {-# INLINE_LATE step #-}-    step _ (m:ms) = m >>= \x -> return $ Yield x ms-    step _ []     = return Stop--{-# INLINE toStreamD #-}-toStreamD :: (K.IsStream t, Monad m) => t m a -> Stream m a-toStreamD = fromStreamK . K.toStream--{-# INLINE_NORMAL fromPrimVar #-}-fromPrimVar :: (MonadIO m, Prim a) => Var IO a -> Stream m a-fromPrimVar var = Stream step ()-  where-    {-# INLINE_LATE step #-}-    step _ () = liftIO (readVar var) >>= \x -> return $ Yield x ()------------------------------------------------------------------------------------ Generation from SVar----------------------------------------------------------------------------------data FromSVarState t m a =-      FromSVarInit-    | FromSVarRead (SVar t m a)-    | FromSVarLoop (SVar t m a) [ChildEvent a]-    | FromSVarDone (SVar t m a)--{-# INLINE_NORMAL fromSVar #-}-fromSVar :: (MonadAsync m) => SVar t m a -> Stream m a-fromSVar svar = Stream step FromSVarInit-    where--    {-# INLINE_LATE step #-}-    step _ FromSVarInit = do-        ref <- liftIO $ newIORef ()-        _ <- liftIO $ mkWeakIORef ref hook-        -- when this copy of svar gets garbage collected "ref" will get-        -- garbage collected and our GC hook will be called.-        let sv = svar{svarRef = Just ref}-        return $ Skip (FromSVarRead sv)--        where--        {-# NOINLINE hook #-}-        hook = do-            when (svarInspectMode svar) $ do-                r <- liftIO $ readIORef (svarStopTime (svarStats svar))-                when (isNothing r) $-                    printSVar svar "SVar Garbage Collected"-            cleanupSVar svar-            -- If there are any SVars referenced by this SVar a GC will prompt-            -- them to be cleaned up quickly.-            when (svarInspectMode svar) performMajorGC--    step _ (FromSVarRead sv) = do-        list <- readOutputQ sv-        -- Reversing the output is important to guarantee that we process the-        -- outputs in the same order as they were generated by the constituent-        -- streams.-        return $ Skip $ FromSVarLoop sv (Prelude.reverse list)--    step _ (FromSVarLoop sv []) = do-        done <- postProcess sv-        return $ Skip $ if done-                      then (FromSVarDone sv)-                      else (FromSVarRead sv)--    step _ (FromSVarLoop sv (ev : es)) = do-        case ev of-            ChildYield a -> return $ Yield a (FromSVarLoop sv es)-            ChildStop tid e -> do-                accountThread sv tid-                case e of-                    Nothing -> do-                        stop <- shouldStop tid-                        if stop-                        then do-                            liftIO (cleanupSVar sv)-                            return $ Skip (FromSVarDone sv)-                        else return $ Skip (FromSVarLoop sv es)-                    Just ex ->-                        case fromException ex of-                            Just ThreadAbort ->-                                return $ Skip (FromSVarLoop sv es)-                            Nothing -> liftIO (cleanupSVar sv) >> throwM ex-        where--        shouldStop tid =-            case svarStopStyle sv of-                StopNone -> return False-                StopAny -> return True-                StopBy -> do-                    sid <- liftIO $ readIORef (svarStopBy sv)-                    return $ if tid == sid then True else False--    step _ (FromSVarDone sv) = do-        when (svarInspectMode sv) $ do-            t <- liftIO $ getTime Monotonic-            liftIO $ writeIORef (svarStopTime (svarStats sv)) (Just t)-            liftIO $ printSVar sv "SVar Done"-        return Stop------------------------------------------------------------------------------------ Process events received by a fold consumer from a stream producer----------------------------------------------------------------------------------{-# INLINE_NORMAL fromProducer #-}-fromProducer :: (MonadAsync m) => SVar t m a -> Stream m a-fromProducer svar = Stream step (FromSVarRead svar)-    where--    {-# INLINE_LATE step #-}-    step _ (FromSVarRead sv) = do-        list <- readOutputQ sv-        -- Reversing the output is important to guarantee that we process the-        -- outputs in the same order as they were generated by the constituent-        -- streams.-        return $ Skip $ FromSVarLoop sv (Prelude.reverse list)--    step _ (FromSVarLoop sv []) = return $ Skip $ FromSVarRead sv-    step _ (FromSVarLoop sv (ev : es)) = do-        case ev of-            ChildYield a -> return $ Yield a (FromSVarLoop sv es)-            ChildStop tid e -> do-                accountThread sv tid-                case e of-                    Nothing -> do-                        sendStopToProducer sv-                        return $ Skip (FromSVarDone sv)-                    Just _ -> error "Bug: fromProducer: received exception"--    step _ (FromSVarDone sv) = do-        when (svarInspectMode sv) $ do-            t <- liftIO $ getTime Monotonic-            liftIO $ writeIORef (svarStopTime (svarStats sv)) (Just t)-            liftIO $ printSVar sv "SVar Done"-        return Stop--    step _ FromSVarInit = undefined------------------------------------------------------------------------------------ Hoisting the inner monad----------------------------------------------------------------------------------{-# INLINE_NORMAL hoist #-}-hoist :: Monad n => (forall x. m x -> n x) -> Stream m a -> Stream n a-hoist 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--{-# INLINE generally #-}-generally :: Monad m => Stream Identity a -> Stream m a-generally = hoist (return . runIdentity)--{-# 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--{-# INLINE_NORMAL runReaderT #-}-runReaderT :: Monad m => s -> Stream (ReaderT s m) a -> Stream m a-runReaderT sval (Stream step state) = Stream step' state-    where-    {-# INLINE_LATE step' #-}-    step' gst st = do-        r <- Reader.runReaderT (step (adaptState gst) st) sval-        return $ case r of-            Yield x s -> Yield x s-            Skip  s   -> Skip s-            Stop      -> Stop--{-# INLINE_NORMAL evalStateT #-}-evalStateT :: Monad m => s -> Stream (StateT s m) a -> Stream m a-evalStateT sval (Stream step state) = Stream step' (state, sval)-    where-    {-# INLINE_LATE step' #-}-    step' gst (st, sv) = do-        (r, sv') <- State.runStateT (step (adaptState gst) st) sv-        return $ case r of-            Yield x s -> Yield x (s, sv')-            Skip  s   -> Skip (s, sv')-            Stop      -> Stop--{-# INLINE_NORMAL runStateT #-}-runStateT :: Monad m => s -> Stream (StateT s m) a -> Stream m (s, a)-runStateT sval (Stream step state) = Stream step' (state, sval)-    where-    {-# INLINE_LATE step' #-}-    step' gst (st, sv) = do-        (r, sv') <- State.runStateT (step (adaptState gst) st) sv-        return $ case r of-            Yield x s -> Yield (sv', x) (s, sv')-            Skip  s   -> Skip (s, sv')-            Stop      -> Stop----------------------------------------------------------------------------------- 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)----------------------------------------------------------------------------------- Left Folds---------------------------------------------------------------------------------{-# 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---- 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----------------------------------------------------------------------------------- Parses----------------------------------------------------------------------------------- Inlined definition. Without the inline "serially/parser/take" benchmark--- degrades and splitParse 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---- | Run a 'Parse' over a stream.-{-# INLINE_NORMAL parselMx' #-}-parselMx'-    :: MonadThrow m-    => (s -> a -> m (PR.Step s b))-    -> m s-    -> (s -> m b)-    -> Stream m a-    -> m b-parselMx' pstep initial extract (Stream step state) = do-    initial >>= go SPEC state []--    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.-    {-# INLINE go #-}-    go !_ st buf !pst = do-        r <- step defState st-        case r of-            Yield x s -> do-                pRes <- pstep pst x-                case pRes of-                    -- PR.Yield 0 pst1 -> go SPEC s [] pst1-                    PR.Yield n pst1 -> do-                        assert (n <= length (x:buf)) (return ())-                        go SPEC s (Prelude.take n (x:buf)) pst1-                    PR.Skip 0 pst1 -> go SPEC s (x:buf) pst1-                    PR.Skip n pst1 -> do-                        assert (n <= length (x:buf)) (return ())-                        let (src0, buf1) = splitAt n (x:buf)-                            src  = Prelude.reverse src0-                        gobuf SPEC s buf1 src pst1-                    PR.Stop _ b -> return b-                    PR.Error err -> throwM $ ParseError err-            Skip s -> go SPEC s buf pst-            Stop   -> extract pst--    gobuf !_ s buf [] !pst = go SPEC s buf pst-    gobuf !_ s buf (x:xs) !pst = do-        pRes <- pstep pst x-        case pRes of-            -- PR.Yield 0 pst1 -> go SPEC s [] pst1-            PR.Yield n pst1 -> do-                assert (n <= length (x:buf)) (return ())-                gobuf SPEC s (Prelude.take n (x:buf)) xs pst1-            PR.Skip 0 pst1 -> gobuf SPEC s (x:buf) xs pst1-            PR.Skip n pst1 -> do-                assert (n <= length (x:buf)) (return ())-                let (src0, buf1) = splitAt n (x:buf)-                    src  = Prelude.reverse src0 ++ xs-                gobuf SPEC s buf1 src pst1-            PR.Stop _ b -> return b-            PR.Error err -> throwM $ ParseError err----------------------------------------------------------------------------------- Repeated parsing---------------------------------------------------------------------------------{-# ANN type ParseChunksState Fuse #-}-data ParseChunksState x inpBuf st pst =-      ParseChunksInit inpBuf st-    | ParseChunksInitLeftOver inpBuf-    | ParseChunksStream st inpBuf pst-    | ParseChunksBuf inpBuf st inpBuf pst-    | ParseChunksYield x (ParseChunksState x inpBuf st pst)--{-# INLINE_NORMAL splitParse #-}-splitParse-    :: MonadThrow m-    => Parser m a b-    -> Stream m a-    -> Stream m b-splitParse (Parser pstep initial extract) (Stream step state) =-    Stream stepOuter (ParseChunksInit [] state)--    where--    {-# INLINE_LATE stepOuter #-}-    -- Buffer is empty, go to stream processing loop-    stepOuter _ (ParseChunksInit [] st) = do-        initial >>= return . Skip . ParseChunksStream st []--    -- Buffer is not empty, go to buffered processing loop-    stepOuter _ (ParseChunksInit src st) = do-        initial >>= return . Skip . ParseChunksBuf src st []--    -- 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.Yield 0 pst1 -> go SPEC s [] pst1-                    PR.Yield n pst1 -> do-                        assert (n <= length (x:buf)) (return ())-                        let buf1 = Prelude.take n (x:buf)-                        return $ Skip $ ParseChunksStream s buf1 pst1-                    -- PR.Skip 0 pst1 ->-                    --     return $ Skip $ ParseChunksStream s (x:buf) pst1-                    PR.Skip 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-                    -- XXX Specialize for Stop 0 common case?-                    PR.Stop n b -> do-                        assert (n <= length (x:buf)) (return ())-                        let src = Prelude.reverse (Prelude.take n (x:buf))-                        return $ Skip $-                            ParseChunksYield b (ParseChunksInit src s)-                    PR.Error err -> throwM $ ParseError err-            Skip s -> return $ Skip $ ParseChunksStream s buf pst-            Stop   -> do-                b <- extract pst-                let src = Prelude.reverse buf-                return $ Skip $-                    ParseChunksYield b (ParseChunksInitLeftOver src)--    -- 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.Yield 0 pst1 ->-            PR.Yield n pst1 ->  do-                assert (n <= length (x:buf)) (return ())-                let buf1 = Prelude.take n (x:buf)-                return $ Skip $ ParseChunksBuf xs s buf1 pst1-         -- PR.Skip 0 pst1 -> return $ Skip $ ParseChunksBuf xs s (x:buf) pst1-            PR.Skip 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-            -- XXX Specialize for Stop 0 common case?-            PR.Stop n b -> do-                assert (n <= length (x:buf)) (return ())-                let src = Prelude.reverse (Prelude.take n (x:buf)) ++ xs-                return $ Skip $ ParseChunksYield b (ParseChunksInit src s)-            PR.Error err -> throwM $ ParseError err--    stepOuter _ (ParseChunksYield a next) = return $ Yield a next----------------------------------------------------------------------------------- Specialized Folds----------------------------------------------------------------------------------- | Run a streaming composition, discard the results.-{-# INLINE_LATE drain #-}-drain :: Monad m => Stream m a -> m ()--- drain = foldrM (\_ xs -> xs) (return ())-drain (Stream step state) = go SPEC state-  where-    go !_ st = do-        r <- step defState st-        case r of-            Yield _ s -> go SPEC s-            Skip s    -> go SPEC s-            Stop      -> return ()--{-# INLINE_NORMAL null #-}-null :: Monad m => Stream m a -> m Bool-null m = foldrM (\_ _ -> return False) (return True) m--{-# INLINE_NORMAL head #-}-head :: Monad m => Stream m a -> m (Maybe a)-head m = foldrM (\x _ -> return (Just x)) (return Nothing) m--{-# INLINE_NORMAL headElse #-}-headElse :: Monad m => a -> Stream m a -> m a-headElse a m = foldrM (\x _ -> return x) (return a) m---- 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 state-  where-    go st = do-        r <- step defState st-        case r of-            Yield _ s -> return (Just $ Stream step s)-            Skip  s   -> go s-            Stop      -> return Nothing---- XXX will it fuse? need custom impl?-{-# INLINE_NORMAL last #-}-last :: Monad m => Stream m a -> m (Maybe a)-last = foldl' (\_ y -> Just y) Nothing--{-# INLINE_NORMAL elem #-}-elem :: (Monad m, Eq a) => a -> Stream m a -> m Bool--- elem e m = foldrM (\x xs -> if x == e then return True else xs) (return False) m-elem e (Stream step state) = go state-  where-    go st = do-        r <- step defState st-        case r of-            Yield x s-              | x == e    -> return True-              | otherwise -> go s-            Skip s -> go s-            Stop   -> return False--{-# 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--- all p m = foldrM (\x xs -> if p x then xs else return False) (return True) m-all p (Stream step state) = go state-  where-    go st = do-        r <- step defState st-        case r of-            Yield x s-              | p x       -> go s-              | otherwise -> return False-            Skip s -> go s-            Stop   -> return True--{-# INLINE_NORMAL any #-}-any :: Monad m => (a -> Bool) -> Stream m a -> m Bool--- any p m = foldrM (\x xs -> if p x then return True else xs) (return False) m-any p (Stream step state) = go state-  where-    go st = do-        r <- step defState st-        case r of-            Yield x s-              | p x       -> return True-              | otherwise -> go s-            Skip s -> go s-            Stop   -> return False--{-# INLINE_NORMAL maximum #-}-maximum :: (Monad m, Ord a) => Stream m a -> m (Maybe a)-maximum (Stream step state) = go Nothing state-  where-    go Nothing st = do-        r <- step defState st-        case r of-            Yield x s -> go (Just x) s-            Skip  s   -> go Nothing s-            Stop      -> return Nothing-    go (Just acc) st = do-        r <- step defState st-        case r of-            Yield x s-              | acc <= x  -> go (Just x) s-              | otherwise -> go (Just acc) s-            Skip s -> go (Just acc) s-            Stop   -> return (Just acc)--{-# INLINE_NORMAL maximumBy #-}-maximumBy :: Monad m => (a -> a -> Ordering) -> Stream m a -> m (Maybe a)-maximumBy cmp (Stream step state) = go Nothing state-  where-    go Nothing st = do-        r <- step defState st-        case r of-            Yield x s -> go (Just x) s-            Skip  s   -> go 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 (Just acc) s-                _  -> go (Just x) s-            Skip s -> go (Just acc) s-            Stop   -> return (Just acc)--{-# INLINE_NORMAL minimum #-}-minimum :: (Monad m, Ord a) => Stream m a -> m (Maybe a)-minimum (Stream step state) = go Nothing state-  where-    go Nothing st = do-        r <- step defState st-        case r of-            Yield x s -> go (Just x) s-            Skip  s   -> go Nothing s-            Stop      -> return Nothing-    go (Just acc) st = do-        r <- step defState st-        case r of-            Yield x s-              | acc <= x  -> go (Just acc) s-              | otherwise -> go (Just x) s-            Skip s -> go (Just acc) s-            Stop   -> return (Just acc)--{-# INLINE_NORMAL minimumBy #-}-minimumBy :: Monad m => (a -> a -> Ordering) -> Stream m a -> m (Maybe a)-minimumBy cmp (Stream step state) = go Nothing state-  where-    go Nothing st = do-        r <- step defState st-        case r of-            Yield x s -> go (Just x) s-            Skip  s   -> go 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 (Just x) s-                _  -> go (Just acc) s-            Skip s -> go (Just acc) s-            Stop   -> return (Just acc)--{-# INLINE_NORMAL (!!) #-}-(!!) :: (Monad m) => Stream m a -> Int -> m (Maybe a)-(Stream step state) !! i = go 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 (n - 1) s-            Skip s -> go n s-            Stop   -> return Nothing--{-# INLINE_NORMAL lookup #-}-lookup :: (Monad m, Eq a) => a -> Stream m (a, b) -> m (Maybe b)-lookup e m = foldrM (\(a, b) xs -> if e == a then return (Just b) else xs)-                   (return Nothing) m--{-# INLINE_NORMAL findM #-}-findM :: Monad m => (a -> m Bool) -> Stream m a -> m (Maybe a)-findM p m = foldrM (\x xs -> p x >>= \r -> if r then return (Just x) else xs)-                   (return Nothing) m--{-# INLINE find #-}-find :: Monad m => (a -> Bool) -> Stream m a -> m (Maybe a)-find p = findM (return . 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--{-# INLINE toListRev #-}-toListRev :: Monad m => Stream m a -> m [a]-toListRev = foldl' (flip (:)) []---- We can implement reverse as:------ > reverse = foldlS (flip cons) nil------ However, this implementation is unusable because of the horrible performance--- of cons. So we just convert it to a list first and then stream from the--- list.------ XXX Maybe we can use an Array instead of a list here?-{-# INLINE_NORMAL reverse #-}-reverse :: Monad m => Stream m a -> Stream m a-reverse m = Stream step Nothing-    where-    {-# INLINE_LATE step #-}-    step _ Nothing = do-        xs <- toListRev m-        return $ Skip (Just xs)-    step _ (Just (x:xs)) = return $ Yield x (Just xs)-    step _ (Just []) = return Stop---- Much faster reverse for Storables-{-# INLINE_NORMAL reverse' #-}-reverse' :: forall m a. (MonadIO m, Storable a) => Stream m a -> Stream m a-{---- This commented implementation copies the whole stream into one single array--- and then streams from that array, this is 3-4x faster than the chunked code--- that follows.  Though this could be problematic due to unbounded large--- allocations. We need to figure out why the chunked code is slower and if we--- can optimize the chunked code to work as fast as this one. It may be a--- fusion issue?-import Foreign.ForeignPtr (touchForeignPtr)-import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)-import Foreign.Ptr (Ptr, plusPtr)-reverse' m = Stream step Nothing-    where-    {-# INLINE_LATE step #-}-    step _ Nothing = do-        arr <- A.fromStreamD m-        let p = aEnd arr `plusPtr` negate (sizeOf (undefined :: a))-        return $ Skip $ Just (aStart arr, p)--    step _ (Just (start, p)) | p < unsafeForeignPtrToPtr start = return Stop--    step _ (Just (start, p)) = do-        let !x = A.unsafeInlineIO $ do-                    r <- peek p-                    touchForeignPtr start-                    return r-            next = p `plusPtr` negate (sizeOf (undefined :: a))-        return $ Yield x (Just (start, next))--}-reverse' m =-          A.flattenArraysRev-        $ fromStreamK-        $ K.reverse-        $ toStreamK-        $ A.fromStreamDArraysOf A.defaultChunkSize m------------------------------------------------------------------------------------ Grouping/Splitting---------------------------------------------------------------------------------{-# INLINE_NORMAL splitSuffixBy' #-}-splitSuffixBy' :: Monad m-    => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b-splitSuffixBy' predicate f (Stream step state) =-    Stream (stepOuter f) (Just state)--    where--    {-# INLINE_LATE stepOuter #-}-    stepOuter (Fold fstep initial done) gst (Just st) = do-        res <- step (adaptState gst) st-        case res of-            Yield x s -> do-                acc <- initial-                acc' <- fstep acc x-                if (predicate x)-                then done acc' >>= \val -> return $ Yield val (Just s)-                else go SPEC s acc'--            Skip s    -> return $ Skip $ Just s-            Stop      -> return Stop--        where--        go !_ stt !acc = do-            res <- step (adaptState gst) stt-            case res of-                Yield x s -> do-                    acc' <- fstep acc x-                    if (predicate x)-                    then done acc' >>= \val -> return $ Yield val (Just s)-                    else go SPEC s acc'-                Skip s -> go SPEC s acc-                Stop -> done acc >>= \val -> return $ Yield val Nothing--    stepOuter _ _ Nothing = return Stop--{-# INLINE_NORMAL groupsBy #-}-groupsBy :: Monad m-    => (a -> a -> Bool)-    -> Fold m a b-    -> Stream m a-    -> Stream m b-groupsBy cmp f (Stream step state) = Stream (stepOuter f) (Just state, Nothing)--    where--    {-# INLINE_LATE stepOuter #-}-    stepOuter (Fold fstep initial done) gst (Just st, Nothing) = do-        res <- step (adaptState gst) st-        case res of-            Yield x s -> do-                acc <- initial-                acc' <- fstep acc x-                go SPEC x s acc'--            Skip s    -> return $ Skip $ (Just s, Nothing)-            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-                        acc' <- fstep acc x-                        go SPEC prev s acc'-                    else done acc >>= \r -> return $ Yield r (Just s, Just x)-                Skip s -> go SPEC prev s acc-                Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)--    stepOuter (Fold fstep initial done) gst (Just st, Just prev) = do-        acc <- initial-        acc' <- fstep acc prev-        go SPEC st acc'--        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-                        acc' <- fstep acc x-                        go SPEC s acc'-                    else done acc >>= \r -> return $ Yield r (Just s, Just x)-                Skip s -> go SPEC s acc-                Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)--    stepOuter _ _ (Nothing,_) = return Stop--{-# INLINE_NORMAL groupsRollingBy #-}-groupsRollingBy :: Monad m-    => (a -> a -> Bool)-    -> Fold m a b-    -> Stream m a-    -> Stream m b-groupsRollingBy cmp f (Stream step state) =-    Stream (stepOuter f) (Just state, Nothing)-    where--      {-# INLINE_LATE stepOuter #-}-      stepOuter (Fold fstep initial done) gst (Just st, Nothing) = do-          res <- step (adaptState gst) st-          case res of-              Yield x s -> do-                  acc <- initial-                  acc' <- fstep acc x-                  go SPEC x s acc'--              Skip s    -> return $ Skip $ (Just s, Nothing)-              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-                          acc' <- fstep acc x-                          go SPEC x s acc'-                        else-                          done acc >>= \r -> return $ Yield r (Just s, Just x)-                  Skip s -> go SPEC prev s acc-                  Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)--      stepOuter (Fold fstep initial done) gst (Just st, Just prev') = do-          acc <- initial-          acc' <- fstep acc prev'-          go SPEC prev' st acc'--        where-          go !_ prevv stt !acc = do-              res <- step (adaptState gst) stt-              case res of-                  Yield x s -> do-                      if cmp prevv x-                      then do-                          acc' <- fstep acc x-                          go SPEC x s acc'-                      else done acc >>= \r -> return $ Yield r (Just s, Just x)-                  Skip s -> go SPEC prevv s acc-                  Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)--      stepOuter _ _ (Nothing, _) = return Stop--{-# INLINE_NORMAL splitBy #-}-splitBy :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b-splitBy predicate f (Stream step state) = Stream (step' f) (Just state)--    where--    {-# INLINE_LATE step' #-}-    step' (Fold fstep initial done) gst (Just st) = initial >>= go SPEC st--        where--        go !_ stt !acc = do-            res <- step (adaptState gst) stt-            case res of-                Yield x s -> do-                    if predicate x-                    then done acc >>= \r -> return $ Yield r (Just s)-                    else do-                        acc' <- fstep acc x-                        go SPEC s acc'-                Skip s -> go SPEC s acc-                Stop -> done acc >>= \r -> return $ Yield r Nothing--    step' _ _ Nothing = return Stop---- XXX requires -funfolding-use-threshold=150 in lines-unlines benchmark-{-# INLINE_NORMAL splitSuffixBy #-}-splitSuffixBy :: Monad m-    => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b-splitSuffixBy predicate f (Stream step state) = Stream (step' f) (Just state)--    where--    {-# INLINE_LATE step' #-}-    step' (Fold fstep initial done) gst (Just st) = do-        res <- step (adaptState gst) st-        case res of-            Yield x s -> do-                acc <- initial-                if predicate x-                then done acc >>= \val -> return $ Yield val (Just s)-                else do-                    acc' <- fstep acc x-                    go SPEC s acc'--            Skip s    -> return $ Skip $ Just s-            Stop      -> return Stop--        where--        go !_ stt !acc = do-            res <- step (adaptState gst) stt-            case res of-                Yield x s -> do-                    if predicate x-                    then done acc >>= \r -> return $ Yield r (Just s)-                    else do-                        acc' <- fstep acc x-                        go SPEC s acc'-                Skip s -> go SPEC s acc-                Stop -> done acc >>= \r -> return $ Yield r Nothing--    step' _ _ Nothing = return Stop--{-# INLINE_NORMAL wordsBy #-}-wordsBy :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b-wordsBy predicate f (Stream step state) = Stream (stepOuter f) (Just state)--    where--    {-# INLINE_LATE stepOuter #-}-    stepOuter (Fold fstep initial done) gst (Just st) = do-        res <- step (adaptState gst) st-        case res of-            Yield x s -> do-                if predicate x-                then return $ Skip (Just s)-                else do-                    acc <- initial-                    acc' <- fstep acc x-                    go SPEC s acc'--            Skip s    -> return $ Skip $ Just s-            Stop      -> return Stop--        where--        go !_ stt !acc = do-            res <- step (adaptState gst) stt-            case res of-                Yield x s -> do-                    if predicate x-                    then done acc >>= \r -> return $ Yield r (Just s)-                    else do-                        acc' <- fstep acc x-                        go SPEC s acc'-                Skip s -> go SPEC s acc-                Stop -> done acc >>= \r -> return $ Yield r Nothing--    stepOuter _ _ Nothing = return Stop---- 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-    }--}--data SplitOnState s a =-      GO_START-    | GO_EMPTY_PAT s-    | GO_SINGLE_PAT s a-    | GO_SHORT_PAT s-    | GO_KARP_RABIN s !(RB.Ring a) !(Ptr a)-    | GO_DONE--{-# INLINE_NORMAL splitOn #-}-splitOn-    :: forall m a b. (MonadIO m, Storable a, Enum a, Eq a)-    => Array a-    -> Fold m a b-    -> Stream m a-    -> Stream m b-splitOn patArr (Fold fstep initial done) (Stream step state) =-    Stream stepOuter GO_START--    where--    patLen = A.length patArr-    maxIndex = patLen - 1-    elemBits = sizeOf (undefined :: a) * 8--    {-# INLINE_LATE stepOuter #-}-    stepOuter _ GO_START =-        if patLen == 0-        then return $ Skip $ GO_EMPTY_PAT state-        else if patLen == 1-            then do-                r <- liftIO $ (A.unsafeIndexIO patArr 0)-                return $ Skip $ GO_SINGLE_PAT state r-            else if sizeOf (undefined :: a) * patLen-                    <= sizeOf (undefined :: Word)-                then return $ Skip $ GO_SHORT_PAT state-                else do-                    (rb, rhead) <- liftIO $ RB.new patLen-                    return $ Skip $ GO_KARP_RABIN state rb rhead--    stepOuter gst (GO_SINGLE_PAT stt pat) = initial >>= go SPEC stt--        where--        go !_ st !acc = do-            res <- step (adaptState gst) st-            case res of-                Yield x s -> do-                    if pat == x-                    then do-                        r <- done acc-                        return $ Yield r (GO_SINGLE_PAT s pat)-                    else fstep acc x >>= go SPEC s-                Skip s -> go SPEC s acc-                Stop -> done acc >>= \r -> return $ Yield r GO_DONE--    stepOuter gst (GO_SHORT_PAT stt) = initial >>= go0 SPEC 0 (0 :: Word) stt--        where--        mask :: Word-        mask = (1 `shiftL` (elemBits * patLen)) - 1--        addToWord wrd a = (wrd `shiftL` elemBits) .|. fromIntegral (fromEnum a)--        patWord :: Word-        patWord = mask .&. A.foldl' addToWord 0 patArr--        go0 !_ !idx wrd st !acc = do-            res <- step (adaptState gst) st-            case res of-                Yield x s -> do-                    let wrd' = addToWord wrd x-                    if idx == maxIndex-                    then do-                        if wrd' .&. mask == patWord-                        then do-                            r <- done acc-                            return $ Yield r (GO_SHORT_PAT s)-                        else go1 SPEC wrd' s acc-                    else go0 SPEC (idx + 1) wrd' s acc-                Skip s -> go0 SPEC idx wrd s acc-                Stop -> do-                    acc' <- if idx /= 0-                            then go2 wrd idx acc-                            else return acc-                    done acc' >>= \r -> return $ Yield r GO_DONE--        {-# INLINE go1 #-}-        go1 !_ wrd st !acc = do-            res <- step (adaptState gst) st-            case res of-                Yield x s -> do-                    let wrd' = addToWord wrd x-                        old = (mask .&. wrd) `shiftR` (elemBits * (patLen - 1))-                    acc' <- fstep acc (toEnum $ fromIntegral old)-                    if wrd' .&. mask == patWord-                    then done acc' >>= \r -> return $ Yield r (GO_SHORT_PAT s)-                    else go1 SPEC wrd' s acc'-                Skip s -> go1 SPEC wrd s acc-                Stop -> do-                    acc' <- go2 wrd patLen acc-                    done acc' >>= \r -> return $ Yield r GO_DONE--        go2 !wrd !n !acc | n > 0 = do-            let old = (mask .&. wrd) `shiftR` (elemBits * (n - 1))-            fstep acc (toEnum $ fromIntegral old) >>= go2 wrd (n - 1)-        go2 _ _ acc = return acc--    stepOuter gst (GO_KARP_RABIN stt rb rhead) = do-        initial >>= go0 SPEC 0 rhead stt--        where--        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--        -- rh == ringHead-        go0 !_ !idx !rh st !acc = do-            res <- step (adaptState gst) st-            case res of-                Yield x s -> do-                    rh' <- liftIO $ RB.unsafeInsert rb rh x-                    if idx == maxIndex-                    then do-                        let fold = RB.unsafeFoldRing (RB.ringBound rb)-                        let !ringHash = fold addCksum 0 rb-                        if ringHash == patHash-                        then go2 SPEC ringHash rh' s acc-                        else go1 SPEC ringHash rh' s acc-                    else go0 SPEC (idx + 1) rh' s acc-                Skip s -> go0 SPEC idx rh s acc-                Stop -> do-                    !acc' <- if idx /= 0-                             then RB.unsafeFoldRingM rh fstep acc rb-                             else return acc-                    done acc' >>= \r -> return $ Yield r GO_DONE--        -- XXX Theoretically this code can do 4 times faster if GHC generates-        -- optimal code. If we use just "(cksum' == patHash)" condition it goes-        -- 4x faster, as soon as we add the "RB.unsafeEqArray rb v" condition-        -- the generated code changes drastically and becomes 4x slower. Need-        -- to investigate what is going on with GHC.-        {-# INLINE go1 #-}-        go1 !_ !cksum !rh st !acc = do-            res <- step (adaptState gst) st-            case res of-                Yield x s -> do-                    old <- liftIO $ peek rh-                    let cksum' = deltaCksum cksum old x-                    acc' <- fstep acc old--                    if (cksum' == patHash)-                    then do-                        rh' <- liftIO (RB.unsafeInsert rb rh x)-                        go2 SPEC cksum' rh' s acc'-                    else do-                        rh' <- liftIO (RB.unsafeInsert rb rh x)-                        go1 SPEC cksum' rh' s acc'-                Skip s -> go1 SPEC cksum rh s acc-                Stop -> do-                    acc' <- RB.unsafeFoldRingFullM rh fstep acc rb-                    done acc' >>= \r -> return $ Yield r GO_DONE--        go2 !_ !cksum' !rh' s !acc' = do-            if RB.unsafeEqArray rb rh' patArr-            then do-                r <- done acc'-                return $ Yield r (GO_KARP_RABIN s rb rhead)-            else go1 SPEC cksum' rh' s acc'--    stepOuter gst (GO_EMPTY_PAT st) = do-        res <- step (adaptState gst) st-        case res of-            Yield x s -> do-                acc <- initial-                acc' <- fstep acc x-                done acc' >>= \r -> return $ Yield r (GO_EMPTY_PAT s)-            Skip s -> return $ Skip (GO_EMPTY_PAT s)-            Stop -> return Stop--    stepOuter _ GO_DONE = return Stop--{-# INLINE_NORMAL splitSuffixOn #-}-splitSuffixOn-    :: forall m a b. (MonadIO m, Storable a, Enum a, Eq a)-    => Bool-    -> Array a-    -> Fold m a b-    -> Stream m a-    -> Stream m b-splitSuffixOn withSep patArr (Fold fstep initial done)-                (Stream step state) =-    Stream stepOuter GO_START--    where--    patLen = A.length patArr-    maxIndex = patLen - 1-    elemBits = sizeOf (undefined :: a) * 8--    {-# INLINE_LATE stepOuter #-}-    stepOuter _ GO_START =-        if patLen == 0-        then return $ Skip $ GO_EMPTY_PAT state-        else if patLen == 1-             then do-                r <- liftIO $ (A.unsafeIndexIO patArr 0)-                return $ Skip $ GO_SINGLE_PAT state r-             else if sizeOf (undefined :: a) * patLen-                    <= sizeOf (undefined :: Word)-                  then return $ Skip $ GO_SHORT_PAT state-                  else do-                    (rb, rhead) <- liftIO $ RB.new patLen-                    return $ Skip $ GO_KARP_RABIN state rb rhead--    stepOuter gst (GO_SINGLE_PAT stt pat) = do-        -- This first part is the only difference between splitOn and-        -- splitSuffixOn.-        -- If the last element is a separator do not issue a blank segment.-        res <- step (adaptState gst) stt-        case res of-            Yield x s -> do-                acc <- initial-                if pat == x-                then do-                    acc' <- if withSep then fstep acc x else return acc-                    done acc' >>= \r -> return $ Yield r (GO_SINGLE_PAT s pat)-                else fstep acc x >>= go SPEC s-            Skip s    -> return $ Skip $ (GO_SINGLE_PAT s pat)-            Stop      -> return Stop--        where--        -- This is identical for splitOn and splitSuffixOn-        go !_ st !acc = do-            res <- step (adaptState gst) st-            case res of-                Yield x s -> do-                    if pat == x-                    then do-                        acc' <- if withSep then fstep acc x else return acc-                        r <- done acc'-                        return $ Yield r (GO_SINGLE_PAT s pat)-                    else fstep acc x >>= go SPEC s-                Skip s -> go SPEC s acc-                Stop -> done acc >>= \r -> return $ Yield r GO_DONE--    stepOuter gst (GO_SHORT_PAT stt) = do--        -- Call "initial" only if the stream yields an element, otherwise we-        -- may call "initial" but never yield anything. initial may produce a-        -- side effect, therefore we will end up doing and discard a side-        -- effect.--        let idx = 0-        let wrd = 0-        res <- step (adaptState gst) stt-        case res of-            Yield x s -> do-                acc <- initial-                let wrd' = addToWord wrd x-                acc' <- if withSep then fstep acc x else return acc-                if idx == maxIndex-                then do-                    if wrd' .&. mask == patWord-                    then done acc' >>= \r -> return $ Yield r (GO_SHORT_PAT s)-                    else go0 SPEC (idx + 1) wrd' s acc'-                else go0 SPEC (idx + 1) wrd' s acc'-            Skip s -> return $ Skip (GO_SHORT_PAT s)-            Stop -> return Stop--        where--        mask :: Word-        mask = (1 `shiftL` (elemBits * patLen)) - 1--        addToWord wrd a = (wrd `shiftL` elemBits) .|. fromIntegral (fromEnum a)--        patWord :: Word-        patWord = mask .&. A.foldl' addToWord 0 patArr--        go0 !_ !idx wrd st !acc = do-            res <- step (adaptState gst) st-            case res of-                Yield x s -> do-                    let wrd' = addToWord wrd x-                    acc' <- if withSep then fstep acc x else return acc-                    if idx == maxIndex-                    then do-                        if wrd' .&. mask == patWord-                        then do-                            r <- done acc'-                            return $ Yield r (GO_SHORT_PAT s)-                        else go1 SPEC wrd' s acc'-                    else go0 SPEC (idx + 1) wrd' s acc'-                Skip s -> go0 SPEC idx wrd s acc-                Stop -> do-                    if (idx == maxIndex) && (wrd .&. mask == patWord)-                    then return Stop-                    else do-                        acc' <- if idx /= 0 && not withSep-                                then go2 wrd idx acc-                                else return acc-                        done acc' >>= \r -> return $ Yield r GO_DONE--        {-# INLINE go1 #-}-        go1 !_ wrd st !acc = do-            res <- step (adaptState gst) st-            case res of-                Yield x s -> do-                    let wrd' = addToWord wrd x-                        old = (mask .&. wrd) `shiftR` (elemBits * (patLen - 1))-                    acc' <- if withSep-                            then fstep acc x-                            else fstep acc (toEnum $ fromIntegral old)-                    if wrd' .&. mask == patWord-                    then done acc' >>= \r -> return $ Yield r (GO_SHORT_PAT s)-                    else go1 SPEC wrd' s acc'-                Skip s -> go1 SPEC wrd s acc-                Stop ->-                    -- If the last sequence is a separator do not issue a blank-                    -- segment.-                    if wrd .&. mask == patWord-                    then return Stop-                    else do-                        acc' <- if withSep-                                then return acc-                                else go2 wrd patLen acc-                        done acc' >>= \r -> return $ Yield r GO_DONE--        go2 !wrd !n !acc | n > 0 = do-            let old = (mask .&. wrd) `shiftR` (elemBits * (n - 1))-            fstep acc (toEnum $ fromIntegral old) >>= go2 wrd (n - 1)-        go2 _ _ acc = return acc--    stepOuter gst (GO_KARP_RABIN stt rb rhead) = do-        let idx = 0-        res <- step (adaptState gst) stt-        case res of-            Yield x s -> do-                acc <- initial-                acc' <- if withSep then fstep acc x else return acc-                rh' <- liftIO (RB.unsafeInsert rb rhead x)-                if idx == maxIndex-                then do-                    let fold = RB.unsafeFoldRing (RB.ringBound rb)-                    let !ringHash = fold addCksum 0 rb-                    if ringHash == patHash-                    then go2 SPEC ringHash rh' s acc'-                    else go0 SPEC (idx + 1) rh' s acc'-                else go0 SPEC (idx + 1) rh' s acc'-            Skip s -> return $ Skip (GO_KARP_RABIN s rb rhead)-            Stop -> return Stop--        where--        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--        -- rh == ringHead-        go0 !_ !idx !rh st !acc = do-            res <- step (adaptState gst) st-            case res of-                Yield x s -> do-                    acc' <- if withSep then fstep acc x else return acc-                    rh' <- liftIO (RB.unsafeInsert rb rh x)-                    if idx == maxIndex-                    then do-                        let fold = RB.unsafeFoldRing (RB.ringBound rb)-                        let !ringHash = fold addCksum 0 rb-                        if ringHash == patHash-                        then go2 SPEC ringHash rh' s acc'-                        else go1 SPEC ringHash rh' s acc'-                    else go0 SPEC (idx + 1) rh' s acc'-                Skip s -> go0 SPEC idx rh s acc-                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 do-                        !acc' <- if idx /= 0 && not withSep-                                 then RB.unsafeFoldRingM rh fstep acc rb-                                 else return acc-                        done acc' >>= \r -> return $ Yield r GO_DONE--        -- XXX Theoretically this code can do 4 times faster if GHC generates-        -- optimal code. If we use just "(cksum' == patHash)" condition it goes-        -- 4x faster, as soon as we add the "RB.unsafeEqArray rb v" condition-        -- the generated code changes drastically and becomes 4x slower. Need-        -- to investigate what is going on with GHC.-        {-# INLINE go1 #-}-        go1 !_ !cksum !rh st !acc = do-            res <- step (adaptState gst) st-            case res of-                Yield x s -> do-                    old <- liftIO $ peek rh-                    let cksum' = deltaCksum cksum old x-                    acc' <- if withSep-                            then fstep acc x-                            else fstep acc old--                    if (cksum' == patHash)-                    then do-                        rh' <- liftIO (RB.unsafeInsert rb rh x)-                        go2 SPEC cksum' rh' s acc'-                    else do-                        rh' <- liftIO (RB.unsafeInsert rb rh x)-                        go1 SPEC cksum' rh' s acc'-                Skip s -> go1 SPEC cksum rh s acc-                Stop -> do-                    if RB.unsafeEqArray rb rh patArr-                    then return Stop-                    else do-                        acc' <- if withSep-                                then return acc-                                else RB.unsafeFoldRingFullM rh fstep acc rb-                        done acc' >>= \r -> return $ Yield r GO_DONE--        go2 !_ !cksum' !rh' s !acc' = do-            if RB.unsafeEqArray rb rh' patArr-            then do-                r <- done acc'-                return $ Yield r (GO_KARP_RABIN s rb rhead)-            else go1 SPEC cksum' rh' s acc'--    stepOuter gst (GO_EMPTY_PAT st) = do-        res <- step (adaptState gst) st-        case res of-            Yield x s -> do-                acc <- initial-                acc' <- fstep acc x-                done acc' >>= \r -> return $ Yield r (GO_EMPTY_PAT s)-            Skip s -> return $ Skip (GO_EMPTY_PAT s)-            Stop -> return Stop--    stepOuter _ GO_DONE = return Stop--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----------------------------------------------------------------------------------- Substreams---------------------------------------------------------------------------------{-# INLINE_NORMAL isPrefixOf #-}-isPrefixOf :: (Eq a, Monad m) => Stream m a -> Stream m a -> m Bool-isPrefixOf (Stream stepa ta) (Stream stepb tb) = go (ta, tb, Nothing)-  where-    go (sa, sb, Nothing) = do-        r <- stepa defState sa-        case r of-            Yield x sa' -> go (sa', sb, Just x)-            Skip sa'    -> go (sa', sb, Nothing)-            Stop        -> return True--    go (sa, sb, Just x) = do-        r <- stepb defState sb-        case r of-            Yield y sb' ->-                if x == y-                    then go (sa, sb', Nothing)-                    else return False-            Skip sb' -> go (sa, sb', Just x)-            Stop     -> return False--{-# INLINE_NORMAL isSubsequenceOf #-}-isSubsequenceOf :: (Eq a, Monad m) => Stream m a -> Stream m a -> m Bool-isSubsequenceOf (Stream stepa ta) (Stream stepb tb) = go (ta, tb, Nothing)-  where-    go (sa, sb, Nothing) = do-        r <- stepa defState sa-        case r of-            Yield x sa' -> go (sa', sb, Just x)-            Skip sa'    -> go (sa', sb, Nothing)-            Stop        -> return True--    go (sa, sb, Just x) = do-        r <- stepb defState sb-        case r of-            Yield y sb' ->-                if x == y-                    then go (sa, sb', Nothing)-                    else go (sa, sb', Just x)-            Skip sb' -> go (sa, sb', Just x)-            Stop     -> return False--{-# INLINE_NORMAL stripPrefix #-}-stripPrefix-    :: (Eq a, Monad m)-    => Stream m a -> Stream m a -> m (Maybe (Stream m a))-stripPrefix (Stream stepa ta) (Stream stepb tb) = go (ta, tb, Nothing)-  where-    go (sa, sb, Nothing) = do-        r <- stepa defState sa-        case r of-            Yield x sa' -> go (sa', sb, Just x)-            Skip sa'    -> go (sa', sb, Nothing)-            Stop        -> return $ Just (Stream stepb sb)--    go (sa, sb, Just x) = do-        r <- stepb defState sb-        case r of-            Yield y sb' ->-                if x == y-                    then go (sa, sb', Nothing)-                    else return Nothing-            Skip sb' -> go (sa, sb', Just x)-            Stop     -> return Nothing----------------------------------------------------------------------------------- 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 ()-mapM_ m = drain . mapM m------------------------------------------------------------------------------------ Stream transformations using Unfolds------------------------------------------------------------------------------------ Define a unique structure to use in inspection testing-data ConcatMapUState o i =-      ConcatMapUOuter o-    | ConcatMapUInner o i---- | @concatMapU 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'.--{-# INLINE_NORMAL concatMapU #-}-concatMapU :: Monad m => Unfold m a b -> Stream m a -> Stream m b-concatMapU (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)--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.----{-# INLINE_NORMAL concatUnfoldInterleave #-}-concatUnfoldInterleave :: Monad m => Unfold m a b -> Stream m a -> Stream m b-concatUnfoldInterleave (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 concatUnfoldInterleave this one switches streams on Skips.----{-# INLINE_NORMAL concatUnfoldRoundrobin #-}-concatUnfoldRoundrobin :: Monad m => Unfold m a b -> Stream m a -> Stream m b-concatUnfoldRoundrobin (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)--data AppendState s1 s2 = AppendFirst s1 | AppendSecond s2---- Note that this could be much faster compared to the CPS stream. However, as--- the number of streams being composed increases this may become expensive.--- Need to see where the breaking point is between the two.----{-# 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--data InterleaveState s1 s2 = InterleaveFirst s1 s2 | InterleaveSecond s1 s2-    | InterleaveSecondOnly s2 | InterleaveFirstOnly s1--{-# 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--{-# 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--{-# INLINE_NORMAL interleaveSuffix #-}-interleaveSuffix :: Monad m => Stream m a -> Stream m a -> Stream m a-interleaveSuffix (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--{-# INLINE_NORMAL interleaveInfix #-}-interleaveInfix :: Monad m => Stream m a -> Stream m a -> Stream m a-interleaveInfix (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--{-# 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--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---- | Interleave streams (full streams, not the elements) unfolded from two--- input streams and concat. Stop when the first stream stops. If the second--- stream ends before the first one then first stream still keeps running alone--- without any interleaving with the second stream.------    [a1, a2, ... an]                   [b1, b2 ...]--- => [streamA1, streamA2, ... streamAn] [streamB1, streamB2, ...]--- => [streamA1, streamB1, streamA2...StreamAn, streamBn]--- => [a11, a12, ...a1j, b11, b12, ...b1k, a21, a22, ...]----{-# 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 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 interposeSuffix #-}-interposeSuffix-    :: Monad m-    => m c -> Unfold m b c -> Stream m b -> Stream m c-interposeSuffix-    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)--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---- | Interleave streams (full streams, not the elements) unfolded from two--- input streams and concat. Stop when the first stream stops. If the second--- stream ends before the first one then first stream still keeps running alone--- without any interleaving with the second stream.------    [a1, a2, ... an]                   [b1, b2 ...]--- => [streamA1, streamA2, ... streamAn] [streamB1, streamB2, ...]--- => [streamA1, streamB1, streamA2...StreamAn, streamBn]--- => [a11, a12, ...a1j, b11, b12, ...b1k, a21, a22, ...]----{-# 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)-    -}--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 interpose #-}-interpose :: Monad m => m c -> Unfold m b c -> Stream m b -> Stream m c-interpose-    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)-    -}----------------------------------------------------------------------------------- Exceptions---------------------------------------------------------------------------------data GbracketState s1 s2 v-    = GBracketInit-    | GBracketNormal s1 v-    | GBracketException s2---- | The most general bracketing and exception combinator. All other--- combinators can be expressed in terms of this combinator. This can also be--- used for cases which are not covered by the standard combinators.------ /Internal/----{-# INLINE_NORMAL gbracket #-}-gbracket-    :: Monad m-    => m c                                  -- ^ before-    -> (forall s. m s -> m (Either e s))    -- ^ try (exception handling)-    -> (c -> m d)                           -- ^ after, on normal stop-    -> (c -> e -> Stream m b)               -- ^ on exception-    -> (c -> Stream m b)                    -- ^ stream generator-    -> Stream m b-gbracket bef exc aft fexc fnormal =-    Stream step GBracketInit--    where--    {-# INLINE_LATE step #-}-    step _ GBracketInit = do-        r <- bef-        return $ Skip $ GBracketNormal (fnormal r) r--    step gst (GBracketNormal (UnStream step1 st) v) = do-        res <- exc $ 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-            Left e -> return $ Skip (GBracketException (fexc v e))-    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---- | Create an IORef holding a finalizer that is called automatically when the--- IORef is garbage collected. The IORef can be written to with a 'Nothing'--- value to deactivate the finalizer.-newFinalizedIORef :: (MonadIO m, MonadBaseControl IO m)-    => m a -> m (IORef (Maybe (IO ())))-newFinalizedIORef finalizer = do-    mrun <- captureMonadState-    ref <- liftIO $ newIORef $ Just $ liftIO $ void $ do-                _ <- runInIO mrun finalizer-                return ()-    let finalizer1 = do-            res <- readIORef ref-            case res of-                Nothing -> return ()-                Just f -> f-    _ <- liftIO $ mkWeakIORef ref finalizer1-    return ref---- | Run the finalizer stored in an IORef and deactivate it so that it is run--- only once.----runIORefFinalizer :: MonadIO m => IORef (Maybe (IO ())) -> m ()-runIORefFinalizer ref = liftIO $ do-    res <- readIORef ref-    case res of-        Nothing -> return ()-        Just f -> writeIORef ref Nothing >> f---- | Deactivate the finalizer stored in an IORef without running it.----clearIORefFinalizer :: MonadIO m => IORef (Maybe (IO ())) -> m ()-clearIORefFinalizer ref = liftIO $ writeIORef ref Nothing--data GbracketIOState s1 s2 v wref-    = GBracketIOInit-    | GBracketIONormal s1 v wref-    | GBracketIOException s2---- | Like gbracket but also uses a finalizer to make sure when the stream is--- garbage collected we run the finalizing action. This requires a MonadIO and--- MonadBaseControl IO constraint.------ | The most general bracketing and exception combinator. All other--- combinators can be expressed in terms of this combinator. This can also be--- used for cases which are not covered by the standard combinators.------ /Internal/----{-# INLINE_NORMAL gbracketIO #-}-gbracketIO-    :: (MonadIO m, MonadBaseControl IO m)-    => m c                                  -- ^ before-    -> (forall s. m s -> m (Either e s))    -- ^ try (exception handling)-    -> (c -> m d)                           -- ^ after, on normal stop or GC-    -> (c -> e -> Stream m b)               -- ^ on exception-    -> (c -> Stream m b)                    -- ^ stream generator-    -> Stream m b-gbracketIO bef exc aft fexc fnormal =-    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) <- liftBaseOp_ mask_ $ do-            r <- bef-            ref <- newFinalizedIORef (aft r)-            return (r, ref)-        return $ Skip $ GBracketIONormal (fnormal r) r ref--    step gst (GBracketIONormal (UnStream step1 st) v ref) = do-        res <- exc $ 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 -> do-                    runIORefFinalizer ref-                    return Stop-            Left e -> do-                clearIORefFinalizer ref-                return $ Skip (GBracketIOException (fexc v e))-    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 a side effect before the stream yields its first element.-{-# 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---- | Run a side effect whenever the stream stops normally.-{-# INLINE_NORMAL after #-}-after :: Monad m => m b -> Stream m a -> Stream m a-after 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--{-# INLINE_NORMAL afterIO #-}-afterIO :: (MonadIO m, MonadBaseControl IO m)-    => m b -> Stream m a -> Stream m a-afterIO action (Stream step state) = Stream step' Nothing--    where--    {-# INLINE_LATE step' #-}-    step' _ Nothing = do-        ref <- newFinalizedIORef 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-                runIORefFinalizer ref-                return Stop---- XXX These combinators are expensive due to the call to--- onException/handle/try on each step. Therefore, when possible, they should--- be called in an outer loop where we perform less iterations. For example, we--- cannot call them on each iteration in a char stream, instead we can call--- them when doing an IO on an array.------ XXX For high performance error checks in busy streams we may need another--- Error constructor in step.------ | Run a side effect whenever the stream aborts due to an exception. The--- exception is not caught, simply rethrown.-{-# INLINE_NORMAL onException #-}-onException :: MonadCatch m => m b -> Stream m a -> Stream m a-onException action str =-    gbracket (return ()) MC.try return-        (\_ (e :: MC.SomeException) -> nilM (action >> MC.throwM e))-        (\_ -> str)--{-# 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---- XXX bracket is like concatMap, it generates a stream and then flattens it.--- Like concatMap it has 10x worse performance compared to linear fused--- compositions.------ | Run the first action before the stream starts and remember its output,--- generate a stream using the output, run the second action providing the--- remembered value as an argument whenever the stream ends normally or due to--- an exception.-{-# INLINE_NORMAL bracket #-}-bracket :: MonadCatch m => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a-bracket bef aft bet =-    gbracket bef MC.try aft-        (\a (e :: SomeException) -> nilM (aft a >> MC.throwM e)) bet--{-# INLINE_NORMAL bracketIO #-}-bracketIO :: (MonadAsync m, MonadCatch m)-    => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a-bracketIO bef aft bet =-    gbracketIO bef MC.try aft-        (\a (e :: SomeException) -> nilM (aft a >> MC.throwM e)) bet--data BracketState s v = BracketInit | BracketRun s v--{-# 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 <- 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---- | Run a side effect whenever the stream stops normally or aborts due to an--- exception.-{-# INLINE finally #-}-finally :: MonadCatch m => m b -> Stream m a -> Stream m a--- finally action xs = after action $ onException action xs-finally action xs = bracket (return ()) (\_ -> action) (const xs)--{-# INLINE finallyIO #-}-finallyIO :: (MonadAsync m, MonadCatch m) => m b -> Stream m a -> Stream m a-finallyIO action xs = bracketIO (return ()) (\_ -> action) (const xs)---- | When evaluating a stream if an exception occurs, stream evaluation aborts--- and the specified exception handler is run with the exception as argument.-{-# INLINE_NORMAL handle #-}-handle :: (MonadCatch m, Exception e)-    => (e -> Stream m a) -> Stream m a -> Stream m a-handle f str =-    gbracket (return ()) MC.try return (\_ e -> f e) (\_ -> str)--{-# 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 <- 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------------------------------------------------------------------------------------ General transformation----------------------------------------------------------------------------------{-# 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 by Folding (Scans)------------------------------------------------------------------------------------------------------------------------------------------------------------------ Prescans----------------------------------------------------------------------------------- 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 s =-    postscanlMx' (\b a -> return (fstep b a)) (return begin) (return . done) s---- 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 s =-    scanlMx' (\b a -> return (fstep b a)) (return begin) (return . done) s----------------------------------------------------------------------------------- postscans---------------------------------------------------------------------------------{-# INLINE_NORMAL postscanlM' #-}-postscanlM' :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b-postscanlM' fstep begin (Stream step state) =-    begin `seq` Stream step' (state, begin)-  where-    {-# INLINE_LATE step' #-}-    step' gst (st, acc) = acc `seq` do-        r <- step (adaptState gst) st-        case r of-            Yield x s -> do-                y <- fstep acc x-                y `seq` return (Yield y (s, y))-            Skip s -> return $ Skip (s, acc)-            Stop   -> return Stop--{-# INLINE_NORMAL postscanl' #-}-postscanl' :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a-postscanl' f = postscanlM' (\a b -> return (f a b))--{-# INLINE_NORMAL postscanlM #-}-postscanlM :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b-postscanlM fstep begin (Stream step state) = 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-                y <- fstep acc x-                return (Yield y (s, y))-            Skip s -> return $ Skip (s, acc)-            Stop   -> return Stop--{-# INLINE_NORMAL postscanl #-}-postscanl :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a-postscanl f = postscanlM (\a b -> return (f a b))--{-# INLINE_NORMAL scanlM' #-}-scanlM' :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b-scanlM' fstep begin s = begin `seq` (begin `cons` postscanlM' fstep begin s)--{-# INLINE scanl' #-}-scanl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b-scanl' f = scanlM' (\a b -> return (f a b))--{-# INLINE_NORMAL scanlM #-}-scanlM :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b-scanlM fstep begin s = begin `cons` postscanlM fstep begin s--{-# INLINE scanl #-}-scanl :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b-scanl f = scanlM (\a b -> return (f a b))--{-# 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))--{-# 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--{-# INLINE scanl1' #-}-scanl1' :: Monad m => (a -> a -> a) -> Stream m a -> Stream m a-scanl1' f = scanl1M' (\x y -> return (f x y))----------------------------------------------------------------------------------- Stateful map/scan---------------------------------------------------------------------------------data RollingMapState s a = RollingMapInit s | RollingMapGo s a--{-# INLINE rollingMapM #-}-rollingMapM :: Monad m => (a -> a -> m b) -> Stream m a -> Stream m b-rollingMapM f (Stream step1 state1) = Stream step (RollingMapInit state1)-    where-    step gst (RollingMapInit st) = do-        r <- step1 (adaptState gst) st-        return $ case r of-            Yield x s -> Skip $ RollingMapGo s x-            Skip s -> Skip $ RollingMapInit s-            Stop   -> Stop--    step gst (RollingMapGo s1 x1) = do-        r <- step1 (adaptState gst) s1-        case r of-            Yield x s -> do-                !res <- f x x1-                return $ Yield res $ RollingMapGo s x-            Skip s -> return $ Skip $ RollingMapGo s x1-            Stop   -> return $ Stop--{-# INLINE rollingMap #-}-rollingMap :: Monad m => (a -> a -> b) -> Stream m a -> Stream m b-rollingMap f = rollingMapM (\x y -> return $ f x y)----------------------------------------------------------------------------------- Tapping/Distributing---------------------------------------------------------------------------------{-# 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' Nothing--    where--    step' _ Nothing = do-        r <- initial-        return $ Skip (Just (r, state))--    step' gst (Just (acc, st)) = acc `seq` do-        r <- step gst st-        case r of-            Yield x s -> do-                acc' <- fstep acc x-                return $ Yield x (Just (acc', s))-            Skip s    -> return $ Skip (Just (acc, s))-            Stop      -> do-                void $ extract acc-                return $ Stop--{-# 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' Nothing--    where--    {-# INLINE_LATE step' #-}-    step' _ Nothing = do-        r <- initial-        return $ Skip (Just (r, state, offset `mod` n))--    step' gst (Just (acc, st, count)) | count <= 0 = do-        r <- step gst st-        case r of-            Yield x s -> do-                !acc' <- fstep acc x-                return $ Yield x (Just (acc', s, n - 1))-            Skip s    -> return $ Skip (Just (acc, s, count))-            Stop      -> do-                void $ extract acc-                return $ Stop--    step' gst (Just (acc, st, count)) = do-        r <- step gst st-        case r of-            Yield x s -> return $ Yield x (Just (acc, s, count - 1))-            Skip s    -> return $ Skip (Just (acc, s, count))-            Stop      -> do-                void $ extract acc-                return $ Stop--{-# INLINE_NORMAL pollCounts #-}-pollCounts-    :: MonadAsync m-    => (a -> Bool)-    -> (Stream m Int -> Stream m Int)-    -> Fold m Int b-    -> Stream m a-    -> Stream m a-pollCounts predicate transf fld (Stream step state) = Stream step' Nothing-  where--    {-# INLINE_LATE step' #-}-    step' _ Nothing = do-        -- As long as we are using an "Int" for counts lockfree reads from-        -- Var should work correctly on both 32-bit and 64-bit machines.-        -- However, an Int on a 32-bit machine may overflow quickly.-        countVar <- liftIO $ newVar (0 :: Int)-        tid <- forkManaged-            $ void $ runFold fld-            $ transf $ fromPrimVar countVar-        return $ Skip (Just (countVar, tid, state))--    step' gst (Just (countVar, tid, st)) = do-        r <- step gst st-        case r of-            Yield x s -> do-                when (predicate x) $ liftIO $ modifyVar' countVar (+ 1)-                return $ Yield x (Just (countVar, tid, s))-            Skip s -> return $ Skip (Just (countVar, tid, s))-            Stop -> do-                liftIO $ killThread tid-                return Stop--{-# INLINE_NORMAL tapRate #-}-tapRate ::-       (MonadAsync m, MonadCatch m)-    => Double-    -> (Int -> m b)-    -> Stream m a-    -> Stream m a-tapRate samplingRate action (Stream step state) = Stream step' Nothing-  where-    {-# NOINLINE loop #-}-    loop countVar prev = do-        i <--            MC.catch-                (do liftIO $ threadDelay (round $ samplingRate * 1000000)-                    i <- liftIO $ readVar countVar-                    let !diff = i - prev-                    void $ action diff-                    return i)-                (\(e :: AsyncException) -> do-                     i <- liftIO $ readVar countVar-                     let !diff = i - prev-                     void $ action diff-                     throwM (MC.toException e))-        loop countVar i--    {-# INLINE_LATE step' #-}-    step' _ Nothing = do-        countVar <- liftIO $ newVar 0-        tid <- fork $ loop countVar 0-        ref <- liftIO $ newIORef ()-        _ <- liftIO $ mkWeakIORef ref (killThread tid)-        return $ Skip (Just (countVar, tid, state, ref))--    step' gst (Just (countVar, tid, st, ref)) = do-        r <- step gst st-        case r of-            Yield x s -> do-                liftIO $ modifyVar' countVar (+ 1)-                return $ Yield x (Just (countVar, tid, s, ref))-            Skip s -> return $ Skip (Just (countVar, tid, s, ref))-            Stop -> do-                liftIO $ killThread tid-                return Stop------------------------------------------------------------------------------------- Filtering----------------------------------------------------------------------------------{-# INLINE_NORMAL takeWhileM #-}-takeWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a-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--{-# INLINE takeWhile #-}-takeWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a-takeWhile f = takeWhileM (return . f)--{-# 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--data DropWhileState s a-    = DropWhileDrop s-    | DropWhileYield a s-    | DropWhileNext s--{-# INLINE_NORMAL dropWhileM #-}-dropWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a-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)--{-# INLINE dropWhile #-}-dropWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a-dropWhile f = dropWhileM (return . f)--{-# 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--{-# INLINE filter #-}-filter :: Monad m => (a -> Bool) -> Stream m a -> Stream m a-filter f = filterM (return . f)--{-# INLINE_NORMAL uniq #-}-uniq :: (Eq a, Monad m) => Stream m a -> Stream m a-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----------------------------------------------------------------------------------- Transformation by Mapping---------------------------------------------------------------------------------{-# 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----------------------------------------------------------------------------------- Inserting---------------------------------------------------------------------------------data LoopState x s = FirstYield s-                   | InterspersingYield s-                   | YieldAndCarry x s--{-# 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)--data SuffixState s a-    = SuffixElem s-    | SuffixSuffix s-    | SuffixYield a (SuffixState s a)--{-# INLINE_NORMAL intersperseSuffix #-}-intersperseSuffix :: forall m a. Monad m => m a -> Stream m a -> Stream m a-intersperseSuffix 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--data SuffixSpanState s a-    = SuffixSpanElem s Int-    | SuffixSpanSuffix s-    | SuffixSpanYield a (SuffixSpanState s a)-    | SuffixSpanLast-    | SuffixSpanStop---- | intersperse after every n items-{-# INLINE_NORMAL intersperseSuffixBySpan #-}-intersperseSuffixBySpan :: forall m a. Monad m-    => Int -> m a -> Stream m a -> Stream m a-intersperseSuffixBySpan 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--{-# INLINE intersperse #-}-intersperse :: Monad m => a -> Stream m a -> Stream m a-intersperse a = intersperseM (return a)--{-# 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)----------------------------------------------------------------------------------- Deleting---------------------------------------------------------------------------------{-# INLINE_NORMAL deleteBy #-}-deleteBy :: Monad m => (a -> a -> Bool) -> a -> Stream m a -> Stream m a-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----------------------------------------------------------------------------------- Transformation by Map and Filter----------------------------------------------------------------------------------- XXX Will this always fuse properly?-{-# INLINE_NORMAL mapMaybe #-}-mapMaybe :: Monad m => (a -> Maybe b) -> Stream m a -> Stream m b-mapMaybe f = fmap fromJust . filter isJust . map f--{-# INLINE_NORMAL mapMaybeM #-}-mapMaybeM :: Monad m => (a -> m (Maybe b)) -> Stream m a -> Stream m b-mapMaybeM f = fmap fromJust . filter isJust . mapM f----------------------------------------------------------------------------------- Zipping---------------------------------------------------------------------------------{-# INLINE_NORMAL indexed #-}-indexed :: Monad m => Stream m a -> Stream m (Int, a)-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--{-# INLINE_NORMAL indexedR #-}-indexedR :: Monad m => Int -> Stream m a -> Stream m (Int, a)-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--{-# 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--#if __GLASGOW_HASKELL__ >= 801-{-# RULES "zipWithM xs xs"-    forall f xs. zipWithM @Identity f xs xs = mapM (\x -> f x x) xs #-}-#endif--{-# 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))----------------------------------------------------------------------------------- Merging---------------------------------------------------------------------------------{-# 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--{-# 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)----------------------------------------------------------------------------------- Transformation comprehensions---------------------------------------------------------------------------------{-# INLINE_NORMAL the #-}-the :: (Eq a, Monad m) => Stream m a -> m (Maybe a)-the (Stream step state) = go state-  where-    go st = do-        r <- step defState st-        case r of-            Yield x s -> go' x s-            Skip s    -> go s-            Stop      -> return Nothing-    go' n st = do-        r <- step defState st-        case r of-            Yield x s | x == n -> go' n s-                      | otherwise -> return Nothing-            Skip s -> go' n s-            Stop   -> return (Just n)--{-# INLINE runFold #-}-runFold :: (Monad m) => Fold m a b -> Stream m a -> m b-runFold (Fold step begin done) = foldlMx' step begin done------------------------------------------------------------------------------------ Concurrent application and fold------------------------------------------------------------------------------------ XXX These functions should be moved to Stream/Parallel.hs------ Using StreamD the worker stream producing code can fuse with the code to--- queue output to the SVar giving some perf boost.------ Note that StreamD can only be used in limited situations, specifically, we--- cannot implement joinStreamVarPar using this.------ XXX make sure that the SVar passed is a Parallel style SVar.---- | Fold the supplied stream to the SVar asynchronously using Parallel--- concurrency style.--- {-# INLINE_NORMAL toSVarParallel #-}-{-# INLINE toSVarParallel #-}-toSVarParallel :: MonadAsync m-    => State t m a -> SVar t m a -> Stream m a -> m ()-toSVarParallel st sv xs =-    if svarInspectMode sv-    then forkWithDiag-    else do-        tid <--                case getYieldLimit st of-                    Nothing -> doFork (work Nothing)-                                      (svarMrun sv)-                                      (handleChildException sv)-                    Just _  -> doFork (workLim Nothing)-                                      (svarMrun sv)-                                      (handleChildException sv)-        modifyThread sv tid--    where--    {-# NOINLINE work #-}-    work info = (runFold (FL.toParallelSVar sv info) xs)--    {-# NOINLINE workLim #-}-    workLim info = runFold (FL.toParallelSVarLimited sv info) xs--    {-# NOINLINE forkWithDiag #-}-    forkWithDiag = do-        -- We do not use workerCount in case of ParallelVar but still there is-        -- no harm in maintaining it correctly.-        liftIO $ atomicModifyIORefCAS_ (workerCount sv) $ \n -> n + 1-        recordMaxWorkers sv-        -- This allocation matters when significant number of workers are being-        -- sent. We allocate it only when needed. The overhead increases by 4x.-        winfo <--            case yieldRateInfo sv of-                Nothing -> return Nothing-                Just _ -> liftIO $ do-                    cntRef <- newIORef 0-                    t <- getTime Monotonic-                    lat <- newIORef (0, t)-                    return $ Just WorkerInfo-                        { workerYieldMax = 0-                        , workerYieldCount = cntRef-                        , workerLatencyStart = lat-                        }-        tid <--            case getYieldLimit st of-                Nothing -> doFork (work winfo)-                                  (svarMrun sv)-                                  (handleChildException sv)-                Just _  -> doFork (workLim winfo)-                                  (svarMrun sv)-                                  (handleChildException sv)-        modifyThread sv tid--{-# INLINE_NORMAL mkParallelD #-}-mkParallelD :: MonadAsync m => Stream m a -> Stream m a-mkParallelD m = Stream step Nothing-    where--    step gst Nothing = do-        sv <- newParallelVar StopNone gst-        toSVarParallel gst sv m-        -- XXX use unfold instead?-        return $ Skip $ Just $ fromSVar sv--    step gst (Just (UnStream step1 st)) = do-        r <- step1 gst st-        return $ case r of-            Yield a s -> Yield a (Just $ Stream step1 s)-            Skip s    -> Skip (Just $ Stream step1 s)-            Stop      -> Stop---- Compare with mkAsync. mkAsync uses an Async style SVar whereas this uses a--- parallel style SVar for evaluation. Currently, parallel style cannot use--- rate control whereas Async style can use rate control. In async style SVar--- the worker thread terminates when the buffer is full whereas in Parallel--- style it blocks.------ | Make the stream producer and consumer run concurrently by introducing a--- buffer between them. The producer thread evaluates the input stream until--- the buffer fills, it blocks if the buffer is full until there is space in--- the buffer. The consumer consumes the stream lazily from the buffer.------ /Internal/----{-# INLINE_NORMAL mkParallel #-}-mkParallel :: (K.IsStream t, MonadAsync m) => t m a -> t m a-mkParallel = fromStreamD . mkParallelD . toStreamD---- Note: we can use another API with two callbacks stop and yield if we want--- the callback to be able to indicate end of stream.------ | Generates a callback and a stream pair. The callback returned is used to--- queue values to the stream.  The stream is infinite, there is no way for the--- callback to indicate that it is done now.------ /Internal/----{-# INLINE_NORMAL newCallbackStream #-}-newCallbackStream :: (K.IsStream t, MonadAsync m) => m ((a -> m ()), t m a)-newCallbackStream = do-    sv <- newParallelVar StopNone defState--    -- XXX Add our own thread-id to the SVar as we can not know the callback's-    -- thread-id and the callback is not run in a managed worker. We need to-    -- handle this better.-    liftIO myThreadId >>= modifyThread sv--    let callback a = liftIO $ void $ send sv (ChildYield a)-    -- XXX we can return an SVar and then the consumer can unfold from the-    -- SVar?-    return (callback, fromStreamD (fromSVar sv))------------------------------------------------------------------------------------ Concurrent tap------------------------------------------------------------------------------------ | Create an SVar with a fold consumer that will fold any elements sent to it--- using the supplied fold function.-{-# INLINE newFoldSVar #-}-newFoldSVar :: MonadAsync m => State t m a -> Fold m a b -> m (SVar t m a)-newFoldSVar stt f = do-    -- Buffer size for the SVar is derived from the current state-    sv <- newParallelVar StopAny (adaptState stt)-    -- Add the producer thread-id to the SVar.-    liftIO myThreadId >>= modifyThread sv-    void $ doFork (work sv) (svarMrun sv) (handleFoldException sv)-    return sv--    where--    {-# NOINLINE work #-}-    work sv = void $ runFold f $ fromProducer sv--data TapState sv st = TapInit | Tapping sv st | TapDone st--{-# INLINE_NORMAL tapAsync #-}-tapAsync :: MonadAsync m => Fold m a b -> Stream m a -> Stream m a-tapAsync f (Stream step1 state1) = Stream step TapInit-    where--    drainFold svr = do-            -- In general, a Stop event would come equipped with the result-            -- of the fold. It is not used here but it would be useful in-            -- applicative and distribute.-            done <- fromConsumer svr-            when (not done) $ do-                liftIO $ withDiagMVar svr "teeToSVar: waiting to drain"-                       $ takeMVar (outputDoorBellFromConsumer svr)-                drainFold svr--    stopFold svr = do-            liftIO $ sendStop svr Nothing-            -- drain/wait until a stop event arrives from the fold.-            drainFold svr--    {-# INLINE_LATE step #-}-    step gst TapInit = do-        sv <- newFoldSVar gst f-        return $ Skip (Tapping sv state1)--    step gst (Tapping sv st) = do-        r <- step1 gst st-        case r of-            Yield a s ->  do-                done <- pushToFold sv a-                if done-                then do-                    -- XXX we do not need to wait synchronously here-                    stopFold sv-                    return $ Yield a (TapDone s)-                else return $ Yield a (Tapping sv s)-            Skip s -> return $ Skip (Tapping sv s)-            Stop -> do-                stopFold sv-                return $ Stop--    step gst (TapDone st) = do-        r <- step1 gst st-        return $ case r of-            Yield a s -> Yield a (TapDone s)-            Skip s    -> Skip (TapDone s)-            Stop      -> Stop---- XXX Exported from Array again as this fold is specific to Array--- | Take last 'n' elements from the stream and discard the rest.-{-# INLINE lastN #-}-lastN :: (Storable a, MonadIO m) => Int -> Fold m a (Array a)-lastN n-    | n <= 0 = fmap (const mempty) FL.drain-    | otherwise = Fold step initial done-  where-    step (Tuple3' rb rh i) a = do-        rh1 <- liftIO $ RB.unsafeInsert rb rh a-        return $ Tuple3' rb rh1 (i + 1)-    initial = fmap (\(a, b) -> Tuple3' a b (0 :: Int)) $ liftIO $ RB.new n-    done (Tuple3' rb rh i) = do-        arr <- liftIO $ A.newArray n-        foldFunc i rh snoc' arr rb-    snoc' b a = liftIO $ A.unsafeSnoc b a-    foldFunc i-        | i < n = RB.unsafeFoldRingM-        | otherwise = RB.unsafeFoldRingFullM----------------------------------------------------------------------------------- Time related----------------------------------------------------------------------------------- XXX using getTime in the loop can be pretty expensive especially for--- computations where iterations are lightweight. We have the following--- options:------ 1) Run a timeout thread updating a flag asynchronously and check that--- flag here, that way we can have a cheap termination check.------ 2) Use COARSE clock to get time with lower resolution but more efficiently.------ 3) Use rdtscp/rdtsc to get time directly from the processor, compute the--- termination value of rdtsc in the beginning and then in each iteration just--- get rdtsc and check if we should terminate.----data TakeByTime st s-    = TakeByTimeInit st-    | TakeByTimeCheck st s-    | TakeByTimeYield st s--{-# INLINE_NORMAL takeByTime #-}-takeByTime :: (MonadIO m, TimeUnit64 t) => t -> Stream m a -> Stream m a-takeByTime duration (Stream step1 state1) = Stream step (TakeByTimeInit state1)-    where--    lim = toRelTime64 duration--    {-# INLINE_LATE step #-}-    step _ (TakeByTimeInit _) | lim == 0 = return Stop-    step _ (TakeByTimeInit st) = do-        t0 <- liftIO $ getTime Monotonic-        return $ Skip (TakeByTimeYield st t0)-    step _ (TakeByTimeCheck st t0) = do-        t <- liftIO $ getTime Monotonic-        return $-            if diffAbsTime64 t t0 > lim-            then Stop-            else Skip (TakeByTimeYield st t0)-    step gst (TakeByTimeYield st t0) = do-        r <- step1 gst st-        return $ case r of-             Yield x s -> Yield x (TakeByTimeCheck s t0)-             Skip s -> Skip (TakeByTimeCheck s t0)-             Stop -> Stop--data DropByTime st s x-    = DropByTimeInit st-    | DropByTimeGen st s-    | DropByTimeCheck st s x-    | DropByTimeYield st--{-# INLINE_NORMAL dropByTime #-}-dropByTime :: (MonadIO m, TimeUnit64 t) => t -> Stream m a -> Stream m a-dropByTime duration (Stream step1 state1) = Stream step (DropByTimeInit state1)-    where--    lim = toRelTime64 duration--    {-# INLINE_LATE step #-}-    step _ (DropByTimeInit st) = do-        t0 <- liftIO $ getTime Monotonic-        return $ Skip (DropByTimeGen st t0)-    step gst (DropByTimeGen st t0) = do-        r <- step1 gst st-        return $ case r of-             Yield x s -> Skip (DropByTimeCheck s t0 x)-             Skip s -> Skip (DropByTimeGen s t0)-             Stop -> Stop-    step _ (DropByTimeCheck st t0 x) = do-        t <- liftIO $ getTime Monotonic-        if diffAbsTime64 t t0 <= lim-        then return $ Skip $ DropByTimeGen st t0-        else return $ Yield x $ DropByTimeYield st-    step gst (DropByTimeYield st) = do-        r <- step1 gst st-        return $ case r of-             Yield x s -> Yield x (DropByTimeYield s)-             Skip s -> Skip (DropByTimeYield s)-             Stop -> Stop---- XXX we should move this to stream generation section of this file. Also, the--- take/drop combinators above should be moved to filtering section.-{-# INLINE_NORMAL currentTime #-}-currentTime :: MonadAsync m => Double -> Stream m AbsTime-currentTime g = Stream step Nothing--    where--    g' = g * 10 ^ (6 :: Int)--    -- XXX should have a minimum granularity to avoid high CPU usage?-    {-# INLINE delayTime #-}-    delayTime =-        if g' >= fromIntegral (maxBound :: Int)-        then maxBound-        else round g'--    updateTimeVar timeVar = do-        threadDelay $ delayTime-        MicroSecond64 t <- fromAbsTime <$> getTime Monotonic-        modifyVar' timeVar (const t)--    {-# INLINE_LATE step #-}-    step _ Nothing = do-        -- XXX note that 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.-        timeVar <- liftIO $ newVar (0 :: Int64)-        tid <- forkManaged $ liftIO $ forever (updateTimeVar timeVar)-        return $ Skip $ Just (timeVar, tid)--    step _ s@(Just (timeVar, _)) = do-        a <- liftIO $ readVar timeVar-        -- 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 (MicroSecond64 a)) s+-- |+-- 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.Nesting+    , module Streamly.Internal.Data.Stream.StreamD.Transform+    )+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.Nesting+import Streamly.Internal.Data.Stream.StreamD.Transform
+ src/Streamly/Internal/Data/Stream/StreamD/Eliminate.hs view
@@ -0,0 +1,524 @@+-- |+-- 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+    , parse_++    -- * 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+    , isSubsequenceOf+    , stripPrefix+    )+where++#include "inline.hs"++import Control.Exception (assert)+import Control.Monad.Catch (MonadThrow, throwM)+import GHC.Exts (SpecConstrAnnotation(..))+import GHC.Types (SPEC(..))+import Streamly.Internal.Data.Parser (ParseError(..))++import qualified Streamly.Internal.Data.Parser as PR+import qualified Streamly.Internal.Data.Parser.ParserD as PRD+import qualified Streamly.Internal.Data.Stream.StreamD.Nesting as Nesting++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+import Streamly.Internal.Data.SVar++------------------------------------------------------------------------------+-- 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 parse #-}+parse+    :: MonadThrow m+    => PRD.Parser m a b+    -> Stream m a+    -> m b+parse parser strm = do+    (b, _) <- parse_ parser strm+    return b++-- | Run a 'Parse' over a stream and return rest of the Stream.+{-# INLINE_NORMAL parse_ #-}+parse_+    :: MonadThrow m+    => PRD.Parser m a b+    -> Stream m a+    -> m (b, Stream m a)+parse_ (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 (b, stream)+        PRD.IError err -> throwM $ ParseError err++    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.+    {-# INLINE go #-}+    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 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 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 (b, Stream step st)+                    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 (b, Nesting.append (fromList src) (Stream step s))+                    PR.Error err -> throwM $ ParseError err+            Skip s -> go SPEC s buf pst+            Stop   -> do+                b <- extract pst+                return (b, let List buffer = buf in fromList buffer)++    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 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 (b, Nesting.append (fromList src) (Stream step s))+            PR.Error err -> throwM $ ParseError err++------------------------------------------------------------------------------+-- Specialized Folds+------------------------------------------------------------------------------++-- | Run a streaming composition, discard the results.+{-# INLINE_LATE drain #-}+drain :: Monad m => Stream m a -> m ()+-- drain = foldrM (\_ xs -> xs) (return ())+drain (Stream step state) = go SPEC state+  where+    go !_ st = do+        r <- step defState st+        case r of+            Yield _ s -> go SPEC s+            Skip s    -> go SPEC s+            Stop      -> return ()++{-# INLINE_NORMAL null #-}+null :: Monad m => Stream m a -> m Bool+null m = foldrM (\_ _ -> return False) (return True) m++{-# INLINE_NORMAL head #-}+head :: Monad m => Stream m a -> m (Maybe a)+head m = foldrM (\x _ -> return (Just x)) (return Nothing) m++{-# INLINE_NORMAL headElse #-}+headElse :: Monad m => a -> Stream m a -> m a+headElse a m = foldrM (\x _ -> return x) (return a) m++-- 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 state+  where+    go st = do+        r <- step defState st+        case r of+            Yield _ s -> return (Just $ Stream step s)+            Skip  s   -> go s+            Stop      -> return Nothing++-- XXX will it fuse? need custom impl?+{-# INLINE_NORMAL last #-}+last :: Monad m => Stream m a -> m (Maybe a)+last = foldl' (\_ y -> Just y) Nothing++{-# INLINE_NORMAL elem #-}+elem :: (Monad m, Eq a) => a -> Stream m a -> m Bool+-- elem e m = foldrM (\x xs -> if x == e then return True else xs) (return False) m+elem e (Stream step state) = go state+  where+    go st = do+        r <- step defState st+        case r of+            Yield x s+              | x == e    -> return True+              | otherwise -> go s+            Skip s -> go s+            Stop   -> return False++{-# 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+-- all p m = foldrM (\x xs -> if p x then xs else return False) (return True) m+all p (Stream step state) = go state+  where+    go st = do+        r <- step defState st+        case r of+            Yield x s+              | p x       -> go s+              | otherwise -> return False+            Skip s -> go s+            Stop   -> return True++{-# INLINE_NORMAL any #-}+any :: Monad m => (a -> Bool) -> Stream m a -> m Bool+-- any p m = foldrM (\x xs -> if p x then return True else xs) (return False) m+any p (Stream step state) = go state+  where+    go st = do+        r <- step defState st+        case r of+            Yield x s+              | p x       -> return True+              | otherwise -> go s+            Skip s -> go s+            Stop   -> return False++{-# INLINE_NORMAL maximum #-}+maximum :: (Monad m, Ord a) => Stream m a -> m (Maybe a)+maximum (Stream step state) = go Nothing state+  where+    go Nothing st = do+        r <- step defState st+        case r of+            Yield x s -> go (Just x) s+            Skip  s   -> go Nothing s+            Stop      -> return Nothing+    go (Just acc) st = do+        r <- step defState st+        case r of+            Yield x s+              | acc <= x  -> go (Just x) s+              | otherwise -> go (Just acc) s+            Skip s -> go (Just acc) s+            Stop   -> return (Just acc)++{-# INLINE_NORMAL maximumBy #-}+maximumBy :: Monad m => (a -> a -> Ordering) -> Stream m a -> m (Maybe a)+maximumBy cmp (Stream step state) = go Nothing state+  where+    go Nothing st = do+        r <- step defState st+        case r of+            Yield x s -> go (Just x) s+            Skip  s   -> go 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 (Just acc) s+                _  -> go (Just x) s+            Skip s -> go (Just acc) s+            Stop   -> return (Just acc)++{-# INLINE_NORMAL minimum #-}+minimum :: (Monad m, Ord a) => Stream m a -> m (Maybe a)+minimum (Stream step state) = go Nothing state+  where+    go Nothing st = do+        r <- step defState st+        case r of+            Yield x s -> go (Just x) s+            Skip  s   -> go Nothing s+            Stop      -> return Nothing+    go (Just acc) st = do+        r <- step defState st+        case r of+            Yield x s+              | acc <= x  -> go (Just acc) s+              | otherwise -> go (Just x) s+            Skip s -> go (Just acc) s+            Stop   -> return (Just acc)++{-# INLINE_NORMAL minimumBy #-}+minimumBy :: Monad m => (a -> a -> Ordering) -> Stream m a -> m (Maybe a)+minimumBy cmp (Stream step state) = go Nothing state+  where+    go Nothing st = do+        r <- step defState st+        case r of+            Yield x s -> go (Just x) s+            Skip  s   -> go 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 (Just x) s+                _  -> go (Just acc) s+            Skip s -> go (Just acc) s+            Stop   -> return (Just acc)++{-# INLINE_NORMAL (!!) #-}+(!!) :: (Monad m) => Stream m a -> Int -> m (Maybe a)+(Stream step state) !! i = go 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 (n - 1) s+            Skip s -> go n s+            Stop   -> return Nothing++{-# INLINE_NORMAL lookup #-}+lookup :: (Monad m, Eq a) => a -> Stream m (a, b) -> m (Maybe b)+lookup e m = foldrM (\(a, b) xs -> if e == a then return (Just b) else xs)+                   (return Nothing) m++{-# INLINE_NORMAL findM #-}+findM :: Monad m => (a -> m Bool) -> Stream m a -> m (Maybe a)+findM p m = foldrM (\x xs -> p x >>= \r -> if r then return (Just x) else xs)+                   (return Nothing) m++{-# 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]+toListRev = foldl' (flip (:)) []++------------------------------------------------------------------------------+-- Transformation comprehensions+------------------------------------------------------------------------------++{-# INLINE_NORMAL the #-}+the :: (Eq a, Monad m) => Stream m a -> m (Maybe a)+the (Stream step state) = go state+  where+    go st = do+        r <- step defState st+        case r of+            Yield x s -> go' x s+            Skip s    -> go s+            Stop      -> return Nothing+    go' n st = do+        r <- step defState st+        case r of+            Yield x s | x == n -> go' n s+                      | otherwise -> return Nothing+            Skip s -> go' n s+            Stop   -> return (Just n)++------------------------------------------------------------------------------+-- 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 ()+mapM_ m = drain . mapM m++------------------------------------------------------------------------------+-- Multi-stream folds+------------------------------------------------------------------------------++{-# INLINE_NORMAL isPrefixOf #-}+isPrefixOf :: (Eq a, Monad m) => Stream m a -> Stream m a -> m Bool+isPrefixOf (Stream stepa ta) (Stream stepb tb) = go (ta, tb, Nothing)+  where+    go (sa, sb, Nothing) = do+        r <- stepa defState sa+        case r of+            Yield x sa' -> go (sa', sb, Just x)+            Skip sa'    -> go (sa', sb, Nothing)+            Stop        -> return True++    go (sa, sb, Just x) = do+        r <- stepb defState sb+        case r of+            Yield y sb' ->+                if x == y+                    then go (sa, sb', Nothing)+                    else return False+            Skip sb' -> go (sa, sb', Just x)+            Stop     -> return False++{-# INLINE_NORMAL isSubsequenceOf #-}+isSubsequenceOf :: (Eq a, Monad m) => Stream m a -> Stream m a -> m Bool+isSubsequenceOf (Stream stepa ta) (Stream stepb tb) = go (ta, tb, Nothing)+  where+    go (sa, sb, Nothing) = do+        r <- stepa defState sa+        case r of+            Yield x sa' -> go (sa', sb, Just x)+            Skip sa'    -> go (sa', sb, Nothing)+            Stop        -> return True++    go (sa, sb, Just x) = do+        r <- stepb defState sb+        case r of+            Yield y sb' ->+                if x == y+                    then go (sa, sb', Nothing)+                    else go (sa, sb', Just x)+            Skip sb' -> go (sa, sb', Just x)+            Stop     -> return False++{-# INLINE_NORMAL stripPrefix #-}+stripPrefix+    :: (Eq a, Monad m)+    => Stream m a -> Stream m a -> m (Maybe (Stream m a))+stripPrefix (Stream stepa ta) (Stream stepb tb) = go (ta, tb, Nothing)+  where+    go (sa, sb, Nothing) = do+        r <- stepa defState sa+        case r of+            Yield x sa' -> go (sa', sb, Just x)+            Skip sa'    -> go (sa', sb, Nothing)+            Stop        -> return $ Just (Stream stepb sb)++    go (sa, sb, Just x) = do+        r <- stepb defState sb+        case r of+            Yield y sb' ->+                if x == y+                    then go (sa, sb', Nothing)+                    else return Nothing+            Skip sb' -> go (sa, sb', Just x)+            Stop     -> return Nothing
+ src/Streamly/Internal/Data/Stream/StreamD/Exception.hs view
@@ -0,0 +1,351 @@+-- |+-- 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+    , after_+    , after+    , bracket_+    , bracket+    , onException+    , finally_+    , finally+    , ghandle+    , handle+    )+where++#include "inline.hs"++import Control.Exception (Exception, SomeException, mask_)+import Control.Monad.Catch (MonadCatch)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.Control (MonadBaseControl, liftBaseOp_)+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+import Streamly.Internal.Data.SVar++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.+-- * does not require a 'MonadAsync' constraint.+--+-- /Inhibits stream fusion/+--+-- /Pre-release/+--+{-# INLINE_NORMAL gbracket_ #-}+gbracket_+    :: Monad m+    => m c                                  -- ^ before+    -> (forall s. m s -> m (Either e s))    -- ^ try (exception handling)+    -> (c -> m d)                           -- ^ after, on normal stop+    -> (c -> e -> Stream m b -> Stream m b) -- ^ on exception+    -> (c -> Stream m b)                    -- ^ stream generator+    -> Stream m b+gbracket_ bef exc aft fexc fnormal =+    Stream step GBracketInit++    where++    {-# INLINE_LATE step #-}+    step _ GBracketInit = do+        r <- bef+        return $ Skip $ GBracketNormal (fnormal r) r++    step gst (GBracketNormal (UnStream step1 st) v) = do+        res <- exc $ 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 (fexc 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)@.+--+-- 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, MonadBaseControl IO m)+    => m c                                  -- ^ before+    -> (forall s. m s -> m (Either e s))    -- ^ try (exception handling)+    -> (c -> m d)                           -- ^ after, on normal stop or GC+    -> (c -> e -> Stream m b -> m (Stream m b)) -- ^ on exception+    -> (c -> Stream m b)                    -- ^ stream generator+    -> Stream m b+gbracket bef exc aft fexc fnormal =+    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) <- liftBaseOp_ mask_ $ do+            r <- bef+            ref <- newIOFinalizer (aft r)+            return (r, ref)+        return $ Skip $ GBracketIONormal (fnormal r) r ref++    step gst (GBracketIONormal (UnStream step1 st) v ref) = do+        res <- exc $ 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 -> 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.+                stream <- clearingIOFinalizer ref (fexc 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++-- | See 'Streamly.Internal.Data.Stream.IsStream.before'.+--+{-# 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++-- | See 'Streamly.Internal.Data.Stream.IsStream.after_'.+--+{-# INLINE_NORMAL after_ #-}+after_ :: Monad m => m b -> Stream m a -> Stream m a+after_ 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++-- | See 'Streamly.Internal.Data.Stream.IsStream.after'.+--+{-# INLINE_NORMAL after #-}+after :: (MonadIO m, MonadBaseControl IO m)+    => m b -> Stream m a -> Stream m a+after action (Stream step state) = Stream step' Nothing++    where++    {-# INLINE_LATE step' #-}+    step' _ Nothing = do+        ref <- 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.+--+-- | See 'Streamly.Internal.Data.Stream.IsStream.onException'.+--+{-# INLINE_NORMAL onException #-}+onException :: MonadCatch m => m b -> Stream m a -> Stream m a+onException action str =+    gbracket_ (return ()) (inline MC.try) return+        (\_ (e :: MC.SomeException) _ -> nilM (action >> MC.throwM e))+        (\_ -> str)++{-# 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++-- | See 'Streamly.Internal.Data.Stream.IsStream.bracket_'.+--+{-# INLINE_NORMAL bracket_ #-}+bracket_ :: MonadCatch m+    => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a+bracket_ bef aft bet =+    gbracket_ bef (inline MC.try) aft+        (\a (e :: SomeException) _ -> nilM (aft a >> MC.throwM e)) bet++-- | See 'Streamly.Internal.Data.Stream.IsStream.bracket'.+--+{-# INLINE_NORMAL bracket #-}+bracket :: (MonadAsync m, MonadCatch m)+    => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a+bracket bef aft bet =+    gbracket bef (inline MC.try) aft+        (\a (e :: SomeException) _ -> aft a >> return (nilM (MC.throwM e))) bet++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++-- | See 'Streamly.Internal.Data.Stream.IsStream.finally_'.+--+{-# INLINE finally_ #-}+finally_ :: MonadCatch m => m b -> Stream m a -> Stream m a+finally_ action xs = bracket_ (return ()) (\_ -> action) (const xs)++-- | See 'Streamly.Internal.Data.Stream.IsStream.finally'.+--+-- finally action xs = after action $ onException action xs+--+{-# INLINE finally #-}+finally :: (MonadAsync m, MonadCatch m) => m b -> Stream m a -> Stream m a+finally action xs = bracket (return ()) (\_ -> action) (const xs)++-- | See 'Streamly.Internal.Data.Stream.IsStream.ghandle'.+--+{-# INLINE_NORMAL ghandle #-}+ghandle :: (MonadCatch m, Exception e)+    => (e -> Stream m a -> Stream m a) -> Stream m a -> Stream m a+ghandle f str =+    gbracket_ (return ()) (inline MC.try) return (\_ -> f) (\_ -> str)++-- | See 'Streamly.Internal.Data.Stream.IsStream.handle'.+--+{-# INLINE_NORMAL handle #-}+handle :: (MonadCatch m, Exception e)+    => (e -> Stream m a) -> Stream m a -> Stream m a+handle f str =+    gbracket_ (return ()) (inline MC.try) return (\_ e _ -> f e) (\_ -> str)++-- | 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
+ src/Streamly/Internal/Data/Stream/StreamD/Generate.hs view
@@ -0,0 +1,405 @@+-- |+-- 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+--+-- Prefer unfolds ("Streamly.Internal.Data.Unfold") over the combinators in+-- this module. They are more powerful and efficient as they can be transformed+-- and composed on the input side efficiently and they can fuse in nested+-- operations (e.g.  unfoldMany). All the combinators in this module can be+-- expressed using unfolds with the same efficiency.+--+-- Operations in this module that are not in "Streamly.Internal.Data.Unfold":+-- generate, times, fromPrimIORef.+--+-- We should plan to replace this module with "Streamly.Internal.Data.Unfold"+-- in future.++-- 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+    , enumerateFromStepIntegral+    , enumerateFromIntegral+    , enumerateFromThenIntegral+    , enumerateFromToIntegral+    , enumerateFromThenToIntegral++    , enumerateFromStepNum+    , numFrom+    , numFromThen+    , enumerateFromToFractional+    , enumerateFromThenToFractional++    -- * Time Enumeration+    , times++    -- * 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.++    -- Note: Direct style stream does not support @fromFoldable@.+    , fromList+    , fromListM++    -- * Conversions+    , fromStreamK+    , toStreamK+    , fromStreamD+    , toStreamD+    )+where++#include "inline.hs"++import Control.Monad.IO.Class (MonadIO(..))+import Streamly.Internal.Data.Time.Clock+    (Clock(Monotonic), asyncClock, readClock)+import Streamly.Internal.Data.Time.Units+    (toAbsTime, AbsTime, toRelTime64, RelTime64)++import Prelude hiding (iterate, repeat, replicate, takeWhile)+import Streamly.Internal.Data.Stream.StreamD.Type+import Streamly.Internal.Data.SVar++------------------------------------------------------------------------------+-- Primitives+------------------------------------------------------------------------------++-- | An empty 'Stream'.+{-# INLINE_NORMAL nil #-}+nil :: Monad m => Stream m a+nil = Stream (\_ _ -> return Stop) ()++-- XXX implement in terms of consM?+-- cons x = consM (return x)+--+-- | Can fuse but has O(n^2) complexity.+{-# INLINE_NORMAL cons #-}+cons :: Monad m => a -> Stream m a -> Stream m a+cons x (Stream step state) = Stream step1 Nothing+    where+    {-# INLINE_LATE step1 #-}+    step1 _ Nothing   = return $ Yield x (Just state)+    step1 gst (Just st) = do+        r <- step gst st+        return $+          case r of+            Yield a s -> Yield a (Just s)+            Skip  s   -> Skip (Just s)+            Stop      -> Stop++------------------------------------------------------------------------------+-- Unfolding+------------------------------------------------------------------------------++-- Adapted from vector package+{-# INLINE_NORMAL unfoldrM #-}+unfoldrM :: Monad m => (s -> m (Maybe (a, s))) -> s -> Stream m a+unfoldrM next state = Stream step state+  where+    {-# INLINE_LATE step #-}+    step _ st = do+        r <- next st+        return $ case r of+            Just (x, s) -> Yield x s+            Nothing     -> Stop++{-# INLINE_LATE unfoldr #-}+unfoldr :: Monad m => (s -> Maybe (a, s)) -> s -> Stream m a+unfoldr f = unfoldrM (return . f)++------------------------------------------------------------------------------+-- From values+------------------------------------------------------------------------------++{-# INLINE_NORMAL repeatM #-}+repeatM :: Monad m => m a -> Stream m a+repeatM x = Stream (\_ _ -> x >>= \r -> return $ Yield r ()) ()++{-# INLINE_NORMAL repeat #-}+repeat :: Monad m => a -> Stream m a+repeat x = Stream (\_ _ -> return $ Yield x ()) ()++-- Adapted from the vector package+{-# INLINE_NORMAL replicateM #-}+replicateM :: forall m a. Monad m => Int -> m a -> Stream m a+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)++{-# 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+enumerateFromStepNum from stride = Stream step 0+    where+    {-# INLINE_LATE step #-}+    step _ !i = return $ (Yield $! (from + i * stride)) $! (i + 1)++{-# INLINE_NORMAL numFrom #-}+numFrom :: (Monad m, Num a) => a -> Stream m a+numFrom from = enumerateFromStepNum from 1++{-# INLINE_NORMAL numFromThen #-}+numFromThen :: (Monad m, Num a) => a -> a -> Stream m a+numFromThen from next = enumerateFromStepNum from (next - from)++------------------------------------------------------------------------------+-- Enumeration of Integrals+------------------------------------------------------------------------------++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++{-# INLINE_NORMAL enumerateFromThenToIntegral #-}+enumerateFromThenToIntegral+    :: (Monad m, Integral a)+    => a -> a -> a -> Stream m a+enumerateFromThenToIntegral from next to+    | next >= from = enumerateFromThenToIntegralUp from next to+    | otherwise    = enumerateFromThenToIntegralDn from next to++{-# INLINE_NORMAL enumerateFromThenIntegral #-}+enumerateFromThenIntegral+    :: (Monad m, Integral a, Bounded a)+    => a -> a -> Stream m a+enumerateFromThenIntegral from next =+    if next > from+    then enumerateFromThenToIntegralUp from next maxBound+    else enumerateFromThenToIntegralDn from next minBound++-- | Can be used to enumerate unbounded integrals. This does not check for+-- overflow or underflow for bounded integrals.+--+{-# INLINE_NORMAL enumerateFromStepIntegral #-}+enumerateFromStepIntegral :: (Integral a, Monad m) => a -> a -> Stream m a+enumerateFromStepIntegral from stride =+    from `seq` stride `seq` Stream step from+    where+        {-# INLINE_LATE step #-}+        step _ !x = return $ Yield x $! (x + stride)++-- | Enumerate upwards from @from@ to @to@. We are assuming that "to" is+-- constrained by the type to be within max/min bounds.+{-# INLINE enumerateFromToIntegral #-}+enumerateFromToIntegral :: (Monad m, Integral a) => a -> a -> Stream m a+enumerateFromToIntegral from to =+    takeWhile (<= to) $ enumerateFromStepIntegral from 1++{-# 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.+{-# 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++{-# INLINE_NORMAL enumerateFromThenToFractional #-}+enumerateFromThenToFractional+    :: (Monad m, Fractional a, Ord a)+    => a -> a -> a -> Stream m a+enumerateFromThenToFractional from next to =+    takeWhile predicate $ numFromThen from next+    where+    mid = (next - from) / 2+    predicate | next >= from  = (<= to + mid)+              | otherwise     = (>= to + mid)++------------------------------------------------------------------------------+-- Time Enumeration+------------------------------------------------------------------------------++{-# INLINE_NORMAL times #-}+times :: MonadAsync m => Double -> Stream m (AbsTime, RelTime64)+times 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++-------------------------------------------------------------------------------+-- From Generators+-------------------------------------------------------------------------------++{-# INLINE_NORMAL fromIndicesM #-}+fromIndicesM :: Monad m => (Int -> m a) -> Stream m a+fromIndicesM gen = Stream step 0+  where+    {-# INLINE_LATE step #-}+    step _ i = do+       x <- gen i+       return $ Yield x (i + 1)++{-# 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+-------------------------------------------------------------------------------++{-# INLINE_NORMAL iterateM #-}+iterateM :: Monad m => (a -> m a) -> m a -> Stream m a+iterateM step = Stream (\_ st -> st >>= \(!x) -> return $ Yield x (step x))++{-# INLINE_NORMAL iterate #-}+iterate :: Monad m => (a -> a) -> a -> Stream m a+iterate step st = iterateM (return . step) (return st)++-------------------------------------------------------------------------------+-- From containers+-------------------------------------------------------------------------------++-- XXX we need the MonadAsync constraint because of a rewrite rule.+-- | Convert a list of monadic actions to a 'Stream'+{-# INLINE_LATE fromListM #-}+fromListM :: MonadAsync m => [m a] -> Stream m a+fromListM = Stream step+  where+    {-# INLINE_LATE step #-}+    step _ (m:ms) = m >>= \x -> return $ Yield x ms+    step _ []     = return Stop
+ src/Streamly/Internal/Data/Stream/StreamD/Lift.hs view
@@ -0,0 +1,112 @@+-- |+-- 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+      hoist+    , generally -- XXX generalize++    -- * Transform Inner Monad+    , liftInner+    , runReaderT+    , evalStateT+    , runStateT+    )+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 Data.Functor.Identity (Identity(..))+import Streamly.Internal.Data.SVar (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++-------------------------------------------------------------------------------+-- Generalize Inner Monad+-------------------------------------------------------------------------------++{-# INLINE_NORMAL hoist #-}+hoist :: Monad n => (forall x. m x -> n x) -> Stream m a -> Stream n a+hoist 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++{-# INLINE generally #-}+generally :: Monad m => Stream Identity a -> Stream m a+generally = hoist (return . runIdentity)++-------------------------------------------------------------------------------+-- Transform Inner Monad+-------------------------------------------------------------------------------++{-# 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++{-# 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++{-# 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++{-# 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
+ src/Streamly/Internal/Data/Stream/StreamD/Nesting.hs view
@@ -0,0 +1,2326 @@+-- |+-- 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+    -- unfoldManyInterleave.+    , InterleaveState(..)+    , interleave+    , interleaveMin+    , interleaveSuffix+    , interleaveInfix++    -- *** 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 unfoldManyRoundRobin.+    , roundRobin -- interleaveFair?/ParallelFair++    -- *** Zipping+    -- | Zip corresponding elements of two streams.+    , zipWith+    , zipWithM++    -- *** Merging+    -- | Interleave elements from two streams based on a condition.+    , mergeBy+    , mergeByM++    -- ** 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 (..)+    , unfoldManyInterleave+    , unfoldManyRoundRobin++    -- *** Interpose+    -- | Like unfoldMany but intersperses an effect between the streams. A+    -- special case of gintercalate.+    , interpose+    , interposeSuffix++    -- *** Intercalate+    -- | Like unfoldMany but intersperses streams from another source between+    -- the streams from the first source.+    , gintercalate+    , gintercalateSuffix++    -- * 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 m a b) -> t m a -> t m b+    -- @++    -- ** Folding+    -- | Apply folds on a stream.+    , foldMany+    , foldIterateM++    -- ** 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+    , parseIterate++    -- ** Grouping+    -- | Group segments of a stream and fold. Special case of parsing.+    , chunksOf+    , groupsOf2+    , groupsBy+    , groupsRollingBy++    -- ** Splitting+    -- | A special case of parsing.+    , wordsBy+    , splitOnSeq+    , splitOnSuffixSeq++    -- * Transform (Nested Containers)+    -- | Opposite to compact in ArrayStream+    , splitInnerBy+    , splitInnerBySuffix+    )+where++#include "inline.hs"++import Control.Exception (assert)+import Control.Monad.Catch (MonadThrow, throwM)+import Control.Monad.IO.Class (MonadIO(..))+import Data.Bits (shiftR, shiftL, (.|.), (.&.))+#if __GLASGOW_HASKELL__ >= 801+import Data.Functor.Identity ( Identity )+#endif+import Data.Word (Word32)+import Foreign.Storable (Storable(..))+import Fusion.Plugin.Types (Fuse(..))+import GHC.Types (SPEC(..))++import Streamly.Internal.Data.Array.Foreign.Type (Array(..))+import Streamly.Internal.Data.Fold.Type (Fold(..))+import Streamly.Internal.Data.Parser (ParseError(..))+import Streamly.Internal.Data.Unfold.Type (Unfold(..))++import qualified Streamly.Internal.Data.Array.Foreign.Type as A+import qualified Streamly.Internal.Data.Fold.Type as FL+import qualified Streamly.Internal.Data.Parser as PR+import qualified Streamly.Internal.Data.Parser.ParserD as PRD+import qualified Streamly.Internal.Ring.Foreign as RB++import Streamly.Internal.Data.Stream.StreamD.Type+import Streamly.Internal.Data.SVar++import Prelude hiding (concatMap, mapM, zipWith)++------------------------------------------------------------------------------+-- Appending+------------------------------------------------------------------------------++data AppendState s1 s2 = AppendFirst s1 | AppendSecond s2++-- Note that this could be much faster compared to the CPS stream. However, as+-- the number of streams being composed increases this may become expensive.+-- Need to see where the breaking point is between the two.+--+{-# 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++{-# 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++{-# 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++{-# INLINE_NORMAL interleaveSuffix #-}+interleaveSuffix :: Monad m => Stream m a -> Stream m a -> Stream m a+interleaveSuffix (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++{-# INLINE_NORMAL interleaveInfix #-}+interleaveInfix :: Monad m => Stream m a -> Stream m a -> Stream m a+interleaveInfix (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+------------------------------------------------------------------------------++{-# 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++------------------------------------------------------------------------------+-- Zipping+------------------------------------------------------------------------------++{-# 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++#if __GLASGOW_HASKELL__ >= 801+{-# RULES "zipWithM xs xs"+    forall f xs. zipWithM @Identity f xs xs = mapM (\x -> f x x) xs #-}+#endif++{-# 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))++------------------------------------------------------------------------------+-- Merging+------------------------------------------------------------------------------++{-# 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++{-# 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)++------------------------------------------------------------------------------+-- 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.+--+{-# INLINE_NORMAL unfoldManyInterleave #-}+unfoldManyInterleave :: Monad m => Unfold m a b -> Stream m a -> Stream m b+unfoldManyInterleave (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 unfoldManyInterleave this one switches streams on Skips.+--+{-# INLINE_NORMAL unfoldManyRoundRobin #-}+unfoldManyRoundRobin :: Monad m => Unfold m a b -> Stream m a -> Stream m b+unfoldManyRoundRobin (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 interposeSuffix #-}+interposeSuffix+    :: Monad m+    => m c -> Unfold m b c -> Stream m b -> Stream m c+interposeSuffix+    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)++{-# 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 interpose #-}+interpose :: Monad m => m c -> Unfold m b c -> Stream m b -> Stream m c+interpose+    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)+    -}++------------------------------------------------------------------------------+-- 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++-- | Interleave streams (full streams, not the elements) unfolded from two+-- input streams and concat. Stop when the first stream stops. If the second+-- stream ends before the first one then first stream still keeps running alone+-- without any interleaving with the second stream.+--+--    [a1, a2, ... an]                   [b1, b2 ...]+-- => [streamA1, streamA2, ... streamAn] [streamB1, streamB2, ...]+-- => [streamA1, streamB1, streamA2...StreamAn, streamBn]+-- => [a11, a12, ...a1j, b11, b12, ...b1k, a21, a22, ...]+--+{-# 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++-- | Interleave streams (full streams, not the elements) unfolded from two+-- input streams and concat. Stop when the first stream stops. If the second+-- stream ends before the first one then first stream still keeps running alone+-- without any interleaving with the second stream.+--+--    [a1, a2, ... an]                   [b1, b2 ...]+-- => [streamA1, streamA2, ... streamAn] [streamB1, streamB2, ...]+-- => [streamA1, streamB1, streamA2...StreamAn, streamBn]+-- => [a11, a12, ...a1j, b11, b12, ...b1k, a21, a22, ...]+--+{-# 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)+    -}++------------------------------------------------------------------------------+-- Folding+------------------------------------------------------------------------------++{-# 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++{-# INLINE_NORMAL foldIterateM #-}+foldIterateM ::+       Monad m => (b -> m (FL.Fold m a b)) -> 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 fb++    {-# INLINE_LATE stepOuter #-}+    stepOuter _ (FIterInit st seed) = do+        (FL.Fold fstep initial extract) <- func seed+        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++------------------------------------------------------------------------------+-- Parsing+------------------------------------------------------------------------------++{-# ANN type ParseChunksState Fuse #-}+data ParseChunksState x inpBuf st pst =+      ParseChunksInit inpBuf st+    | ParseChunksInitLeftOver inpBuf+    | ParseChunksStream st inpBuf !pst+    | ParseChunksBuf inpBuf st inpBuf !pst+    | ParseChunksYield x (ParseChunksState x inpBuf st pst)++{-# INLINE_NORMAL parseMany #-}+parseMany+    :: MonadThrow m+    => PRD.Parser m a b+    -> Stream m a+    -> Stream m b+parseMany (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 pb next+                    PRD.IError err -> throwM $ ParseError err+            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 pb next+            PRD.IError err -> throwM $ ParseError err++    -- 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 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 b (ParseChunksInit src s)+                    PR.Error err -> throwM $ ParseError err+            Skip s -> return $ Skip $ ParseChunksStream s buf pst+            Stop   -> do+                b <- extract pst+                let src = Prelude.reverse buf+                return $ Skip $+                    ParseChunksYield b (ParseChunksInitLeftOver src)++    -- 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 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 b (ParseChunksInit src s)+            PR.Error err -> throwM $ ParseError err++    stepOuter _ (ParseChunksYield a next) = return $ Yield a next++{-# ANN type ConcatParseState Fuse #-}+data ConcatParseState b inpBuf st p m a =+      ConcatParseInit inpBuf st p+    | ConcatParseInitLeftOver inpBuf+    | forall s. ConcatParseStream st inpBuf (s -> a -> m (PRD.Step s b)) s (s -> m b)+    | forall s. ConcatParseBuf inpBuf st inpBuf (s -> a -> m (PRD.Step s b)) s (s -> m b)+    | ConcatParseYield b (ConcatParseState b inpBuf st p m a)++{-# INLINE_NORMAL parseIterate #-}+parseIterate+    :: MonadThrow m+    => (b -> PRD.Parser m a b)+    -> b+    -> Stream m a+    -> Stream m b+parseIterate 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 pb next+            PRD.IError err -> throwM $ ParseError err++    -- 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 pb next+            PRD.IError err -> throwM $ ParseError err++    -- 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 b (ConcatParseInit src s (func b))+                    PR.Error err -> throwM $ ParseError err+            Skip s -> return $ Skip $ ConcatParseStream s buf pstep pst extract+            Stop   -> do+                b <- extract pst+                let src = Prelude.reverse buf+                return $ Skip $ ConcatParseYield b (ConcatParseInitLeftOver src)++    -- 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 b+                                    (ConcatParseInit src s (func b))+            PR.Error err -> throwM $ ParseError err++    stepOuter _ (ConcatParseYield a next) = return $ Yield a next++------------------------------------------------------------------------------+-- 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, 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 = sizeOf (undefined :: 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 patArr 0+                         return $ Skip $ SplitOnSeqSingle acc state pat+                     else if sizeOf (undefined :: a) * patLen+                               <= sizeOf (undefined :: 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, 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 = sizeOf (undefined :: 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 patArr 0+                         skip $ SplitOnSuffixSeqSingleInit fs state pat+                     else if sizeOf (undefined :: a) * patLen+                               <= sizeOf (undefined :: 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++------------------------------------------------------------------------------+-- 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
+ src/Streamly/Internal/Data/Stream/StreamD/Step.hs view
@@ -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+-}
+ src/Streamly/Internal/Data/Stream/StreamD/Transform.hs view
@@ -0,0 +1,1226 @@+-- |+-- 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+    , tapRate+    , pollCounts++    -- * Folding+    , foldrS+    , foldrT+    , foldlS+    , foldlT++    -- * Scanning By 'Fold'+    , postscanOnce -- XXX rename to postscan+    , scanOnce     -- XXX rename to scan++    -- * 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.+    , filter+    , filterM+    , deleteBy+    , uniq++    -- * Trimming+    -- | Produce a subset of the stream trimmed at ends.+    , take+    , takeByTime+    , takeWhile+    , takeWhileM+    , drop+    , dropByTime+    , dropWhile+    , dropWhileM++    -- * Inserting Elements+    -- | Produce a superset of the stream.+    , insertBy+    , intersperse+    , intersperseM+    , intersperseSuffix+    , intersperseSuffixBySpan++    -- * Inserting Side Effects+    , intersperseM_+    , intersperseSuffix_++    -- * Reordering+    -- | Produce strictly the same set but reordered.+    , reverse+    , reverse'++    -- * Position Indexing+    , indexed+    , indexedR++    -- * Searching+    , findIndices++    -- * Rolling map+    -- | Map using the previous element.+    , rollingMap+    , rollingMapM++    -- * Maybe Streams+    , mapMaybe+    , mapMaybeM+    )+where++#include "inline.hs"++import Control.Concurrent (killThread, threadDelay)+import Control.Exception (AsyncException)+import Control.Monad (void, when)+import Control.Monad.Catch (MonadCatch, throwM)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.Class (MonadTrans(lift))+import Data.IORef (newIORef, mkWeakIORef)+import Data.Maybe (fromJust, isJust)+import Foreign.Storable (Storable(..))+import GHC.Types (SPEC(..))+import qualified Control.Monad.Catch as MC++import Streamly.Internal.Data.Fold.Type (Fold(..))+import Streamly.Internal.Data.Pipe.Type (Pipe(..), PipeState(..))+import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime)+import Streamly.Internal.Data.Time.Units+       (TimeUnit64, toRelTime64, diffAbsTime64)++import qualified Streamly.Internal.Data.Array.Foreign.Type as A+import qualified Streamly.Internal.Data.Fold.Type as FL+import qualified Streamly.Internal.Data.IORef.Prim as Prim+import qualified Streamly.Internal.Data.Pipe.Type as Pipe+import qualified Streamly.Internal.Data.Stream.StreamK as K++import Prelude hiding+       ( drop, dropWhile, filter, map, mapM, reverse+       , scanl, scanl1, sequence, take, takeWhile)++import Streamly.Internal.Data.Stream.StreamD.Type+import Streamly.Internal.Data.SVar++------------------------------------------------------------------------------+-- Piping+------------------------------------------------------------------------------++{-# 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+------------------------------------------------------------------------------++{-# 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++-- 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+------------------------------------------------------------------------------++{-# 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+{-# 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++{-# INLINE_NORMAL pollCounts #-}+pollCounts+    :: MonadAsync m+    => (a -> Bool)+    -> (Stream m Int -> Stream m Int)+    -> Fold m Int b+    -> Stream m a+    -> Stream m a+pollCounts predicate transf fld (Stream step state) = Stream step' Nothing+  where++    {-# INLINE_LATE step' #-}+    step' _ Nothing = do+        -- As long as we are using an "Int" for counts lockfree reads from+        -- Var should work correctly on both 32-bit and 64-bit machines.+        -- However, an Int on a 32-bit machine may overflow quickly.+        countVar <- liftIO $ Prim.newIORef (0 :: Int)+        tid <- forkManaged+            $ void $ fold fld+            $ transf $ Prim.toStreamD countVar+        return $ Skip (Just (countVar, tid, state))++    step' gst (Just (countVar, tid, st)) = do+        r <- step gst st+        case r of+            Yield x s -> do+                when (predicate x) $ liftIO $ Prim.modifyIORef' countVar (+ 1)+                return $ Yield x (Just (countVar, tid, s))+            Skip s -> return $ Skip (Just (countVar, tid, s))+            Stop -> do+                liftIO $ killThread tid+                return Stop++{-# INLINE_NORMAL tapRate #-}+tapRate ::+       (MonadAsync m, MonadCatch m)+    => Double+    -> (Int -> m b)+    -> Stream m a+    -> Stream m a+tapRate samplingRate action (Stream step state) = Stream step' Nothing+  where+    {-# NOINLINE loop #-}+    loop countVar prev = do+        i <-+            MC.catch+                (do liftIO $ threadDelay (round $ samplingRate * 1000000)+                    i <- liftIO $ Prim.readIORef countVar+                    let !diff = i - prev+                    void $ action diff+                    return i)+                (\(e :: AsyncException) -> do+                     i <- liftIO $ Prim.readIORef countVar+                     let !diff = i - prev+                     void $ action diff+                     throwM (MC.toException e))+        loop countVar i++    {-# INLINE_LATE step' #-}+    step' _ Nothing = do+        countVar <- liftIO $ Prim.newIORef 0+        tid <- fork $ loop countVar 0+        ref <- liftIO $ newIORef ()+        _ <- liftIO $ mkWeakIORef ref (killThread tid)+        return $ Skip (Just (countVar, tid, state, ref))++    step' gst (Just (countVar, tid, st, ref)) = do+        r <- step gst st+        case r of+            Yield x s -> do+                liftIO $ Prim.modifyIORef' countVar (+ 1)+                return $ Yield x (Just (countVar, tid, s, ref))+            Skip s -> return $ Skip (Just (countVar, tid, s, ref))+            Stop -> do+                liftIO $ killThread tid+                return Stop++------------------------------------------------------------------------------+-- Scanning with a Fold+------------------------------------------------------------------------------++data ScanState s f = ScanInit s | ScanDo s !f | ScanDone++{-# INLINE_NORMAL postscanOnce #-}+postscanOnce :: Monad m => FL.Fold m a b -> Stream m a -> Stream m b+postscanOnce (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 scanOnce #-}+scanOnce :: Monad m+    => FL.Fold m a b -> Stream m a -> Stream m b+scanOnce (FL.Fold fstep initial extract) (Stream sstep state) =+    Stream step (ScanInit state)++    where++    {-# INLINE_LATE step #-}+    step _ (ScanInit st) = do+        res <- initial+        case res of+            FL.Partial fs -> do+                !b <- extract fs+                return $ Yield b $ ScanDo st fs+            FL.Done b -> return $ 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++------------------------------------------------------------------------------+-- 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 s =+    postscanlMx' (\b a -> return (fstep b a)) (return begin) (return . done) s++-- 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 s =+    scanlMx' (\b a -> return (fstep b a)) (return begin) (return . done) s++------------------------------------------------------------------------------+-- 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)++-- 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 (Just (state1, initial))++    where++    {-# INLINE_LATE step #-}+    step gst (Just (st, acc)) = do+        r <- step1 (adaptState gst) st+        case r of+            Yield x s -> do+                old <- acc+                y <- fstep old x+                y `seq` return (Yield y (Just (s, return y)))+            Skip s -> return $ Skip $ Just (s, acc)+            Stop -> acc >>= done >>= \res -> return (Yield res Nothing)+    step _ Nothing = 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)++{-# 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 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 >>= \x -> x `seq` return x) `consM`+        postscanlMAfter' fstep initial done s++{-# 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+{-# 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++{-# INLINE scanl1' #-}+scanl1' :: Monad m => (a -> a -> a) -> Stream m a -> Stream m a+scanl1' f = scanl1M' (\x y -> return (f x y))++-------------------------------------------------------------------------------+-- Filtering+-------------------------------------------------------------------------------++-- Adapted from the vector package+{-# 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++{-# INLINE filter #-}+filter :: Monad m => (a -> Bool) -> Stream m a -> Stream m a+filter f = filterM (return . f)++-- Adapted from the vector package+{-# INLINE_NORMAL uniq #-}+uniq :: (Eq a, Monad m) => Stream m a -> Stream m a+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++{-# INLINE_NORMAL deleteBy #-}+deleteBy :: Monad m => (a -> a -> Bool) -> a -> Stream m a -> Stream m a+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++------------------------------------------------------------------------------+-- Trimming+------------------------------------------------------------------------------++-- XXX using getTime in the loop can be pretty expensive especially for+-- computations where iterations are lightweight. We have the following+-- options:+--+-- 1) Run a timeout thread updating a flag asynchronously and check that+-- flag here, that way we can have a cheap termination check.+--+-- 2) Use COARSE clock to get time with lower resolution but more efficiently.+--+-- 3) Use rdtscp/rdtsc to get time directly from the processor, compute the+-- termination value of rdtsc in the beginning and then in each iteration just+-- get rdtsc and check if we should terminate.+--+data TakeByTime st s+    = TakeByTimeInit st+    | TakeByTimeCheck st s+    | TakeByTimeYield st s++{-# INLINE_NORMAL takeByTime #-}+takeByTime :: (MonadIO m, TimeUnit64 t) => t -> Stream m a -> Stream m a+takeByTime duration (Stream step1 state1) = Stream step (TakeByTimeInit state1)+    where++    lim = toRelTime64 duration++    {-# INLINE_LATE step #-}+    step _ (TakeByTimeInit _) | lim == 0 = return Stop+    step _ (TakeByTimeInit st) = do+        t0 <- liftIO $ getTime Monotonic+        return $ Skip (TakeByTimeYield st t0)+    step _ (TakeByTimeCheck st t0) = do+        t <- liftIO $ getTime Monotonic+        return $+            if diffAbsTime64 t t0 > lim+            then Stop+            else Skip (TakeByTimeYield st t0)+    step gst (TakeByTimeYield st t0) = do+        r <- step1 gst st+        return $ case r of+             Yield x s -> Yield x (TakeByTimeCheck s t0)+             Skip s -> Skip (TakeByTimeCheck s t0)+             Stop -> Stop++data DropByTime st s x+    = DropByTimeInit st+    | DropByTimeGen st s+    | DropByTimeCheck st s x+    | DropByTimeYield st++{-# INLINE_NORMAL dropByTime #-}+dropByTime :: (MonadIO m, TimeUnit64 t) => t -> Stream m a -> Stream m a+dropByTime duration (Stream step1 state1) = Stream step (DropByTimeInit state1)+    where++    lim = toRelTime64 duration++    {-# INLINE_LATE step #-}+    step _ (DropByTimeInit st) = do+        t0 <- liftIO $ getTime Monotonic+        return $ Skip (DropByTimeGen st t0)+    step gst (DropByTimeGen st t0) = do+        r <- step1 gst st+        return $ case r of+             Yield x s -> Skip (DropByTimeCheck s t0 x)+             Skip s -> Skip (DropByTimeGen s t0)+             Stop -> Stop+    step _ (DropByTimeCheck st t0 x) = do+        t <- liftIO $ getTime Monotonic+        if diffAbsTime64 t t0 <= lim+        then return $ Skip $ DropByTimeGen st t0+        else return $ Yield x $ DropByTimeYield st+    step gst (DropByTimeYield st) = do+        r <- step1 gst st+        return $ case r of+             Yield x s -> Yield x (DropByTimeYield s)+             Skip s -> Skip (DropByTimeYield s)+             Stop -> Stop++-- Adapted from the vector package+{-# 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++{-# INLINE_NORMAL dropWhileM #-}+dropWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a+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)++{-# INLINE dropWhile #-}+dropWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a+dropWhile f = dropWhileM (return . f)++------------------------------------------------------------------------------+-- Inserting Elements+------------------------------------------------------------------------------++{-# 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++{-# 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)++{-# INLINE intersperse #-}+intersperse :: Monad m => a -> Stream m a -> Stream m a+intersperse a = intersperseM (return a)++{-# 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)++data SuffixState s a+    = SuffixElem s+    | SuffixSuffix s+    | SuffixYield a (SuffixState s a)++{-# INLINE_NORMAL intersperseSuffix #-}+intersperseSuffix :: forall m a. Monad m => m a -> Stream m a -> Stream m a+intersperseSuffix 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++{-# INLINE_NORMAL intersperseSuffix_ #-}+intersperseSuffix_ :: Monad m => m b -> Stream m a -> Stream m a+intersperseSuffix_ 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++-- | intersperse after every n items+{-# INLINE_NORMAL intersperseSuffixBySpan #-}+intersperseSuffixBySpan :: forall m a. Monad m+    => Int -> m a -> Stream m a -> Stream m a+intersperseSuffixBySpan 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++------------------------------------------------------------------------------+-- Reordering+------------------------------------------------------------------------------++-- We can implement reverse as:+--+-- > reverse = foldlS (flip cons) nil+--+-- However, this implementation is unusable because of the horrible performance+-- of cons. So we just convert it to a list first and then stream from the+-- list.+--+-- XXX Maybe we can use an Array instead of a list here?+{-# INLINE_NORMAL reverse #-}+reverse :: Monad m => Stream m a -> Stream m a+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++-- Much faster reverse for Storables+{-# INLINE_NORMAL reverse' #-}+reverse' :: forall m a. (MonadIO m, Storable a) => Stream m a -> Stream m a+{-+-- This commented implementation copies the whole stream into one single array+-- and then streams from that array, this has exactly the same performance as+-- the chunked code that follows.  Though this could be problematic due to+-- unbounded large allocations. However, if we use an idiomatic implementation+-- of arraysOf instead of the custom implementation then the chunked code+-- becomes worse by 6 times. Need to investigate if that can be improved.+import Foreign.ForeignPtr (touchForeignPtr)+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)+import Foreign.Ptr (Ptr, plusPtr)+reverse' m = Stream step Nothing+    where+    {-# INLINE_LATE step #-}+    step _ Nothing = do+        arr <- A.fromStreamD m+        let p = A.aEnd arr `plusPtr` negate (sizeOf (undefined :: a))+        return $ Skip $ Just (A.aStart arr, p)++    step _ (Just (start, p)) | p < unsafeForeignPtrToPtr start = return Stop++    step _ (Just (start, p)) = do+        let !x = A.unsafeInlineIO $ do+                    r <- peek p+                    touchForeignPtr start+                    return r+            next = p `plusPtr` negate (sizeOf (undefined :: a))+        return $ Yield x (Just (start, next))+-}+reverse' =+          A.flattenArraysRev -- unfoldMany A.readRev+        . fromStreamK+        . K.reverse+        . toStreamK+        . A.arraysOf A.defaultChunkSize++------------------------------------------------------------------------------+-- Position Indexing+------------------------------------------------------------------------------++-- Adapted from the vector package+{-# INLINE_NORMAL indexed #-}+indexed :: Monad m => Stream m a -> Stream m (Int, a)+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+{-# INLINE_NORMAL indexedR #-}+indexedR :: Monad m => Int -> Stream m a -> Stream m (Int, a)+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++------------------------------------------------------------------------------+-- Searching+------------------------------------------------------------------------------++{-# 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++------------------------------------------------------------------------------+-- Rolling map+------------------------------------------------------------------------------++data RollingMapState s a = RollingMapInit s | RollingMapGo s a++{-# INLINE rollingMapM #-}+rollingMapM :: Monad m => (a -> a -> m b) -> Stream m a -> Stream m b+rollingMapM f (Stream step1 state1) = Stream step (RollingMapInit state1)+    where+    step gst (RollingMapInit st) = do+        r <- step1 (adaptState gst) st+        return $ case r of+            Yield x s -> Skip $ RollingMapGo s x+            Skip s -> Skip $ RollingMapInit s+            Stop   -> Stop++    step gst (RollingMapGo s1 x1) = do+        r <- step1 (adaptState gst) s1+        case r of+            Yield x s -> do+                !res <- f x x1+                return $ Yield res $ RollingMapGo s x+            Skip s -> return $ Skip $ RollingMapGo s x1+            Stop   -> return $ Stop++{-# INLINE rollingMap #-}+rollingMap :: Monad m => (a -> a -> b) -> Stream m a -> Stream m b+rollingMap f = rollingMapM (\x y -> return $ f x y)++------------------------------------------------------------------------------+-- Maybe Streams+------------------------------------------------------------------------------++-- XXX Will this always fuse properly?+{-# INLINE_NORMAL mapMaybe #-}+mapMaybe :: Monad m => (a -> Maybe b) -> Stream m a -> Stream m b+mapMaybe f = fmap fromJust . filter isJust . map f++{-# INLINE_NORMAL mapMaybeM #-}+mapMaybeM :: Monad m => (a -> m (Maybe b)) -> Stream m a -> Stream m b+mapMaybeM f = fmap fromJust . filter isJust . mapM f
src/Streamly/Internal/Data/Stream/StreamD/Type.hs view
@@ -1,102 +1,114 @@-{-# LANGUAGE BangPatterns              #-}-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE ConstraintKinds           #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE MultiParamTypeClasses     #-}-{-# LANGUAGE PatternSynonyms           #-}-{-# LANGUAGE ViewPatterns              #-}-{-# LANGUAGE RankNTypes                #-}- #include "inline.hs"  -- | -- Module      : Streamly.Internal.Data.Stream.StreamD.Type--- Copyright   : (c) 2018 Harendra Kumar+-- Copyright   : (c) 2018 Composewell Technologies --               (c) Roman Leshchinskiy 2008-2010------ License     : BSD3+-- 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 concatMap if we     -- use the pattern synonym "Stream".-#if __GLASGOW_HASKELL__ >= 800     , Stream (Stream, UnStream)-#else-    , Stream (UnStream)-    , pattern Stream-#endif++    -- * Primitives+    , nilM+    , consM+    , uncons++    -- * From Unfold+    , unfold++    -- * From Values+    , fromPure+    , fromEffect++    -- * From Containers+    , fromList++    -- * Conversions From/To     , fromStreamK     , toStreamK+    , toStreamD     , fromStreamD-    , map-    , mapM-    , yield-    , yieldM-    , concatMap-    , concatMapM +    -- * Running a 'Fold'+    , fold+    , fold_++    -- * Right Folds     , foldrT     , foldrM     , foldrMx     , foldr     , foldrS +    -- * Left Folds     , foldl'     , foldlM'     , foldlx'     , foldlMx' +    -- * To Containers     , toList-    , fromList +    -- * Multi-stream folds     , eqBy     , cmpBy++    -- * Transformations+    , map+    , mapM     , take-    , GroupState (..) -- for inspection testing-    , groupsOf+    , takeWhile+    , takeWhileM++    -- * Nesting+    , ConcatMapUState (..)+    , unfoldMany+    , concatMap+    , concatMapM+    , FoldMany (..) -- for inspection testing+    , FoldManyPost (..)+    , foldMany+    , foldManyPost     , groupsOf2+    , chunksOf     ) where  import Control.Applicative (liftA2) import Control.Monad (when) import Control.Monad.Catch (MonadThrow, throwM)-import Control.Monad.Trans (lift, MonadTrans)+import Control.Monad.Trans.Class (lift, MonadTrans) import Data.Functor.Identity (Identity(..))+import Fusion.Plugin.Types (Fuse(..)) import GHC.Base (build) import GHC.Types (SPEC(..))-import Prelude hiding (map, mapM, foldr, take, concatMap)-import Fusion.Plugin.Types (Fuse(..))+import Prelude hiding (map, mapM, foldr, take, concatMap, takeWhile) -import Streamly.Internal.Data.SVar (State(..), adaptState, defState)-import Streamly.Internal.Data.Fold.Types (Fold(..), Fold2(..))+import Streamly.Internal.Data.Fold.Type (Fold(..), Fold2(..))+import Streamly.Internal.Data.Stream.StreamD.Step (Step (..))+import Streamly.Internal.Data.SVar (State, adaptState, defState)+import Streamly.Internal.Data.Unfold.Type (Unfold(..)) -import qualified Streamly.Internal.Data.Stream.StreamK as K+import qualified Streamly.Internal.Data.Fold.Type as FL+import qualified Streamly.Internal.Data.Stream.StreamK.Type as K  ------------------------------------------------------------------------------ -- The direct style stream type ------------------------------------------------------------------------------ --- | 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- -- gst = global state -- | A stream consists of a step function that generates the next step given a -- current state, and the current state.@@ -115,6 +127,103 @@ {-# COMPLETE Stream #-} #endif +------------------------------------------------------------------------------+-- Primitives+------------------------------------------------------------------------------++-- | An empty 'Stream' with a side effect.+{-# INLINE_NORMAL nilM #-}+nilM :: Monad m => m b -> Stream m a+nilM m = Stream (\_ _ -> m >> return Stop) ()++{-# INLINE_NORMAL consM #-}+consM :: Monad m => m a -> Stream m a -> Stream m a+consM m (Stream step state) = Stream step1 Nothing+    where+    {-# INLINE_LATE step1 #-}+    step1 _ Nothing   = m >>= \x -> return $ Yield x (Just state)+    step1 gst (Just st) = do+        r <- step gst st+        return $+          case r of+            Yield a s -> Yield a (Just s)+            Skip  s   -> Skip (Just s)+            Stop      -> Stop++-- | Does not fuse, has the same performance as the StreamK version.+{-# INLINE_NORMAL uncons #-}+uncons :: Monad m => Stream m a -> m (Maybe (a, Stream m a))+uncons (UnStream step state) = go state+  where+    go st = do+        r <- step defState st+        case r of+            Yield x s -> return $ Just (x, Stream step s)+            Skip  s   -> go s+            Stop      -> return Nothing++------------------------------------------------------------------------------+-- From 'Unfold'+------------------------------------------------------------------------------++data UnfoldState s = UnfoldNothing | UnfoldJust s++-- | Convert an 'Unfold' into a 'Stream' by supplying it a seed.+--+{-# INLINE_NORMAL unfold #-}+unfold :: Monad m => Unfold m a b -> a -> Stream m b+unfold (Unfold ustep inject) seed = Stream step UnfoldNothing+  where+    {-# INLINE_LATE step #-}+    step _ UnfoldNothing = inject seed >>= return . Skip . UnfoldJust+    step _ (UnfoldJust st) = do+        r <- ustep st+        return $ case r of+            Yield x s -> Yield x (UnfoldJust s)+            Skip s    -> Skip (UnfoldJust s)+            Stop      -> Stop++------------------------------------------------------------------------------+-- From Values+------------------------------------------------------------------------------++-- | Create a singleton 'Stream' from a pure value.+{-# 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.+{-# INLINE_NORMAL fromEffect #-}+fromEffect :: Monad m => m a -> Stream m a+fromEffect m = Stream step True+  where+    {-# INLINE_LATE step #-}+    step _ True  = m >>= \x -> return $ Yield x False+    step _ False = return Stop++------------------------------------------------------------------------------+-- From Containers+------------------------------------------------------------------------------++-- Adapted from the vector package.+-- | Convert a list of pure values to a 'Stream'+{-# INLINE_LATE fromList #-}+fromList :: Applicative m => [a] -> Stream m a+fromList = Stream step+  where+    {-# INLINE_LATE step #-}+    step _ (x:xs) = pure $ Yield x xs+    step _ []     = pure Stop++------------------------------------------------------------------------------+-- Conversions From/To+------------------------------------------------------------------------------++-- | Convert a CPS encoded StreamK to direct style step encoded StreamD {-# INLINE_LATE fromStreamK #-} fromStreamK :: Monad m => K.Stream m a -> Stream m a fromStreamK = Stream step@@ -125,7 +234,7 @@             yieldk a r = return $ Yield a r          in K.foldStreamShared gst yieldk single stop m1 --- Convert a direct stream to and from CPS encoded stream+-- | Convert a direct style step encoded StreamD to a CPS encoded StreamK {-# INLINE_LATE toStreamK #-} toStreamK :: Monad m => Stream m a -> K.Stream m a toStreamK (Stream step state) = go state@@ -146,165 +255,56 @@     forall s. fromStreamK (toStreamK s) = s #-} #endif ---------------------------------------------------------------------------------- Converting folds--------------------------------------------------------------------------------+-- XXX Rename to toStream or move to some IsStream common module {-# INLINE fromStreamD #-} fromStreamD :: (K.IsStream t, Monad m) => Stream m a -> t m a fromStreamD = K.fromStream . toStreamK +-- XXX Rename to toStream or move to some IsStream common module+{-# INLINE toStreamD #-}+toStreamD :: (K.IsStream t, Monad m) => t m a -> Stream m a+toStreamD = fromStreamK . K.toStream+ --------------------------------------------------------------------------------- Instances+-- Running a 'Fold' ------------------------------------------------------------------------------ --- | Map a monadic function over a 'Stream'-{-# 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)--instance Functor m => Functor (Stream m) where-    {-# INLINE fmap #-}-    fmap f (Stream step state) = Stream step' state-      where-        {-# INLINE_LATE step' #-}-        step' gst st = fmap (fmap f) (step (adaptState gst) st)+{-# INLINE_NORMAL fold #-}+fold :: (Monad m) => Fold m a b -> Stream m a -> m b+fold fld strm = do+    (b, _) <- fold_ fld strm+    return b ---------------------------------------------------------------------------------- concatMap-------------------------------------------------------------------------------+{-# INLINE_NORMAL fold_ #-}+fold_ :: Monad m => Fold m a b -> Stream m a -> m (b, Stream m a)+fold_ (Fold fstep begin done) (Stream step state) = do+    res <- begin+    case res of+        FL.Partial fs -> go SPEC fs state+        FL.Done fb -> return $! (fb, Stream step state) -{-# 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+    where -    -- 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+    {-# INLINE go #-}+    go !_ !fs st = do+        r <- step defState 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)+            Yield x s -> do+                res <- fstep fs x+                case res of+                    FL.Done b -> return $! (b, Stream step s)+                    FL.Partial fs1 -> go SPEC fs1 s+            Skip s -> go SPEC fs s+            Stop -> do+                b <- done fs+                return $! (b, Stream (\ _ _ -> return Stop) ()) -{-# INLINE concatMap #-}-concatMap :: Monad m => (a -> Stream m b) -> Stream m a -> Stream m b-concatMap f = concatMapM (return . f)+------------------------------------------------------------------------------+-- Right Folds+------------------------------------------------------------------------------ --- 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.+-- Adapted from the vector package. ----- {-# RULES "concatMap Array.toStreamD"---      concatMap Array.toStreamD = Array.flattenArray #-}---- | Create a singleton 'Stream' from a pure value.-{-# INLINE_NORMAL yield #-}-yield :: Applicative m => a -> Stream m a-yield x = Stream (\_ s -> pure $ step undefined s) True-  where-    {-# INLINE_LATE step #-}-    step _ True  = Yield x False-    step _ False = Stop--{-# INLINE_NORMAL concatAp #-}-concatAp :: Functor f => Stream f (a -> b) -> Stream f a -> Stream f b-concatAp (Stream stepa statea) (Stream stepb stateb) = Stream step' (Left statea)-  where-    {-# INLINE_LATE step' #-}-    step' gst (Left st) = fmap-        (\r -> case r of-            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-        (\r -> case r of-            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 apSequence #-}-apSequence :: Functor f => Stream f a -> Stream f b -> Stream f b-apSequence (Stream stepa statea) (Stream stepb stateb) = Stream step (Left statea)-  where-    {-# INLINE_LATE step #-}-    step gst (Left st) =-        fmap-            (\r ->-                 case r of-                     Yield _ s -> Skip (Right (s, stateb))-                     Skip s -> Skip (Left s)-                     Stop -> Stop)-            (stepa (adaptState gst) st)-    step gst (Right (ostate, st)) =-        fmap-            (\r ->-                 case r of-                     Yield b s -> Yield b (Right (ostate, s))-                     Skip s -> Skip (Right (ostate, s))-                     Stop -> Skip (Left ostate))-            (stepb gst st)--instance Applicative f => Applicative (Stream f) where-    {-# INLINE pure #-}-    pure = yield-    {-# INLINE (<*>) #-}-    (<*>) = concatAp-    {-# INLINE (*>) #-}-    (*>) = apSequence----- 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 (>>) #-}-    (>>) = (*>)--instance MonadTrans Stream where-    lift = yieldM--instance (MonadThrow m) => MonadThrow (Stream m) where-    throwM = lift . throwM- -- 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@@ -360,15 +360,6 @@ foldr :: Monad m => (a -> b -> b) -> b -> Stream m a -> m b foldr f z = foldrM (\a b -> liftA2 f (return a) b) (return z) --- | Create a singleton 'Stream' from a monadic action.-{-# INLINE_NORMAL yieldM #-}-yieldM :: Monad m => m a -> Stream m a-yieldM m = Stream step True-  where-    {-# INLINE_LATE step #-}-    step _ True  = m >>= \x -> return $ Yield x False-    step _ False = return Stop- -- this performs horribly, should not be used {-# INLINE_NORMAL foldrS #-} foldrS@@ -382,7 +373,7 @@     {-# INLINE_LATE go #-}     go !_ st = do         -- defState??-        r <- yieldM $ step defState st+        r <- fromEffect $ step defState st         case r of           Yield x s -> f x (go SPEC s)           Skip s    -> go SPEC s@@ -404,25 +395,9 @@             Skip s    -> go SPEC s             Stop      -> final -{-# INLINE_NORMAL toList #-}-toList :: Monad m => Stream m a -> m [a]-toList = 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" toList = toListId #-}-{-# INLINE_EARLY toListId #-}-toListId :: Stream Identity a -> Identity [a]-toListId s = Identity $ build (\c n -> toListFB c n s)+------------------------------------------------------------------------------+-- Left Folds+------------------------------------------------------------------------------  -- XXX run begin action only if the stream is not empty. {-# INLINE_NORMAL foldlMx' #-}@@ -446,10 +421,13 @@ foldlx' fstep begin done m =     foldlMx' (\b a -> return (fstep b a)) (return begin) (return . done) m +-- Adapted from the vector package. -- XXX implement in terms of foldlMx'? {-# INLINE_NORMAL foldlM' #-}-foldlM' :: Monad m => (b -> a -> m b) -> b -> Stream m a -> m b-foldlM' fstep begin (Stream step state) = go SPEC begin state+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@@ -463,21 +441,37 @@  {-# INLINE foldl' #-} foldl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> m b-foldl' fstep = foldlM' (\b a -> return (fstep b a))+foldl' fstep begin = foldlM' (\b a -> return (fstep b a)) (return begin) --- | Convert a list of pure values to a 'Stream'-{-# INLINE_LATE fromList #-}-fromList :: Applicative m => [a] -> Stream m a-fromList = Stream step+------------------------------------------------------------------------------+-- To Containers+------------------------------------------------------------------------------++{-# INLINE_NORMAL toList #-}+toList :: Monad m => Stream m a -> m [a]+toList = 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-    {-# INLINE_LATE step #-}-    step _ (x:xs) = pure $ Yield x xs-    step _ []     = pure Stop+    go st = case runIdentity (step defState st) of+             Yield x s -> x `c` go s+             Skip s    -> go s+             Stop      -> n +{-# RULES "toList Identity" toList = toListId #-}+{-# INLINE_EARLY toListId #-}+toListId :: Stream Identity a -> Identity [a]+toListId s = Identity $ build (\c n -> toListFB c n s)+ --------------------------------------------------------------------------------- Comparisons+-- Multi-stream folds ------------------------------------------------------------------------------ +-- Adapted from the vector package. {-# 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@@ -505,6 +499,7 @@         Skip s2'  -> eq_null s2'         Stop      -> return True +-- Adapted from the vector package. -- | Compare two streams lexicographically {-# INLINE_NORMAL cmpBy #-} cmpBy@@ -535,6 +530,43 @@         Skip s2'  -> cmp_null s2'         Stop      -> return EQ +------------------------------------------------------------------------------+-- Transformations+------------------------------------------------------------------------------++-- Adapted from the vector package.+-- | Map a monadic function over a 'Stream'+{-# 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)++instance Functor m => Functor (Stream m) where+    {-# INLINE fmap #-}+    fmap f (Stream step state) = Stream step' state+      where+        {-# INLINE_LATE step' #-}+        step' gst st = fmap (fmap f) (step (adaptState gst) st)++    {-# INLINE (<$) #-}+    (<$) = fmap . const++-------------------------------------------------------------------------------+-- Filtering+-------------------------------------------------------------------------------++-- Adapted from the vector package. {-# INLINE_NORMAL take #-} take :: Monad m => Int -> Stream m a -> Stream m a take n (Stream step state) = n `seq` Stream step' (state, 0)@@ -548,59 +580,340 @@             Stop      -> Stop     step' _ (_, _) = return Stop +-- Adapted from the vector package.+{-# INLINE_NORMAL takeWhileM #-}+takeWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a+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++{-# INLINE takeWhile #-}+takeWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a+takeWhile f = takeWhileM (return . f)+ ------------------------------------------------------------------------------+-- Combine N Streams - concatAp+------------------------------------------------------------------------------++{-# INLINE_NORMAL concatAp #-}+concatAp :: Functor f => Stream f (a -> b) -> Stream f a -> Stream f b+concatAp (Stream stepa statea) (Stream stepb stateb) = Stream step' (Left statea)+  where+    {-# INLINE_LATE step' #-}+    step' gst (Left st) = fmap+        (\r -> case r of+            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+        (\r -> case r of+            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 apSequence #-}+apSequence :: Functor f => Stream f a -> Stream f b -> Stream f b+apSequence (Stream stepa statea) (Stream stepb stateb) =+    Stream step (Left statea)++    where++    {-# INLINE_LATE step #-}+    step gst (Left st) =+        fmap+            (\r ->+                 case r of+                     Yield _ s -> Skip (Right (s, stateb))+                     Skip s -> Skip (Left s)+                     Stop -> Stop)+            (stepa (adaptState gst) st)+    step gst (Right (ostate, st)) =+        fmap+            (\r ->+                 case r of+                     Yield b s -> Yield b (Right (ostate, s))+                     Skip s -> Skip (Right (ostate, s))+                     Stop -> Skip (Left ostate))+            (stepb gst st)++{-# INLINE_NORMAL apDiscardSnd #-}+apDiscardSnd :: Functor f => Stream f a -> Stream f b -> Stream f a+apDiscardSnd (Stream stepa statea) (Stream stepb stateb) =+    Stream step (Left statea)++    where++    {-# INLINE_LATE step #-}+    step gst (Left st) =+        fmap+            (\r ->+                 case r of+                     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+            (\r ->+                 case r of+                     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 (<*>) #-}+    (<*>) = concatAp++#if MIN_VERSION_base(4,10,0)+    {-# INLINE liftA2 #-}+    liftA2 f x = (<*>) (fmap f x)+#endif++    {-# INLINE (*>) #-}+    (*>) = apSequence++    {-# INLINE (<*) #-}+    (<*) = apDiscardSnd++------------------------------------------------------------------------------+-- Combine N Streams - unfoldMany+------------------------------------------------------------------------------++-- Define a unique structure to use in inspection testing+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'.++{-# 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.+{-# 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)++{-# INLINE concatMap #-}+concatMap :: Monad m => (a -> Stream m b) -> Stream m a -> Stream m b+concatMap f = concatMapM (return . f)++-- 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 #-}++-- 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 (>>) #-}+    (>>) = (*>)++------------------------------------------------------------------------------ -- Grouping/Splitting ------------------------------------------------------------------------------  -- s = stream state, fs = fold state-data GroupState s fs-    = GroupStart s-    | GroupBuffer s fs Int-    | GroupYield fs (GroupState s fs)-    | GroupFinish+{-# ANN type FoldManyPost Fuse #-}+data FoldManyPost s fs b a+    = FoldManyPostStart s+    | FoldManyPostLoop s fs+    | FoldManyPostYield b (FoldManyPost s fs b a)+    | FoldManyPostDone -{-# INLINE_NORMAL groupsOf #-}-groupsOf-    :: Monad m-    => Int-    -> Fold m a b-    -> Stream m a-    -> Stream m b-groupsOf n (Fold fstep initial extract) (Stream step state) =-    n `seq` Stream step' (GroupStart state)+-- | Like foldMany but with the following differences:+--+-- * If the stream is empty the default value of the fold would still be+-- emitted in the output.+-- * At the end of the stream if the last application of the fold did not+-- receive any input it would still yield the default fold accumulator as the+-- last value.+--+{-# 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' _ (GroupStart st) = do-        -- XXX shall we use the Natural type instead? Need to check performance-        -- implications.-        when (n <= 0) $-            -- XXX we can pass the module string from the higher level API-            error $ "Streamly.Internal.Data.Stream.StreamD.Type.groupsOf: the size of "-                 ++ "groups [" ++ show n ++ "] must be a natural number"-        -- fs = fold state-        fs <- initial-        return $ Skip (GroupBuffer st fs 0)+    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 -    step' gst (GroupBuffer st fs i) = do+{-# 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 until the stream ends. If the stream is empty+-- the output would be empty.+--+-- @foldMany f = parseMany (fromFold f)@+--+-- A terminating fold may terminate even without accepting a single input. So+-- we run the fold's initial action before evaluating the stream. However, this+-- means that if later the stream does not yield anything we have to discard+-- the fold's initial result which could have generated an effect.+--+{-# 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 -> do-                !fs' <- fstep fs x-                let i' = i + 1-                return $-                    if i' >= n-                    then Skip (GroupYield fs' (GroupStart s))-                    else Skip (GroupBuffer s fs' i')-            Skip s -> return $ Skip (GroupBuffer s fs i)-            Stop -> return $ Skip (GroupYield fs GroupFinish)+            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 -    step' _ (GroupYield fs next) = do-        r <- extract fs-        return $ Yield r next+{-# INLINE chunksOf #-}+chunksOf :: Monad m => Int -> Fold m a b -> Stream m a -> Stream m b+chunksOf n f = foldMany (FL.take n f) -    step' _ GroupFinish = return Stop+data GroupState2 s fs+    = GroupStart2 s+    | GroupBuffer2 s fs Int+    | GroupYield2 fs (GroupState2 s fs)+    | GroupFinish2  {-# INLINE_NORMAL groupsOf2 #-} groupsOf2@@ -611,12 +924,12 @@     -> Stream m a     -> Stream m b groupsOf2 n input (Fold2 fstep inject extract) (Stream step state) =-    n `seq` Stream step' (GroupStart state)+    n `seq` Stream step' (GroupStart2 state)      where      {-# INLINE_LATE step' #-}-    step' _ (GroupStart st) = do+    step' _ (GroupStart2 st) = do         -- XXX shall we use the Natural type instead? Need to check performance         -- implications.         when (n <= 0) $@@ -625,9 +938,9 @@                  ++ "groups [" ++ show n ++ "] must be a natural number"         -- fs = fold state         fs <- input >>= inject-        return $ Skip (GroupBuffer st fs 0)+        return $ Skip (GroupBuffer2 st fs 0) -    step' gst (GroupBuffer st fs i) = do+    step' gst (GroupBuffer2 st fs i) = do         r <- step (adaptState gst) st         case r of             Yield x s -> do@@ -635,13 +948,24 @@                 let i' = i + 1                 return $                     if i' >= n-                    then Skip (GroupYield fs' (GroupStart s))-                    else Skip (GroupBuffer s fs' i')-            Skip s -> return $ Skip (GroupBuffer s fs i)-            Stop -> return $ Skip (GroupYield fs GroupFinish)+                    then Skip (GroupYield2 fs' (GroupStart2 s))+                    else Skip (GroupBuffer2 s fs' i')+            Skip s -> return $ Skip (GroupBuffer2 s fs i)+            Stop -> return $ Skip (GroupYield2 fs GroupFinish2) -    step' _ (GroupYield fs next) = do+    step' _ (GroupYield2 fs next) = do         r <- extract fs         return $ Yield r next -    step' _ GroupFinish = return Stop+    step' _ GroupFinish2 = return Stop++------------------------------------------------------------------------------+-- Other instances+------------------------------------------------------------------------------++instance MonadTrans Stream where+    {-# INLINE lift #-}+    lift = fromEffect++instance (MonadThrow m) => MonadThrow (Stream m) where+    throwM = lift . throwM
src/Streamly/Internal/Data/Stream/StreamDK.hs view
@@ -1,12 +1,3 @@-{-# LANGUAGE BangPatterns              #-}-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE PatternSynonyms           #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}--- {-# LANGUAGE ScopedTypeVariables #-}- #include "inline.hs"  -- |
src/Streamly/Internal/Data/Stream/StreamDK/Type.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE ExistentialQuantification          #-}-{-# LANGUAGE FlexibleContexts                   #-}- -- | -- Module      : Streamly.StreamDK.Type -- Copyright   : (c) 2019 Composewell Technologies
src/Streamly/Internal/Data/Stream/StreamK.hs view
@@ -1,19 +1,10 @@-{-# LANGUAGE BangPatterns              #-}-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE ConstraintKinds           #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE InstanceSigs              #-}-{-# LANGUAGE MultiParamTypeClasses     #-}-{-# LANGUAGE RankNTypes                #-}-{-# LANGUAGE ScopedTypeVariables       #-}-{-# LANGUAGE UndecidableInstances      #-} -- XXX+{-# LANGUAGE UndecidableInstances #-}  #include "inline.hs"  -- | -- Module      : Streamly.Internal.Data.Stream.StreamK--- Copyright   : (c) 2017 Harendra Kumar+-- Copyright   : (c) 2017 Composewell Technologies -- -- License     : BSD3 -- Maintainer  : streamly@composewell.com@@ -70,8 +61,8 @@     , iterateM      -- ** Conversions-    , yield-    , yieldM+    , fromPure+    , fromEffect     , fromFoldable     , fromList     , fromStreamK@@ -97,6 +88,7 @@     , foldlT     , foldlx'     , foldlMx'+    , fold      -- ** Specialized Folds     , drain@@ -171,6 +163,11 @@     , concatMapBy     , concatMap     , bindWith+    , concatPairsWith+    , apWith+    , apSerial+    , apSerialDiscardFst+    , apSerialDiscardSnd      -- ** Transformation comprehensions     , the@@ -189,7 +186,7 @@     ) where -import Control.Monad.Trans (MonadTrans(lift))+import Control.Monad.Trans.Class (MonadTrans(lift)) import Control.Monad (void, join) import Control.Monad.Reader.Class  (MonadReader(..)) import Data.Function (fix)@@ -203,6 +200,11 @@ import Streamly.Internal.Data.SVar import Streamly.Internal.Data.Stream.StreamK.Type +import qualified Streamly.Internal.Data.Fold.Type as FL++-- $setup+-- >>> :m+ ------------------------------------------------------------------------------- -- Deconstruction -------------------------------------------------------------------------------@@ -259,30 +261,30 @@ -- Special generation ------------------------------------------------------------------------------- --- | Same as yieldM+-- | Same as fromEffect -- -- @since 0.2.0-{-# DEPRECATED once "Please use yieldM instead." #-}+{-# DEPRECATED once "Please use fromEffect instead." #-} {-# INLINE once #-} once :: (Monad m, IsStream t) => m a -> t m a-once = yieldM+once = fromEffect  -- | -- @ -- repeatM = fix . cons--- repeatM = cycle1 . yield+-- repeatM = cycle1 . fromPure -- @ -- -- Generate an infinite stream by repeating a monadic value. ----- /Internal/+-- /Pre-release/ repeatM :: (IsStream t, MonadAsync m) => m a -> t m a repeatM = go     where go m = m |: go m  -- Generate an infinite stream by repeating a pure value. ----- /Internal/+-- /Pre-release/ {-# INLINE repeat #-} repeat :: IsStream t => a -> t m a repeat a = let x = cons a x in x@@ -314,16 +316,16 @@  {-# INLINE iterate #-} iterate :: IsStream t => (a -> a) -> a -> t m a-iterate step = fromStream . go+iterate step = go     where-        go s = cons s (go (step s))+        go !s = cons s (go (step s))  {-# INLINE iterateM #-} iterateM :: (IsStream t, MonadAsync m) => (a -> m a) -> m a -> t m a iterateM step = go     where     go s = mkStream $ \st stp sng yld -> do-        next <- s+        !next <- s         foldStreamShared st stp sng yld (return next |: go (step next))  -------------------------------------------------------------------------------@@ -385,44 +387,6 @@             yieldk a r = fmap (step p) (go a r)          in foldStream defState yieldk single stp m1 --- | 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 t m a b x. (IsStream t, Monad m)-    => (x -> a -> x) -> x -> (x -> b) -> t m a -> m b-foldlx' step begin done m = get $ go m begin-    where-    {-# NOINLINE get #-}-    get :: t 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 :: t m a -> x -> t 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' :: (IsStream t, Monad m) => (b -> a -> b) -> b -> t m a -> m b-foldl' step begin = foldlx' step begin id- -- XXX replace the recursive "go" with explicit continuations. -- | Like 'foldx', but with a monadic step function. {-# INLINABLE foldlMx' #-}@@ -436,10 +400,31 @@             yieldk a r = acc >>= \b -> step b a >>= \x -> go (return x) r          in foldStream defState yieldk single stop m1 +{-# INLINABLE fold #-}+fold :: (IsStream t, Monad m) => FL.Fold m a b -> t 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+ -- | Like 'foldl'' but with a monadic step function. {-# INLINE foldlM' #-}-foldlM' :: (IsStream t, Monad m) => (b -> a -> m b) -> b -> t m a -> m b-foldlM' step begin = foldlMx' step (return begin) return+foldlM' :: (IsStream t, Monad m) => (b -> a -> m b) -> m b -> t m a -> m b+foldlM' step begin = foldlMx' step begin return  -- | Lazy left fold to a stream. {-# INLINE foldlS #-}@@ -529,37 +514,76 @@         yieldk _ r = foldStream st yld sng stp r     in foldStream st yieldk single stop m --- | Iterate a lazy function `f` of the shape `m a -> t m a` until it gets--- fully defined i.e. becomes independent of its argument action, then return--- the resulting value of the function (`t m a`).+-- | We can define cyclic structures using @let@: ----- It can be used to construct a stream that uses a cyclic definition. For--- example:+-- >>> 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.+--+-- >>> import Data.Function (fix)+-- >>> 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.Prelude as S+-- import Streamly.Internal.Data.Stream.IsStream as Stream -- import System.IO.Unsafe (unsafeInterleaveIO) -- -- main = do---     S.mapM_ print $ S.mfix $ \x -> do---       a <- S.fromList [1,2]---       b <- S.fromListM [return 3, unsafeInterleaveIO (fmap fst x)]---       return (a, b)+--     Stream.mapM_ print $ Stream.mfix f+--+--     where+--+--     f action = do+--         let incr n act = fmap ((+n) . snd) $ unsafeInterleaveIO act+--         x <- Stream.fromListM [incr 1 action, incr 2 action]+--         y <- Stream.fromList [4,5]+--         return (x, y) -- @ ----- Note that the function `f` must be lazy in its argument, that's why we use--- 'unsafeInterleaveIO' because IO monad is strict.+-- 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. ----- /Internal/+-- 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/  mfix :: (IsStream t, Monad m) => (m a -> t m a) -> t 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 xs = fix  (f . headPartial)-          ys = mfix (tailPartial . f) +    where++    -- fix the head element of the stream+    xs = fix  (f . headPartial)++    -- now fix the tail recursively+    ys = mfix (tailPartial . f)+ {-# INLINE init #-} init :: (IsStream t, Monad m) => t m a -> m (Maybe (t m a)) init m = go1 m@@ -905,7 +929,7 @@         let yieldk i x = foldStreamShared st yld sng stp $ return i |: 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 |: yield i+        let single i = foldStreamShared st yld sng stp $ a |: fromPure i             yieldk i x = foldStreamShared st yld sng stp $ a |: return i |: go x          in foldStream st yieldk single stp m2 @@ -919,8 +943,8 @@   where     go m1 = mkStream $ \st yld _ _ ->         let single a = case cmp x a of-                GT -> yld a (yield x)-                _  -> yld x (yield a)+                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)
src/Streamly/Internal/Data/Stream/StreamK/Type.hs view
@@ -1,24 +1,10 @@-{-# LANGUAGE BangPatterns              #-}-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE ConstraintKinds           #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE InstanceSigs              #-}-{-# LANGUAGE MultiParamTypeClasses     #-}-{-# LANGUAGE PatternSynonyms           #-}-{-# LANGUAGE KindSignatures            #-}-{-# LANGUAGE ViewPatterns              #-}-#if __GLASGOW_HASKELL__ >= 806-{-# LANGUAGE QuantifiedConstraints     #-}-#endif-{-# LANGUAGE RankNTypes                #-}-{-# LANGUAGE UndecidableInstances      #-} -- XXX+{-# LANGUAGE UndecidableInstances #-}  #include "inline.hs"  -- | -- Module      : Streamly.Internal.Data.Stream.StreamK.Type--- Copyright   : (c) 2017 Harendra Kumar+-- Copyright   : (c) 2017 Composewell Technologies -- -- License     : BSD3 -- Maintainer  : streamly@composewell.com@@ -47,10 +33,13 @@     -- * Elimination     , foldStream     , foldStreamShared+    , foldl'+    , foldlx'      -- * foldr/build     , foldrM     , foldrS+    , foldrSShared     , foldrSM     , build     , buildS@@ -65,8 +54,8 @@     , (.:)     , consMStream     , consMBy-    , yieldM-    , yield+    , fromEffect+    , fromPure      , nil     , nilM@@ -79,6 +68,11 @@     , concatMapBy     , concatMap     , bindWith+    , concatPairsWith+    , apWith+    , apSerial+    , apSerialDiscardFst+    , apSerialDiscardSnd      , Streaming   -- deprecated     )@@ -86,9 +80,8 @@  import Control.Monad (ap, (>=>)) import Control.Monad.Trans.Class (MonadTrans(lift))-#if __GLASGOW_HASKELL__ >= 800 import Data.Kind (Type)-#endif+ #if __GLASGOW_HASKELL__ < 808 import Data.Semigroup (Semigroup(..)) #endif@@ -96,6 +89,9 @@  import Streamly.Internal.Data.SVar +-- $setup+-- >>> import Streamly.Prelude as Stream+ ------------------------------------------------------------------------------ -- Basic stream type ------------------------------------------------------------------------------@@ -116,10 +112,10 @@ -- 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 Stream type parameter from State as it is always constant. -- We can remove it from SVar as well---+ newtype Stream m a =     MkStream (forall r.                State Stream m a         -- state@@ -142,7 +138,9 @@ -- | Class of types that can represent a stream of elements of some type 'a' in -- some monad 'm'. ----- @since 0.2.0+-- /Since: 0.2.0 ("Streamly")/+--+-- @since 0.8.0 class #if __GLASGOW_HASKELL__ >= 806     ( forall m a. MonadAsync m => Semigroup (t m a)@@ -164,7 +162,7 @@     -- ["hello","world"]     -- @     ---    -- /Concurrent (do not use 'parallely' to construct infinite streams)/+    -- /Concurrent (do not use 'fromParallel' to construct infinite streams)/     --     -- @since 0.2.0     consM :: MonadAsync m => m a -> t m a -> t m a@@ -180,11 +178,11 @@     --     -- @     -- let delay = threadDelay 1000000 >> print 1-    -- drain $ serially  $ delay |: delay |: delay |: nil-    -- drain $ parallely $ delay |: delay |: delay |: nil+    -- drain $ fromSerial  $ delay |: delay |: delay |: nil+    -- drain $ fromParallel $ delay |: delay |: delay |: nil     -- @     ---    -- /Concurrent (do not use 'parallely' to construct infinite streams)/+    -- /Concurrent (do not use 'fromParallel' to construct infinite streams)/     --     -- @since 0.2.0     (|:) :: MonadAsync m => m a -> t m a -> t m a@@ -208,7 +206,9 @@ -- -- | Adapt any specific stream type to any other specific stream type. ----- @since 0.1.0+-- /Since: 0.1.0 ("Streamly")/+--+-- @since 0.8.0 adapt :: (IsStream t1, IsStream t2) => t1 m a -> t2 m a adapt = fromStream . toStream @@ -343,24 +343,24 @@ -- [] -- @ ----- /Internal/+-- /Pre-release/ {-# INLINE_NORMAL nilM #-} nilM :: (IsStream t, Monad m) => m b -> t m a nilM m = mkStream $ \_ _ _ stp -> m >> stp -{-# INLINE_NORMAL yield #-}-yield :: IsStream t => a -> t m a-yield a = mkStream $ \_ _ single _ -> single a+{-# INLINE_NORMAL fromPure #-}+fromPure :: IsStream t => a -> t m a+fromPure a = mkStream $ \_ _ single _ -> single a -{-# INLINE_NORMAL yieldM #-}-yieldM :: (Monad m, IsStream t) => m a -> t m a-yieldM m = fromStream $ mkStream $ \_ _ single _ -> m >>= single+{-# INLINE_NORMAL fromEffect #-}+fromEffect :: (Monad m, IsStream t) => m a -> t m a+fromEffect m = fromStream $ mkStream $ \_ _ single _ -> m >>= single  -- XXX specialize to IO? {-# INLINE consMBy #-} consMBy :: (IsStream t, MonadAsync m) => (t m a -> t m a -> t m a)     -> m a -> t m a -> t m a-consMBy f m r = (fromStream $ yieldM m) `f` r+consMBy f m r = (fromStream $ fromEffect m) `f` r  ------------------------------------------------------------------------------ -- Folding a stream@@ -490,7 +490,7 @@ {-# RULES "foldrSShared/nil"     forall k z. foldrSShared k z nil = z #-} {-# RULES "foldrSShared/single"-    forall k z x. foldrSShared k z (yield x) = k x z #-}+    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 #-} @@ -504,7 +504,7 @@ -- 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 (yield x) = k x z #-}+{-# 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 #-} @@ -537,7 +537,7 @@  -- {-# 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 (yieldM x) = k x 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 #-} @@ -551,7 +551,7 @@ {-# RULES "foldrSMShared/nil"     forall k z. foldrSMShared k z nil = z #-} {-# RULES "foldrSMShared/single"-    forall k z x. foldrSMShared k z (yieldM x) = k x z #-}+    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 #-} @@ -762,14 +762,67 @@     #-}  ------------------------------------------------------------------------------+-- 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 t m a b x. (IsStream t, Monad m)+    => (x -> a -> x) -> x -> (x -> b) -> t m a -> m b+foldlx' step begin done m = get $ go m begin+    where+    {-# NOINLINE get #-}+    get :: t 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 :: t m a -> x -> t 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' :: (IsStream t, Monad m) => (b -> a -> b) -> b -> t m a -> m b+foldl' step begin = foldlx' step begin id++------------------------------------------------------------------------------ -- Semigroup ------------------------------------------------------------------------------ --- | Polymorphic version of the 'Semigroup' operation '<>' of 'SerialT'.--- Appends two streams sequentially, yielding all elements from the first+infixr 6 `serial`++-- | Appends two streams sequentially, yielding all elements from the first -- stream, and then all elements from the second stream. ----- @since 0.2.0+-- >>> import Streamly.Prelude (serial)+-- >>> stream1 = Stream.fromList [1,2]+-- >>> stream2 = Stream.fromList [3,4]+-- >>> Stream.toList $ stream1 `serial` stream2+-- [1,2,3,4]+--+-- This operation can be used to fold an infinite lazy container of streams.+--+-- /Since: 0.2.0 ("Streamly")/+--+-- @since 0.8.0 {-# INLINE serial #-} serial :: IsStream t => t m a -> t m a -> t m a -- XXX This doubles the time of toNullAp benchmark, may not be fusing properly@@ -802,9 +855,6 @@ -- Functor ------------------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ < 800-#define Type *-#endif -- Note eta expanded {-# INLINE_LATE mapFB #-} mapFB :: forall (t :: (Type -> Type) -> Type -> Type) b m a.@@ -885,7 +935,8 @@ -------------------------------------------------------------------------------  instance MonadTrans Stream where-    lift = yieldM+    {-# INLINE lift #-}+    lift = fromEffect  ------------------------------------------------------------------------------- -- Nesting@@ -897,6 +948,118 @@ 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 apWith #-}+apWith+    :: IsStream t+    => (t m b -> t m b -> t m b)+    -> t m (a -> b)+    -> t m a+    -> t m b+apWith 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++{-# INLINE apSerial #-}+apSerial+    :: IsStream t+    => t m (a -> b)+    -> t m a+    -> t m b+apSerial 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 apSerialDiscardFst #-}+apSerialDiscardFst+    :: IsStream t+    => t m a+    -> t m b+    -> t m b+apSerialDiscardFst 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 apSerialDiscardSnd #-}+apSerialDiscardSnd+    :: IsStream t+    => t m a+    -> t m b+    -> t m a+apSerialDiscardSnd 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+ -- XXX This is just concatMapBy 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@@ -904,7 +1067,7 @@ {-# INLINE bindWith #-} bindWith     :: IsStream t-    => (forall c. t m c -> t m c -> t m c)+    => (t m b -> t m b -> t m b)     -> t m a     -> (a -> t m b)     -> t m b@@ -935,7 +1098,7 @@ {-# INLINE concatMapBy #-} concatMapBy     :: IsStream t-    => (forall c. t m c -> t m c -> t m c)+    => (t m b -> t m b -> t m b)     -> (a -> t m b)     -> t m a     -> t m b@@ -966,9 +1129,54 @@      (\c n -> foldrSShared (\x b -> foldrSShared c b (unShare $ f x)) n xs) -} +-- | See 'Streamly.Internal.Data.Stream.IsStream.concatPairsWith' for+-- documentation.+--+{-# INLINE concatPairsWith #-}+concatPairsWith+    :: IsStream t+    => (t m b -> t m b -> t m b)+    -> (a -> t m b)+    -> t m a+    -> t m b+concatPairsWith combine f = go Nothing++    where++    go Nothing stream =+        mkStream $ \st yld sng stp ->+            let foldShared = foldStreamShared st yld sng stp+                single a   = foldShared $ unShare (f a)+                yieldk a r = foldShared $ go (Just a) r+            in foldStream (adaptState st) yieldk single stp stream+    go (Just a1) stream =+        mkStream $ \st yld sng stp ->+            let foldShared = foldStreamShared st yld sng stp+                stop = foldShared $ unShare (f a1)+                single a = foldShared $ unShare (f a1) `combine` f a+                yieldk a r =+                    foldShared+                        $ concatPairsWith combine+                            (\(x,y) -> combine (unShare x) y)+                        $ (f a1, f a) `cons` makePairs Nothing r+            in foldStream (adaptState st) yieldk single stop stream++    makePairs Nothing stream =+        mkStream $ \st yld sng stp ->+            let foldShared = foldStreamShared st yld sng stp+                single a   = sng (f a, nil)+                yieldk a r = foldShared $ makePairs (Just a) r+            in foldStream (adaptState st) yieldk single stp stream+    makePairs (Just a1) stream =+        mkStream $ \st yld sng _ ->+            let stop = sng (f a1, nil)+                single a = sng (f a1, f a)+                yieldk a r = yld (f a1, f a) (makePairs Nothing r)+            in foldStream (adaptState st) yieldk single stop stream+ instance Monad m => Applicative (Stream m) where     {-# INLINE pure #-}-    pure = yield+    pure = fromPure     {-# INLINE (<*>) #-}     (<*>) = ap @@ -983,7 +1191,7 @@  {- -- Like concatMap but generates stream using an unfold function. Similar to--- concatUnfold but for StreamK.+-- unfoldMany but for StreamK. concatUnfoldr :: IsStream t     => (b -> t m (Maybe (a, b))) -> t m b -> t m a concatUnfoldr = undefined
src/Streamly/Internal/Data/Stream/Zip.hs view
@@ -1,36 +1,27 @@-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE ConstraintKinds           #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE GeneralizedNewtypeDeriving#-}-{-# LANGUAGE InstanceSigs              #-}-{-# LANGUAGE MultiParamTypeClasses     #-}-{-# LANGUAGE TypeFamilies              #-}-{-# LANGUAGE UndecidableInstances      #-} -- XXX--#if MIN_VERSION_base(4,17,0)-{-# LANGUAGE TypeOperators             #-}-#endif+{-# LANGUAGE UndecidableInstances #-}  -- | -- Module      : Streamly.Internal.Data.Stream.Zip--- Copyright   : (c) 2017 Harendra Kumar+-- Copyright   : (c) 2017 Composewell Technologies -- -- License     : BSD3 -- Maintainer  : streamly@composewell.com -- Stability   : experimental -- Portability : GHC --+-- To run examples in this module: --+-- >>> import qualified Streamly.Prelude as Stream+-- module Streamly.Internal.Data.Stream.Zip     (       ZipSerialM     , ZipSerial-    , zipSerially+    , fromZipSerial      , ZipAsyncM     , ZipAsync-    , zipAsyncly+    , fromZipAsync      , zipWith     , zipWithM@@ -57,27 +48,41 @@ import Data.Semigroup (Semigroup(..)) #endif import GHC.Exts (IsList(..), IsString(..))-import Text.Read (Lexeme(Ident), lexP, parens, prec, readPrec, readListPrec,-                  readListPrecDefault)-import Prelude hiding (map, repeat, zipWith, errorWithoutStackTrace)--import Streamly.Internal.BaseCompat ((#.), errorWithoutStackTrace)+import Text.Read+       ( Lexeme(Ident), lexP, parens, prec, readPrec, readListPrec+       , readListPrecDefault)+import Streamly.Internal.BaseCompat ((#.), errorWithoutStackTrace, oneShot) import Streamly.Internal.Data.Stream.StreamK (IsStream(..), Stream)-import Streamly.Internal.Data.Strict (Maybe'(..), toMaybe)+import Streamly.Internal.Data.Maybe.Strict (Maybe'(..), toMaybe) import Streamly.Internal.Data.SVar (MonadAsync) +import qualified Streamly.Internal.Data.Stream.Parallel as Par import qualified Streamly.Internal.Data.Stream.Prelude as P-import qualified Streamly.Internal.Data.Stream.StreamK as K-import qualified Streamly.Internal.Data.Stream.StreamD as D-+    (cmpBy, eqBy, foldl', foldr, fromList, toList, fromStreamS, toStreamS)+import qualified Streamly.Internal.Data.Stream.StreamK as K (repeat)+import qualified Streamly.Internal.Data.Stream.StreamK.Type as K+import qualified Streamly.Internal.Data.Stream.StreamD as D (zipWithM)+import qualified Streamly.Internal.Data.Stream.StreamD.Type as D #ifdef USE_STREAMK_ONLY-import qualified Streamly.Internal.Data.Stream.StreamK as S+import qualified Streamly.Internal.Data.Stream.StreamK as S (zipWith, zipWithM) #else-import qualified Streamly.Internal.Data.Stream.StreamD as S+import qualified Streamly.Internal.Data.Stream.StreamD as S (zipWith, zipWithM) #endif +import Prelude hiding (map, repeat, zipWith, errorWithoutStackTrace)+ #include "Instances.hs" +-- $setup+-- >>> import qualified Streamly.Prelude as Stream+-- >>> import Control.Concurrent (threadDelay)+-- >>> :{+--  delay n = do+--      threadDelay (n * 1000000)   -- sleep for n seconds+--      putStrLn (show n ++ " sec") -- print "n sec"+--      return n                    -- IO Int+-- :}+ -- | Like 'zipWith' but using a monadic zipping function. -- -- @since 0.4.0@@ -109,8 +114,8 @@ zipAsyncWithM :: (IsStream t, MonadAsync m)     => (a -> b -> m c) -> t m a -> t m b -> t m c zipAsyncWithM f m1 m2 = D.fromStreamD $-    D.zipWithM f (D.mkParallelD $ D.toStreamD m1)-                 (D.mkParallelD $ D.toStreamD m2)+    D.zipWithM f (Par.mkParallelD $ D.toStreamD m1)+                 (Par.mkParallelD $ D.toStreamD m2)  -- | Like 'zipWith' but zips concurrently i.e. both the streams being zipped -- are generated concurrently.@@ -125,24 +130,24 @@ -- Serially Zipping Streams ------------------------------------------------------------------------------ --- | The applicative instance of 'ZipSerialM' zips a number of streams serially--- i.e. it produces one element from each stream serially and then zips all--- those elements.+-- | For 'ZipSerialM' streams: -- -- @--- main = (toList . 'zipSerially' $ (,,) \<$\> s1 \<*\> s2 \<*\> s3) >>= print---     where s1 = fromFoldable [1, 2]---           s2 = fromFoldable [3, 4]---           s3 = fromFoldable [5, 6]--- @+-- (<>) = 'Streamly.Prelude.serial'+-- (<*>) = 'Streamly.Prelude.serial.zipWith' id -- @+--+-- Applicative evaluates the streams being zipped serially:+--+-- >>> s1 = Stream.fromFoldable [1, 2]+-- >>> s2 = Stream.fromFoldable [3, 4]+-- >>> s3 = Stream.fromFoldable [5, 6]+-- >>> Stream.toList $ Stream.fromZipSerial $ (,,) <$> s1 <*> s2 <*> s3 -- [(1,3,5),(2,4,6)]--- @ ----- The 'Semigroup' instance of this type works the same way as that of--- 'SerialT'.+-- /Since: 0.2.0 ("Streamly")/ ----- @since 0.2.0+-- @since 0.8.0 newtype ZipSerialM m a = ZipSerialM {getZipSerialM :: Stream m a}         deriving (Semigroup, Monoid) @@ -153,21 +158,25 @@  -- | An IO stream whose applicative instance zips streams serially. ----- @since 0.2.0+-- /Since: 0.2.0 ("Streamly")/+--+-- @since 0.8.0 type ZipSerial = ZipSerialM IO  -- | Fix the type of a polymorphic stream as 'ZipSerialM'. ----- @since 0.2.0-zipSerially :: IsStream t => ZipSerialM m a -> t m a-zipSerially = K.adapt+-- /Since: 0.2.0 ("Streamly")/+--+-- @since 0.8.0+fromZipSerial :: IsStream t => ZipSerialM m a -> t m a+fromZipSerial = K.adapt --- | Same as 'zipSerially'.+-- | Same as 'fromZipSerial'. -- -- @since 0.1.0-{-# DEPRECATED zipping "Please use zipSerially instead." #-}+{-# DEPRECATED zipping "Please use fromZipSerial instead." #-} zipping :: IsStream t => ZipSerialM m a -> t m a-zipping = zipSerially+zipping = fromZipSerial  consMZip :: Monad m => m a -> ZipSerialM m a -> ZipSerialM m a consMZip m ms = fromStream $ K.consMStream m (toStream ms)@@ -205,43 +214,48 @@ -- Parallely Zipping Streams ------------------------------------------------------------------------------ ----- | Like 'ZipSerialM' but zips in parallel, it generates all the elements to--- be zipped concurrently.+-- | For 'ZipAsyncM' streams: -- -- @--- main = (toList . 'zipAsyncly' $ (,,) \<$\> s1 \<*\> s2 \<*\> s3) >>= print---     where s1 = fromFoldable [1, 2]---           s2 = fromFoldable [3, 4]---           s3 = fromFoldable [5, 6]--- @--- @--- [(1,3,5),(2,4,6)]+-- (<>) = 'Streamly.Prelude.serial'+-- (<*>) = 'Streamly.Prelude.serial.zipAsyncWith' id -- @ ----- The 'Semigroup' instance of this type works the same way as that of--- 'SerialT'.+-- Applicative evaluates the streams being zipped concurrently, the following+-- would take half the time that it would take in serial zipping: ----- @since 0.2.0+-- >>> s = Stream.fromFoldableM $ Prelude.map delay [1, 1, 1]+-- >>> Stream.toList $ Stream.fromZipAsync $ (,) <$> s <*> s+-- ...+-- [(1,1),(1,1),(1,1)]+--+-- /Since: 0.2.0 ("Streamly")/+--+-- @since 0.8.0 newtype ZipAsyncM m a = ZipAsyncM {getZipAsyncM :: Stream m a}         deriving (Semigroup, Monoid)  -- | An IO stream whose applicative instance zips streams wAsyncly. ----- @since 0.2.0+-- /Since: 0.2.0 ("Streamly")/+--+-- @since 0.8.0 type ZipAsync = ZipAsyncM IO  -- | Fix the type of a polymorphic stream as 'ZipAsyncM'. ----- @since 0.2.0-zipAsyncly :: IsStream t => ZipAsyncM m a -> t m a-zipAsyncly = K.adapt+-- /Since: 0.2.0 ("Streamly")/+--+-- @since 0.8.0+fromZipAsync :: IsStream t => ZipAsyncM m a -> t m a+fromZipAsync = K.adapt --- | Same as 'zipAsyncly'.+-- | Same as 'fromZipAsync'. -- -- @since 0.1.0-{-# DEPRECATED zippingAsync "Please use zipAsyncly instead." #-}+{-# DEPRECATED zippingAsync "Please use fromZipAsync instead." #-} zippingAsync :: IsStream t => ZipAsyncM m a -> t m a-zippingAsync = zipAsyncly+zippingAsync = fromZipAsync  consMZipAsync :: Monad m => m a -> ZipAsyncM m a -> ZipAsyncM m a consMZipAsync m ms = fromStream $ K.consMStream m (toStream ms)
− src/Streamly/Internal/Data/Strict.hs 
@@ -1,59 +0,0 @@--- |--- Module      : Streamly.Internal.Data.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.Strict-    (-      Tuple' (..)-    , Tuple3' (..)-    , Tuple4' (..)-    , Maybe' (..)-    , toMaybe-    , Either' (..)-    )-where------------------------------------------------------------------------------------ Tuples------------------------------------------------------------------------------------data Tuple' a b = Tuple' !a !b deriving Show-data Tuple3' a b c = Tuple3' !a !b !c deriving Show-data Tuple4' a b c d = Tuple4' !a !b !c !d deriving Show------------------------------------------------------------------------------------ Maybe-------------------------------------------------------------------------------------- | A strict 'Maybe'-data Maybe' a = Just' !a | Nothing' deriving Show---- XXX perhaps we can use a type class having fromStrict/toStrict operations.------ | Convert strict Maybe' to lazy Maybe-{-# INLINABLE toMaybe #-}-toMaybe :: Maybe' a -> Maybe a-toMaybe  Nothing' = Nothing-toMaybe (Just' a) = Just a------------------------------------------------------------------------------------ Either-------------------------------------------------------------------------------------- | A strict 'Either'-data Either' a b = Left' !a | Right' !b deriving Show
src/Streamly/Internal/Data/Time.hs view
@@ -1,6 +1,6 @@ -- | -- Module      : Streamly.Internal.Data.Time--- Copyright   : (c) 2017 Harendra Kumar+-- Copyright   : (c) 2017 Composewell Technologies -- -- License     : BSD3 -- Maintainer  : streamly@composewell.com
+ src/Streamly/Internal/Data/Time/Clock.hs view
@@ -0,0 +1,80 @@+-- |+-- 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+    )+where++import Control.Concurrent (threadDelay, ThreadId)+import Control.Monad (forever)+import Streamly.Internal.Data.Time.Clock.Type (Clock(..), getTime)+import Streamly.Internal.Data.Time.Units (MicroSecond64(..), fromAbsTime)+import Streamly.Internal.Control.Concurrent (forkManaged)++import qualified Streamly.Internal.Data.IORef.Prim as Prim+++------------------------------------------------------------------------------+-- Async clock+------------------------------------------------------------------------------++{-# INLINE updateTimeVar #-}+updateTimeVar :: Clock -> Prim.IORef MicroSecond64 -> IO ()+updateTimeVar clock timeVar = do+    t <- fromAbsTime <$> getTime clock+    Prim.modifyIORef' timeVar (const t)++{-# INLINE updateWithDelay #-}+updateWithDelay :: RealFrac a =>+    Clock -> a -> Prim.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, Prim.IORef MicroSecond64)+asyncClock clock g = do+    timeVar <- Prim.newIORef 0+    updateTimeVar clock timeVar+    tid <- forkManaged $ forever (updateWithDelay clock g timeVar)+    return (tid, timeVar)++{-# INLINE readClock #-}+readClock :: (ThreadId, Prim.IORef MicroSecond64) -> IO MicroSecond64+readClock (_, timeVar) = Prim.readIORef timeVar
− src/Streamly/Internal/Data/Time/Clock.hsc 
@@ -1,312 +0,0 @@-{-# LANGUAGE CPP                         #-}-{-# LANGUAGE DeriveGeneric               #-}-{-# LANGUAGE GeneralizedNewtypeDeriving  #-}-{-# LANGUAGE ScopedTypeVariables         #-}--#if __GLASGOW_HASKELL__ >= 800-{-# OPTIONS_GHC -Wno-identities          #-}-{-# OPTIONS_GHC -Wno-orphans             #-}-{-# OPTIONS_GHC -fno-warn-unused-imports #-}-#endif--#ifndef __GHCJS__-#include "config.h"-#endif---- |--- Module      : Streamly.Internal.Data.Time.Clock--- Copyright   : (c) 2019 Harendra Kumar---               (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.--#if __GHCJS__-#define HS_CLOCK_GHCJS 1-#elif defined(_WIN32)-#define HS_CLOCK_WINDOWS 1-#elif (defined (HAVE_TIME_H) && defined(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--module Streamly.Internal.Data.Time.Clock-    (-    -- * 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 <time.h>--#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, Typeable)------------------------------------------------------------------------------------ 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 <time.h>-#include <mach/clock.h>--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----------------------------------------------------------------------------------#if __GLASGOW_HASKELL__ < 800-#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)-#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--{-# 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
+ src/Streamly/Internal/Data/Time/Clock/Darwin.c view
@@ -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 <time.h>+#include <mach/clock.h>+#include <mach/mach.h>++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__ */
+ src/Streamly/Internal/Data/Time/Clock/Type.hsc view
@@ -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 <time.h>++#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, Typeable)++-------------------------------------------------------------------------------+-- 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 <time.h>+#include <mach/clock.h>++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
+ src/Streamly/Internal/Data/Time/Clock/Windows.c view
@@ -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 <windows.h>++#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 */
+ src/Streamly/Internal/Data/Time/Clock/config-clock.h view
@@ -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
− src/Streamly/Internal/Data/Time/Darwin.c 
@@ -1,36 +0,0 @@-/*- * 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 <time.h>-#include <mach/clock.h>-#include <mach/mach.h>--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__ */
+ src/Streamly/Internal/Data/Time/TimeSpec.hsc view
@@ -0,0 +1,155 @@+{-# LANGUAGE CPP                         #-}+{-# LANGUAGE ScopedTypeVariables         #-}++{-# 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 <time.h>+#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
src/Streamly/Internal/Data/Time/Units.hs view
@@ -1,16 +1,13 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ScopedTypeVariables        #-}--#include "inline.hs"+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE UnboxedTuples #-}  -- | -- Module      : Streamly.Internal.Data.Time.Units--- Copyright   : (c) 2019 Harendra Kumar+-- Copyright   : (c) 2019 Composewell Technologies -- -- License     : BSD3 -- Maintainer  : streamly@composewell.com--- Stability   : experimental+-- Stability   : pre-release -- Portability : GHC  module Streamly.Internal.Data.Time.Units@@ -49,9 +46,14 @@     ) where -import Data.Int+#include "inline.hs"+ import Text.Printf (printf) +import Data.Int+import Data.Primitive.Types (Prim(..))+import Streamly.Internal.Data.Time.TimeSpec+ ------------------------------------------------------------------------------- -- Some constants -------------------------------------------------------------------------------@@ -68,6 +70,7 @@ tenPower9 :: Int64 tenPower9 = 1000000000 + ------------------------------------------------------------------------------- -- Time Unit Representations -------------------------------------------------------------------------------@@ -103,6 +106,7 @@              , Real              , Integral              , Ord+             , Prim              )  -- | An 'Int64' time representation with a microsecond resolution.@@ -117,6 +121,7 @@              , Real              , Integral              , Ord+             , Prim              )  -- | An 'Int64' time representation with a millisecond resolution.@@ -131,6 +136,7 @@              , Real              , Integral              , Ord+             , Prim              )  -------------------------------------------------------------------------------@@ -138,77 +144,6 @@ -------------------------------------------------------------------------------  ---------------------------------------------------------------------------------- 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)) =-    if (s > 0 && ns < 0)-    then TimeSpec (s - 1) (ns + tenPower9)-    else if (s < 0 && ns > 0)-    then TimeSpec (s + 1) (ns - tenPower9)-    else 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--------------------------------------------------------------------------------- -- Time unit conversions ------------------------------------------------------------------------------- @@ -280,34 +215,38 @@  instance TimeUnit MicroSecond64 where     {-# INLINE toTimeSpec #-}-    toTimeSpec (MicroSecond64 t) = TimeSpec s us+    toTimeSpec (MicroSecond64 t) = TimeSpec s (us * tenPower3)         where (s, us) = t `divMod` tenPower6      {-# INLINE fromTimeSpec #-}-    fromTimeSpec (TimeSpec s us) =-        MicroSecond64 $ s * tenPower6 + us+    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 us-        where (s, us) = t `divMod` tenPower3+    toTimeSpec (MilliSecond64 t) = TimeSpec s (ms * tenPower6)+        where (s, ms) = t `divMod` tenPower3      {-# INLINE fromTimeSpec #-}-    fromTimeSpec (TimeSpec s us) =-        MilliSecond64 $ s * tenPower3 + us+    fromTimeSpec (TimeSpec s ns) =+        -- XXX round ns to nearest millisecond?+        MilliSecond64 $ s * tenPower3 + (ns `div` tenPower6)  instance TimeUnit64 MilliSecond64 where     {-# INLINE toNanoSecond64 #-}-    toNanoSecond64 (MilliSecond64 us) = NanoSecond64 $ us * tenPower6+    toNanoSecond64 (MilliSecond64 ms) = NanoSecond64 $ ms * tenPower6      {-# INLINE fromNanoSecond64 #-}+    -- XXX round ns to nearest millisecond?     fromNanoSecond64 (NanoSecond64 ns) = MilliSecond64 $ ns `div` tenPower6  -------------------------------------------------------------------------------
− src/Streamly/Internal/Data/Time/Windows.c 
@@ -1,115 +0,0 @@-/*- * Code taken from the Haskell "clock" package.- *- * Copyright (c) 2009-2012, Cetin Sert- * Copyright (c) 2010, Eugene Kirpichov- */--#ifdef _WIN32-#include <windows.h>--#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 */
− src/Streamly/Internal/Data/Time/config.h.in 
@@ -1,57 +0,0 @@-/* src/Streamly/Internal/Data/Time/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 <inttypes.h> header file. */-#undef HAVE_INTTYPES_H--/* Define to 1 if you have the <stdint.h> header file. */-#undef HAVE_STDINT_H--/* Define to 1 if you have the <stdio.h> header file. */-#undef HAVE_STDIO_H--/* Define to 1 if you have the <stdlib.h> header file. */-#undef HAVE_STDLIB_H--/* Define to 1 if you have the <strings.h> header file. */-#undef HAVE_STRINGS_H--/* Define to 1 if you have the <string.h> header file. */-#undef HAVE_STRING_H--/* Define to 1 if you have the <sys/stat.h> header file. */-#undef HAVE_SYS_STAT_H--/* Define to 1 if you have the <sys/types.h> header file. */-#undef HAVE_SYS_TYPES_H--/* Define to 1 if you have the <time.h> header file. */-#undef HAVE_TIME_H--/* Define to 1 if you have the <unistd.h> 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
+ src/Streamly/Internal/Data/Tuple/Strict.hs view
@@ -0,0 +1,35 @@+-- |+-- 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' (..)+    , Tuple4' (..)+    )+where++-- | A strict '(,)'+data Tuple' a b = Tuple' !a !b deriving Show++-- | A strict '(,,)'+data Tuple3' a b c = Tuple3' !a !b !c deriving Show++-- | A strict '(,,,)'+data Tuple4' a b c d = Tuple4' !a !b !c !d deriving Show
src/Streamly/Internal/Data/Unfold.hs view
@@ -1,1074 +1,1341 @@-{-# LANGUAGE BangPatterns              #-}-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE PatternSynonyms           #-}-{-# LANGUAGE RankNTypes                #-}-{-# LANGUAGE RecordWildCards           #-}-{-# LANGUAGE ScopedTypeVariables       #-}-{-# LANGUAGE TupleSections             #-}--#include "inline.hs"---- |--- Module      : Streamly.Internal.Data.Unfold--- Copyright   : (c) 2019 Composewell Technologies--- License     : BSD3--- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC------ 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.---- Open control flow style streams can also have two representations. StreamK--- is a producer style representation. We can also have a consumer style--- representation. We can use that for composable folds in StreamK--- representation.----module Streamly.Internal.Data.Unfold-    (-    -- * Unfold Type-      Unfold--    -- * Operations on Input-    , lmap-    , lmapM-    , supply-    , supplyFirst-    , supplySecond-    , discardFirst-    , discardSecond-    , swap-    -- coapply-    -- comonad--    -- * Operations on Output-    , fold-    -- pipe--    -- * Unfolds-    , fromStream-    , fromStream1-    , fromStream2-    , nilM-    , consM-    , effect-    , singletonM-    , singleton-    , identity-    , const-    , replicateM-    , repeatM-    , fromList-    , fromListM-    , enumerateFromStepIntegral-    , enumerateFromToIntegral-    , enumerateFromIntegral--    -- * Transformations-    , map-    , mapM-    , mapMWithInput--    -- * Filtering-    , takeWhileM-    , takeWhile-    , take-    , filter-    , filterM--    -- * Zipping-    , zipWithM-    , zipWith-    , teeZipWith--    -- * Nesting-    , concat-    , concatMapM-    , outerProduct--    -- * Exceptions-    , gbracket-    , gbracketIO-    , before-    , after-    , afterIO-    , onException-    , finally-    , finallyIO-    , bracket-    , bracketIO-    , handle-    )-where--import Control.Exception (Exception, mask_)-import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad.Trans.Control (MonadBaseControl, liftBaseOp_)-import Data.Void (Void)-import GHC.Types (SPEC(..))-import Prelude-       hiding (concat, map, mapM, takeWhile, take, filter, const, zipWith)--import Fusion.Plugin.Types (Fuse(..))-import Streamly.Internal.Data.Stream.StreamD.Type (Stream(..), Step(..))-#if __GLASGOW_HASKELL__ < 800-import Streamly.Internal.Data.Stream.StreamD.Type (pattern Stream)-#endif-import Streamly.Internal.Data.Unfold.Types (Unfold(..))-import Streamly.Internal.Data.Fold.Types (Fold(..))-import Streamly.Internal.Data.SVar (defState, MonadAsync)-import Control.Monad.Catch (MonadCatch)--import qualified Prelude-import qualified Control.Monad.Catch as MC-import qualified Data.Tuple as Tuple-import qualified Streamly.Internal.Data.Stream.StreamK as K-import qualified Streamly.Internal.Data.Stream.StreamD as D------------------------------------------------------------------------------------ Input operations------------------------------------------------------------------------------------ | Map a function on the input argument of the 'Unfold'.------ @--- lmap f = concat (singleton f)--- @------ /Internal/-{-# INLINE_NORMAL lmap #-}-lmap :: (a -> c) -> Unfold m c b -> Unfold m a b-lmap f (Unfold ustep uinject) = Unfold ustep (uinject . f)---- | Map an action on the input argument of the 'Unfold'.------ @--- lmapM f = concat (singletonM f)--- @------ /Internal/-{-# INLINE_NORMAL lmapM #-}-lmapM :: Monad m => (a -> m c) -> Unfold m c b -> Unfold m a b-lmapM f (Unfold ustep uinject) = Unfold ustep (\x -> f x >>= uinject)---- XXX change the signature to the following?--- supply :: a -> Unfold m a b -> Unfold m Void b------ | Supply the seed to an unfold closing the input end of the unfold.------ /Internal/----{-# INLINE_NORMAL supply #-}-supply :: Unfold m a b -> a -> Unfold m Void b-supply unf a = lmap (Prelude.const a) unf---- XXX change the signature to the following?--- supplyFirst :: a -> Unfold m (a, b) c -> Unfold m b c------ | 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.------ /Internal/----{-# INLINE_NORMAL supplyFirst #-}-supplyFirst :: Unfold m (a, b) c -> a -> Unfold m b c-supplyFirst unf a = lmap (a, ) unf---- XXX change the signature to the following?--- supplySecond :: b -> Unfold m (a, b) c -> Unfold m a c------ | 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.------ /Internal/----{-# INLINE_NORMAL supplySecond #-}-supplySecond :: Unfold m (a, b) c -> b -> Unfold m a c-supplySecond unf b = lmap (, b) unf---- | 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.------ /Internal/----{-# 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.------ /Internal/----{-# 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.------ /Internal/----{-# INLINE_NORMAL swap #-}-swap :: Unfold m (a, c) b -> Unfold m (c, a) b-swap = lmap Tuple.swap------------------------------------------------------------------------------------ Output operations------------------------------------------------------------------------------------ | 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.------ /Internal/----{-# INLINE_NORMAL fold #-}-fold :: Monad m => Unfold m a b -> Fold m b c -> a -> m c-fold (Unfold ustep inject) (Fold fstep initial extract) a =-    initial >>= \x -> inject a >>= go SPEC x-  where-    -- XXX !acc?-    {-# INLINE_LATE go #-}-    go !_ acc st = acc `seq` do-        r <- ustep st-        case r of-            Yield x s -> do-                acc' <- fstep acc x-                go SPEC acc' s-            Skip s -> go SPEC acc s-            Stop   -> extract acc--{-# INLINE_NORMAL map #-}-map :: Monad m => (b -> c) -> Unfold m a b -> Unfold m a c-map f (Unfold ustep uinject) = Unfold step uinject-    where-    {-# INLINE_LATE step #-}-    step st = do-        r <- ustep st-        return $ case r of-            Yield x s -> Yield (f x) s-            Skip s    -> Skip s-            Stop      -> Stop--{-# INLINE_NORMAL mapM #-}-mapM :: Monad m => (b -> m c) -> Unfold m a b -> Unfold m a c-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--{-# INLINE_NORMAL mapMWithInput #-}-mapMWithInput :: Monad m => (a -> b -> m c) -> Unfold m a b -> Unfold m a c-mapMWithInput 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------------------------------------------------------------------------------------ Convert streams into unfolds----------------------------------------------------------------------------------{-# INLINE_LATE streamStep #-}-streamStep :: Monad m => Stream m a -> m (Step (Stream m a) a)-streamStep (Stream step1 state) = do-    r <- step1 defState state-    return $ case r of-        Yield x s -> Yield x (Stream step1 s)-        Skip s    -> Skip (Stream step1 s)-        Stop      -> Stop---- | Convert a stream into an 'Unfold'. Note that a stream converted to an--- 'Unfold' may not be as efficient as an 'Unfold' in some situations.------ /Internal/-fromStream :: (K.IsStream t, Monad m) => t m b -> Unfold m Void b-fromStream str = Unfold streamStep (\_ -> return $ D.toStreamD str)---- | Convert a single argument stream generator function into an--- 'Unfold'. Note that a stream converted to an 'Unfold' may not be as--- efficient as an 'Unfold' in some situations.------ /Internal/-fromStream1 :: (K.IsStream t, Monad m) => (a -> t m b) -> Unfold m a b-fromStream1 f = Unfold streamStep (return . D.toStreamD . f)---- | Convert a two argument stream generator function into an 'Unfold'. Note--- that a stream converted to an 'Unfold' may not be as efficient as an--- 'Unfold' in some situations.------ /Internal/-fromStream2 :: (K.IsStream t, Monad m)-    => (a -> b -> t m c) -> Unfold m (a, b) c-fromStream2 f = Unfold streamStep (\(a, b) -> return $ D.toStreamD $ f a b)------------------------------------------------------------------------------------ Unfolds------------------------------------------------------------------------------------ | Lift a monadic function into an unfold generating a nil stream with a side--- effect.----{-# INLINE nilM #-}-nilM :: Monad m => (a -> m c) -> Unfold m a b-nilM f = Unfold step return-    where-    {-# INLINE_LATE step #-}-    step x = f x >> return Stop---- | Prepend a monadic single element generator function to an 'Unfold'.------ /Internal/-{-# INLINE_NORMAL consM #-}-consM :: Monad m => (a -> m b) -> Unfold m a b -> Unfold m a b-consM action unf = Unfold step inject--    where--    inject = return . Left--    {-# INLINE_LATE step #-}-    step (Left a) = do-        action a >>= \r -> return $ Yield r (Right (D.unfold unf a))-    step (Right (UnStream step1 st)) = do-        res <- step1 defState 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---- | Lift a monadic effect into an unfold generating a singleton stream.----{-# INLINE effect #-}-effect :: Monad m => m b -> Unfold m Void b-effect eff = Unfold step inject-    where-    inject _ = return True-    {-# INLINE_LATE step #-}-    step True = eff >>= \r -> return $ Yield r False-    step False = return Stop---- XXX change it to yieldM or change yieldM in Prelude to singletonM------ | Lift a monadic function into an unfold generating a singleton stream.----{-# INLINE singletonM #-}-singletonM :: Monad m => (a -> m b) -> Unfold m a b-singletonM f = Unfold step inject-    where-    inject x = return $ Just x-    {-# INLINE_LATE step #-}-    step (Just x) = f x >>= \r -> return $ Yield r Nothing-    step Nothing = return Stop---- | Lift a pure function into an unfold generating a singleton stream.----{-# INLINE singleton #-}-singleton :: Monad m => (a -> b) -> Unfold m a b-singleton f = singletonM $ return . f---- | Identity unfold. Generates a singleton stream with the seed as the only--- element in the stream.------ > identity = singletonM return----{-# INLINE identity #-}-identity :: Monad m => Unfold m a a-identity = singletonM return--const :: Monad m => m b -> Unfold m a b-const m = Unfold step inject-    where-    inject _ = return ()-    step () = m >>= \r -> return $ Yield r ()---- | Generates a stream replicating the seed @n@ times.----{-# INLINE replicateM #-}-replicateM :: Monad m => Int -> Unfold m a a-replicateM n = Unfold step inject-    where-    inject x = return (x, n)-    {-# INLINE_LATE step #-}-    step (x, i) = return $-        if i <= 0-        then Stop-        else Yield x (x, (i - 1))---- | Generates an infinite stream repeating the seed.----{-# INLINE repeatM #-}-repeatM :: Monad m => Unfold m a a-repeatM = Unfold step return-    where-    {-# INLINE_LATE step #-}-    step x = return $ Yield x x---- | Convert a list of pure values to a 'Stream'-{-# INLINE_LATE fromList #-}-fromList :: Monad m => Unfold m [a] a-fromList = Unfold step inject-  where-    inject x = return x-    {-# INLINE_LATE step #-}-    step (x:xs) = return $ Yield x xs-    step []     = return Stop---- | Convert a list of monadic values to a 'Stream'-{-# INLINE_LATE fromListM #-}-fromListM :: Monad m => Unfold m [m a] a-fromListM = Unfold step inject-  where-    inject x = return x-    {-# INLINE_LATE step #-}-    step (x:xs) = x >>= \r -> return $ Yield r xs-    step []     = return Stop------------------------------------------------------------------------------------ Filtering----------------------------------------------------------------------------------{-# INLINE_NORMAL take #-}-take :: Monad m => Int -> Unfold m a b -> Unfold m a b-take n (Unfold step1 inject1) = Unfold step inject-  where-    inject x = do-        s <- inject1 x-        return (s, 0)-    {-# INLINE_LATE step #-}-    step (st, i) | i < n = do-        r <- step1 st-        return $ case r of-            Yield x s -> Yield x (s, i + 1)-            Skip s -> Skip (s, i)-            Stop   -> Stop-    step (_, _) = return Stop--{-# INLINE_NORMAL takeWhileM #-}-takeWhileM :: Monad m => (b -> m Bool) -> Unfold m a b -> Unfold m a 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--{-# INLINE takeWhile #-}-takeWhile :: Monad m => (b -> Bool) -> Unfold m a b -> Unfold m a b-takeWhile f = takeWhileM (return . f)--{-# 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--{-# INLINE filter #-}-filter :: Monad m => (b -> Bool) -> Unfold m a b -> Unfold m a b-filter f = filterM (return . f)------------------------------------------------------------------------------------ Enumeration------------------------------------------------------------------------------------ | Can be used to enumerate unbounded integrals. This does not check for--- overflow or underflow for bounded integrals.-{-# INLINE_NORMAL enumerateFromStepIntegral #-}-enumerateFromStepIntegral :: (Integral a, Monad m) => 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)---- We are assuming that "to" is constrained by the type to be within--- max/min bounds.-{-# INLINE enumerateFromToIntegral #-}-enumerateFromToIntegral :: (Monad m, Integral a) => a -> Unfold m a a-enumerateFromToIntegral to =-    takeWhile (<= to) $ supplySecond enumerateFromStepIntegral 1--{-# INLINE enumerateFromIntegral #-}-enumerateFromIntegral :: (Monad m, Integral a, Bounded a) => Unfold m a a-enumerateFromIntegral = enumerateFromToIntegral maxBound------------------------------------------------------------------------------------ Zipping----------------------------------------------------------------------------------{-# INLINE_NORMAL zipWithM #-}-zipWithM :: Monad m-    => (a -> b -> m c) -> Unfold m x a -> Unfold m y b -> Unfold m (x, y) c-zipWithM f (Unfold step1 inject1) (Unfold step2 inject2) = Unfold step inject--    where--    inject (x, y) = do-        s1 <- inject1 x-        s2 <- inject2 y-        return (s1, s2, Nothing)--    {-# INLINE_LATE step #-}-    step (s1, s2, Nothing) = do-        r <- step1 s1-        return $-          case r of-            Yield x s -> Skip (s, s2, Just x)-            Skip s    -> Skip (s, s2, Nothing)-            Stop      -> Stop--    step (s1, s2, Just x) = do-        r <- step2 s2-        case r of-            Yield y s -> do-                z <- f x y-                return $ Yield z (s1, s, Nothing)-            Skip s -> return $ Skip (s1, s, Just x)-            Stop   -> return Stop---- | Divide the input into two unfolds and then zip the outputs to a single--- stream.------ @---   S.mapM_ print--- $ S.concatUnfold (UF.zipWith (,) UF.identity (UF.singleton sqrt))--- $ S.map (\x -> (x,x))--- $ S.fromList [1..10]--- @------ /Internal/----{-# INLINE zipWith #-}-zipWith :: Monad m-    => (a -> b -> c) -> Unfold m x a -> Unfold m y b -> Unfold m (x, y) c-zipWith f = zipWithM (\a b -> return (f a b))---- | Distribute the input to two unfolds and then zip the outputs to a single--- stream.------ @--- S.mapM_ print $ S.concatUnfold (UF.teeZipWith (,) UF.identity (UF.singleton sqrt)) $ S.fromList [1..10]--- @------ /Internal/----{-# INLINE_NORMAL teeZipWith #-}-teeZipWith :: Monad m-    => (a -> b -> c) -> Unfold m x a -> Unfold m x b -> Unfold m x c-teeZipWith f unf1 unf2 = lmap (\x -> (x,x)) $ zipWith f unf1 unf2------------------------------------------------------------------------------------ Nested----------------------------------------------------------------------------------{-# ANN type ConcatState Fuse #-}-data ConcatState s1 s2 = ConcatOuter s1 | ConcatInner s1 s2---- | Apply the second unfold to each output element of the first unfold and--- flatten the output in a single stream.------ /Internal/----{-# INLINE_NORMAL concat #-}-concat :: Monad m => Unfold m a b -> Unfold m b c -> Unfold m a c-concat (Unfold step1 inject1) (Unfold step2 inject2) = 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)--data OuterProductState s1 s2 sy x y =-    OuterProductOuter s1 y | OuterProductInner s1 sy s2 x---- | Create an outer product (vector product or cartesian product) of the--- output streams of two unfolds.----{-# INLINE_NORMAL outerProduct #-}-outerProduct :: Monad m-    => Unfold m a b -> Unfold m c d -> Unfold m (a, c) (b, d)-outerProduct (Unfold step1 inject1) (Unfold step2 inject2) = Unfold step inject-    where-    inject (x, y) = do-        s1 <- inject1 x-        return $ OuterProductOuter s1 y--    {-# INLINE_LATE step #-}-    step (OuterProductOuter st1 sy) = do-        r <- step1 st1-        case r of-            Yield x s -> do-                s2 <- inject2 sy-                return $ Skip (OuterProductInner s sy s2 x)-            Skip s    -> return $ Skip (OuterProductOuter s sy)-            Stop      -> return Stop--    step (OuterProductInner ost sy ist x) = do-        r <- step2 ist-        return $ case r of-            Yield y s -> Yield (x, y) (OuterProductInner ost sy s x)-            Skip s    -> Skip (OuterProductInner ost sy s x)-            Stop      -> Skip (OuterProductOuter ost sy)---- XXX This can be used to implement a Monad instance for "Unfold m ()".--data ConcatMapState s1 s2 = ConcatMapOuter s1 | ConcatMapInner s1 s2---- | Map an unfold generating action to each element of an unfold and--- flattern the results into a single stream.----{-# INLINE_NORMAL concatMapM #-}-concatMapM :: Monad m-    => (b -> m (Unfold m () 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 s--    {-# INLINE_LATE step #-}-    step (ConcatMapOuter st) = do-        r <- step1 st-        case r of-            Yield x s -> do-                Unfold step2 inject2 <- f x-                innerSt <- inject2 ()-                return $ Skip (ConcatMapInner s (Stream (\_ ss -> step2 ss)-                                                        innerSt))-            Skip s    -> return $ Skip (ConcatMapOuter s)-            Stop      -> return Stop--    step (ConcatMapInner ost (UnStream istep ist)) = do-        r <- istep defState ist-        return $ case r of-            Yield x s -> Yield x (ConcatMapInner ost (Stream istep s))-            Skip s    -> Skip (ConcatMapInner ost (Stream istep s))-            Stop      -> Skip (ConcatMapOuter ost)----------------------------------------------------------------------------------- Exceptions----------------------------------------------------------------------------------- | The most general bracketing and exception combinator. All other--- combinators can be expressed in terms of this combinator. This can also be--- used for cases which are not covered by the standard combinators.------ /Internal/----{-# 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-            Left e -> do-                r <- einject (v, e)-                return $ Skip (Left r)-    step (Left st) = do-        res <- estep st-        case res of-            Yield x s -> return $ Yield x (Left s)-            Skip s    -> return $ Skip (Left s)-            Stop      -> return Stop---- | The most general bracketing and exception combinator. All other--- combinators can be expressed in terms of this combinator. This can also be--- used for cases which are not covered by the standard combinators.------ /Internal/----{-# INLINE_NORMAL gbracketIO #-}-gbracketIO-    :: (MonadIO m, MonadBaseControl IO m)-    => (a -> m c)                           -- ^ before-    -> (forall s. m s -> m (Either e s))    -- ^ try (exception handling)-    -> (c -> m d)                           -- ^ after, on normal stop, or GC-    -> Unfold m (c, e) b                    -- ^ on exception-    -> Unfold m c b                         -- ^ unfold to run-    -> Unfold m a b-gbracketIO bef exc aft (Unfold estep einject) (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) <- liftBaseOp_ mask_ $ do-            r <- bef x-            ref <- D.newFinalizedIORef (aft r)-            return (r, ref)-        s <- inject1 r-        return $ Right (s, r, ref)--    {-# INLINE_LATE step #-}-    step (Right (st, v, ref)) = do-        res <- exc $ 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-                    D.runIORefFinalizer ref-                    return Stop-            Left e -> do-                D.clearIORefFinalizer ref-                r <- einject (v, e)-                return $ Skip (Left r)-    step (Left st) = do-        res <- estep st-        case res of-            Yield x s -> return $ Yield x (Left s)-            Skip s    -> return $ Skip (Left s)-            Stop      -> return Stop---- The custom implementation of "before" is slightly faster (5-7%) than--- "_before".  This is just to document and make sure that we can always use--- gbracket to implement before. The same applies to other combinators as well.----{-# INLINE_NORMAL _before #-}-_before :: Monad m => (a -> m c) -> Unfold m a b -> Unfold m a b-_before action unf = gbracket (\x -> action x >> return x) (fmap Right)-                             (\_ -> return ()) undefined unf---- | Run a side effect before the unfold yields its first element.------ /Internal/-{-# INLINE_NORMAL before #-}-before :: Monad m => (a -> m c) -> Unfold m a b -> Unfold m a b-before action (Unfold step1 inject1) = Unfold step inject--    where--    inject x = do-        _ <- action x-        st <- inject1 x-        return st--    {-# INLINE_LATE step #-}-    step st = do-        res <- step1 st-        case res of-            Yield x s -> return $ Yield x s-            Skip s    -> return $ Skip s-            Stop      -> return Stop--{-# 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---- | Run a side effect whenever the unfold stops normally.------ Prefer afterIO over this as the @after@ action in this combinator is not--- executed if the unfold is partially evaluated lazily and then garbage--- collected.------ /Internal/-{-# 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---- | Run a side effect whenever the unfold stops normally--- or is garbage collected after a partial lazy evaluation.------ /Internal/-{-# INLINE_NORMAL afterIO #-}-afterIO :: (MonadIO m, MonadBaseControl IO m)-    => (a -> m 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 <- D.newFinalizedIORef (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-                D.runIORefFinalizer ref-                return Stop--{-# INLINE_NORMAL _onException #-}-_onException :: MonadCatch m => (a -> m c) -> Unfold m a b -> Unfold m a b-_onException action unf =-    gbracket return MC.try-        (\_ -> return ())-        (nilM (\(a, (e :: MC.SomeException)) -> action a >> MC.throwM e)) unf---- | Run a side effect whenever the unfold aborts due to an exception.------ /Internal/-{-# 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-        case res of-            Yield x s -> return $ Yield x (s, v)-            Skip s    -> return $ Skip (s, v)-            Stop      -> return Stop--{-# INLINE_NORMAL _finally #-}-_finally :: MonadCatch m => (a -> m c) -> Unfold m a b -> Unfold m a b-_finally action unf =-    gbracket return MC.try action-        (nilM (\(a, (e :: MC.SomeException)) -> action a >> MC.throwM e)) unf---- | Run a side effect whenever the unfold stops normally or aborts due to an--- exception.------ Prefer finallyIO over this as the @after@ action in this combinator is not--- executed if the unfold is partially evaluated lazily and then garbage--- collected.------ /Internal/-{-# 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---- | Run a side effect whenever the unfold stops normally, aborts due to an--- exception or if it is garbage collected after a partial lazy evaluation.------ /Internal/-{-# INLINE_NORMAL finallyIO #-}-finallyIO :: (MonadAsync m, MonadCatch m)-    => (a -> m 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 <- D.newFinalizedIORef (action x)-        return (s, ref)--    {-# INLINE_LATE step #-}-    step (st, ref) = do-        res <- step1 st `MC.onException` D.runIORefFinalizer ref-        case res of-            Yield x s -> return $ Yield x (s, ref)-            Skip s    -> return $ Skip (s, ref)-            Stop      -> do-                D.runIORefFinalizer 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 unf =-    gbracket bef MC.try aft (nilM (\(a, (e :: MC.SomeException)) -> aft a >>-    MC.throwM e)) unf---- | @bracket before after between@ runs the @before@ action and then unfolds--- its output using the @between@ unfold. When the @between@ unfold is done or--- if an exception occurs then the @after@ action is run with the output of--- @before@ as argument.------ Prefer bracketIO over this as the @after@ action in this combinator is not--- executed if the unfold is partially evaluated lazily and then garbage--- collected.------ /Internal/-{-# 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---- | @bracket before after between@ runs the @before@ action and then unfolds--- its output using the @between@ unfold. When the @between@ unfold is done or--- if an exception occurs then the @after@ action is run with the output of--- @before@ as argument. The after action is also executed if the unfold is--- paritally evaluated and then garbage collected.------ /Internal/-{-# INLINE_NORMAL bracketIO #-}-bracketIO :: (MonadAsync m, MonadCatch m)-    => (a -> m c) -> (c -> m 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) <- liftBaseOp_ mask_ $ do-            r <- bef x-            ref <- D.newFinalizedIORef (aft r)-            return (r, ref)-        s <- inject1 r-        return (s, ref)--    {-# INLINE_LATE step #-}-    step (st, ref) = do-        res <- step1 st `MC.onException` D.runIORefFinalizer ref-        case res of-            Yield x s -> return $ Yield x (s, ref)-            Skip s    -> return $ Skip (s, ref)-            Stop      -> do-                D.runIORefFinalizer ref-                return Stop---- | When unfolding if an exception occurs, unfold the exception using the--- exception unfold supplied as the first argument to 'handle'.------ /Internal/-{-# INLINE_NORMAL handle #-}-handle :: (MonadCatch m, Exception e)-    => Unfold m e b -> Unfold m a b -> Unfold m a b-handle exc unf =-    gbracket return MC.try (\_ -> return ()) (discardFirst exc) unf+#include "inline.hs"++-- |+-- Module      : Streamly.Internal.Data.Unfold+-- Copyright   : (c) 2019 Composewell Technologies+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- To run the examples in this module:+--+-- >>> import qualified Streamly.Data.Fold as Fold+-- >>> import qualified Streamly.Internal.Data.Unfold as Unfold+--+-- = 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.++-- Open control flow style streams can also have two representations. StreamK+-- is a producer style representation. We can also have a consumer style+-- representation. We can use that for composable folds in StreamK+-- representation.+--++-- = 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.Prelude.concatMap' combinator which uses @a -> t m b@+-- (where @t@ is a stream type) to generate streams is much less efficient+-- compared to 'Streamly.Prelude.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+    (+    -- * Unfold Type+      Step(..)+    , Unfold++    -- * Folding+    , fold+    -- pipe++    -- * Unfolds+    -- One to one correspondence with+    -- "Streamly.Internal.Data.Stream.IsStream.Generate"+    -- ** Basic Constructors+    , mkUnfoldM+    , mkUnfoldrM+    , unfoldrM+    , unfoldr+    , functionM+    , function+    , identity+    , nilM+    , consM++    -- ** From Values+    , fromEffect+    , fromPure++    -- ** Generators+    -- | Generate a monadic stream from a seed.+    , repeatM+    , replicateM+    , fromIndicesM+    , iterateM++    -- ** Enumerations+    -- *** Enumerate Num+    , enumerateFromStepNum+    , numFrom++    -- *** Enumerate Integral+    , enumerateFromStepIntegral+    , enumerateFromToIntegral+    , enumerateFromIntegral++    -- *** Enumerate Fractional+    -- | Use 'Num' enumerations for fractional or floating point number+    -- enumerations.+    , enumerateFromToFractional++    -- ** From Containers+    , fromList+    , fromListM++    , fromStream+    , fromStreamK+    , fromStreamD++    , fromSVar+    , fromProducer++    -- * Combinators+    -- ** Mapping on Input+    , lmap+    , lmapM+    , supply+    , supplyFirst+    , supplySecond+    , discardFirst+    , discardSecond+    , swap+    -- coapply+    -- comonad++    -- ** Mapping on Output+    , map+    , mapM+    , mapMWithInput++    -- ** Filtering+    , takeWhileM+    , takeWhile+    , take+    , filter+    , filterM+    , drop+    , dropWhile+    , dropWhileM++    -- ** Zipping+    , zipWithM+    , zipWith++    -- ** Cross product+    , crossWithM+    , crossWith+    , cross+    , apply++    -- ** Nesting+    , ConcatState (..)+    , many+    , concatMapM+    , bind++    -- ** Resource Management+    , gbracket_+    , gbracket+    , before+    , after+    , after_+    , finally+    , finally_+    , bracket+    , bracket_++    -- ** Exceptions+    , onException+    , handle+    )+where++import Control.Exception (Exception, fromException, mask_)+import Control.Monad ((>=>), when)+import Control.Monad.Catch (MonadCatch)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.Control (MonadBaseControl, liftBaseOp_)+import Data.IORef (newIORef, readIORef, mkWeakIORef, writeIORef)+import Data.Maybe (isNothing)+import Data.Void (Void)+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.Time.Clock (Clock(Monotonic), getTime)+import System.Mem (performMajorGC)++import qualified Prelude+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 as K (uncons)+import qualified Streamly.Internal.Data.Stream.StreamK.Type as K++import Streamly.Internal.Data.SVar+import Streamly.Internal.Data.Unfold.Type+import Prelude+       hiding (map, mapM, takeWhile, take, filter, const, zipWith+              , drop, dropWhile)++-- $setup+-- >>> import qualified Streamly.Data.Fold as Fold+-- >>> import qualified Streamly.Internal.Data.Unfold as Unfold++-------------------------------------------------------------------------------+-- Input operations+-------------------------------------------------------------------------------++-- | Map an action on the input argument of the 'Unfold'.+--+-- @+-- lmapM f = Unfold.many (Unfold.functionM f)+-- @+--+-- /Since: 0.8.0/+{-# 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.+--+-- @+-- supply a = Unfold.lmap (Prelude.const a)+-- @+--+-- /Pre-release/+--+{-# INLINE_NORMAL supply #-}+supply :: a -> Unfold m a b -> Unfold m Void b+supply 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.+--+-- @+-- supplyFirst a = Unfold.lmap (a, )+-- @+--+-- /Pre-release/+--+{-# INLINE_NORMAL supplyFirst #-}+supplyFirst :: a -> Unfold m (a, b) c -> Unfold m b c+supplyFirst 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.+--+-- @+-- supplySecond b = Unfold.lmap (, b)+-- @+--+-- /Pre-release/+--+{-# INLINE_NORMAL supplySecond #-}+supplySecond :: b -> Unfold m (a, b) c -> Unfold m a c+supplySecond b = lmap (, b)++-- | 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+-------------------------------------------------------------------------------++-- | 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+--+-- /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++-- | Apply a monadic function to each element of the stream and replace it+-- with the output of the resulting action.+--+-- /Since: 0.8.0/+--+{-# INLINE_NORMAL mapM #-}+mapM :: Monad m => (b -> m c) -> Unfold m a b -> Unfold m a c+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++{-# INLINE_NORMAL mapMWithInput #-}+mapMWithInput :: Monad m => (a -> b -> m c) -> Unfold m a b -> Unfold m a c+mapMWithInput 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++-------------------------------------------------------------------------------+-- Convert streams into unfolds+-------------------------------------------------------------------------------++{-# INLINE_NORMAL fromStreamD #-}+fromStreamD :: Monad m => Unfold m (Stream m a) a+fromStreamD = Unfold step 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++{-# INLINE_NORMAL fromStreamK #-}+fromStreamK :: Monad m => Unfold m (K.Stream m a) a+fromStreamK = Unfold step return++    where++    {-# INLINE_LATE step #-}+    step stream = do+        r <- K.uncons stream+        return $ case r of+            Just (x, xs) -> Yield x xs+            Nothing -> Stop++-- XXX Using Unfold.fromStreamD seems to be faster (using cross product test+-- case) than using fromStream even if it is implemented using fromStreamD.+--+-- | Convert a stream into an 'Unfold'. Note that a stream converted to an+-- 'Unfold' may not be as efficient as an 'Unfold' in some situations.+--+-- /Since: 0.8.0/+--+{-# INLINE_NORMAL fromStream #-}+fromStream :: (K.IsStream t, Monad m) => Unfold m (t m a) a+fromStream = lmap K.toStream fromStreamK++-------------------------------------------------------------------------------+-- Unfolds+-------------------------------------------------------------------------------++-- | Lift a monadic function into an unfold generating a nil stream with a side+-- effect.+--+{-# INLINE nilM #-}+nilM :: Monad m => (a -> m c) -> Unfold m a b+nilM f = Unfold step return+    where+    {-# INLINE_LATE step #-}+    step x = f x >> return Stop++-- | 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 :: Monad m => (a -> m b) -> Unfold m a b -> Unfold m a b+consM action unf = Unfold step inject++    where++    inject = return . Left++    {-# INLINE_LATE step #-}+    step (Left a) =+        action a >>= \r -> return $ Yield r (Right (D.unfold unf a))+    step (Right (UnStream step1 st)) = do+        res <- step1 defState 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++-- | Convert a list of pure values to a 'Stream'+--+-- /Since: 0.8.0/+--+{-# INLINE_LATE fromList #-}+fromList :: Monad m => Unfold m [a] a+fromList = Unfold step inject+  where+    inject = return+    {-# INLINE_LATE step #-}+    step (x:xs) = return $ Yield x xs+    step []     = return Stop++-- | Convert a list of monadic values to a 'Stream'+--+-- /Since: 0.8.0/+--+{-# INLINE_LATE fromListM #-}+fromListM :: Monad m => Unfold m [m a] a+fromListM = Unfold step inject+  where+    inject = return+    {-# INLINE_LATE step #-}+    step (x:xs) = x >>= \r -> return $ Yield r xs+    step []     = return Stop++------------------------------------------------------------------------------+-- Specialized Generation+------------------------------------------------------------------------------++-- | Generates a stream replicating the seed @n@ times.+--+-- /Since: 0.8.0/+--+{-# INLINE replicateM #-}+replicateM :: Monad m => Int -> Unfold m (m a) a+replicateM n = Unfold step inject++    where++    inject x = return (x, n)++    {-# INLINE_LATE step #-}+    step (x, i) =+        if i <= 0+        then return Stop+        else do+            x1 <- x+            return $ Yield x1 (x, i - 1)++-- | Generates an infinite stream repeating the seed.+--+-- /Since: 0.8.0/+--+{-# INLINE repeatM #-}+repeatM :: Monad m => Unfold m (m a) a+repeatM = Unfold step return+    where+    {-# INLINE_LATE step #-}+    step x = x >>= \x1 -> return $ Yield x1 x++-- | Generates an infinite stream starting with the given seed and applying the+-- given function repeatedly.+--+-- /Since: 0.8.0/+--+{-# INLINE iterateM #-}+iterateM :: Monad m => (a -> m a) -> Unfold m (m a) a+iterateM f = Unfold step id+    where+    {-# INLINE_LATE step #-}+    step x = do+        fx <- f x+        return $ Yield x fx++-- | @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 :: Monad m => (Int -> m a) -> Unfold m Int a+fromIndicesM gen = Unfold step return+  where+    {-# INLINE_LATE step #-}+    step i = do+         x <- gen i+         return $ Yield x (i + 1)++-------------------------------------------------------------------------------+-- Filtering+-------------------------------------------------------------------------------++-- |+-- >>> u = Unfold.take 2 Unfold.fromList+-- >>> Unfold.fold Fold.toList u [1..100]+-- [1,2]+--+-- /Since: 0.8.0/+--+{-# INLINE_NORMAL take #-}+take :: Monad m => Int -> Unfold m a b -> Unfold m a b+take n (Unfold step1 inject1) = Unfold step inject+  where+    inject x = do+        s <- inject1 x+        return (s, 0)+    {-# INLINE_LATE step #-}+    step (st, i) | i < n = do+        r <- step1 st+        return $ case r of+            Yield x s -> Yield x (s, i + 1)+            Skip s -> Skip (s, i)+            Stop   -> Stop+    step (_, _) = return Stop++-- | Same as 'takeWhile' but with a monadic predicate.+--+-- /Since: 0.8.0/+--+{-# INLINE_NORMAL takeWhileM #-}+takeWhileM :: Monad m => (b -> m Bool) -> Unfold m a b -> Unfold m a 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.+--+-- /Since: 0.8.0/+--+{-# INLINE takeWhile #-}+takeWhile :: Monad m => (b -> Bool) -> Unfold m a b -> Unfold m a b+takeWhile f = takeWhileM (return . f)++-- | Same as 'filter' but with a monadic predicate.+--+-- /Since: 0.8.0/+--+{-# 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.+--+-- /Since: 0.8.0/+--+{-# 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@.+--+-- /Since: 0.8.0/+--+{-# INLINE_NORMAL drop #-}+drop :: Monad m => Int -> Unfold m a b -> Unfold m a b+drop n (Unfold step inject) = Unfold step' inject'++    where++    inject' a = do+        b <- inject a+        return (b, n)++    {-# INLINE_LATE step' #-}+    step' (st, i)+        | i > 0 = do+            r <- step st+            return+                $ case r of+                      Yield _ s -> Skip (s, i - 1)+                      Skip s -> Skip (s, i)+                      Stop -> Stop+        | otherwise = do+            r <- step st+            return+                $ case r of+                      Yield x s -> Yield x (s, 0)+                      Skip s -> Skip (s, 0)+                      Stop -> Stop++-- | @dropWhileM f unf@ drops elements from the stream generated by @unf@ while+-- the condition holds true. The condition function @f@ is /monadic/ in nature.+--+-- /Since: 0.8.0/+--+{-# 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.+--+-- /Since: 0.8.0/+--+{-# INLINE dropWhile #-}+dropWhile :: Monad m => (b -> Bool) -> Unfold m a b -> Unfold m a b+dropWhile f = dropWhileM (return . f)++------------------------------------------------------------------------------+-- Enumeration of Num+------------------------------------------------------------------------------++-- | Generate an infinite stream starting from a starting value with increments+-- of the given stride.  The implementation is numerically stable for floating+-- point values.+--+-- Note 'enumerateFromStepIntegral' is faster for integrals.+--+-- /Pre-release/+--+{-# INLINE enumerateFromStepNum #-}+enumerateFromStepNum :: (Monad m, Num a) => a -> Unfold m a a+enumerateFromStepNum stride = Unfold step inject++    where++    inject !from = return (from, 0)++    {-# INLINE_LATE step #-}+    step (from, !i) = return $ (Yield $! (from + i * stride)) $! (from, i + 1)++-- | @numFrom = enumerateFromStepNum 1@+--+-- /Pre-release/+--+{-# INLINE_NORMAL numFrom #-}+numFrom :: (Monad m, Num a) => Unfold m a a+numFrom = enumerateFromStepNum 1++------------------------------------------------------------------------------+-- Enumeration of Integrals+------------------------------------------------------------------------------++-- | Can be used to enumerate unbounded integrals. This does not check for+-- overflow or underflow for bounded integrals.+{-# INLINE_NORMAL enumerateFromStepIntegral #-}+enumerateFromStepIntegral :: (Integral a, Monad m) => 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)++-- We are assuming that "to" is constrained by the type to be within+-- max/min bounds.+{-# INLINE enumerateFromToIntegral #-}+enumerateFromToIntegral :: (Monad m, Integral a) => a -> Unfold m a a+enumerateFromToIntegral to =+    takeWhile (<= to) $ supplySecond 1 enumerateFromStepIntegral++{-# INLINE enumerateFromIntegral #-}+enumerateFromIntegral :: (Monad m, Integral a, Bounded a) => Unfold m a a+enumerateFromIntegral = enumerateFromToIntegral maxBound++------------------------------------------------------------------------------+-- Enumeration of Fractionals+------------------------------------------------------------------------------++-- | /Internal/+--+-- > enumerateFromToFractional to = takeWhile (<= to + 1 / 2) $ enumerateFromStepNum 1+--+{-# INLINE_NORMAL enumerateFromToFractional #-}+enumerateFromToFractional :: (Monad m, Fractional a, Ord a) => a -> Unfold m a a+enumerateFromToFractional to =+    takeWhile (<= to + 1 / 2) $ enumerateFromStepNum 1++-------------------------------------------------------------------------------+-- Generation from SVar+-------------------------------------------------------------------------------++data FromSVarState t m a =+      FromSVarInit (SVar t m a)+    | FromSVarRead (SVar t m a)+    | FromSVarLoop (SVar t m a) [ChildEvent a]+    | FromSVarDone (SVar t m a)++-- | /Internal/+--+{-# INLINE_NORMAL fromSVar #-}+fromSVar :: MonadAsync m => Unfold m (SVar t m a) a+fromSVar = Unfold step (return . FromSVarInit)+    where++    {-# INLINE_LATE step #-}+    step (FromSVarInit svar) = do+        ref <- liftIO $ newIORef ()+        _ <- liftIO $ mkWeakIORef ref hook+        -- when this copy of svar gets garbage collected "ref" will get+        -- garbage collected and our GC hook will be called.+        let sv = svar{svarRef = Just ref}+        return $ Skip (FromSVarRead sv)++        where++        {-# NOINLINE hook #-}+        hook = do+            when (svarInspectMode svar) $ do+                r <- liftIO $ readIORef (svarStopTime (svarStats svar))+                when (isNothing r) $+                    printSVar svar "SVar Garbage Collected"+            cleanupSVar svar+            -- If there are any SVars referenced by this SVar a GC will prompt+            -- them to be cleaned up quickly.+            when (svarInspectMode svar) performMajorGC++    step (FromSVarRead sv) = do+        list <- readOutputQ sv+        -- Reversing the output is important to guarantee that we process the+        -- outputs in the same order as they were generated by the constituent+        -- streams.+        return $ Skip $ FromSVarLoop sv (Prelude.reverse list)++    step (FromSVarLoop sv []) = do+        done <- postProcess sv+        return $ Skip $ if done+                      then FromSVarDone sv+                      else FromSVarRead sv++    step (FromSVarLoop sv (ev : es)) = do+        case ev of+            ChildYield a -> return $ Yield a (FromSVarLoop sv es)+            ChildStop tid e -> do+                accountThread sv tid+                case e of+                    Nothing -> do+                        stop <- shouldStop tid+                        if stop+                        then do+                            liftIO (cleanupSVar sv)+                            return $ Skip (FromSVarDone sv)+                        else return $ Skip (FromSVarLoop sv es)+                    Just ex ->+                        case fromException ex of+                            Just ThreadAbort ->+                                return $ Skip (FromSVarLoop sv es)+                            Nothing -> liftIO (cleanupSVar sv) >> MC.throwM ex+        where++        shouldStop tid =+            case svarStopStyle sv of+                StopNone -> return False+                StopAny -> return True+                StopBy -> do+                    sid <- liftIO $ readIORef (svarStopBy sv)+                    return $ tid == sid++    step (FromSVarDone sv) = do+        when (svarInspectMode sv) $ do+            t <- liftIO $ getTime Monotonic+            liftIO $ writeIORef (svarStopTime (svarStats sv)) (Just t)+            liftIO $ printSVar sv "SVar Done"+        return Stop++-------------------------------------------------------------------------------+-- Process events received by a fold consumer from a stream producer+-------------------------------------------------------------------------------++-- XXX Have an error for "FromSVarInit" instead of undefined. The error can+-- redirect the user to report the failure to the developers.+-- | /Internal/+--+{-# INLINE_NORMAL fromProducer #-}+fromProducer :: MonadAsync m => Unfold m (SVar t m a) a+fromProducer = Unfold step (return . FromSVarRead)+    where++    {-# INLINE_LATE step #-}+    step (FromSVarRead sv) = do+        list <- readOutputQ sv+        -- Reversing the output is important to guarantee that we process the+        -- outputs in the same order as they were generated by the constituent+        -- streams.+        return $ Skip $ FromSVarLoop sv (Prelude.reverse list)++    step (FromSVarLoop sv []) = return $ Skip $ FromSVarRead sv+    step (FromSVarLoop sv (ev : es)) = do+        case ev of+            ChildYield a -> return $ Yield a (FromSVarLoop sv es)+            ChildStop tid e -> do+                accountThread sv tid+                case e of+                    Nothing -> do+                        sendStopToProducer sv+                        return $ Skip (FromSVarDone sv)+                    Just _ -> error "Bug: fromProducer: received exception"++    step (FromSVarDone sv) = do+        when (svarInspectMode sv) $ do+            t <- liftIO $ getTime Monotonic+            liftIO $ writeIORef (svarStopTime (svarStats sv)) (Just t)+            liftIO $ printSVar sv "SVar Done"+        return Stop++    step (FromSVarInit _) = undefined++------------------------------------------------------------------------------+-- Exceptions+------------------------------------------------------------------------------++-- | Like 'gbracket' 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.+-- * does not require a 'MonadAsync' constraint.+--+-- /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+        case res of+            Yield x s -> return $ Yield x (Left s)+            Skip s    -> return $ Skip (Left s)+            Stop      -> 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. 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 gbracket #-}+gbracket+    :: (MonadIO m, MonadBaseControl IO m)+    => (a -> m c)                           -- ^ before+    -> (forall s. m s -> m (Either e s))    -- ^ try (exception handling)+    -> (c -> m d)                           -- ^ after, on normal stop, or GC+    -> 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+        -- Mask asynchronous exceptions to make the execution of 'bef' and+        -- the registration of 'aft' atomic. See comment in 'D.gbracketIO'.+        (r, ref) <- liftBaseOp_ 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 <- exc $ 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.+                r <- clearingIOFinalizer ref (einject (v, e))+                return $ Skip (Left r)+    step (Left st) = do+        res <- estep st+        case res of+            Yield x s -> return $ Yield x (Left s)+            Skip s    -> return $ Skip (Left s)+            Stop      -> return 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 after #-}+after :: (MonadIO m, MonadBaseControl IO 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+        ref <- 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+        case res of+            Yield x s -> return $ Yield x (s, v)+            Skip s    -> return $ Skip (s, v)+            Stop      -> return 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 'finally' with following differences:+--+-- * action @a -> m c@ won't run if the stream is garbage collected+--   after partial evaluation.+-- * does not require a 'MonadAsync' constraint.+--+-- /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 finally #-}+finally :: (MonadAsync m, 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+        ref <- 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 'bracket' 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.+-- * does not require a 'MonadAsync' constraint.+--+-- /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 bracket #-}+bracket :: (MonadAsync m, 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+        -- Mask asynchronous exceptions to make the execution of 'bef' and+        -- the registration of 'aft' atomic. See comment in 'D.gbracketIO'.+        (r, ref) <- liftBaseOp_ 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)
+ src/Streamly/Internal/Data/Unfold/Type.hs view
@@ -0,0 +1,569 @@+-- |+-- Module      : Streamly.Internal.Data.Unfold.Type+-- Copyright   : (c) 2019 Composewell Technologies+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- To run the examples in this module:+--+-- >>> import qualified Streamly.Prelude as Stream+-- >>> import qualified Streamly.Data.Fold as Fold+-- >>> import qualified Streamly.Internal.Data.Unfold as Unfold++module Streamly.Internal.Data.Unfold.Type+    ( Unfold (..)++    -- * Basic Constructors+    , mkUnfoldM+    , mkUnfoldrM+    , unfoldrM+    , unfoldr+    , functionM+    , function+    , identity++    -- * From Values+    , fromEffect+    , fromPure++    -- * Transformations+    , lmap+    , map++    -- * Nesting+    , ConcatState (..)+    , many++    -- Applicative+    , apSequence+    , apDiscardSnd+    , crossWithM+    , crossWith+    , cross+    , apply++    -- Monad+    , concatMapM+    , concatMap+    , bind++    , zipWithM+    , zipWith+    )+where++#include "inline.hs"++-- import Control.Arrow (Arrow(..))+-- import Control.Category (Category(..))+import Fusion.Plugin.Types (Fuse(..))+import Streamly.Internal.Data.Stream.StreamD.Step (Step(..))++import Prelude hiding (const, map, concatMap, zipWith)++-- $setup+-- >>> import qualified Streamly.Prelude as Stream+-- >>> import qualified Streamly.Data.Fold as Fold+-- >>> import qualified Streamly.Internal.Data.Unfold as Unfold++------------------------------------------------------------------------------+-- Monadic Unfolds+------------------------------------------------------------------------------++-- The order of arguments allows 'Category' and 'Arrow' instances but precludes+-- contravariant and contra-applicative.+--+-- | 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@.+--+-- @since 0.7.0++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.+--+-- /Since: 0.8.0/+--+{-# 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]+--+-- /Since: 0.8.0/+--+{-# 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)+-- @+--+-- /Since: 0.8.0/+{-# INLINE_NORMAL lmap #-}+lmap :: (a -> c) -> Unfold m c b -> Unfold m a b+lmap f (Unfold ustep uinject) = Unfold ustep (uinject Prelude.. f)++------------------------------------------------------------------------------+-- Functor+------------------------------------------------------------------------------++-- | Map a function on the output of the unfold (the type @b@).+--+-- /Pre-release/+{-# INLINE_NORMAL map #-}+map :: Functor m => (b -> c) -> Unfold m a b -> Unfold m a c+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+------------------------------------------------------------------------------++-- | 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++-- | 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++-- | Outer product discarding the first element.+--+-- /Unimplemented/+--+{-# INLINE_NORMAL apSequence #-}+apSequence :: -- Monad m =>+    Unfold m a b -> Unfold m a c -> Unfold m a c+apSequence (Unfold _step1 _inject1) (Unfold _step2 _inject2) = undefined++-- | Outer product discarding the second element.+--+-- /Unimplemented/+--+{-# INLINE_NORMAL apDiscardSnd #-}+apDiscardSnd :: -- Monad m =>+    Unfold m a b -> Unfold m a c -> Unfold m a b+apDiscardSnd (Unfold _step1 _inject1) (Unfold _step2 _inject2) = undefined++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.+--+-- /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 (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)]+--+-- /Since: 0.8.0/+--+{-# 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'.+--+-- > cross = crossWith (,)+--+-- To cross the streams from a tuple we can write:+--+-- @+-- crossProduct :: Monad m => Unfold m a b -> Unfold m c d -> Unfold m (a, c) (b, d)+-- crossProduct u1 u2 = cross (lmap fst u1) (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 (,)++apply :: Monad m => Unfold m a (b -> c) -> Unfold m a b -> Unfold m a c+apply u1 u2 = fmap (\(a, b) -> a b) (cross u1 u2)++{-+-- | Example:+--+-- >>> rlist = Unfold.lmap fst Unfold.fromList+-- >>> llist = Unfold.lmap snd Unfold.fromList+-- >>> Stream.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))++-- | 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.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.+--+-- /Since: 0.8.0/++{-# 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+--+-- /Since: 0.8.0/++{-# 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 second unfold to each output element of the first unfold and+-- flatten the output in a single stream.+--+-- /Since: 0.8.0/+--+{-# INLINE_NORMAL many #-}+many :: Monad m => Unfold m a b -> Unfold m b c -> Unfold m a c+many (Unfold step1 inject1) (Unfold step2 inject2) = 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 (.) #-}+    (.) = flip 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)+--+-- /Since: 0.8.0/+--+{-# 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)+-}
− src/Streamly/Internal/Data/Unfold/Types.hs 
@@ -1,31 +0,0 @@-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts          #-}---- |--- Module      : Streamly.Internal.Data.Unfold.Types--- Copyright   : (c) 2019 Composewell Technologies--- License     : BSD3--- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC--module Streamly.Internal.Data.Unfold.Types-    ( Unfold (..)-    )-where--import Streamly.Internal.Data.Stream.StreamD.Type (Step(..))----------------------------------------------------------------------------------- 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@.------ @since 0.7.0--data Unfold m a b =-    -- | @Unfold step inject@-    forall s. Unfold (s -> m (Step s b)) (a -> m s)
− src/Streamly/Internal/Data/Unicode/Char.hs 
@@ -1,67 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}---- |--- Module      : Streamly.Data.Internal.Unicode.Char--- Copyright   : (c) 2018 Composewell Technologies------ License     : BSD3--- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC----module Streamly.Internal.Data.Unicode.Char-    (-    -- * Predicates-      isAsciiAlpha--    -- * Unicode aware operations-    {--      toCaseFold-    , toLower-    , toUpper-    , toTitle-    -}-    )-where--import Data.Char (isAsciiUpper, isAsciiLower)---- import Streamly (IsStream)------------------------------------------------------------------------------------ Unicode aware operations on strings------------------------------------------------------------------------------------ | Select alphabetic characters in the ascii character set.------ /Internal/----{-# INLINE isAsciiAlpha #-}-isAsciiAlpha :: Char -> Bool-isAsciiAlpha c = isAsciiUpper c || isAsciiLower c------------------------------------------------------------------------------------ Unicode aware operations on strings----------------------------------------------------------------------------------{---- |--- /undefined/-toCaseFold :: IsStream t => Char -> t m Char-toCaseFold = undefined---- |--- /undefined/-toLower :: IsStream t => Char -> t m Char-toLower = undefined---- |--- /undefined/-toUpper :: IsStream t => Char -> t m Char-toUpper = undefined---- |--- /undefined/-toTitle :: IsStream t => Char -> t m Char-toTitle = undefined--}
− src/Streamly/Internal/Data/Unicode/Stream.hs 
@@ -1,744 +0,0 @@-{-# LANGUAGE BangPatterns     #-}-{-# LANGUAGE CPP              #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE PatternSynonyms  #-}-{-# LANGUAGE RankNTypes       #-}-{-# LANGUAGE RecordWildCards  #-}---- |--- Module      : Streamly.Data.Internal.Unicode.Stream--- Copyright   : (c) 2018 Composewell Technologies---               (c) Bjoern Hoehrmann 2008-2009------ License     : BSD3--- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC-----#include "inline.hs"--module Streamly.Internal.Data.Unicode.Stream-    (-    -- * Construction (Decoding)-      decodeLatin1-    , decodeUtf8-    , decodeUtf8Lax-    , DecodeError(..)-    , DecodeState-    , CodePoint-    , decodeUtf8Either-    , resumeDecodeUtf8Either-    , decodeUtf8Arrays-    , decodeUtf8ArraysLenient--    -- * Elimination (Encoding)-    , encodeLatin1-    , encodeLatin1Lax-    , encodeUtf8-    {--    -- * Operations on character strings-    , strip -- (dropAround isSpace)-    , stripEnd-    -}--    -- * StreamD UTF8 Encoding / Decoding transformations.-    , decodeUtf8D-    , encodeUtf8D-    , decodeUtf8LenientD-    , decodeUtf8EitherD-    , resumeDecodeUtf8EitherD-    , decodeUtf8ArraysD-    , decodeUtf8ArraysLenientD--    -- * Transformation-    , stripStart-    , lines-    , words-    , unlines-    , unwords-    )-where--import Control.Monad.IO.Class (MonadIO, liftIO)-import Data.Bits (shiftR, shiftL, (.|.), (.&.))-import Data.Char (ord)-import Data.Word (Word8)-import Foreign.ForeignPtr (touchForeignPtr)-import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)-import Foreign.Storable (Storable(..))-import GHC.Base (assert, unsafeChr)-import GHC.ForeignPtr (ForeignPtr (..))-import GHC.IO.Encoding.Failure (isSurrogate)-import GHC.Ptr (Ptr (..), plusPtr)-import Prelude hiding (String, lines, words, unlines, unwords)-import System.IO.Unsafe (unsafePerformIO)--import Streamly (IsStream)-import Streamly.Data.Fold (Fold)-import Streamly.Memory.Array (Array)-import Streamly.Internal.Data.Unfold (Unfold)-import Streamly.Internal.Data.SVar (adaptState)-import Streamly.Internal.Data.Stream.StreamD (Stream(..), Step (..))-import Streamly.Internal.Data.Strict (Tuple'(..))--#if __GLASGOW_HASKELL__ < 800-import Streamly.Internal.Data.Stream.StreamD (pattern Stream)-#endif--import qualified Streamly.Internal.Memory.Array.Types as A-import qualified Streamly.Internal.Prelude as S-import qualified Streamly.Internal.Data.Stream.StreamD as D------------------------------------------------------------------------------------ Encoding/Decoding Unicode (UTF-8) Characters------------------------------------------------------------------------------------ UTF-8 primitives, Lifted from GHC.IO.Encoding.UTF8.--data WList = WCons !Word8 !WList | WNil--{-# 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--data CodingFailureMode-    = TransliterateCodingFailure-    | ErrorOnCodingFailure-    deriving (Show)--{-# INLINE replacementChar #-}-replacementChar :: Char-replacementChar = '\xFFFD'---- Int helps in cheaper conversion from Int to Char-type CodePoint = Int-type DecodeState = Word8---- 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-  ]--utf8d :: A.Array Word8-utf8d =-      unsafePerformIO-    -- Aligning to cacheline makes a barely noticeable difference-    -- XXX currently alignment is not implemented for unmanaged allocation-    $ D.runFold (A.writeNAlignedUnmanaged 64 (length decodeTable))-              (D.fromList decodeTable)---- | 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 = A.unsafeInlineIO $ peekElemOff p i in x---- 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--    utf8table =-        let !(Ptr addr) = table-            end = table `plusPtr` 364-        in A.Array (ForeignPtr addr undefined) end end :: A.Array Word8-    showByte = "Streamly: decode0: byte: " ++ show byte-    showTable = " table: " ++ show utf8table---- 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--    utf8table =-        let !(Ptr addr) = table-            end = table `plusPtr` 364-        in A.Array (ForeignPtr addr undefined) end end :: A.Array Word8-    showByte = "Streamly: decode1: byte: " ++ show byte-    showState st cp =-        " state: " ++ show st ++-        " codepoint: " ++ show cp ++-        " table: " ++ show utf8table---- 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)----data DecodeError = DecodeError !DecodeState !CodePoint deriving Show--data FreshPoint s a-    = FreshPointDecodeInit s-    | FreshPointDecodeInit1 s Word8-    | FreshPointDecodeFirst s Word8-    | FreshPointDecoding s !DecodeState !CodePoint-    | YieldAndContinue a (FreshPoint s a)-    | Done---- XXX Add proper error messages--- XXX Implement this in terms of decodeUtf8Either-{-# INLINE_NORMAL decodeUtf8WithD #-}-decodeUtf8WithD :: Monad m => CodingFailureMode -> Stream m Word8 -> Stream m Char-decodeUtf8WithD cfm (Stream step state) =-    let A.Array p _ _ = utf8d-        !ptr = (unsafeForeignPtrToPtr p)-    in Stream (step' ptr) (FreshPointDecodeInit state)-  where-    {-# INLINE transliterateOrError #-}-    transliterateOrError e s =-        case cfm of-            ErrorOnCodingFailure -> error e-            TransliterateCodingFailure -> YieldAndContinue replacementChar s-    {-# INLINE inputUnderflow #-}-    inputUnderflow =-        case cfm of-            ErrorOnCodingFailure ->-                error "Streamly.Internal.Data.Stream.StreamD.decodeUtf8With: Input Underflow"-            TransliterateCodingFailure -> YieldAndContinue replacementChar Done-    {-# INLINE_LATE step' #-}-    step' _ gst (FreshPointDecodeInit st) = do-        r <- step (adaptState gst) st-        return $ case r of-            Yield x s -> Skip (FreshPointDecodeInit1 s x)-            Skip s -> Skip (FreshPointDecodeInit s)-            Stop   -> Skip Done--    step' _ _ (FreshPointDecodeInit1 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))-                    (FreshPointDecodeInit 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 $ FreshPointDecodeFirst st x--    -- XXX should we merge it with FreshPointDecodeInit1?-    step' table _ (FreshPointDecodeFirst st x) = do-        let (Tuple' sv cp) = decode0 table x-        return $-            case sv of-                12 ->-                    Skip $-                    transliterateOrError-                        "Streamly.Internal.Data.Stream.StreamD.decodeUtf8With: Invalid UTF8 codepoint encountered"-                        (FreshPointDecodeInit st)-                0 -> error "unreachable state"-                _ -> Skip (FreshPointDecoding st sv cp)--    -- We recover by trying the new byte x a starter of a new codepoint.-    -- XXX need to use the same recovery in array decoding routine as well-    step' table gst (FreshPointDecoding 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)-                                        (FreshPointDecodeInit s)-                        12 ->-                            Skip $-                            transliterateOrError-                                "Streamly.Internal.Data.Stream.StreamD.decodeUtf8With: Invalid UTF8 codepoint encountered"-                                (FreshPointDecodeInit1 s x)-                        _ -> Skip (FreshPointDecoding s sv cp)-            Skip s -> return $ Skip (FreshPointDecoding s statePtr codepointPtr)-            Stop -> return $ Skip inputUnderflow--    step' _ _ (YieldAndContinue c s) = return $ Yield c s-    step' _ _ Done = return Stop--{-# INLINE decodeUtf8D #-}-decodeUtf8D :: Monad m => Stream m Word8 -> Stream m Char-decodeUtf8D = decodeUtf8WithD ErrorOnCodingFailure--{-# INLINE decodeUtf8LenientD #-}-decodeUtf8LenientD :: Monad m => Stream m Word8 -> Stream m Char-decodeUtf8LenientD = decodeUtf8WithD TransliterateCodingFailure--{-# INLINE_NORMAL resumeDecodeUtf8EitherD #-}-resumeDecodeUtf8EitherD-    :: Monad m-    => DecodeState-    -> CodePoint-    -> Stream m Word8-    -> Stream m (Either DecodeError Char)-resumeDecodeUtf8EitherD dst codep (Stream step state) =-    let A.Array p _ _ = utf8d-        !ptr = (unsafeForeignPtrToPtr p)-        stt =-            if dst == 0-            then FreshPointDecodeInit state-            else FreshPointDecoding state dst codep-    in Stream (step' ptr) stt-  where-    {-# INLINE_LATE step' #-}-    step' _ gst (FreshPointDecodeInit st) = do-        r <- step (adaptState gst) st-        return $ case r of-            Yield x s -> Skip (FreshPointDecodeInit1 s x)-            Skip s -> Skip (FreshPointDecodeInit s)-            Stop   -> Skip Done--    step' _ _ (FreshPointDecodeInit1 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))-                    (FreshPointDecodeInit 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 $ FreshPointDecodeFirst st x--    -- XXX should we merge it with FreshPointDecodeInit1?-    step' table _ (FreshPointDecodeFirst st x) = do-        let (Tuple' sv cp) = decode0 table x-        return $-            case sv of-                12 ->-                    Skip $ YieldAndContinue (Left $ DecodeError 0 (fromIntegral x))-                                            (FreshPointDecodeInit st)-                0 -> error "unreachable state"-                _ -> Skip (FreshPointDecoding st sv cp)--    -- We recover by trying the new byte x a starter of a new codepoint.-    -- XXX need to use the same recovery in array decoding routine as well-    step' table gst (FreshPointDecoding 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)-                                        (FreshPointDecodeInit s)-                        12 ->-                            Skip $ YieldAndContinue (Left $ DecodeError statePtr codepointPtr)-                                        (FreshPointDecodeInit1 s x)-                        _ -> Skip (FreshPointDecoding s sv cp)-            Skip s -> return $ Skip (FreshPointDecoding s statePtr codepointPtr)-            Stop -> return $ Skip $ YieldAndContinue (Left $ DecodeError statePtr codepointPtr) Done--    step' _ _ (YieldAndContinue c s) = return $ Yield c s-    step' _ _ Done = return Stop--{-# INLINE_NORMAL decodeUtf8EitherD #-}-decodeUtf8EitherD :: Monad m-    => Stream m Word8 -> Stream m (Either DecodeError Char)-decodeUtf8EitherD = resumeDecodeUtf8EitherD 0 0--data FlattenState s a-    = OuterLoop s !(Maybe (DecodeState, CodePoint))-    | InnerLoopDecodeInit s (ForeignPtr a) !(Ptr a) !(Ptr a)-    | InnerLoopDecodeFirst s (ForeignPtr a) !(Ptr a) !(Ptr a) Word8-    | InnerLoopDecoding s (ForeignPtr a) !(Ptr a) !(Ptr a)-        !DecodeState !CodePoint-    | YAndC !Char (FlattenState s a) -- These constructors can be-                                     -- encoded in the FreshPoint-                                     -- 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-    -> Stream m (A.Array Word8)-    -> Stream m Char-decodeUtf8ArraysWithD cfm (Stream step state) =-    let A.Array p _ _ = utf8d-        !ptr = (unsafeForeignPtrToPtr p)-    in Stream (step' ptr) (OuterLoop state Nothing)-  where-    {-# INLINE transliterateOrError #-}-    transliterateOrError e s =-        case cfm of-            ErrorOnCodingFailure -> error e-            TransliterateCodingFailure -> YAndC replacementChar s-    {-# INLINE inputUnderflow #-}-    inputUnderflow =-        case cfm of-            ErrorOnCodingFailure ->-                error-                    "Streamly.Internal.Data.Stream.StreamD.decodeUtf8ArraysWith: Input Underflow"-            TransliterateCodingFailure -> YAndC replacementChar D-    {-# INLINE_LATE step' #-}-    step' _ gst (OuterLoop st Nothing) = do-        r <- step (adaptState gst) st-        return $-            case r of-                Yield A.Array {..} s ->-                    let p = unsafeForeignPtrToPtr aStart-                     in Skip (InnerLoopDecodeInit s aStart p aEnd)-                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 A.Array {..} s ->-                    let p = unsafeForeignPtrToPtr aStart-                     in Skip (InnerLoopDecoding s aStart p aEnd ds cp)-                Skip s -> Skip (OuterLoop s dst)-                Stop -> Skip inputUnderflow-    step' _ _ (InnerLoopDecodeInit st startf p end)-        | p == end = do-            liftIO $ touchForeignPtr startf-            return $ Skip $ OuterLoop st Nothing-    step' _ _ (InnerLoopDecodeInit st startf p end) = do-        x <- liftIO $ peek 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 startf (p `plusPtr` 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 startf p end x--    step' table _ (InnerLoopDecodeFirst st startf 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 startf (p `plusPtr` 1) end)-                0 -> error "unreachable state"-                _ -> Skip (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)-    step' _ _ (InnerLoopDecoding st startf p end sv cp)-        | p == end = do-            liftIO $ touchForeignPtr startf-            return $ Skip $ OuterLoop st (Just (sv, cp))-    step' table _ (InnerLoopDecoding st startf p end statePtr codepointPtr) = do-        x <- liftIO $ peek p-        let (Tuple' sv cp) = decode1 table statePtr codepointPtr x-        return $-            case sv of-                0 ->-                    Skip $-                    YAndC-                        (unsafeChr cp)-                        (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)-                12 ->-                    Skip $-                    transliterateOrError-                        "Streamly.Internal.Data.Stream.StreamD.decodeUtf8ArraysWith: Invalid UTF8 codepoint encountered"-                        (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)-                _ -> Skip (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)-    step' _ _ (YAndC c s) = return $ Yield c s-    step' _ _ D = return Stop--{-# INLINE decodeUtf8ArraysD #-}-decodeUtf8ArraysD ::-       MonadIO m-    => Stream m (A.Array Word8)-    -> Stream m Char-decodeUtf8ArraysD = decodeUtf8ArraysWithD ErrorOnCodingFailure--{-# INLINE decodeUtf8ArraysLenientD #-}-decodeUtf8ArraysLenientD ::-       MonadIO m-    => Stream m (A.Array Word8)-    -> Stream m Char-decodeUtf8ArraysLenientD = decodeUtf8ArraysWithD TransliterateCodingFailure--data EncodeState s = EncodeState s !WList---- 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 => Stream m Char -> Stream m Word8-encodeUtf8D (Stream step state) = Stream step' (EncodeState state WNil)-  where-    {-# INLINE_LATE step' #-}-    step' gst (EncodeState st WNil) = do-        r <- step (adaptState gst) st-        return $-            case r of-                Yield c s ->-                    case ord c of-                        x-                            | x <= 0x7F ->-                                Yield (fromIntegral x) (EncodeState s WNil)-                            | x <= 0x7FF -> Skip (EncodeState s (ord2 c))-                            | x <= 0xFFFF ->-                                if isSurrogate c-                                    then error-                                             "Streamly.Internal.Data.Stream.StreamD.encodeUtf8: Encountered a surrogate"-                                    else Skip (EncodeState s (ord3 c))-                            | otherwise -> Skip (EncodeState s (ord4 c))-                Skip s -> Skip (EncodeState s WNil)-                Stop -> Stop-    step' _ (EncodeState s (WCons x xs)) = return $ Yield x (EncodeState s xs)----- | Decode a stream of bytes to Unicode characters by mapping each byte to a--- corresponding Unicode 'Char' in 0-255 range.------ /Since: 0.7.0/-{-# INLINE decodeLatin1 #-}-decodeLatin1 :: (IsStream t, Monad m) => t m Word8 -> t m Char-decodeLatin1 = S.map (unsafeChr . fromIntegral)---- | 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.------ /Since: 0.7.0/-{-# INLINE encodeLatin1 #-}-encodeLatin1 :: (IsStream t, Monad m) => t m Char -> t m Word8-encodeLatin1 = S.map convert-    where-    convert c =-        let codepoint = ord c-        in if codepoint > 255-           then error $ "Streamly.String.encodeLatin1 invalid " ++-                      "input char codepoint " ++ show codepoint-           else fromIntegral codepoint---- | Like 'encodeLatin1' but silently truncates and maps input characters beyond--- 255 to (incorrect) chars in 0-255 range. No error or exception is thrown--- when such truncation occurs.------ /Since: 0.7.0/-{-# INLINE encodeLatin1Lax #-}-encodeLatin1Lax :: (IsStream t, Monad m) => t m Char -> t m Word8-encodeLatin1Lax = S.map (fromIntegral . ord)---- | Decode a UTF-8 encoded bytestream to a stream of Unicode characters.--- The incoming stream is truncated if an invalid codepoint is encountered.------ /Since: 0.7.0/-{-# INLINE decodeUtf8 #-}-decodeUtf8 :: (Monad m, IsStream t) => t m Word8 -> t m Char-decodeUtf8 = D.fromStreamD . decodeUtf8D . D.toStreamD---- |------ /Internal/-{-# INLINE decodeUtf8Arrays #-}-decodeUtf8Arrays :: (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char-decodeUtf8Arrays = D.fromStreamD . decodeUtf8ArraysD . D.toStreamD---- | Decode a UTF-8 encoded bytestream to a stream of Unicode characters.--- Any invalid codepoint encountered is replaced with the unicode replacement--- character.------ /Since: 0.7.0/-{-# INLINE decodeUtf8Lax #-}-decodeUtf8Lax :: (Monad m, IsStream t) => t m Word8 -> t m Char-decodeUtf8Lax = D.fromStreamD . decodeUtf8LenientD . D.toStreamD---- |------ /Internal/-{-# INLINE decodeUtf8Either #-}-decodeUtf8Either :: (Monad m, IsStream t)-    => t m Word8 -> t m (Either DecodeError Char)-decodeUtf8Either = D.fromStreamD . decodeUtf8EitherD . D.toStreamD---- |------ /Internal/-{-# INLINE resumeDecodeUtf8Either #-}-resumeDecodeUtf8Either-    :: (Monad m, IsStream t)-    => DecodeState-    -> CodePoint-    -> t m Word8-    -> t m (Either DecodeError Char)-resumeDecodeUtf8Either st cp =-    D.fromStreamD . resumeDecodeUtf8EitherD st cp . D.toStreamD---- |------ /Internal/-{-# INLINE decodeUtf8ArraysLenient #-}-decodeUtf8ArraysLenient ::-       (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char-decodeUtf8ArraysLenient =-    D.fromStreamD . decodeUtf8ArraysLenientD . D.toStreamD---- | Encode a stream of Unicode characters to a UTF-8 encoded bytestream.------ /Since: 0.7.0/-{-# INLINE encodeUtf8 #-}-encodeUtf8 :: (Monad m, IsStream t) => t m Char -> t m Word8-encodeUtf8 = D.fromStreamD . encodeUtf8D . D.toStreamD--{------------------------------------------------------------------------------------ Utility operations on strings----------------------------------------------------------------------------------strip :: IsStream t => t m Char -> t m Char-strip = undefined--stripEnd :: IsStream t => t m Char -> t m Char-stripEnd = undefined--}---- | Remove leading whitespace from a string.------ > stripStart = S.dropWhile isSpace------ /Internal/-{-# INLINE stripStart #-}-stripStart :: (Monad m, IsStream t) => t m Char -> t m Char-stripStart = S.dropWhile isSpace---- | Fold each line of the stream using the supplied 'Fold'--- and stream the result.------ >>> S.toList $ lines FL.toList (S.fromList "lines\nthis\nstring\n\n\n")--- ["lines", "this", "string", "", ""]------ > lines = S.splitOnSuffix (== '\n')------ /Internal/-{-# INLINE lines #-}-lines :: (Monad m, IsStream t) => Fold m Char b -> t m Char -> t m b-lines = S.splitOnSuffix (== '\n')--foreign import ccall unsafe "u_iswspace"-  iswspace :: Int -> Int---- | 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-  | otherwise = iswspace (ord c) /= 0-  where-    uc = fromIntegral (ord c) :: Word---- | Fold each word of the stream using the supplied 'Fold'--- and stream the result.------ >>>  S.toList $ words FL.toList (S.fromList "fold these     words")--- ["fold", "these", "words"]------ > words = S.wordsBy isSpace------ /Internal/-{-# INLINE words #-}-words :: (Monad m, IsStream t) => Fold m Char b -> t m Char -> t m b-words = S.wordsBy isSpace---- | Unfold a stream to character streams using the supplied 'Unfold'--- and concat the results suffixing a newline character @\\n@ to each stream.------ /Internal/-{-# INLINE unlines #-}-unlines :: (MonadIO m, IsStream t) => Unfold m a Char -> t m a -> t m Char-unlines = S.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.------ /Internal/-{-# INLINE unwords #-}-unwords :: (MonadIO m, IsStream t) => Unfold m a Char -> t m a -> t m Char-unwords = S.interpose ' '
src/Streamly/Internal/FileSystem/Dir.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP             #-}- #include "inline.hs"  -- |@@ -8,7 +6,7 @@ -- -- License     : BSD3 -- Maintainer  : streamly@composewell.com--- Stability   : experimental+-- Stability   : pre-release -- Portability : GHC  module Streamly.Internal.FileSystem.Dir@@ -64,8 +62,9 @@ import Prelude hiding (read)  -- import Streamly.Data.Fold (Fold)-import Streamly.Internal.Data.Unfold.Types (Unfold(..))--- import Streamly.Internal.Memory.Array.Types+import Streamly.Internal.BaseCompat (fromLeft, fromRight)+import Streamly.Internal.Data.Unfold.Type (Unfold(..))+-- import Streamly.Internal.Data.Array.Foreign.Type --        (Array(..), writeNUnsafe, defaultChunkSize, shrinkToFit, --         lpackArraysChunksOf) -- import Streamly.Internal.Data.Stream.Serial (SerialT)@@ -73,26 +72,14 @@ -- import Streamly.String (encodeUtf8, decodeUtf8, foldLines)  -- import qualified Streamly.Data.Fold as FL--- import qualified Streamly.Internal.Data.Fold.Types as FL+-- import qualified Streamly.Internal.Data.Fold.Type as FL import qualified Streamly.Internal.Data.Unfold as UF--- import qualified Streamly.Internal.Memory.ArrayStream as AS-import qualified Streamly.Internal.Prelude as S--- import qualified Streamly.Memory.Array as A+-- import qualified Streamly.Internal.Data.Array.Stream.Foreign as AS+import qualified Streamly.Internal.Data.Stream.IsStream as S+-- import qualified Streamly.Data.Array.Foreign as A -- import qualified Streamly.Internal.Data.Stream.StreamD.Type as D import qualified System.Directory as Dir -#if MIN_VERSION_base(4,10,0)-import Data.Either (fromRight, fromLeft)-#else-fromLeft :: a -> Either a b -> a-fromLeft _ (Left a) = a-fromLeft a _        = a--fromRight :: b -> Either a b -> b-fromRight _ (Right b) = b-fromRight b _         = b-#endif- {- {-# INLINABLE readArrayUpto #-} readArrayUpto :: Int -> Handle -> IO (Array Word8)@@ -179,9 +166,9 @@  -- | Unfolds a handle into a stream of 'Word8' arrays. Requests to the IO -- device are performed using a buffer of size--- 'Streamly.Internal.Memory.Array.Types.defaultChunkSize'. The+-- 'Streamly.Internal.Data.Array.Foreign.Type.defaultChunkSize'. The -- size of arrays in the resulting stream are therefore less than or equal to--- 'Streamly.Internal.Memory.Array.Types.defaultChunkSize'.+-- 'Streamly.Internal.Data.Array.Foreign.Type.defaultChunkSize'. -- -- @since 0.7.0 {-# INLINE readChunks #-}@@ -202,12 +189,12 @@ -- @since 0.7.0 {-# INLINE readWithBufferOf #-} readWithBufferOf :: MonadIO m => Unfold m (Int, Handle) Word8-readWithBufferOf = UF.concat readChunksWithBufferOf A.read+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@. ----- /Internal/+-- /Pre-release/ {-# INLINE toStreamWithBufferOf #-} toStreamWithBufferOf :: (IsStream t, MonadIO m) => Int -> Handle -> t m Word8 toStreamWithBufferOf chunkSize h = AS.concat $ toChunksWithBufferOf chunkSize h@@ -265,7 +252,7 @@  -- | Raw read of a directory. ----- /Internal/+-- /Pre-release/ {-# INLINE toStream #-} toStream :: (IsStream t, MonadIO m) => String -> t m String toStream = S.unfold read@@ -273,7 +260,7 @@ -- | Read directories as Left and files as Right. Filter out "." and ".." -- entries. ----- /Internal/+-- /Pre-release/ {-# INLINE toEither #-} toEither :: (IsStream t, MonadIO m)     => String -> t m (Either String String)@@ -356,7 +343,7 @@ -- > write = 'writeWithBufferOf' A.defaultChunkSize -- -- | Write a byte stream to a file handle. Accumulates the input in chunks of--- up to 'Streamly.Internal.Memory.Array.Types.defaultChunkSize' before writing.+-- up to 'Streamly.Internal.Data.Array.Foreign.Type.defaultChunkSize' before writing. -- -- NOTE: This may perform better than the 'write' fold, you can try this if you -- need some extra perf boost.@@ -401,12 +388,12 @@ -- @since 0.7.0 {-# INLINE writeWithBufferOf #-} writeWithBufferOf :: MonadIO m => Int -> Handle -> Fold m Word8 ()-writeWithBufferOf n h = FL.lchunksOf n (writeNUnsafe n) (writeChunks h)+writeWithBufferOf n h = FL.chunksOf 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.Memory.Array.Types.defaultChunkSize' before writing+-- up to 'Streamly.Internal.Data.Array.Foreign.Type.defaultChunkSize' before writing -- to the IO device. -- -- @since 0.7.0
+ src/Streamly/Internal/FileSystem/Event/Darwin.h view
@@ -0,0 +1,63 @@+#include <config.h>++struct watch;++struct pathName {+    const UInt8 *pathBytes;+    size_t pathLen;+};++int createWatch+    ( struct pathName* folders+    , int n  /* number of entries in "folders" */+    , UInt32 createFlags+    , UInt64 since+    , double latency+    , int* fd+    , void** wp+    );++void destroyWatch(struct watch* w);++/******************************************************************************+ * Create Flags+ *****************************************************************************/++UInt32 FSEventStreamCreateFlagNoDefer ();+UInt32 FSEventStreamCreateFlagWatchRoot ();+UInt32 FSEventStreamCreateFlagFileEvents ();+UInt32 FSEventStreamCreateFlagIgnoreSelf ();+#if HAVE_DECL_KFSEVENTSTREAMCREATEFLAGFULLHISTORY+UInt32 FSEventStreamCreateFlagFullHistory;+#endif++/******************************************************************************+ * Event Flags+ *****************************************************************************/++UInt32 FSEventStreamEventFlagEventIdsWrapped ();+UInt32 FSEventStreamEventFlagMustScanSubDirs ();+UInt32 FSEventStreamEventFlagKernelDropped ();+UInt32 FSEventStreamEventFlagUserDropped ();+UInt32 FSEventStreamEventFlagHistoryDone ();+UInt32 FSEventStreamEventFlagRootChanged ();+UInt32 FSEventStreamEventFlagMount ();+UInt32 FSEventStreamEventFlagUnmount ();+UInt32 FSEventStreamEventFlagItemChangeOwner ();+UInt32 FSEventStreamEventFlagItemInodeMetaMod ();+UInt32 FSEventStreamEventFlagItemFinderInfoMod ();+UInt32 FSEventStreamEventFlagItemXattrMod ();+UInt32 FSEventStreamEventFlagItemCreated ();+UInt32 FSEventStreamEventFlagItemRemoved ();+UInt32 FSEventStreamEventFlagItemRenamed ();+UInt32 FSEventStreamEventFlagItemModified ();+#if HAVE_DECL_KFSEVENTSTREAMEVENTFLAGITEMCLONED+UInt32 FSEventStreamEventFlagItemCloned ();+#endif+UInt32 FSEventStreamEventFlagItemIsDir ();+UInt32 FSEventStreamEventFlagItemIsFile ();+UInt32 FSEventStreamEventFlagItemIsSymlink ();+#if HAVE_DECL_KFSEVENTSTREAMEVENTFLAGITEMISHARDLINK+UInt32 FSEventStreamEventFlagItemIsHardlink ();+#endif+UInt32 FSEventStreamEventFlagItemIsLastHardlink ();
+ src/Streamly/Internal/FileSystem/Event/Darwin.hs view
@@ -0,0 +1,1030 @@+-- |+-- Module      : Streamly.Internal.FileSystem.Event.Darwin+-- Copyright   : (c) 2020 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : pre-release+-- Portability : GHC+--+-- =Overview+--+-- Use 'watchTrees' with a list of file system paths you want to watch as+-- argument. It returns a stream of 'Event' representing the file system events+-- occurring under the watched paths.+--+-- @+-- {-\# LANGUAGE MagicHash #-}+-- Stream.mapM_ (putStrLn . 'showEvent') $ 'watchTrees' [Array.fromCString\# "path"#]+-- @+--+-- 'Event' is an opaque type. Accessor functions (e.g. 'showEvent' above)+-- provided in this module are used to determine the attributes of the event.+--+-- =Design notes+--+-- For reference documentation see:+--+-- * "<https://developer.apple.com/library/archive/documentation/Darwin/Conceptual/FSEvents_ProgGuide/UsingtheFSEventsFramework/UsingtheFSEventsFramework.html Apple FS Events Programming Guide>"+-- * "<https://developer.apple.com/documentation/coreservices/file_system_events?language=objc Apple FS Events Reference>"+--+-- We try to keep the macOS\/Linux/Windows event handling APIs and defaults+-- semantically and syntactically as close as possible.+--+-- =BUGS+--+-- There may be some idiosyncrasies in event reporting.+--+-- 1. Multiple events may be coalesced into a single event having multiple+-- flags set.  For example, on macOS 10.15.6, "touch x; rm x" or "touch x; mv x+-- y" produces an event with both "Created" and "Deleted/Moved" flags set.+--+-- 2. The same event can occur multiple times. For example, "touch x; sleep 1;+-- rm x" generates a "Created" event followed by an event with both "Created"+-- and "Deleted" flags set. Similarly, a cloned event can also occur multiple+-- times.+--+-- 3. Some events can go missing and only the latest one is reported. See+-- 'isCreated' for one such case.+--+-- 4. When @rm -rf@ is used on the watched root directory, only one 'isDeleted'+-- event occurs and that is for the root. However, @rm -rf@ on a directory+-- inside the watch root produces 'isDeleted' events for all files.+--+-- 5. When a file is moved, a move event occurs for both the source and the+-- destination files. There seems to be no way to distinguish the source and+-- the destination. Perhaps the lower eventId can be considered as source.+--+-- 6. When a file is cloned both source and destination generate a cloned+-- event, however the source has lower eventId and destination may have+-- OwnerGroupModeChanged, InodeAttrsChanged, Created flags as well.+--+-- You may have to stat the path of the event to know more information about+-- what might have happened.  It may be a good idea to watch the behavior of+-- events you are handling before you can rely on it. See the individual event+-- APIs for some of the known issues marked with `BUGS`. Also see the "Handling+-- Events" section in the "Apple FS Events Programming Guide".+--+-- * "<https://stackoverflow.com/questions/18415285/osx-fseventstreameventflags-not-working-correctly Stack overflow question on event coalescing>"+--+-- =TODO+--+-- APIs for persistent event-id related functionality, to get events from+-- specific event-id etc are not implemented.++#include <config.h>++-- macOS 10.7++#if HAVE_DECL_KFSEVENTSTREAMCREATEFLAGFILEEVENTS++module Streamly.Internal.FileSystem.Event.Darwin+    (+    -- * Creating a Watch++    -- ** Default configuration+      Config+    , Toggle (..)+    , defaultConfig++    -- ** Watch Behavior+    , BatchInfo (..)+    , setEventBatching++    -- ** Events of Interest+    , setRootChanged+    , setFileEvents+    , setIgnoreSelf+#if HAVE_DECL_KFSEVENTSTREAMCREATEFLAGFULLHISTORY+    , setFullHistory+#endif++    -- ** Watch APIs+    , watchTrees+    , watchTreesWith++    -- * Handling Events+    , Event+    , getEventId+    , getAbsPath++    -- ** Exception Conditions+    , isEventIdWrapped+    , isMustScanSubdirs+    , isKernelDropped+    , isUserDropped++    -- ** Root Level Events+    -- | Events that belong to the root path as a whole and not to specific+    -- itmes contained in it.+    , isMount+    , isUnmount+    , isHistoryDone+    , isRootChanged++    -- ** Item Level Metadata change+    , isOwnerGroupModeChanged+    , isInodeAttrsChanged+    , isFinderInfoChanged+    , isXAttrsChanged++    -- ** Item Level CRUD events+    , isCreated+    , isDeleted+    , isMoved+    , isModified+#if HAVE_DECL_KFSEVENTSTREAMEVENTFLAGITEMCLONED+    , isCloned+#endif++    -- ** Item Path info+    , isDir+    , isFile+    , isSymLink+#if HAVE_DECL_KFSEVENTSTREAMEVENTFLAGITEMISHARDLINK+    , isHardLink+    , isLastHardLink+#endif++    -- * Debugging+    , showEvent+    )+where++import Control.Concurrent (MVar, newMVar, takeMVar, putMVar)+import Control.Monad (when)+import Control.Monad.IO.Class (liftIO)+import Data.Bits ((.|.), (.&.), complement)+import Data.Functor.Identity (runIdentity)+import Data.List.NonEmpty (NonEmpty)+import Data.Word (Word8, Word32, Word64)+import Foreign.C.Types (CInt(..), CDouble(..), CSize(..), CUChar(..))+import Foreign.Marshal.Alloc (alloca)+import Foreign.Marshal.Array (withArray)+import Foreign.Ptr (Ptr, castPtr)+import Foreign.Storable (Storable(..))+import GHC.IO.Handle.FD (fdToHandle)+import Streamly.Prelude (SerialT)+import Streamly.Internal.Data.Cont (contListMap)+import Streamly.Internal.Data.Parser (Parser)+import Streamly.Internal.Data.Array.Foreign.Type (Array(..))+import System.IO (Handle, hClose)++import qualified Data.List.NonEmpty as NonEmpty+import qualified Streamly.Internal.Data.Parser as PR+import qualified Streamly.Internal.Data.Stream.IsStream as S+import qualified Streamly.Internal.Unicode.Stream as U+import qualified Streamly.Internal.FileSystem.Handle as FH+import qualified Streamly.Internal.Data.Array.Foreign as A++-------------------------------------------------------------------------------+-- Subscription to events+-------------------------------------------------------------------------------++-- | Watch configuration, used to specify the events of interest and the+-- behavior of the watch.+--+-- /Pre-release/+--+data Config = Config+    { latency :: Double+    , createFlags   :: Word32+    }++-------------------------------------------------------------------------------+-- Batching Events+-------------------------------------------------------------------------------++foreign import ccall safe+    "FileSystem/Event/Darwin.h FSEventStreamCreateFlagNoDefer"+    kFSEventStreamCreateFlagNoDefer :: Word32++data BatchInfo =+      Throttle Double -- ^ Deliver an event immediately but suppress the+                      -- following events upto the specified time.+    | Batch Double    -- ^ Collapse all events that occurred in the specified+                      -- time window (in seconds) and deliver them as a single+                      -- batch.++-- | Set how the events should be batched. See 'BatchInfo' for details.  A+-- negative value for time is treated as 0.+--+-- /default: Batch 0.0/+--+-- /macOS 10.5+/+--+-- /Pre-release/+--+setEventBatching :: BatchInfo -> Config -> Config+setEventBatching batchInfo cfg@Config{..} =+    let (t, status) =+            case batchInfo of+                Throttle sec | sec < 0 -> (0, On)+                Throttle sec -> (sec, On)+                Batch sec | sec < 0 -> (0, Off)+                Batch sec -> (sec, Off)+    in setFlag kFSEventStreamCreateFlagNoDefer status $ cfg {latency = t}++-------------------------------------------------------------------------------+-- Boolean settings+-------------------------------------------------------------------------------++-- | Whether a setting is 'On' or 'Off'.+--+-- /Pre-release/+--+data Toggle = On | Off++setFlag :: Word32 -> Toggle -> Config -> Config+setFlag mask status cfg@Config{..} =+    let flags =+            case status of+                On -> createFlags .|. mask+                Off -> createFlags .&. complement mask+    in cfg {createFlags = flags}++foreign import ccall safe+    "FSEventStreamCreateFlagWatchRoot"+    kFSEventStreamCreateFlagWatchRoot :: Word32++-- | Watch the changes to the path of the top level file system objects being+-- watched. If the root directory is deleted, moved or renamed you will receive+-- an 'isRootChanged' event with an eventId 0.+--+-- /default: Off/+--+-- /macOS 10.5+/+--+-- /Pre-release/+--+setRootChanged :: Toggle -> Config -> Config+setRootChanged = setFlag kFSEventStreamCreateFlagWatchRoot++foreign import ccall safe+    "FSEventStreamCreateFlagFileEvents"+    kFSEventStreamCreateFlagFileEvents :: Word32++-- | When this is 'Off' only events for the watched directories are reported.+-- For example, when a file is created inside a directory it is reported as an+-- event, the path name in the event is the path of the directory being+-- watched.  Events cannot be distinguished based on the type of event.+--+-- When it is 'On' the path reported in the event is the path of the item and+-- not the of the directory in which it is contained. We can use the event+-- accessor functions to determine the event type and the path type etc.+--+-- /default: On/+--+-- /macOS 10.7+/+--+-- /Pre-release/+--+setFileEvents :: Toggle -> Config -> Config+setFileEvents = setFlag kFSEventStreamCreateFlagFileEvents++foreign import ccall safe+    "FSEventStreamCreateFlagIgnoreSelf"+    kFSEventStreamCreateFlagIgnoreSelf :: Word32++-- | When this is 'On' events generated by the current process are not+-- reported.+--+-- /default: Off/+--+-- /macOS 10.6+/+--+-- /Pre-release/+--+setIgnoreSelf :: Toggle -> Config -> Config+setIgnoreSelf = setFlag kFSEventStreamCreateFlagIgnoreSelf++#if HAVE_DECL_KFSEVENTSTREAMCREATEFLAGFULLHISTORY+foreign import ccall safe+    "FSEventStreamCreateFlagFullHistory"+    kFSEventStreamCreateFlagFullHistory :: Word32++-- | When this is 'On' all events since the beginning of time are reported.+--+-- /default: Off/+--+-- /macOS 10.15+/+--+-- /Pre-release/+--+setFullHistory :: Toggle -> Config -> Config+setFullHistory = setFlag kFSEventStreamCreateFlagFullHistory+#endif++-------------------------------------------------------------------------------+-- Default config+-------------------------------------------------------------------------------++-- | The default settings are:+--+-- * 'setEventBatching' ('Batch' 0.0)+-- * 'setFileEvents' 'On'+-- * 'setRootChanged' 'Off'+-- * 'setIgnoreSelf' 'Off'+#if HAVE_DECL_KFSEVENTSTREAMCREATEFLAGFULLHISTORY+-- * 'setFullHistory' 'Off'+#endif+--+-- /Pre-release/+--+defaultConfig :: Config+defaultConfig = setFileEvents On $ Config+    { latency = 0.0+    , createFlags = 0+    }++-------------------------------------------------------------------------------+-- Open an event stream (C FFI)+-------------------------------------------------------------------------------++-- See FileSystem/Event/Darwin.h++data CWatch++-- Representation of "struct pathName" in "FileSystem/Event/Darwin.h"+data PathName = PathName+    { pathBytes :: Ptr CUChar+    , pathLen :: CSize+    }++instance Storable PathName where+    alignment _ = sizeOf (undefined :: Ptr a)+    sizeOf _ = sizeOf (undefined :: Ptr CUChar) + sizeOf (undefined :: CSize)+    peek ptr = do+        bptr <- peekByteOff ptr 0+        len <- peekByteOff ptr (sizeOf (undefined :: Ptr CUChar))+        return $ PathName bptr len+    poke ptr PathName{..} = do+        pokeByteOff ptr 0 pathBytes+        pokeByteOff ptr (sizeOf (undefined :: Ptr CUChar)) pathLen++foreign import ccall safe "FileSystem/Event/Darwin.h createWatch" createWatch+    :: Ptr PathName+    -> CInt+    -> Word32+    -> Word64+    -> CDouble+    -> Ptr (CInt)+    -> Ptr (Ptr CWatch)+    -> IO CInt++foreign import ccall safe "FileSystem/Event/Darwin.h destroyWatch" destroyWatch+    :: Ptr CWatch -> IO ()++-------------------------------------------------------------------------------+-- Open an event stream+-------------------------------------------------------------------------------++-- | A handle for a watch.+data Watch = Watch Handle (Ptr CWatch) (MVar Bool)++-- | Given a 'Config' and @paths@ start monitoring the paths for file system+-- events. Returns a 'Watch' handle which can then be used to read the event+-- stream or to close the watch.+--+-- Implementation Note: This API creates an OS level thread where an event loop+-- runs and writes the events to the write side fd of a POSIX pipe. Event+-- stream APIs read the events from the read end of this pipe.  Since an OS+-- level thread is forked, creating a new watch stream is expensive. It is+-- advised to minimize the number of watches.+--+-- /Pre-release/+--+openWatch :: Config -> NonEmpty (Array Word8) -> IO Watch+openWatch Config{..} paths = do+    -- XXX check whether the path exists. If the path does not exist and+    -- is created later it cannot be properly monitored. Also a user may+    -- inadvertently provide a path for which the user may not have permission+    -- and then later wonder why events are not being reported.+    withPathNames (NonEmpty.toList paths) $ \arraysPtr ->+        alloca $ \fdPtr -> do+        alloca $ \watchPPtr -> do+            let nArrays = fromIntegral (NonEmpty.length paths)+                seconds = (realToFrac latency)+            r <- createWatch+                    arraysPtr nArrays createFlags 0 seconds fdPtr watchPPtr+            when (r /= 0) $+                ioError (userError "openWatch: failed to create watch.")+            fd <- peek fdPtr+            h <- fdToHandle fd+            watchPtr <- peek watchPPtr+            closeLock <- newMVar False+            return $ Watch h watchPtr closeLock++    where++    withPathName :: Array Word8 -> (PathName -> IO a) -> IO a+    withPathName arr act = do+        A.unsafeAsPtr arr $ \ptr ->+            let pname = PathName (castPtr ptr) (fromIntegral (A.length arr))+            in act pname++    withPathNames = contListMap withPathName withArray++-- | Close a 'Watch' handle.+--+-- /Pre-release/+--+closeWatch :: Watch -> IO ()+closeWatch (Watch h watchPtr mvar) = do+    hClose h+    closed <- takeMVar mvar+    when (not closed) $ destroyWatch watchPtr+    putMVar mvar True++-------------------------------------------------------------------------------+-- Raw events read from the watch file handle+-------------------------------------------------------------------------------++-- | An Event generated by the file system. Use the accessor functions to+-- examine the event.+--+-- /Pre-release/+--+data Event = Event+   { eventId :: Word64+   , eventFlags :: Word32+   , eventAbsPath :: Array Word8+   } deriving (Show, Ord, Eq)++-- XXX We can perhaps use parseD monad instance for fusing with parseMany? Need+-- to measure the perf.+--+-- XXX should we use a magic in the header to avoid any issues due to+-- misalignment of records? Can that ever happen?+--+readOneEvent :: Parser IO Word8 Event+readOneEvent = do+    arr <- PR.takeEQ 24 (A.writeN 24)+    let arr1 = A.unsafeCast arr :: Array Word64+        eid = A.unsafeIndex arr1 0+        eflags = A.unsafeIndex arr1 1+        pathLen = fromIntegral $ A.unsafeIndex arr1 2+    path <- PR.takeEQ pathLen (A.writeN pathLen)+    return $ Event+        { eventId = eid+        , eventFlags = fromIntegral eflags+        , eventAbsPath = path+        }++watchToStream :: Watch -> SerialT IO Event+watchToStream (Watch handle _ _) =+    S.parseMany readOneEvent $ S.unfold FH.read handle++-- | Start monitoring a list of file system paths for file system events with+-- the supplied configuration operation over the 'defaultConfig'. The+-- paths could be files or directories.  When the path is a directory, the+-- whole directory tree under it is watched recursively. Monitoring starts from+-- the current time onwards. The paths are specified as UTF-8 encoded 'Array'+-- of 'Word8'.+--+-- If the path name to be watched is a symbolic link then the target of the+-- link is watched instead of the symbolic link itself. If the symbolic link is+-- removed later the target is still watched as usual.+--+-- When 'setFileEvents' is 'Off' then events occurring inside the watch root+-- cannot be distinguished from each other.  For example, we cannot determine+-- if an event is a "create" or "delete", we only know that some event ocurred+-- under the watched directory hierarchy.  Also, no path information for the+-- target item of the event is generated.+--+-- If the watched path is deleted and created again the events start coming+-- again for that path. A file type path being watched could be deleted and+-- recreated as a directory. If the watched path is moved to another path (or+-- is deleted and recreated as a symbolic link to another path) then no events+-- are reported for any changes under the new path.+--+-- BUGS: If a watch is started on a non-existing path then the path is not+-- watched even if it is created later.  The macOS API does not fail for a+-- non-existing path.  If a non-existing path is watched with 'setRootChanged'+-- then an 'isRootChanged' event is reported if the path is created later and+-- the "path" field in the event is set to the dirname of the path rather than+-- the full absolute path. This is the observed behavior on macOS 10.15.1.+--+-- @+-- {-\# LANGUAGE MagicHash #-}+-- watchTreesWith ('setIgnoreSelf' 'On' . 'setRootChanged' 'On') [Array.fromCString\# "path"#]+-- @+--+-- /Pre-release/+--+watchTreesWith ::+    (Config -> Config) -> NonEmpty (Array Word8) -> SerialT IO Event+watchTreesWith f paths = S.bracket before after watchToStream++    where++    before = liftIO $ openWatch (f defaultConfig) paths+    after = (liftIO . closeWatch)++-- | Like 'watchTreesWith' but uses the 'defaultConfig' options.+--+-- @+-- watchTrees = watchTreesWith id+-- @+--+watchTrees :: NonEmpty (Array Word8) -> SerialT IO Event+watchTrees = watchTreesWith id++-------------------------------------------------------------------------------+-- Examine the event stream+-------------------------------------------------------------------------------++-- | Get the event id of an 'Event'.  Event-id is a monotonically increasing+-- 64-bit integer identifying an event uniquely.+--+-- /Pre-release/+--+getEventId :: Event -> Word64+getEventId Event{..} = eventId++foreign import ccall safe+    "FSEventStreamEventFlagEventIdsWrapped"+    kFSEventStreamEventFlagEventIdsWrapped :: Word32++-- | Determine whether the event id has wrapped. This is impossible on any+-- traditional hardware in any reasonable amount of time unless the event-id+-- starts from a very high value, because the event-id is a 64-bit integer.+-- However, apple still recommends to check and handle this flag.+--+-- /macOS 10.5+/+--+-- /Pre-release/+--+isEventIdWrapped :: Event -> Bool+isEventIdWrapped = getFlag kFSEventStreamEventFlagEventIdsWrapped++-- | Get the absolute path of the file system object for which the event is+-- generated. The path is a UTF-8 encoded array of bytes.+--+-- /Pre-release/+--+getAbsPath :: Event -> Array Word8+getAbsPath Event{..} = eventAbsPath++-------------------------------------------------------------------------------+-- Event types+-------------------------------------------------------------------------------++getFlag :: Word32 -> Event -> Bool+getFlag mask Event{..} = eventFlags .&. mask /= 0++-------------------------------------------------------------------------------+-- Error events+-------------------------------------------------------------------------------++foreign import ccall safe+    "FSEventStreamEventFlagMustScanSubDirs"+    kFSEventStreamEventFlagMustScanSubDirs :: Word32++-- | Apple documentation says that "If an event in a directory occurs at about+-- the same time as one or more events in a subdirectory of that directory, the+-- events may be coalesced into a single event." In that case you will recieve+-- 'isMustScanSubdirs' event. In that case the path listed in the event is+-- invalidated and you must rescan it to know the current state.+--+-- This event can also occur if a communication error (overflow) occurs in+-- sending the event and the event gets dropped. In that case 'isKernelDropped'+-- and/or 'isUserDropped' attributes will also be set.+--+-- /macOS 10.5+/+--+-- /Pre-release/+--+isMustScanSubdirs :: Event -> Bool+isMustScanSubdirs = getFlag kFSEventStreamEventFlagMustScanSubDirs++foreign import ccall safe+    "FSEventStreamEventFlagKernelDropped"+    kFSEventStreamEventFlagKernelDropped :: Word32++-- | Did an event get dropped due to a kernel processing issue? Set only when+-- 'isMustScanSubdirs' is also true.+--+-- /macOS 10.5+/+--+-- /Pre-release/+--+isKernelDropped :: Event -> Bool+isKernelDropped = getFlag kFSEventStreamEventFlagKernelDropped++foreign import ccall safe+    "FSEventStreamEventFlagUserDropped"+    kFSEventStreamEventFlagUserDropped :: Word32++-- | Did an event get dropped due to a user process issue? Set only when+-- 'isMustScanSubdirs' is also true.+--+-- /macOS 10.5+/+--+-- /Pre-release/+--+isUserDropped :: Event -> Bool+isUserDropped = getFlag kFSEventStreamEventFlagUserDropped++-------------------------------------------------------------------------------+-- Global Sentinel Events+-------------------------------------------------------------------------------++foreign import ccall safe+    "FSEventStreamEventFlagHistoryDone"+    kFSEventStreamEventFlagHistoryDone :: Word32++-- | Determine whether the event is a history done marker event. A history done+-- event is generated when the historical events from before the current time+-- are done. Historical events are generated when the "since" parameter in the+-- watch config is set to before the current time.+--+-- /macOS 10.5+/+--+-- /Pre-release/+--+isHistoryDone :: Event -> Bool+isHistoryDone = getFlag kFSEventStreamEventFlagHistoryDone++-------------------------------------------------------------------------------+-- Events affecting the watched path only+-------------------------------------------------------------------------------++foreign import ccall safe+    "FSEventStreamEventFlagRootChanged"+    kFSEventStreamEventFlagRootChanged :: Word32++-- | Determine whether the event indicates a change of path of the monitored+-- object itself. Note that the object may become unreachable or deleted after+-- a change of path.+--+-- /Applicable only when 'setRootChanged' is 'On'/+--+-- /Occurs only for the watched path/+--+-- /macOS 10.5+/+--+-- /Pre-release/+--+isRootChanged :: Event -> Bool+isRootChanged = getFlag kFSEventStreamEventFlagRootChanged++-------------------------------------------------------------------------------+-- Global events under the watched path+-------------------------------------------------------------------------------++foreign import ccall safe+    "FSEventStreamEventFlagMount"+    kFSEventStreamEventFlagMount :: Word32++-- | Determine whether the event is a mount event. A mount event is generated+-- if a volume is mounted under the path being watched.+--+-- /macOS 10.5+/+--+-- /Pre-release/+--+isMount :: Event -> Bool+isMount = getFlag kFSEventStreamEventFlagMount++foreign import ccall safe+    "FSEventStreamEventFlagUnmount"+    kFSEventStreamEventFlagUnmount :: Word32++-- | Determine whether the event is an unmount event. An unmount event is+-- generated if a volume mounted under the path being watched is unmounted.+--+-- /macOS 10.5+/+--+-- /Pre-release/+--+isUnmount :: Event -> Bool+isUnmount = getFlag kFSEventStreamEventFlagUnmount++-------------------------------------------------------------------------------+-- Metadata change Events (applicable only when 'setFileEvents' is 'On')+-------------------------------------------------------------------------------++foreign import ccall safe+    "FSEventStreamEventFlagItemChangeOwner"+    kFSEventStreamEventFlagItemChangeOwner :: Word32++-- | Determine whether the event is ownership, group, permissions or ACL change+-- event of an object contained within the monitored path.+--+-- Note that this event may be generated even if the metadata is changed to the+-- same value again.+--+-- /Applicable only when 'setFileEvents' is 'On'/+--+-- /Can occur for watched path or a file inside it/+--+-- /macOS 10.7+/+--+-- /Pre-release/+--+isOwnerGroupModeChanged :: Event -> Bool+isOwnerGroupModeChanged = getFlag kFSEventStreamEventFlagItemChangeOwner++foreign import ccall safe+    "FSEventStreamEventFlagItemInodeMetaMod"+    kFSEventStreamEventFlagItemInodeMetaMod :: Word32++-- | Determine whether the event indicates inode metadata change for an object+-- contained within the monitored path. This event is generated when inode+-- attributes other than the owner, group or permissions are changed e.g. file+-- modification time. It does not occur when the link count of a file changes+-- (as of macOS 10.15.1).+--+-- /Applicable only when 'setFileEvents' is 'On'/+--+-- /Can occur for watched path or a file inside it/+--+-- /macOS 10.7+/+--+-- /Pre-release/+--+isInodeAttrsChanged :: Event -> Bool+isInodeAttrsChanged = getFlag kFSEventStreamEventFlagItemInodeMetaMod++foreign import ccall safe+    "FSEventStreamEventFlagItemFinderInfoMod"+    kFSEventStreamEventFlagItemFinderInfoMod :: Word32++-- | Determine whether the event indicates finder information metadata change+-- for an object contained within the monitored path.+--+-- /Applicable only when 'setFileEvents' is 'On'/+--+-- /macOS 10.7+/+--+-- /Pre-release/+--+isFinderInfoChanged :: Event -> Bool+isFinderInfoChanged = getFlag kFSEventStreamEventFlagItemFinderInfoMod++foreign import ccall safe+    "FSEventStreamEventFlagItemXattrMod"+    kFSEventStreamEventFlagItemXattrMod :: Word32++-- | Determine whether the event indicates extended attributes metadata change+-- for an object contained within the monitored path.+--+-- /Applicable only when 'setFileEvents' is 'On'/+--+-- /Can occur for watched path or a file inside it/+--+-- /macOS 10.7+/+--+-- /Pre-release/+--+isXAttrsChanged :: Event -> Bool+isXAttrsChanged = getFlag kFSEventStreamEventFlagItemXattrMod++-------------------------------------------------------------------------------+-- CRUD Events (applicable only when 'setFileEvents' is 'On')+-------------------------------------------------------------------------------++foreign import ccall safe+    "FSEventStreamEventFlagItemCreated"+    kFSEventStreamEventFlagItemCreated :: Word32++-- | Determine whether the event indicates creation of an object within the+-- monitored path. This event is generated when any file system object other+-- than a hard link is created.  On hard linking only an 'isInodeAttrsChanged'+-- event on the directory is generated, it is not a create event. However, when+-- a hard link is deleted 'isDeleted' and 'isHardLink' both are true.+--+-- This event can occur for the watched path if the path was deleted/moved and+-- created again (tested on macOS 10.15.1). However, if a watch is started on a+-- non-existing path and the path is created later, then this event is not+-- generated, the path is not watched.+--+-- BUGS: On 10.15.1 when we use a "touch x" to create a file for the first time+-- only an 'isInodeAttrsChanged' event occurs and there is no 'isCreated'+-- event. However, this seems to have been fixed on 10.15.6.+--+-- /Applicable only when 'setFileEvents' is 'On'/+--+-- /Can occur for watched path or a file inside it/+--+-- /macOS 10.7+/+--+-- /Pre-release/+--+isCreated :: Event -> Bool+isCreated = getFlag kFSEventStreamEventFlagItemCreated++foreign import ccall safe+    "FSEventStreamEventFlagItemRemoved"+    kFSEventStreamEventFlagItemRemoved :: Word32++-- | Determine whether the event indicates deletion of an object within the+-- monitored path. This is true when a file or a hardlink is deleted.+--+-- Applicable only when 'setFileEvents' is 'On'.+--+-- /Can occur for watched path or a file inside it/+--+-- /macOS 10.7+/+--+-- /Pre-release/+--+isDeleted :: Event -> Bool+isDeleted = getFlag kFSEventStreamEventFlagItemRemoved++foreign import ccall safe+    "FSEventStreamEventFlagItemRenamed"+    kFSEventStreamEventFlagItemRenamed :: Word32++-- | Determine whether the event indicates rename of an object within the+-- monitored path. This event is generated when a file is renamed within the+-- watched directory or if it is moved out of or in the watched directory.+--+-- /Applicable only when 'setFileEvents' is 'On'/+--+-- /Can occur for watched path or a file inside it/+--+-- /macOS 10.7+/+--+-- /Pre-release/+--+isMoved :: Event -> Bool+isMoved = getFlag kFSEventStreamEventFlagItemRenamed++foreign import ccall safe+    "FSEventStreamEventFlagItemModified"+    kFSEventStreamEventFlagItemModified :: Word32++-- | Determine whether the event indicates modification of an object within the+-- monitored path. This event is generated only for files and not directories.+--+-- Applicable only when 'setFileEvents' is 'On'.+--+-- /macOS 10.7+/+--+-- /Pre-release/+--+isModified :: Event -> Bool+isModified = getFlag kFSEventStreamEventFlagItemModified++#if HAVE_DECL_KFSEVENTSTREAMEVENTFLAGITEMCLONED+foreign import ccall safe+    "FSEventStreamEventFlagItemCloned"+    kFSEventStreamEventFlagItemCloned :: Word32++-- | Determine whether the event indicates cloning of an object within the+-- monitored path. The "Duplicate" command in the "File" menu of the "Finder"+-- application generates a "clone" event.+--+-- Applicable only when 'setFileEvents' is 'On'.+--+-- /macOS 10.13+/+--+-- /Pre-release/+--+isCloned :: Event -> Bool+isCloned = getFlag kFSEventStreamEventFlagItemCloned+#endif++-------------------------------------------------------------------------------+-- Information about path type (applicable only when 'setFileEvents' is 'On')+-------------------------------------------------------------------------------++foreign import ccall safe+    "FSEventStreamEventFlagItemIsDir"+    kFSEventStreamEventFlagItemIsDir :: Word32++-- | Determine whether the event is for a directory path.+--+-- Applicable only when 'setFileEvents' is 'On'.+--+-- /macOS 10.7+/+--+-- /Pre-release/+--+isDir :: Event -> Bool+isDir = getFlag kFSEventStreamEventFlagItemIsDir++foreign import ccall safe+    "FSEventStreamEventFlagItemIsFile"+    kFSEventStreamEventFlagItemIsFile :: Word32++-- | Determine whether the event is for a file path.+--+-- Applicable only when 'setFileEvents' is 'On'.+--+-- /macOS 10.7+/+--+-- /Pre-release/+--+isFile :: Event -> Bool+isFile = getFlag kFSEventStreamEventFlagItemIsFile++foreign import ccall safe+    "FSEventStreamEventFlagItemIsSymlink"+    kFSEventStreamEventFlagItemIsSymlink :: Word32++-- | Determine whether the event is for a symbolic link path.+--+-- Applicable only when 'setFileEvents' is 'On'.+--+-- /macOS 10.7+/+--+-- /Pre-release/+--+isSymLink :: Event -> Bool+isSymLink = getFlag kFSEventStreamEventFlagItemIsSymlink++#if HAVE_DECL_KFSEVENTSTREAMEVENTFLAGITEMISHARDLINK+foreign import ccall safe+    "FSEventStreamEventFlagItemIsHardlink"+    kFSEventStreamEventFlagItemIsHardlink :: Word32++-- | Determine whether the event is for a file with more than one hard link.+-- When 'isFile' is true we can check for 'isHardLink'. Note that 'isHardLink'+-- is not true when a hard link is created, however, it is true when a file+-- which has or had more than one link in the past is removed. This is not true+-- if a file never had more than one link.+--+-- Applicable only when 'setFileEvents' is 'On'.+--+-- /macOS 10.10+/+--+-- /Pre-release/+--+isHardLink :: Event -> Bool+isHardLink = getFlag kFSEventStreamEventFlagItemIsHardlink++foreign import ccall safe+    "FSEventStreamEventFlagItemIsLastHardlink"+     kFSEventStreamEventFlagItemIsLastHardlink :: Word32++-- | Determine whether the event is for a hard link path with only one hard+-- link.  If 'isHardLink' is true then we can check for 'isLastHardLink'.  This+-- is true when a file has had more than one link and now the last link is+-- removed. In that case both 'isHardLink' and 'isLastHardLink" would be true.+--+-- Applicable only when 'setFileEvents' is 'On'.+--+-- /macOS 10.10+/+--+-- /Pre-release/+--+isLastHardLink :: Event -> Bool+isLastHardLink = getFlag kFSEventStreamEventFlagItemIsLastHardlink+#endif++-------------------------------------------------------------------------------+-- Debugging+-------------------------------------------------------------------------------++-- | Convert an 'Event' record to a String representation.+showEvent :: Event -> String+showEvent ev@Event{..} =+    let path = runIdentity $ S.toList $ U.decodeUtf8' $ A.toStream eventAbsPath+    in "--------------------------"+        ++ "\nId = " ++ show eventId+        ++ "\nPath = " ++ show path+        ++ "\nFlags " ++ show eventFlags++        ++ showev isMustScanSubdirs "MustScanSubdirs"+        ++ showev isKernelDropped "KernelDropped"+        ++ showev isUserDropped "UserDropped"++        ++ showev isRootChanged "RootChanged"+        ++ showev isMount "Mount"+        ++ showev isUnmount "Unmount"+        ++ showev isHistoryDone "HistoryDone"++        ++ showev isOwnerGroupModeChanged "OwnerGroupModeChanged"+        ++ showev isInodeAttrsChanged "InodeAttrsChanged"+        ++ showev isFinderInfoChanged "FinderInfoChanged"+        ++ showev isXAttrsChanged "XAttrsChanged"++        ++ showev isCreated "Created"+        ++ showev isDeleted "Deleted"+        ++ showev isModified "Modified"+        ++ showev isMoved "Moved"+#if HAVE_DECL_KFSEVENTSTREAMEVENTFLAGITEMCLONED+        ++ showev isCloned "Cloned"+#endif++        ++ showev isDir "Dir"+        ++ showev isFile "File"+        ++ showev isSymLink "SymLink"+#if HAVE_DECL_KFSEVENTSTREAMEVENTFLAGITEMISHARDLINK+        ++ showev isHardLink "HardLink"+        ++ showev isLastHardLink "LastHardLink"+#endif+        ++ "\n"++        where showev f str = if f ev then "\n" ++ str else ""+#else+module Streamly.Internal.FileSystem.Event.Darwin () where+#warning "Autoconf did not find the definition \+kFSEventStreamCreateFlagFileEvents in Darwin header files.\+Do you have Cocoa framework header files installed?\+Not compiling the Streamly.Internal.FileSystem.Event.Darwin module. \+Programs depending on this module may not compile. \+Check if HAVE_DECL_KFSEVENTSTREAMCREATEFLAGFILEEVENTS is defined in config.h \+generated from src/config.h.in"+#endif
+ src/Streamly/Internal/FileSystem/Event/Darwin.m view
@@ -0,0 +1,294 @@+/*+ * Code adapted from the Haskell "hfsevents" package.+ *+ * Copyright (c) 2012, Luite Stegeman+ *+ */++#include <config.h>++#if HAVE_DECL_KFSEVENTSTREAMCREATEFLAGFILEEVENTS++#include <CoreServices/CoreServices.h>+#include <pthread.h>+#include <unistd.h>+#include <FileSystem/Event/Darwin.h>++/*+ * For reference documentaion see:+ * https://developer.apple.com/documentation/coreservices/file_system_events?language=objc+ * https://developer.apple.com/library/archive/documentation/Darwin/Conceptual/FSEvents_ProgGuide/UsingtheFSEventsFramework/UsingtheFSEventsFramework.html+ *+ * An OS thread is started which runs the event loop. A pipe is created+ * and the events are sent to the pipes. The receiver can read the pipe+ * output end to get the events.+ */++/******************************************************************************+ * Create Flags+ *****************************************************************************/++UInt32 FSEventStreamCreateFlagNoDefer () {+  return kFSEventStreamCreateFlagNoDefer;+}+UInt32 FSEventStreamCreateFlagWatchRoot () {+  return kFSEventStreamCreateFlagWatchRoot;+}+UInt32 FSEventStreamCreateFlagFileEvents () {+  return kFSEventStreamCreateFlagFileEvents;+}+UInt32 FSEventStreamCreateFlagIgnoreSelf () {+  return kFSEventStreamCreateFlagIgnoreSelf;+}+#if 0+UInt32 FSEventStreamCreateFlagFullHistory = kFSEventStreamCreateFlagFullHistory;+#endif++/******************************************************************************+ * Event Flags+ *****************************************************************************/++UInt32 FSEventStreamEventFlagEventIdsWrapped () {+  return kFSEventStreamEventFlagEventIdsWrapped;+}+UInt32 FSEventStreamEventFlagMustScanSubDirs () {+  return kFSEventStreamEventFlagMustScanSubDirs;+}+UInt32 FSEventStreamEventFlagKernelDropped () {+  return kFSEventStreamEventFlagKernelDropped;+}+UInt32 FSEventStreamEventFlagUserDropped () {+  return kFSEventStreamEventFlagUserDropped;+}+UInt32 FSEventStreamEventFlagHistoryDone () {+  return kFSEventStreamEventFlagHistoryDone;+}+UInt32 FSEventStreamEventFlagRootChanged () {+  return kFSEventStreamEventFlagRootChanged;+}+UInt32 FSEventStreamEventFlagMount () {+  return kFSEventStreamEventFlagMount;+}+UInt32 FSEventStreamEventFlagUnmount () {+  return kFSEventStreamEventFlagUnmount;+}+UInt32 FSEventStreamEventFlagItemChangeOwner () {+  return kFSEventStreamEventFlagItemChangeOwner;+}+UInt32 FSEventStreamEventFlagItemInodeMetaMod () {+  return kFSEventStreamEventFlagItemInodeMetaMod;+}+UInt32 FSEventStreamEventFlagItemFinderInfoMod () {+  return kFSEventStreamEventFlagItemFinderInfoMod;+}+UInt32 FSEventStreamEventFlagItemXattrMod () {+  return kFSEventStreamEventFlagItemXattrMod;+}+UInt32 FSEventStreamEventFlagItemCreated () {+  return kFSEventStreamEventFlagItemCreated;+}+UInt32 FSEventStreamEventFlagItemRemoved () {+  return kFSEventStreamEventFlagItemRemoved;+}+UInt32 FSEventStreamEventFlagItemRenamed () {+  return kFSEventStreamEventFlagItemRenamed;+}+UInt32 FSEventStreamEventFlagItemModified () {+  return kFSEventStreamEventFlagItemModified;+}+#if __MAC_OS_X_VERSION_MIN_REQUIRED >= 101300+UInt32 FSEventStreamEventFlagItemCloned () {+  return kFSEventStreamEventFlagItemCloned;+}+#endif+UInt32 FSEventStreamEventFlagItemIsDir () {+  return kFSEventStreamEventFlagItemIsDir;+}+UInt32 FSEventStreamEventFlagItemIsFile () {+  return kFSEventStreamEventFlagItemIsFile;+}+UInt32 FSEventStreamEventFlagItemIsSymlink () {+  return kFSEventStreamEventFlagItemIsSymlink;+}+#if __MAC_OS_X_VERSION_MIN_REQUIRED >= 101000+UInt32 FSEventStreamEventFlagItemIsHardlink () {+  return kFSEventStreamEventFlagItemIsHardlink;+}+#endif+UInt32 FSEventStreamEventFlagItemIsLastHardlink () {+  return kFSEventStreamEventFlagItemIsLastHardlink;+}++/******************************************************************************+ * Event watch+ *****************************************************************************/++/* Write an event to the pipe input fd */+static void writeEvent(int fd, UInt64 eventId, UInt64 eventFlags, char* path) +{+    UInt64 buf[3];+    buf[0] = eventId;+    buf[1] = eventFlags;+    /* XXX Is the path string in UTF-8? */+    buf[2] = (UInt64)strlen(path);+    write(fd, buf, 3 * sizeof(UInt64));+    write(fd, path, strlen(path));+}++/* thread state */+struct watch+{+    FSEventStreamRef eventStream;+    CFRunLoopRef runLoop;+    int writefd;+    pthread_mutex_t mut;+};++/* Just writes the event to the pipe input fd */+static void watchCallback+    ( ConstFSEventStreamRef streamRef+    , void *clientCallBackInfo+    , size_t n+    , void *eventPaths+    , const FSEventStreamEventFlags eventFlags[]+    , const FSEventStreamEventId eventIds[]+    )+{+    int i;+    struct watch *w = clientCallBackInfo;+    char **paths = eventPaths;++    for (i = 0; i < n; i++) {+        writeEvent(w->writefd, eventIds[i], eventFlags[i], paths[i]);+    }+}++/******************************************************************************+ * Start a watch event loop+ *****************************************************************************/++/* Event loop run in a pthread */+static void *watchRunLoop(void *vw)+{+    struct watch* w = (struct watch*) vw;+    CFRunLoopRef rl = CFRunLoopGetCurrent();+    CFRetain(rl);+    w->runLoop = rl;+    FSEventStreamScheduleWithRunLoop(w->eventStream, rl, kCFRunLoopDefaultMode);+    FSEventStreamStart(w->eventStream);+    pthread_mutex_unlock(&w->mut);+    CFRunLoopRun();+    pthread_exit(NULL);+}++#define MAX_WATCH_PATHS 4096++int createWatch+    ( struct pathName* folders+    , int n  /* number of entries in folders */+    , UInt32 createFlags+    , UInt64 since+    , double latency+    , int* fd+    , void** wp+    )+{+    if (n > MAX_WATCH_PATHS) {+      return -1;+    }++    int pfds[2];+    if (pipe (pfds)) {+      return -1;+    }++    /*+     * XXX We can possibly use since == 0 to get all events since+     * beginning of time+     */+    if (!since) {+      since = kFSEventStreamEventIdSinceNow;+    }++    /* Setup paths array */+    CFStringRef *cffolders = malloc(n * sizeof(CFStringRef));+    int i;+    for(i = 0; i < n; i++) {+      cffolders[i] = CFStringCreateWithBytes+          ( NULL+          , folders[i].pathBytes+          , folders[i].pathLen+          , kCFStringEncodingUTF8+          , false+          );+    }+    CFArrayRef paths = CFArrayCreate(NULL, (const void **)cffolders, n, NULL);++    /* Setup context */+    struct watch *w = malloc(sizeof(struct watch));+    FSEventStreamContext ctx;+    ctx.version = 0;+    ctx.info = (void*)w;+    ctx.retain = NULL;+    ctx.release = NULL;+    ctx.copyDescription = NULL;++    /* Create watch using paths and context*/+    FSEventStreamRef es = FSEventStreamCreate+        (NULL, &watchCallback, &ctx, paths, since, latency, createFlags);++    /* Run the event loop in a pthread */+    int retval;+    if(es != NULL) {+        /* Success */+        w->writefd = pfds[1];+        w->eventStream = es;+        w->runLoop = NULL;++        /* Lock to prevent race against watch destroy */+        pthread_mutex_init(&w->mut, NULL);+        pthread_mutex_lock(&w->mut);+        pthread_t t;+        pthread_create(&t, NULL, &watchRunLoop, (void*)w);++        /* return the out fd and the watch struct */+        *fd = pfds[0];+        *wp = w;+        retval = 0;+    } else {+        /* Failure */+        close(pfds[0]);+        close(pfds[1]);+        free(w);+        retval = -1;+    }++    /* Cleanup */+    for (i = 0; i < n; i++) {+        CFRelease (cffolders[i]);+    }+    free(cffolders);+    CFRelease(paths);+    return retval;+}++/******************************************************************************+ * Stop a watch event loop+ *****************************************************************************/++void destroyWatch(struct watch* w) {+    /* Stop the loop so the thread will exit */+    pthread_mutex_lock(&w->mut);+    FSEventStreamStop(w->eventStream);+    FSEventStreamInvalidate(w->eventStream);+    CFRunLoopStop(w->runLoop);+    CFRelease(w->runLoop);+    FSEventStreamRelease(w->eventStream);+    close(w->writefd);+    pthread_mutex_unlock(&w->mut);++    /* Cleanup */+    pthread_mutex_destroy(&w->mut);+    free(w);+}+#endif
+ src/Streamly/Internal/FileSystem/Event/Linux.hs view
@@ -0,0 +1,1234 @@+-- |+-- Module      : Streamly.Internal.FileSystem.Event.Linux+-- Copyright   : (c) 2020 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : pre-release+-- Portability : GHC+--+-- =Overview+--+-- Use 'watchPaths' with a list of file system paths you want to watch as+-- argument. It returns a stream of 'Event' representing the file system events+-- occurring under the watched paths.+--+-- @+-- Stream.mapM_ (putStrLn . 'showEvent') $ 'watchPaths' [Array.fromCString\# "dir"#]+-- @+--+-- 'Event' is an opaque type. Accessor functions (e.g. 'showEvent' above)+-- provided in this module are used to determine the attributes of the event.+--+-- Identical successive events may be coalesced into a single event.+--+-- =Design notes+--+-- For reference documentation see:+--+-- * <https://man7.org/linux/man-pages/man7/inotify.7.html inotify man page>+--+-- We try to keep the macOS\/Linux/Windows event handling APIs and defaults+-- semantically and syntactically as close as possible.+--+-- =BUGs+--+-- When testing on Linux Kernel version @5.3.0-53-generic #47-Ubuntu@, the last+-- event for the root path seems to be delayed until one more event occurs.+--+-- = Differences between macOS and Linux APIs:+--+-- 1. macOS watch is based on the path provided to it, if the path is+-- deleted and recreated it will still be watched, if the path moves to another+-- path it won't be watched anymore. Whereas Linux watch is based on a handle+-- to the path, if the path is deleted and recreated it won't be watched, if+-- the path moves to another it can still be watched (though this is+-- configurable).+--+-- 2. macOS watches the directory hierarchy recursively, Linux watches only one+-- level of dir, recursive watch has to be built in user space by watching for+-- create events and adding the new directories to the watch. Not sure how this+-- will scale for too many paths.+--+-- 3. In macOS the path of the subject of the event is absolute, in Linux the+-- path is the name of the object inside the dir being watched.+--+-- 4. On Linux 'watchPaths' fails if a path does not exist, on macOS it does+-- not fail.++#include "config.h"++#if HAVE_DECL_IN_EXCL_UNLINK+module Streamly.Internal.FileSystem.Event.Linux+    (+    -- * Subscribing to events++    -- ** Default configuration+      Config+    , Toggle (..)+    , defaultConfig++    -- ** Watch Behavior+    , setFollowSymLinks+    , setUnwatchMoved+    , setOneShot+    , setOnlyDir+    , WhenExists (..)+    , setWhenExists++    -- ** Events of Interest+    -- *** Root Level Events+    , setRootDeleted+    , setRootMoved++    -- *** Item Level Metadata change+    , setMetadataChanged++    -- *** Item Level Access+    , setAccessed+    , setOpened+    , setWriteClosed+    , setNonWriteClosed++    -- *** Item CRUD events+    , setCreated+    , setDeleted+    , setMovedFrom+    , setMovedTo+    , setModified++    , setAllEvents++    -- ** Watch APIs+    -- XXX watchPaths is redundant now because we can use watchTrees with+    -- setRecursiveMode False. Perhaps we can use a common "watch" API.+    , watchPathsWith+    , watchPaths+    , watchTreesWith+    , watchTrees+    , addToWatch+    , removeFromWatch++    -- * Handling Events+    , Event(..)+    , getRoot+    , getRelPath+    , getAbsPath+    , getCookie++    -- ** Exception Conditions+    , isOverflow++    -- ** Root Level Events+    , isRootUnwatched+    , isRootDeleted+    , isRootMoved+    , isRootUnmounted++    -- ** Item Level Metadata change+    , isMetadataChanged++    -- ** Item Level Access+    , isAccessed+    , isOpened+    , isWriteClosed+    , isNonWriteClosed++    -- ** Item CRUD events+    , isCreated+    , isDeleted+    , isMovedFrom+    , isMovedTo+    , isModified++    -- ** Item Path info+    , isDir++    -- * Debugging+    , showEvent+    )+where++import Control.Monad (void, when)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Bits ((.|.), (.&.), complement)+import Data.Char (ord)+import Data.Foldable (foldlM)+import Data.Functor.Identity (runIdentity)+import Data.IntMap.Lazy (IntMap)+import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)+import Data.List.NonEmpty (NonEmpty)+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup (Semigroup(..))+#endif+import Data.Word (Word8, Word32)+import Foreign.C.Error (throwErrnoIfMinus1)+import Foreign.C.String (CString)+import Foreign.C.Types (CInt(..), CUInt(..))+import Foreign.Ptr (Ptr)+import Foreign.Storable (peek, peekByteOff, sizeOf)+import GHC.IO.Device (IODeviceType(Stream))+import GHC.IO.FD (fdFD, mkFD)+import GHC.IO.Handle.FD (mkHandleFromFD)+import Streamly.Prelude (SerialT)+import Streamly.Internal.Data.Parser (Parser)+import Streamly.Internal.Data.Array.Foreign.Type (Array(..))+import System.IO (Handle, hClose, IOMode(ReadMode))+#if !MIN_VERSION_base(4,10,0)+import Control.Concurrent.MVar (readMVar)+import Data.Typeable (cast)+import GHC.IO.Exception (IOException(..), IOErrorType(..), ioException)+import GHC.IO.FD (FD)+import GHC.IO.Handle.Types (Handle__(..), Handle(FileHandle, DuplexHandle))+#else+import GHC.IO.Handle.FD (handleToFd)+#endif++import qualified Data.IntMap.Lazy as Map+import qualified Data.List.NonEmpty as NonEmpty+import qualified Streamly.Internal.Data.Array.Foreign as A+import qualified Streamly.Internal.Data.Fold as FL+import qualified Streamly.Internal.Data.Parser as PR+import qualified Streamly.Internal.Data.Stream.IsStream as S+import qualified Streamly.Internal.FileSystem.Dir as Dir+import qualified Streamly.Internal.FileSystem.Handle as FH+import qualified Streamly.Internal.Unicode.Stream as U++-------------------------------------------------------------------------------+-- Subscription to events+-------------------------------------------------------------------------------++-- | Watch configuration, used to specify the events of interest and the+-- behavior of the watch.+--+-- /Pre-release/+--+data Config = Config+    { watchRec :: Bool+    , createFlags :: Word32+    }++-------------------------------------------------------------------------------+-- Boolean settings+-------------------------------------------------------------------------------++-- | Whether a setting is 'On' or 'Off'.+--+-- /Pre-release/+--+data Toggle = On | Off++toggle :: Toggle -> Toggle+toggle On = Off+toggle Off = On++setFlag :: Word32 -> Toggle -> Config -> Config+setFlag mask status cfg@Config{..} =+    let flags =+            case status of+                On -> createFlags .|. mask+                Off -> createFlags .&. complement mask+    in cfg {createFlags = flags}++-------------------------------------------------------------------------------+-- Settings+-------------------------------------------------------------------------------++-- | Watch the whole directory tree recursively instead of watching just one+-- level of directory.+--+-- /default: Off/+--+-- /Pre-release/+--+setRecursiveMode :: Bool -> Config -> Config+setRecursiveMode rec cfg@Config{} = cfg {watchRec = rec}++foreign import capi+    "sys/inotify.h value IN_DONT_FOLLOW" iN_DONT_FOLLOW :: Word32++-- | If the pathname to be watched is a symbolic link then watch the target of+-- the symbolic link instead of the symbolic link itself.+--+-- /default: On/+--+-- /Pre-release/+--+setFollowSymLinks :: Toggle -> Config -> Config+setFollowSymLinks s = setFlag iN_DONT_FOLLOW (toggle s)++foreign import capi+    "sys/inotify.h value IN_EXCL_UNLINK" iN_EXCL_UNLINK :: Word32++-- | If an object moves out of the directory being watched then stop watching+-- it.+--+-- /default: On/+--+-- /Pre-release/+--+setUnwatchMoved :: Toggle -> Config -> Config+setUnwatchMoved = setFlag iN_EXCL_UNLINK++#if HAVE_DECL_IN_MASK_CREATE+foreign import capi+    "sys/inotify.h value IN_MASK_CREATE" iN_MASK_CREATE :: Word32+#endif++foreign import capi+    "sys/inotify.h value IN_MASK_ADD" iN_MASK_ADD :: Word32++-- | What to do if a watch already exists when 'openWatch' or 'addToWatch' is+-- called for a path.+--+-- /Pre-release/+--+data WhenExists =+      AddIfExists -- ^ Do not set an existing setting to 'Off' only set to 'On'+    | ReplaceIfExists -- ^ Replace the existing settings with new settings+#if HAVE_DECL_IN_MASK_CREATE+    | FailIfExists -- ^ Fail the API+#endif++-- | When adding a new path to the watch, specify what to do if a watch already+-- exists on that path.+--+-- /default: FailIfExists/+--+-- /Pre-release/+--+setWhenExists :: WhenExists -> Config -> Config+setWhenExists val cfg =+    case val of+        AddIfExists -> setFlag iN_MASK_ADD On cfg+        ReplaceIfExists -> setFlag iN_MASK_ADD Off cfg+#if HAVE_DECL_IN_MASK_CREATE+        FailIfExists -> setFlag iN_MASK_CREATE On cfg+#endif++foreign import capi+    "sys/inotify.h value IN_ONESHOT" iN_ONESHOT :: Word32++-- | Watch the object only for one event and then remove it from the watch.+--+-- /default: Off/+--+-- /Pre-release/+--+setOneShot :: Toggle -> Config -> Config+setOneShot = setFlag iN_ONESHOT++foreign import capi+    "sys/inotify.h value IN_ONLYDIR" iN_ONLYDIR :: Word32++-- | Watch the object only if it is a directory. This provides a race-free way+-- to ensure that the watched object is a directory.+--+-- /default: Off/+--+-- /Pre-release/+--+setOnlyDir :: Toggle -> Config -> Config+setOnlyDir = setFlag iN_ONLYDIR++-------------------------------------------------------------------------------+-- Event types that can occur+-------------------------------------------------------------------------------++foreign import capi+    "sys/inotify.h value IN_DELETE_SELF" iN_DELETE_SELF :: Word32++-- | Report when the watched path itself gets deleted.+--+-- /default: On/+--+-- /Pre-release/+--+setRootDeleted :: Toggle -> Config -> Config+setRootDeleted = setFlag iN_DELETE_SELF++foreign import capi+    "sys/inotify.h value IN_MOVE_SELF" iN_MOVE_SELF :: Word32++-- | Report when the watched root path itself gets renamed.+--+-- /default: On/+--+-- /Pre-release/+--+setRootMoved :: Toggle -> Config -> Config+setRootMoved = setFlag iN_MOVE_SELF++foreign import capi+    "sys/inotify.h value IN_ATTRIB" iN_ATTRIB :: Word32++-- | Report when the metadata e.g. owner, permission modes, modifications times+-- of an object changes.+--+-- /default: On/+--+-- /Pre-release/+--+setMetadataChanged :: Toggle -> Config -> Config+setMetadataChanged = setFlag iN_ATTRIB++foreign import capi+    "sys/inotify.h value IN_ACCESS" iN_ACCESS :: Word32++-- | Report when a file is accessed.+--+-- /default: On/+--+-- /Pre-release/+--+setAccessed :: Toggle -> Config -> Config+setAccessed = setFlag iN_ACCESS++foreign import capi+    "sys/inotify.h value IN_OPEN" iN_OPEN :: Word32++-- | Report when a file is opened.+--+-- /default: On/+--+-- /Pre-release/+--+setOpened :: Toggle -> Config -> Config+setOpened = setFlag iN_OPEN++foreign import capi+    "sys/inotify.h value IN_CLOSE_WRITE" iN_CLOSE_WRITE :: Word32++-- | Report when a file that was opened for writes is closed.+--+-- /default: On/+--+-- /Pre-release/+--+setWriteClosed :: Toggle -> Config -> Config+setWriteClosed = setFlag iN_CLOSE_WRITE++foreign import capi+    "sys/inotify.h value IN_CLOSE_NOWRITE" iN_CLOSE_NOWRITE :: Word32++-- | Report when a file that was opened for not writing is closed.+--+-- /default: On/+--+-- /Pre-release/+--+setNonWriteClosed :: Toggle -> Config -> Config+setNonWriteClosed = setFlag iN_CLOSE_NOWRITE++foreign import capi+    "sys/inotify.h value IN_CREATE" iN_CREATE :: Word32++-- | Report when a file is created.+--+-- /default: On/+--+-- /Pre-release/+--+setCreated :: Toggle -> Config -> Config+setCreated = setFlag iN_CREATE++foreign import capi+    "sys/inotify.h value IN_DELETE" iN_DELETE :: Word32++-- | Report when a file is deleted.+--+-- /default: On/+--+-- /Pre-release/+--+setDeleted :: Toggle -> Config -> Config+setDeleted = setFlag iN_DELETE++foreign import capi+    "sys/inotify.h value IN_MOVED_FROM" iN_MOVED_FROM :: Word32++-- | Report the source of a move.+--+-- /default: On/+--+-- /Pre-release/+--+setMovedFrom :: Toggle -> Config -> Config+setMovedFrom = setFlag iN_MOVED_FROM++foreign import capi+    "sys/inotify.h value IN_MOVED_TO" iN_MOVED_TO :: Word32++-- | Report the target of a move.+--+-- /default: On/+--+-- /Pre-release/+--+setMovedTo :: Toggle -> Config -> Config+setMovedTo = setFlag iN_MOVED_TO++foreign import capi+    "sys/inotify.h value IN_MODIFY" iN_MODIFY :: Word32++-- | Report when a file is modified.+--+-- /default: On/+--+-- /Pre-release/+--+setModified :: Toggle -> Config -> Config+setModified = setFlag iN_MODIFY++-- | Set all events 'On' or 'Off'.+--+-- /default: On/+--+-- /Pre-release/+--+setAllEvents :: Toggle -> Config -> Config+setAllEvents s cfg =+    ( setRootDeleted s+    . setRootMoved s+    . setMetadataChanged s+    . setAccessed s+    . setOpened s+    . setWriteClosed s+    . setNonWriteClosed s+    . setCreated s+    . setDeleted s+    . setMovedFrom s+    . setMovedTo s+    . setModified s+    ) cfg++-------------------------------------------------------------------------------+-- Default config+-------------------------------------------------------------------------------++-- The defaults are set in such a way that the behavior on macOS and Linux is+-- as much compatible as possible.+--+-- | The default is:+--+-- * 'setFollowSymLinks' 'On'+-- * 'setUnwatchMoved' 'On'+-- * 'setOneShot' 'Off'+-- * 'setOnlyDir' 'Off'+-- * 'setWhenExists' 'AddIfExists'+-- * 'setAllEvents' 'On'+--+-- /Pre-release/+--+defaultConfig :: Config+defaultConfig =+      setWhenExists AddIfExists+    $ setAllEvents On+    $ Config+        { watchRec = True+        , createFlags = 0+        }++-------------------------------------------------------------------------------+-- Open an event stream+-------------------------------------------------------------------------------++-- | A handle for a watch.+data Watch =+    Watch+        Handle                  -- File handle for the watch+        (IORef+            (IntMap             -- Key is the watch descriptor+                ( Array Word8   -- Absolute path of the watch root+                , Array Word8   -- Path of subdir relative to watch root+                )+            )+        )++-- Instead of using the watch descriptor we can provide APIs that use the path+-- itself to identify the watch. That will require us to maintain a map from wd+-- to path in the Watch handle.++newtype WD = WD CInt deriving Show++foreign import ccall unsafe+    "sys/inotify.h inotify_init" c_inotify_init :: IO CInt++-- | Create a 'Watch' handle. 'addToWatch' can be used to add paths being+-- monitored by this watch.+--+-- /Pre-release/+--+createWatch :: IO Watch+createWatch = do+    rawfd <- throwErrnoIfMinus1 "createWatch" c_inotify_init+    -- we could use fdToHandle but it cannot determine the fd type+    -- automatically for the inotify fd+    (fd, fdType) <-+        mkFD+            rawfd+            ReadMode+            (Just (Stream, 0, 0))  -- (IODeviceType, CDev, CIno)+            False                  -- not a socket+            False                  -- non-blocking is false+    let fdString = "<createWatch file descriptor: " ++ show fd ++ ">"+    h <-+        mkHandleFromFD+           fd+           fdType+           fdString+           ReadMode+           True    -- use non-blocking IO+           Nothing -- TextEncoding (binary)+    emptyMapRef <- newIORef Map.empty+    return $ Watch h emptyMapRef++foreign import ccall unsafe+    "sys/inotify.h inotify_add_watch" c_inotify_add_watch+        :: CInt -> CString -> CUInt -> IO CInt++-- XXX we really do not know the path encoding, all we know is that it is "/"+-- separated bytes. So these may fail or convert the path in an unexpected+-- manner. We should ultimately remove all usage of these.++toUtf8 :: MonadIO m => String -> m (Array Word8)+toUtf8 = A.fromStream . U.encodeUtf8 . S.fromList++utf8ToString :: Array Word8 -> String+utf8ToString = runIdentity . S.toList . U.decodeUtf8' . A.toStream++#if !MIN_VERSION_base(4,10,0)+-- | Turn an existing Handle into a file descriptor. This function throws an+-- IOError if the Handle does not reference a file descriptor.+handleToFd :: Handle -> IO FD+handleToFd h = case h of+    FileHandle _ mv -> do+      Handle__{haDevice = dev} <- readMVar mv+      case cast dev of+        Just fd -> return fd+        Nothing -> throwErr "not a file descriptor"+    DuplexHandle{} -> throwErr "not a file handle"++    where++    throwErr msg = ioException $ IOError (Just h)+      InappropriateType "handleToFd" msg Nothing Nothing+#endif++-- | Add a trailing "/" at the end of the path if there is none. Do not add a+-- "/" if the path is empty.+--+ensureTrailingSlash :: Array Word8 -> Array Word8+ensureTrailingSlash path =+    if A.length path /= 0+    then+        let mx = A.getIndex path (A.length path - 1)+         in case mx of+            Nothing -> error "ensureTrailingSlash: Bug: Invalid index"+            Just x ->+                if x /= fromIntegral (ord '/')+                then path <> A.fromCString# "/"#+                else path+    else path++-- | @addToWatch cfg watch root subpath@ adds @subpath@ to the list of paths+-- being monitored under @root@ via the watch handle @watch@.  @root@ must be+-- an absolute path and @subpath@ must be relative to @root@.+--+-- /Pre-release/+--+addToWatch :: Config -> Watch -> Array Word8 -> Array Word8 -> IO ()+addToWatch cfg@Config{..} watch@(Watch handle wdMap) root0 path0 = do+    -- XXX do not add if the path is already added+    -- XXX if the watch is added by the scan and not via an event we can+    -- generate a create event assuming that the create may have been lost. We+    -- can also mark in the map that this entry was added by the scan. So if an+    -- actual create event later comes and tries to add this again then we can+    -- ignore that and drop the create event to avoid duplicate create, because+    -- we have already emitted it.+    --+    -- When a directory is added by the scan we should also emit create events+    -- for files that may have got added to the dir. However, such create+    -- events may get duplicated because of a race between the scan generated+    -- versus real events.+    --+    -- Or we may distinguish between scan generated events and real events so+    -- that the application can assume that other events may been lost and+    -- handle it. For example, if it is a dir create the application can read+    -- the dir to scan the files in it.+    --+    let root = ensureTrailingSlash root0+        path = ensureTrailingSlash path0+        absPath = root <> path+    fd <- handleToFd handle++    -- XXX we need to tolerate an error where we are adding a watch for a+    -- non-existing file because the file may have got deleted by the time we+    -- added the watch. Perhaps we can have a flag in config for this and keep+    -- the default value to tolerate the error.+    --+    -- XXX The file may have even got deleted and then recreated which we will+    -- never get to know, document this.+    wd <- A.unsafeAsCString absPath $ \pathPtr ->+            throwErrnoIfMinus1 ("addToWatch: " ++ utf8ToString absPath) $+                c_inotify_add_watch (fdFD fd) pathPtr (CUInt createFlags)++    -- We add the parent first so that we start getting events for any new+    -- creates and add the new subdirectories on creates while we are adding+    -- the children.+    modifyIORef wdMap (Map.insert (fromIntegral wd) (root, path))++    -- Now add the children. If we missed any creates while we were adding the+    -- parent, this will make sure they are added too.+    --+    -- XXX Ensure that we generate events that we may have missed while we were+    -- adding the dirs.+    --+    -- XXX toDirs currently uses paths as String, we need to convert it+    -- to "/" separated by byte arrays.+    when watchRec $ do+        S.mapM_ (\p -> addToWatch cfg watch root (path <> p))+            $ S.mapM toUtf8+            $ Dir.toDirs $ utf8ToString absPath++foreign import ccall unsafe+    "sys/inotify.h inotify_rm_watch" c_inotify_rm_watch+        :: CInt -> CInt -> IO CInt++-- | Remove an absolute root path from a 'Watch', if a path was moved after+-- adding you need to provide the original path which was used to add the+-- Watch.+--+-- /Pre-release/+--+removeFromWatch :: Watch -> Array Word8 -> IO ()+removeFromWatch (Watch handle wdMap) path = do+    fd <- handleToFd handle+    km <- readIORef wdMap+    wdMap1 <- foldlM (step fd) Map.empty (Map.toList km)+    writeIORef wdMap wdMap1++    where++    step fd newMap (wd, v) = do+        if (fst v) == path+        then do+            let err = "removeFromWatch: " ++ show (utf8ToString path)+                rm = c_inotify_rm_watch (fdFD fd) (fromIntegral wd)+            void $ throwErrnoIfMinus1 err rm+            return newMap+        else return $ Map.insert wd v newMap++-- | Given a 'Config' and list of @paths@ ("/" separated byte arrays) start+-- monitoring the paths for file system events. Returns a 'Watch' handle which+-- can then be used to read the event stream or to close the watch.+--+-- /Pre-release/+--+openWatch :: Config -> NonEmpty (Array Word8) -> IO Watch+openWatch cfg paths = do+    w <- createWatch+    mapM_ (\p -> addToWatch cfg w p (A.fromList [])) $ NonEmpty.toList paths+    return w++-- | Close a 'Watch' handle.+--+-- /Pre-release/+--+closeWatch :: Watch -> IO ()+closeWatch (Watch h _) = hClose h++-------------------------------------------------------------------------------+-- Raw events read from the watch file handle+-------------------------------------------------------------------------------++newtype Cookie = Cookie Word32 deriving (Show, Eq)++-- | An Event generated by the file system. Use the accessor functions to+-- examine the event.+--+-- /Pre-release/+--+data Event = Event+   { eventWd :: CInt+   , eventFlags :: Word32+   , eventCookie :: Word32+   , eventRelPath :: Array Word8+   , eventMap :: IntMap (Array Word8, Array Word8)+   } deriving (Show, Ord, Eq)++-- The inotify event struct from the man page/header file:+--+--            struct inotify_event {+--                int      wd;       /* Watch descriptor */+--                uint32_t mask;     /* Mask describing event */+--                uint32_t cookie;   /* Unique cookie associating related+--                                      events (for rename(2)) */+--                uint32_t len;      /* Size of name field */+--                char     name[];   /* Optional null-terminated name */+--            };+--+-- XXX We can perhaps use parseD monad instance for fusing with parseMany? Need+-- to measure the perf.+--+readOneEvent :: Config -> Watch -> Parser IO Word8 Event+readOneEvent cfg  wt@(Watch _ wdMap) = do+    let headerLen = (sizeOf (undefined :: CInt)) + 12+    arr <- PR.takeEQ headerLen (A.writeN headerLen)+    (ewd, eflags, cookie, pathLen) <- PR.fromEffect $ A.unsafeAsPtr arr readHeader+    -- XXX need the "initial" in parsers to return a step type so that "take 0"+    -- can return without an input. otherwise if pathLen is 0 we will keep+    -- waiting to read one more char before we return this event.+    path <-+        if pathLen /= 0+        then do+            -- XXX takeEndBy_ drops the separator so assumes a null+            -- terminated path, we should use a takeWhile nested inside a+            -- takeP+            pth <-+                PR.fromFold+                    $ FL.takeEndBy_ (== 0)+                    $ FL.take pathLen (A.writeN pathLen)+            let remaining = pathLen - A.length pth - 1+            when (remaining /= 0) $ PR.takeEQ remaining FL.drain+            return pth+        else return $ A.fromList []+    wdm <- PR.fromEffect $ readIORef wdMap+    let (root, sub) =+            case Map.lookup (fromIntegral ewd) wdm of+                    Just pair -> pair+                    Nothing ->+                        error $ "readOneEvent: "+                                  <> "Unknown watch descriptor: "+                                  <> show ewd+    let -- "sub" is guaranteed to have a trailing "/"+        sub1 = sub <> path+        -- Check for "ISDIR" first because it is less likely+        isDirCreate = eflags .&. iN_ISDIR /= 0 && eflags .&. iN_CREATE /= 0+    when (watchRec cfg && isDirCreate)+        $ PR.fromEffect $ addToWatch cfg wt root sub1+    -- XXX Handle IN_DELETE, IN_DELETE_SELF, IN_MOVE_SELF, IN_MOVED_FROM,+    -- IN_MOVED_TO+    -- What if a large dir tree gets moved in to our hierarchy? Do we get a+    -- single event for the top level dir in this case?+    return $ Event+        { eventWd = (fromIntegral ewd)+        , eventFlags = eflags+        , eventCookie = cookie+        , eventRelPath = sub1+        , eventMap = wdm+        }++    where++    readHeader (ptr :: Ptr Word8) = do+        let len = sizeOf (undefined :: CInt)+        ewd <- peek ptr+        eflags <- peekByteOff ptr len+        cookie <- peekByteOff ptr (len + 4)+        pathLen :: Word32 <- peekByteOff ptr (len + 8)+        return (ewd, eflags, cookie, fromIntegral pathLen)++watchToStream :: Config -> Watch -> SerialT IO Event+watchToStream cfg wt@(Watch handle _) = do+    -- Do not use too small a buffer. As per inotify man page:+    --+    -- The behavior when the buffer given to read(2) is too small to return+    -- information about the next event depends on the kernel version: in+    -- kernels before 2.6.21, read(2) returns 0; since kernel 2.6.21, read(2)+    -- fails with the error EINVAL.  Specifying a buffer of size+    --+    --          sizeof(struct inotify_event) + NAME_MAX + 1+    --+    -- will be sufficient to read at least one event.+    S.parseMany (readOneEvent cfg wt) $ S.unfold FH.read handle++-- | Start monitoring a list of file system paths for file system events with+-- the supplied configuration operation over the 'defaultConfig'. The+-- paths could be files or directories. When the path is a directory, only the+-- files and directories directly under the watched directory are monitored,+-- contents of subdirectories are not monitored.  Monitoring starts from the+-- current time onwards. The paths are specified as "/" separated 'Array' of+-- 'Word8'.+--+-- @+-- watchPathsWith+--  ('setFollowSymLinks' On . 'setUnwatchMoved' Off)+--  [Array.fromCString\# "dir"#]+-- @+--+-- /Pre-release/+--+watchPathsWith ::+    (Config -> Config) -> NonEmpty (Array Word8) -> SerialT IO Event+watchPathsWith f = watchTreesWith (f . setRecursiveMode False)++-- | Like 'watchPathsWith' but uses the 'defaultConfig' options.+--+-- @+-- watchPaths = watchPathsWith id+-- @+--+-- /Pre-release/+--+watchPaths :: NonEmpty (Array Word8) -> SerialT IO Event+watchPaths = watchPathsWith id++-- XXX We should not go across the mount points of network file systems or file+-- systems that are known to not generate any events.+--+-- | Start monitoring a list of file system paths for file system events with+-- the supplied configuration operation over the 'defaultConfig'. The+-- paths could be files or directories.  When the path is a directory, the+-- whole directory tree under it is watched recursively. Monitoring starts from+-- the current time onwards.+--+-- Note that recrusive watch on a large directory tree could be expensive. When+-- starting a watch, the whole tree must be read and watches are started on+-- each directory in the tree. The initial time to start the watch as well as+-- the memory required is proportional to the number of directories in the+-- tree.+--+-- When new directories are created under the tree they are added to the watch+-- on receiving the directory create event. However, the creation of a dir and+-- adding a watch for it is not atomic.  The implementation takes care of this+-- and makes sure that watches are added for all directories.  However, In the+-- mean time, the directory may have received more events which may get lost.+-- Handling of any such lost events is yet to be implemented.+--+-- See the Linux __inotify__ man page for more details.+--+-- /Pre-release/+--+watchTreesWith ::+    (Config -> Config) -> NonEmpty (Array Word8) -> SerialT IO Event+watchTreesWith f paths = S.bracket before after (watchToStream cfg)++    where++    cfg = f defaultConfig+    before = liftIO $ openWatch cfg paths+    after = liftIO . closeWatch++-- | Like 'watchTreesWith' but uses the 'defaultConfig' options.+--+-- @+-- watchTrees = watchTreesWith id+-- @+--+watchTrees :: NonEmpty (Array Word8) -> SerialT IO Event+watchTrees = watchTreesWith id++-------------------------------------------------------------------------------+-- Examine event stream+-------------------------------------------------------------------------------++-- | Get the watch root corresponding to the 'Event'.+--+-- Note that if a path was moved after adding to the watch, this will give the+-- original path and not the new path after moving.+--+-- TBD: we can possibly update the watch root on a move self event.+--+-- /Pre-release/+--+getRoot :: Event -> Array Word8+getRoot Event{..} =+    if (eventWd >= 1)+    then+        case Map.lookup (fromIntegral eventWd) eventMap of+            Just path -> fst path+            Nothing ->+                error $ "Bug: getRoot: No path found corresponding to the "+                    ++ "watch descriptor " ++ show eventWd+    else A.fromList []++-- XXX should we use a Maybe here?+-- | Get the file system object path for which the event is generated, relative+-- to the watched root. The path is a "/" separated array of bytes.+--+-- /Pre-release/+--+getRelPath :: Event -> Array Word8+getRelPath Event{..} = eventRelPath+++-- | Get the absolute file system object path for which the event is generated.+-- The path is a "/" separated array of bytes.+--+-- /Pre-release/+--+getAbsPath :: Event -> Array Word8+getAbsPath ev = getRoot ev <> getRelPath ev++-- XXX should we use a Maybe?+-- | Cookie is set when a rename occurs. The cookie value can be used to+-- connect the 'isMovedFrom' and 'isMovedTo' events, if both the events belong+-- to the same move operation then they will have the same cookie value.+--+-- /Pre-release/+--+getCookie :: Event -> Cookie+getCookie Event{..} = Cookie eventCookie++-------------------------------------------------------------------------------+-- Event types+-------------------------------------------------------------------------------++getFlag :: Word32 -> Event -> Bool+getFlag mask Event{..} = eventFlags .&. mask /= 0++-------------------------------------------------------------------------------+-- Error events+-------------------------------------------------------------------------------++foreign import capi+    "sys/inotify.h value IN_Q_OVERFLOW" iN_Q_OVERFLOW :: Word32++-- XXX rename to isQOverflowed or hasOverflowed?+--+-- macOS overflow API is more specific, it tells which paths have lost the+-- events due to overflow.+--+-- | Event queue overflowed (WD is invalid for this event) and we may have lost+-- some events..  The user application must scan everything under the watched+-- paths to know the current state.+--+-- /Pre-release/+--+isOverflow :: Event -> Bool+isOverflow = getFlag iN_Q_OVERFLOW++-------------------------------------------------------------------------------+-- Events affecting the watched path only+-------------------------------------------------------------------------------++foreign import capi+    "sys/inotify.h value IN_IGNORED" iN_IGNORED :: Word32++-- Compare with isRootChanged on macOS. isRootChanged includes all these cases.+--+-- | A path was removed from the watch explicitly using 'removeFromWatch' or+-- automatically (file was deleted, or filesystem was unmounted).+--+-- /Occurs only for a watched path/+--+-- /Pre-release/+--+isRootUnwatched :: Event -> Bool+isRootUnwatched = getFlag iN_IGNORED++-- | Watched file/directory was itself deleted.  (This event also occurs if an+-- object is moved to another filesystem, since mv(1) in effect copies the file+-- to the other filesystem and then deletes it from the original filesystem.)+-- In addition, an 'isRootUnwatched' event will subsequently be generated+-- for the watch descriptor.+--+-- /Occurs only for a watched path/+--+-- /Pre-release/+--+isRootDeleted :: Event -> Bool+isRootDeleted = getFlag iN_DELETE_SELF++-- | Watched file/directory was itself moved within the file system.+--+-- /Occurs only for a watched path/+--+-- /Pre-release/+--+isRootMoved :: Event -> Bool+isRootMoved = getFlag iN_MOVE_SELF++foreign import capi+    "sys/inotify.h value IN_UNMOUNT" iN_UNMOUNT :: Word32++-- | Filesystem containing watched object was unmounted.  In addition, an+-- 'isRootUnwatched' event will subsequently be generated for the watch+-- descriptor.+--+-- /Occurs only for a watched path/+--+-- /Pre-release/+--+isRootUnmounted :: Event -> Bool+isRootUnmounted = getFlag iN_UNMOUNT++-------------------------------------------------------------------------------+-- Metadata change Events+-------------------------------------------------------------------------------++-- macOS has multiple APIs for metadata change for different metadata.+--+-- | Determine whether the event indicates inode metadata change for an object+-- contained within the monitored path.+--+-- Metadata change may include, permissions (e.g., chmod(2)), timestamps+-- (e.g., utimensat(2)), extended attributes (setxattr(2)), link count (since+-- Linux 2.6.25; e.g., for the target of link(2) and for unlink(2)), and+-- user/group ID (e.g., chown(2)).+--+-- /Can occur for watched path or a file inside it/+--+-- /Pre-release/+--+isMetadataChanged :: Event -> Bool+isMetadataChanged = getFlag iN_ATTRIB++-------------------------------------------------------------------------------+-- Access+-------------------------------------------------------------------------------++-- | File was accessed (e.g. read, execve).+--+-- /Occurs only for a file inside the watched directory/+--+-- /Pre-release/+--+isAccessed :: Event -> Bool+isAccessed = getFlag iN_ACCESS++-- | File or directory was opened.+--+-- /Occurs only for a file inside the watched directory/+--+-- /Pre-release/+--+isOpened :: Event -> Bool+isOpened = getFlag iN_OPEN++-- | File opened for writing was closed.+--+-- /Occurs only for a file inside the watched directory/+--+-- /Pre-release/+--+isWriteClosed :: Event -> Bool+isWriteClosed = getFlag iN_CLOSE_WRITE++-- XXX what if it was opened for append? Does NOWRITE mean all cases where the+-- mode was not write? A dir open comes in this category?+--+-- | File or directory opened for read but not write was closed.+--+-- /Can occur for watched path or a file inside it/+--+-- /Pre-release/+--+isNonWriteClosed :: Event -> Bool+isNonWriteClosed = getFlag iN_CLOSE_NOWRITE++-------------------------------------------------------------------------------+-- CRUD Events+-------------------------------------------------------------------------------++-- On macOS this is not generated on hard linking but on Linux it is.+--+-- | File/directory created in watched directory (e.g., open(2) O_CREAT,+-- mkdir(2), link(2), symlink(2), bind(2) on a UNIX domain socket).+--+-- /Occurs only for an object inside the watched directory/+--+-- /Pre-release/+--+isCreated :: Event -> Bool+isCreated = getFlag iN_CREATE++-- | File/directory deleted from watched directory.+--+-- /Occurs only for an object inside the watched directory/+--+-- /Pre-release/+--+isDeleted :: Event -> Bool+isDeleted = getFlag iN_DELETE++-- XXX what if an object is moved in from outside or moved out of the monitored+-- dir?+--+-- | Generated for the original path when an object is moved from under a+-- monitored directory.+--+-- /Occurs only for an object inside the watched directory/+--+-- /Pre-release/+--+isMovedFrom :: Event -> Bool+isMovedFrom = getFlag iN_MOVED_FROM++-- | Generated for the new path when an object is moved under a monitored+-- directory.+--+-- /Occurs only for an object inside the watched directory/+--+-- /Pre-release/+--+isMovedTo :: Event -> Bool+isMovedTo = getFlag iN_MOVED_TO++-- | Determine whether the event indicates modification of an object within the+-- monitored path. This event is generated only for files and not directories.+--+-- /Occurs only for an object inside the watched directory/+--+-- /Pre-release/+--+isModified :: Event -> Bool+isModified = getFlag iN_MODIFY++-------------------------------------------------------------------------------+-- Information about path type (applicable only when 'setFileEvents' is 'On')+-------------------------------------------------------------------------------++foreign import capi+    "sys/inotify.h value IN_ISDIR" iN_ISDIR :: Word32++-- | Determine whether the event is for a directory path.+--+-- /Pre-release/+--+isDir :: Event -> Bool+isDir = getFlag iN_ISDIR++-------------------------------------------------------------------------------+-- Debugging+-------------------------------------------------------------------------------++-- | Convert an 'Event' record to a String representation.+showEvent :: Event -> String+showEvent ev@Event{..} =+       "--------------------------"+    ++ "\nWd = " ++ show eventWd+    ++ "\nRoot = " ++ show (utf8ToString $ getRoot ev)+    ++ "\nRelative Path = " ++ show (utf8ToString $ getRelPath ev)+    ++ "\nAbsolute Path = " ++ show (utf8ToString $ getAbsPath ev)+    ++ "\nCookie = " ++ show (getCookie ev)+    ++ "\nFlags " ++ show eventFlags++    ++ showev isOverflow "Overflow"++    ++ showev isRootUnwatched "RootUnwatched"+    ++ showev isRootDeleted "RootDeleted"+    ++ showev isRootMoved "RootMoved"+    ++ showev isRootUnmounted "RootUnmounted"++    ++ showev isMetadataChanged "MetadataChanged"++    ++ showev isAccessed "Accessed"+    ++ showev isOpened "Opened"+    ++ showev isWriteClosed "WriteClosed"+    ++ showev isNonWriteClosed "NonWriteClosed"++    ++ showev isCreated "Created"+    ++ showev isDeleted "Deleted"+    ++ showev isModified "Modified"+    ++ showev isMovedFrom "MovedFrom"+    ++ showev isMovedTo "MovedTo"++    ++ showev isDir "Dir"+    ++ "\n"++        where showev f str = if f ev then "\n" ++ str else ""+#else+#warning "Disabling module Streamly.Internal.FileSystem.Event.Linux. Does not support kernels older than 2.6.36."+module Streamly.Internal.FileSystem.Event.Linux () where+#endif
+ src/Streamly/Internal/FileSystem/Event/Windows.hs view
@@ -0,0 +1,583 @@+-- Some code snippets are adapted from the fsnotify package.+-- http://hackage.haskell.org/package/fsnotify-0.3.0.1/+--+-- |+-- Module      : Streamly.Internal.FileSystem.Event.Windows+-- Copyright   : (c) 2020 Composewell Technologies+--               (c) 2012, Mark Dittmer+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : pre-release+-- Portability : GHC+--+-- =Overview+--+-- Use 'watchTrees'or 'watchPaths' with a list of file system paths you want to+-- watch as argument. It returns a stream of 'Event' representing the file+-- system events occurring under the watched paths.+--+-- @+-- {-\# LANGUAGE MagicHash #-}+-- Stream.mapM_ (putStrLn . 'showEvent') $ 'watchTrees' [Array.fromCString\# "path"#]+-- @+--+-- 'Event' is an opaque type. Accessor functions (e.g. 'showEvent' above)+-- provided in this module are used to determine the attributes of the event.+--+-- =Design notes+--+-- For Windows reference documentation see:+--+-- * <https://docs.microsoft.com/en-us/windows/win32/api/winnt/ns-winnt-file_notify_information file notify information>+-- * <https://docs.microsoft.com/en-us/windows/win32/api/winbase/nf-winbase-readdirectorychangesw read directory changes>+--+-- We try to keep the macOS\/Linux/Windows event handling APIs and defaults+-- semantically and syntactically as close as possible.+--+-- =Availability+--+-- As per the Windows reference docs, the fs event notification API is+-- available in:+--+-- * Minimum supported client: Windows XP [desktop apps | UWP apps]+-- * Minimum supported server: Windows Server 2003 [desktop apps | UWP apps++module Streamly.Internal.FileSystem.Event.Windows+    (+    -- * Subscribing to events++    -- ** Default configuration+      Config+    , Event (..)+    , Toggle (..)+    , setFlag+    , defaultConfig+    , getConfigFlag+    , setAllEvents++    -- ** Watch Behavior+    , setRecursiveMode++    -- ** Events of Interest+    -- *** Root Level Events+    , setModifiedFileName+    , setModifiedDirName+    , setModifiedAttribute+    , setModifiedSize+    , setModifiedLastWrite+    , setModifiedSecurity++    -- ** Watch APIs+    , watchPaths+    , watchPathsWith+    , watchTrees+    , watchTreesWith++    -- * Handling Events+    , getAbsPath+    , getRelPath+    , getRoot++    -- ** Item CRUD events+    , isCreated+    , isDeleted+    , isMovedFrom+    , isMovedTo+    , isModified++    -- ** Exception Conditions+    , isOverflow++    -- * Debugging+    , showEvent+    )+where++import Control.Monad.IO.Class (MonadIO(liftIO))+import Data.Bits ((.|.), (.&.), complement)+import Data.Functor.Identity (runIdentity)+import Data.List.NonEmpty (NonEmpty)+import Data.Word (Word8)+import Foreign.C.String (peekCWStringLen)+import Foreign.Marshal.Alloc (alloca, allocaBytes)+import Foreign.Storable (peekByteOff)+import Foreign.Ptr (Ptr, FunPtr, castPtr, nullPtr, nullFunPtr, plusPtr)+import Streamly.Prelude (SerialT, parallel)+import System.Win32.File+    ( FileNotificationFlag+    , LPOVERLAPPED+    , closeHandle+    , createFile+    , fILE_FLAG_BACKUP_SEMANTICS+    , fILE_LIST_DIRECTORY+    , fILE_NOTIFY_CHANGE_FILE_NAME+    , fILE_NOTIFY_CHANGE_DIR_NAME+    , fILE_NOTIFY_CHANGE_ATTRIBUTES+    , fILE_NOTIFY_CHANGE_SIZE+    , fILE_NOTIFY_CHANGE_LAST_WRITE+    , fILE_NOTIFY_CHANGE_SECURITY+    , fILE_SHARE_READ+    , fILE_SHARE_WRITE+    , oPEN_EXISTING+    )+import System.Win32.Types (BOOL, DWORD, HANDLE, LPVOID, LPDWORD, failIfFalse_)+import qualified Data.List.NonEmpty as NonEmpty+import qualified Streamly.Internal.Data.Stream.IsStream as S+import qualified Streamly.Internal.Unicode.Stream as U+import qualified Streamly.Internal.Data.Array.Foreign as A+import Streamly.Internal.Data.Array.Foreign (Array)++-- | Watch configuration, used to specify the events of interest and the+-- behavior of the watch.+--+-- /Pre-release/+--+data Config = Config+    { watchRec :: BOOL+    , createFlags :: DWORD+    }++-------------------------------------------------------------------------------+-- Boolean settings+-------------------------------------------------------------------------------++-- | Whether a setting is 'On' or 'Off'.+--+-- /Pre-release/+--+data Toggle = On | Off++setFlag :: DWORD -> Toggle -> Config -> Config+setFlag mask status cfg@Config{..} =+    let flags =+            case status of+                On -> createFlags .|. mask+                Off -> createFlags .&. complement mask+    in cfg {createFlags = flags}++-- | Set watch event on directory recursively.+--+-- /default: On/+--+-- /Pre-release/+--+setRecursiveMode :: BOOL -> Config -> Config+setRecursiveMode rec cfg@Config{} = cfg {watchRec = rec}++-- | Report when a file name is modified.+--+-- /default: On/+--+-- /Pre-release/+--+setModifiedFileName :: Toggle -> Config -> Config+setModifiedFileName = setFlag fILE_NOTIFY_CHANGE_FILE_NAME++-- | Report when a directory name is modified.+--+-- /default: On/+--+-- /Pre-release/+--+setModifiedDirName :: Toggle -> Config -> Config+setModifiedDirName = setFlag fILE_NOTIFY_CHANGE_DIR_NAME++-- | Report when a file attribute is modified.+--+-- /default: On/+--+-- /Pre-release/+--+setModifiedAttribute :: Toggle -> Config -> Config+setModifiedAttribute = setFlag fILE_NOTIFY_CHANGE_ATTRIBUTES++-- | Report when a file size is changed.+--+-- /default: On/+--+-- /Pre-release/+--+setModifiedSize :: Toggle -> Config -> Config+setModifiedSize = setFlag fILE_NOTIFY_CHANGE_SIZE++-- | Report when a file last write time is changed.+--+-- /default: On/+--+-- /Pre-release/+--+setModifiedLastWrite :: Toggle -> Config -> Config+setModifiedLastWrite = setFlag fILE_NOTIFY_CHANGE_LAST_WRITE++-- | Report when a file Security attributes is changed.+--+-- /default: On/+--+-- /Pre-release/+--+setModifiedSecurity :: Toggle -> Config -> Config+setModifiedSecurity = setFlag fILE_NOTIFY_CHANGE_SECURITY++-- | Set all events 'On' or 'Off'.+--+-- /default: On/+--+-- /Pre-release/+--+setAllEvents :: Toggle -> Config -> Config+setAllEvents s =+     setModifiedFileName s+    . setModifiedDirName s+    . setModifiedAttribute s+    . setModifiedSize s+    . setModifiedLastWrite s+    . setModifiedSecurity s++defaultConfig :: Config+defaultConfig = setAllEvents On $ Config {watchRec = True, createFlags = 0}++getConfigFlag :: Config -> DWORD+getConfigFlag Config{..} = createFlags++getConfigRecMode :: Config -> BOOL+getConfigRecMode Config{..} = watchRec++data Event = Event+    { eventFlags :: DWORD+    , eventRelPath :: String+    , eventRootPath :: String+    , totalBytes :: DWORD+    } deriving (Show, Ord, Eq)++-- For reference documentation see:+--+-- See https://docs.microsoft.com/en-us/windows/win32/api/winnt/ns-winnt-file_notify_information+data FILE_NOTIFY_INFORMATION = FILE_NOTIFY_INFORMATION+    { fniNextEntryOffset :: DWORD+    , fniAction :: DWORD+    , fniFileName :: String+    } deriving Show++type LPOVERLAPPED_COMPLETION_ROUTINE =+    FunPtr ((DWORD, DWORD, LPOVERLAPPED) -> IO ())++-- | A handle for a watch.+getWatchHandle :: FilePath -> IO (HANDLE, FilePath)+getWatchHandle dir = do+    h <- createFile dir+        -- Access mode+        fILE_LIST_DIRECTORY+        -- Share mode+        (fILE_SHARE_READ .|. fILE_SHARE_WRITE)+        -- Security attributes+        Nothing+        -- Create mode, we want to look at an existing directory+        oPEN_EXISTING+        -- File attribute, NOT using OVERLAPPED since we work synchronously+        fILE_FLAG_BACKUP_SEMANTICS+        -- No template file+        Nothing+    return (h, dir)++-- For reference documentation see:+--+-- See https://docs.microsoft.com/en-us/windows/win32/api/winbase/nf-winbase-readdirectorychangesw+-- Note that this API uses UTF-16 for file system paths:+-- 1. https://docs.microsoft.com/en-us/windows/win32/intl/unicode-in-the-windows-api+-- 2. https://docs.microsoft.com/en-us/windows/win32/intl/unicode+foreign import ccall safe+    "windows.h ReadDirectoryChangesW" c_ReadDirectoryChangesW ::+           HANDLE+        -> LPVOID+        -> DWORD+        -> BOOL+        -> DWORD+        -> LPDWORD+        -> LPOVERLAPPED+        -> LPOVERLAPPED_COMPLETION_ROUTINE+        -> IO BOOL++readDirectoryChangesW ::+       HANDLE+    -> Ptr FILE_NOTIFY_INFORMATION+    -> DWORD+    -> BOOL+    -> FileNotificationFlag+    -> LPDWORD+    -> IO ()+readDirectoryChangesW h buf bufSize wst f br =+    let res = c_ReadDirectoryChangesW+                    h (castPtr buf) bufSize wst f br nullPtr nullFunPtr+     in failIfFalse_ "ReadDirectoryChangesW" res++peekFNI :: Ptr FILE_NOTIFY_INFORMATION -> IO FILE_NOTIFY_INFORMATION+peekFNI buf = do+    neof <- peekByteOff buf 0+    acti <- peekByteOff buf 4+    fnle <- peekByteOff buf 8+    -- Note: The path is UTF-16 encoded C WChars, peekCWStringLen converts+    -- UTF-16 to UTF-32 Char String+    fnam <- peekCWStringLen+        -- start of array+        (buf `plusPtr` 12,+        -- fnle is the length in *bytes*, and a WCHAR is 2 bytes+        fromEnum (fnle :: DWORD) `div` 2)+    return $ FILE_NOTIFY_INFORMATION neof acti fnam++readChangeEvents ::+    Ptr FILE_NOTIFY_INFORMATION -> String -> DWORD -> IO [Event]+readChangeEvents pfni root bytesRet = do+    fni <- peekFNI pfni+    let entry = Event+            { eventFlags = fniAction fni+            , eventRelPath = fniFileName fni+            , eventRootPath = root+            , totalBytes = bytesRet+            }+        nioff = fromEnum $ fniNextEntryOffset fni+    entries <-+        if nioff == 0+        then return []+        else readChangeEvents (pfni `plusPtr` nioff) root bytesRet+    return $ entry : entries++readDirectoryChanges ::+    String -> HANDLE -> Bool -> FileNotificationFlag -> IO [Event]+readDirectoryChanges root h wst mask = do+    let maxBuf = 63 * 1024+    allocaBytes maxBuf $ \buffer -> do+        alloca $ \bret -> do+            readDirectoryChangesW h buffer (toEnum maxBuf) wst mask bret+            bytesRet <- peekByteOff bret 0+            readChangeEvents buffer root bytesRet++type FileAction = DWORD++fILE_ACTION_ADDED             :: FileAction+fILE_ACTION_ADDED             =  1++fILE_ACTION_REMOVED           :: FileAction+fILE_ACTION_REMOVED           =  2++fILE_ACTION_MODIFIED          :: FileAction+fILE_ACTION_MODIFIED          =  3++fILE_ACTION_RENAMED_OLD_NAME  :: FileAction+fILE_ACTION_RENAMED_OLD_NAME  =  4++fILE_ACTION_RENAMED_NEW_NAME  :: FileAction+fILE_ACTION_RENAMED_NEW_NAME  =  5++eventStreamAggr :: (HANDLE, FilePath, Config) -> SerialT IO Event+eventStreamAggr (handle, rootPath, cfg) =  do+    let recMode = getConfigRecMode cfg+        flagMasks = getConfigFlag cfg+    S.concatMap S.fromList $ S.repeatM+        $ readDirectoryChanges rootPath handle recMode flagMasks++pathsToHandles ::+    NonEmpty FilePath -> Config -> SerialT IO (HANDLE, FilePath, Config)+pathsToHandles paths cfg = do+    let pathStream = S.fromList (NonEmpty.toList paths)+        st2 = S.mapM getWatchHandle pathStream+    S.map (\(h, f) -> (h, f, cfg)) st2++-------------------------------------------------------------------------------+-- Utilities+-------------------------------------------------------------------------------++utf8ToString :: Array Word8 -> FilePath+utf8ToString = runIdentity . S.toList . U.decodeUtf8 . A.toStream++utf8ToStringList :: NonEmpty (Array Word8) -> NonEmpty FilePath+utf8ToStringList = NonEmpty.map utf8ToString++-- | Close a Directory handle.+--+-- /Pre-release/+--+closePathHandleStream :: SerialT IO (HANDLE, FilePath, Config) -> IO ()+closePathHandleStream = S.mapM_ (\(h, _, _) -> closeHandle h)++-- | Start monitoring a list of file system paths for file system events with+-- the supplied configuration operation over the 'defaultConfig'. The+-- paths could be files or directories. When the path is a directory, only the+-- files and directories directly under the watched directory are monitored,+-- contents of subdirectories are not monitored.  Monitoring starts from the+-- current time onwards.+--+-- /Pre-release/+--+watchPathsWith ::+       (Config -> Config)+    -> NonEmpty (Array Word8)+    -> SerialT IO Event+watchPathsWith f = watchTreesWith (f . setRecursiveMode False)++-- | Like 'watchPathsWith' but uses the 'defaultConfig' options.+--+-- @+-- watchPaths = watchPathsWith id+-- @+--+-- /Pre-release/+--+watchPaths :: NonEmpty (Array Word8) -> SerialT IO Event+watchPaths = watchPathsWith id++-- XXX+-- Document the path treatment for Linux/Windows/macOS modules.+-- Remove the utf-8 encoding requirement of paths? It can be encoding agnostic+-- "\" separated bytes, the application can decide what encoding to use.+-- Instead of always using widechar (-W) APIs can we call the underlying APIs+-- based on the configured code page?+-- https://docs.microsoft.com/en-us/windows/uwp/design/globalizing/use-utf8-code-page+--+-- | Start monitoring a list of file system paths for file system events with+-- the supplied configuration operation over the 'defaultConfig'. The+-- paths could be files or directories.  When the path is a directory, the+-- whole directory tree under it is watched recursively. Monitoring starts from+-- the current time onwards.+--+-- /Pre-release/+--+watchTreesWith ::+       (Config -> Config)+    -> NonEmpty (Array Word8)+    -> SerialT IO Event+watchTreesWith f paths =+     S.bracket before after (S.concatMapWith parallel eventStreamAggr)++    where++    before =+        let cfg = f $ setRecursiveMode True defaultConfig+         in return $ pathsToHandles (utf8ToStringList paths) cfg+    after = liftIO . closePathHandleStream++-- | Like 'watchTreesWith' but uses the 'defaultConfig' options.+--+-- @+-- watchTrees = watchTreesWith id+-- @+--+watchTrees :: NonEmpty (Array Word8) -> SerialT IO Event+watchTrees = watchTreesWith id++-- | Add a trailing "\" at the end of the path if there is none. Do not add a+-- "\" if the path is empty.+--+ensureTrailingSlash :: String -> String+ensureTrailingSlash path =+    if null path+    then path+    else+        let x = last path+        in if x /= '\\' && x /= '/'+            then path ++ "\\"+            else path++getFlag :: DWORD -> Event -> Bool+getFlag mask Event{..} = eventFlags == mask++-- XXX Change the type to Array Word8 to make it compatible with other APIs.+--+-- | Get the file system object path for which the event is generated, relative+-- to the watched root. The path is a UTF-8 encoded array of bytes.+--+-- /Pre-release/+--+getRelPath :: Event -> String+getRelPath Event{..} = eventRelPath++-- XXX Change the type to Array Word8 to make it compatible with other APIs.+--+-- | Get the watch root directory to which this event belongs.+--+-- /Pre-release/+--+getRoot :: Event -> String+getRoot Event{..} = ensureTrailingSlash eventRootPath++-- XXX Change the type to Array Word8 to make it compatible with other APIs.+--+-- | Get the absolute file system object path for which the event is generated.+-- The path is a UTF-8 encoded array of bytes.+--+-- /Pre-release/+--+getAbsPath :: Event -> String+getAbsPath ev = getRoot ev <> getRelPath ev++-- XXX need to document the exact semantics of these.+--+-- | File/directory created in watched directory.+--+-- /Pre-release/+--+isCreated :: Event -> Bool+isCreated = getFlag fILE_ACTION_ADDED++-- | File/directory deleted from watched directory.+--+-- /Pre-release/+--+isDeleted :: Event -> Bool+isDeleted = getFlag fILE_ACTION_REMOVED++-- | Generated for the original path when an object is moved from under a+-- monitored directory.+--+-- /Pre-release/+--+isMovedFrom :: Event -> Bool+isMovedFrom = getFlag fILE_ACTION_RENAMED_OLD_NAME++-- | Generated for the new path when an object is moved under a monitored+-- directory.+--+-- /Pre-release/+--+isMovedTo :: Event -> Bool+isMovedTo = getFlag fILE_ACTION_RENAMED_NEW_NAME++-- XXX This event is generated only for files and not directories?+--+-- | Determine whether the event indicates modification of an object within the+-- monitored path.+--+-- /Pre-release/+--+isModified :: Event -> Bool+isModified = getFlag fILE_ACTION_MODIFIED++-- |  If the buffer overflows, entire contents of the buffer are discarded,+-- therefore, events are lost.  The user application must scan everything under+-- the watched paths to know the current state.+--+-- /Pre-release/+--+isOverflow :: Event -> Bool+isOverflow Event{..} = totalBytes == 0++-------------------------------------------------------------------------------+-- Debugging+-------------------------------------------------------------------------------++-- | Convert an 'Event' record to a String representation.+showEvent :: Event -> String+showEvent ev@Event{..} =+        "--------------------------"+    ++ "\nRoot = " ++ show (getRoot ev)+    ++ "\nRelative Path = " ++ show (getRelPath ev)+    ++ "\nAbsolute Path = " ++ show (getAbsPath ev)+    ++ "\nFlags " ++ show eventFlags+    ++ showev isOverflow "Overflow"+    ++ showev isCreated "Created"+    ++ showev isDeleted "Deleted"+    ++ showev isModified "Modified"+    ++ showev isMovedFrom "MovedFrom"+    ++ showev isMovedTo "MovedTo"+    ++ "\n"++    where showev f str = if f ev then "\n" ++ str else ""
+ src/Streamly/Internal/FileSystem/FD.hs view
@@ -0,0 +1,574 @@+#include "inline.hs"++-- |+-- Module      : Streamly.Internal.FileSystem.FD+-- Copyright   : (c) 2019 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- This module is a an experimental replacement for+-- "Streamly.FileSystem.Handle". The former module provides IO facilities based+-- on the GHC Handle type. The APIs in this module avoid the GHC handle layer+-- and provide more explicit control over buffering.+--+-- Read and write data as streams and arrays to and from files.+--+-- This module provides read and write APIs based on handles. Before reading or+-- writing, a file must be opened first using 'openFile'. The 'Handle' returned+-- by 'openFile' is then used to access the file. A 'Handle' is backed by an+-- operating system file descriptor. When the 'Handle' is garbage collected the+-- underlying file descriptor is automatically closed. A handle can be+-- explicitly closed using 'closeFile'.+--+-- Reading and writing APIs are divided into two categories, sequential+-- streaming APIs and random or seekable access APIs.  File IO APIs are quite+-- similar to "Streamly.Data.Array.Foreign" read write APIs. In that regard, arrays can+-- be considered as in-memory files or files can be considered as on-disk+-- arrays.+--+-- > import qualified Streamly.Internal.FileSystem.FD as FD+--++module Streamly.Internal.FileSystem.FD+    (+    -- * File Handles+      Handle+    , stdin+    , stdout+    , stderr+    , openFile++    -- TODO file path based APIs+    -- , readFile+    -- , writeFile++    -- * Streaming IO+    -- | Streaming APIs read or write data to or from a file or device+    -- sequentially, they never perform a seek to a random location.  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+    -- 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.++    -- ** Read File to Stream+    , read+    -- , readUtf8+    -- , readLines+    -- , readFrames+    , readInChunksOf++    -- -- * Array Read+    -- , readArrayUpto+    -- , readArrayOf++    , readArrays+    , readArraysOfUpto+    -- , readArraysOf++    -- ** Write File from Stream+    , write+    -- , writeUtf8+    -- , writeUtf8Lines+    -- , writeFrames+    , writeInChunksOf++    -- -- * Array Write+    -- , writeArray+    , writeArrays+    , writeArraysPackedUpto++    -- XXX these are incomplete+    -- , writev+    -- , writevArraysPackedUpto++    -- -- * 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.+    --+    -- , readIndex+    -- , readSlice+    -- , readSliceRev+    -- , readAt -- read from a given position to th end of file+    -- , readSliceArrayUpto+    -- , readSliceArrayOf++    -- , writeIndex+    -- , writeSlice+    -- , writeSliceRev+    -- , writeAt -- start writing at the given position+    -- , writeSliceArray+    )+where++import Control.Monad.IO.Class (MonadIO(..))+import Data.Word (Word8)+import Foreign.ForeignPtr (withForeignPtr)+-- import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)+import Foreign.Ptr (plusPtr, castPtr)+import Foreign.Storable (Storable(..))+import GHC.ForeignPtr (mallocPlainForeignPtrBytes)+-- import System.IO (Handle, hGetBufSome, hPutBuf)+import System.IO (IOMode)+import Prelude hiding (read)++import qualified GHC.IO.FD as FD+import qualified GHC.IO.Device as RawIO++import Streamly.Internal.Data.Array.Foreign.Type (Array(..), byteLength, defaultChunkSize, unsafeFreeze)+import Streamly.Internal.Data.Array.Foreign.Mut.Type (mutableArray)++import Streamly.Internal.Data.Stream.Serial (SerialT)+import Streamly.Internal.Data.Stream.StreamK.Type (IsStream, mkStream)++#if !defined(mingw32_HOST_OS)+import Streamly.Internal.Data.Array.Stream.Foreign (groupIOVecsOf)+import Streamly.Internal.Data.Stream.StreamD (toStreamD)+import Streamly.Internal.Data.Stream.StreamD.Type (fromStreamD)+import qualified Streamly.Internal.FileSystem.FDIO as RawIO hiding (write)+#endif+-- import Streamly.Data.Fold (Fold)+-- import Streamly.String (encodeUtf8, decodeUtf8, foldLines)++import qualified Streamly.Data.Array.Foreign as A+import qualified Streamly.Internal.Data.Array.Stream.Foreign as AS+import qualified Streamly.Prelude as S+import qualified Streamly.Internal.Data.Stream.StreamD.Type as D++-------------------------------------------------------------------------------+-- 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.++-------------------------------------------------------------------------------+-- Handles+-------------------------------------------------------------------------------++-- XXX attach a finalizer+-- | A 'Handle' is returned by 'openFile' and is subsequently used to perform+-- read and write operations on a file.+--+newtype Handle = Handle FD.FD++-- | File handle for standard input+stdin :: Handle+stdin = Handle FD.stdin++-- | File handle for standard output+stdout :: Handle+stdout = Handle FD.stdout++-- | File handle for standard error+stderr :: Handle+stderr = Handle FD.stderr++-- XXX we can support all the flags that the "open" system call supports.+-- Instead of using RTS locking mechanism can we use system provided locking+-- instead?+--+-- | Open a file that is not a directory and return a file handle.+-- 'openFile' enforces a multiple-reader single-writer locking on files. That+-- is, there may either be many handles on the same file which manage input, or+-- just one handle on the file which manages output. If any open handle is+-- managing a file for output, no new handle can be allocated for that file. If+-- any open handle is managing a file for input, new handles can only be+-- allocated if they do not manage output. Whether two files are the same is+-- implementation-dependent, but they should normally be the same if they have+-- the same absolute path name and neither has been renamed, for example.+--+openFile :: FilePath -> IOMode -> IO Handle+openFile path mode = Handle . fst <$> FD.openFile path mode True++-------------------------------------------------------------------------------+-- Array IO (Input)+-------------------------------------------------------------------------------++-- | Read a 'ByteArray' from a file handle. If no data is available on the+-- handle it blocks until some data becomes available. If data is available+-- then it immediately returns that data without blocking. It reads a maximum+-- of up to the size requested.+{-# INLINABLE readArrayUpto #-}+readArrayUpto :: Int -> Handle -> IO (Array Word8)+readArrayUpto size (Handle fd) = do+    ptr <- mallocPlainForeignPtrBytes size+    -- ptr <- mallocPlainForeignPtrAlignedBytes size (alignment (undefined :: Word8))+    withForeignPtr ptr $ \p -> do+        -- n <- hGetBufSome h p size+#if MIN_VERSION_base(4,15,0)+        n <- RawIO.read fd p 0 size+#else+        n <- RawIO.read fd p size+#endif+        -- XXX shrink only if the diff is significant+        -- Use unsafeFreezeWithShrink+        return $+            unsafeFreeze $ mutableArray ptr (p `plusPtr` n) (p `plusPtr` size)++-------------------------------------------------------------------------------+-- 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 (Handle fd) arr = withForeignPtr (aStart arr) $ \p ->+    -- RawIO.writeAll fd (castPtr p) aLen+#if MIN_VERSION_base(4,15,0)+    RawIO.write fd (castPtr p) 0 aLen+#else+    RawIO.write fd (castPtr p) aLen+#endif+    {-+    -- Experiment to compare "writev" based IO with "write" based IO.+    iov <- A.newArray 1+    let iov' = iov {aEnd = aBound iov}+    A.writeIndex iov' 0 (RawIO.IOVec (castPtr p) (fromIntegral aLen))+    RawIO.writevAll fd (unsafeForeignPtrToPtr (aStart iov')) 1+    -}+    where+    aLen = byteLength arr++#if !defined(mingw32_HOST_OS)+-- | Write an array of 'IOVec' to a file handle.+--+-- @since 0.7.0+{-# INLINABLE writeIOVec #-}+writeIOVec :: Handle -> Array RawIO.IOVec -> IO ()+writeIOVec _ iov | A.length iov == 0 = return ()+writeIOVec (Handle fd) iov =+    withForeignPtr (aStart iov) $ \p ->+        RawIO.writevAll fd p (A.length iov)+#endif++-------------------------------------------------------------------------------+-- Stream of Arrays IO+-------------------------------------------------------------------------------++-- | @readArraysOfUpto 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@.+{-# INLINABLE _readArraysOfUpto #-}+_readArraysOfUpto :: (IsStream t, MonadIO m)+    => Int -> Handle -> t m (Array Word8)+_readArraysOfUpto 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++{-# INLINE_NORMAL readArraysOfUpto #-}+readArraysOfUpto :: (IsStream t, MonadIO m)+    => Int -> Handle -> t m (Array Word8)+readArraysOfUpto 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 ()++-- XXX read 'Array a' instead of Word8+--+-- | @readArrays h@ reads a stream of arrays from file handle @h@.+-- The maximum size of a single array is limited to @defaultChunkSize@.+-- 'readArrays' ignores the prevailing 'TextEncoding' and 'NewlineMode'+-- on the 'Handle'.+--+-- > readArrays = readArraysOfUpto defaultChunkSize+--+-- @since 0.7.0+{-# INLINE readArrays #-}+readArrays :: (IsStream t, MonadIO m) => Handle -> t m (Array Word8)+readArrays = readArraysOfUpto defaultChunkSize++-------------------------------------------------------------------------------+-- Read File to Stream+-------------------------------------------------------------------------------++-- TODO for concurrent streams implement readahead IO. We can send multiple+-- read requests at the same time. For serial case we can use async IO. We can+-- also control the read throughput in mbps or IOPS.++-- | @readInChunksOf chunkSize handle@ reads a byte stream from a file handle,+-- reads are performed in chunks of up to @chunkSize@.  The stream ends as soon+-- as EOF is encountered.+--+{-# INLINE readInChunksOf #-}+readInChunksOf :: (IsStream t, MonadIO m) => Int -> Handle -> t m Word8+readInChunksOf chunkSize h = AS.concat $ readArraysOfUpto chunkSize h++-- TODO+-- read :: (IsStream t, MonadIO m, Storable a) => Handle -> t m a+--+-- > read = 'readByChunks' A.defaultChunkSize+-- | Generate a stream of elements of the given type from a file 'Handle'. The+-- stream ends when EOF is encountered.+--+-- @since 0.7.0+{-# INLINE read #-}+read :: (IsStream t, MonadIO m) => Handle -> t m Word8+read = AS.concat . readArrays++-------------------------------------------------------------------------------+-- Writing+-------------------------------------------------------------------------------++-- | Write a stream of arrays to a handle.+--+-- @since 0.7.0+{-# INLINE writeArrays #-}+writeArrays :: (MonadIO m, Storable a) => Handle -> SerialT m (Array a) -> m ()+writeArrays h = S.mapM_ (liftIO . writeArray h)++-- | Write a stream of arrays to a handle after coalescing them in chunks of+-- specified size. The chunk size is only a maximum and the actual writes could+-- be smaller than that as we do not split the arrays to fit them to the+-- specified size.+--+-- @since 0.7.0+{-# INLINE writeArraysPackedUpto #-}+writeArraysPackedUpto :: (MonadIO m, Storable a)+    => Int -> Handle -> SerialT m (Array a) -> m ()+writeArraysPackedUpto n h xs = writeArrays h $ AS.compact n xs++#if !defined(mingw32_HOST_OS)+-- XXX this is incomplete+-- | Write a stream of 'IOVec' arrays to a handle.+--+-- @since 0.7.0+{-# INLINE writev #-}+writev :: MonadIO m => Handle -> SerialT m (Array RawIO.IOVec) -> m ()+writev h = S.mapM_ (liftIO . writeIOVec h)++-- XXX this is incomplete+-- | Write a stream of arrays to a handle after grouping them in 'IOVec' arrays+-- of up to a maximum total size. Writes are performed using gather IO via+-- @writev@ system call. The maximum number of entries in each 'IOVec' group+-- limited to 512.+--+-- @since 0.7.0+{-# INLINE _writevArraysPackedUpto #-}+_writevArraysPackedUpto :: MonadIO m+    => Int -> Handle -> SerialT m (Array a) -> m ()+_writevArraysPackedUpto n h xs =+    writev h $ fromStreamD $ groupIOVecsOf n 512 (toStreamD xs)+#endif++-- 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.+--+-- @since 0.7.0+{-# INLINE writeInChunksOf #-}+writeInChunksOf :: MonadIO m => Int -> Handle -> SerialT m Word8 -> m ()+writeInChunksOf n h m = writeArrays h $ AS.arraysOf n m++-- > write = 'writeInChunksOf' A.defaultChunkSize+--+-- | Write a byte stream to a file handle. Combines the bytes in chunks of size+-- up to 'A.defaultChunkSize' before writing.  Note that the write behavior+-- depends on the 'IOMode' and the current seek position of the handle.+--+-- @since 0.7.0+{-# INLINE write #-}+write :: MonadIO m => Handle -> SerialT m Word8 -> m ()+write = writeInChunksOf defaultChunkSize++{-+{-# INLINE write #-}+write :: (MonadIO m, Storable a) => Handle -> SerialT m a -> m ()+write = toHandleWith A.defaultChunkSize+-}++-------------------------------------------------------------------------------+-- 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 :: (IsStream t, MonadIO m) => Handle -> t 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 -> SerialT 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 :: (IsStream t, MonadIO m) => Handle -> t 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 :: (IsStream t, MonadIO m) => Handle -> Fold m Char b -> t 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 :: (IsStream t, MonadIO m, Storable a)+    => Array a -> Handle -> Fold m a b -> t 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 :: (IsStream t, MonadIO m, Storable a)+    => Array a -> Handle -> t 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 :: (IsStream t, MonadIO m, Storable a)+    => Int -> Handle -> Int -> Int -> t 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 :: (IsStream t, MonadIO m, Storable a)+    => Handle -> Int -> Int -> t 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 :: (IsStream t, MonadIO m, Storable a)+    => Handle -> Int -> Int -> t 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 :: (IsStream t, Monad m, Storable a)+    => Handle -> Int -> Int -> t 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 :: (IsStream t, Monad m, Storable a)+    => Handle -> Int -> Int -> t m a -> m ()+writeSliceRev arr i len s = undefined+-}
+ src/Streamly/Internal/FileSystem/FDIO.hs view
@@ -0,0 +1,225 @@+#include "inline.hs"++-- |+-- Module      : Streamly.Internal.FileSystem.FDIO+-- Copyright   : (c) 2019 Composewell Technologies+-- Copyright   : (c) 1994-2008 The University of Glasgow+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- Low level IO routines interfacing the operating system.+--++module Streamly.Internal.FileSystem.FDIO+    ( write+    , writeAll+    , IOVec (..)+    , writev+    , writevAll+    )+where++import Control.Monad (when)+#if !defined(mingw32_HOST_OS)+import Control.Concurrent (threadWaitWrite)+import Data.Int (Int64)+import Foreign.C.Error (throwErrnoIfMinus1RetryMayBlock)+#if __GLASGOW_HASKELL__ >= 802+import Foreign.C.Types (CBool(..))+#endif+import System.Posix.Internals (c_write, c_safe_write)+import Streamly.Internal.FileSystem.IOVec (c_writev, c_safe_writev)+#endif++import Foreign.C.Types (CSize(..), CInt(..))+import Data.Word (Word8)+import Foreign.Ptr (plusPtr, Ptr)++import GHC.IO.FD (FD(..))++import Streamly.Internal.FileSystem.IOVec (IOVec(..))++-------------------------------------------------------------------------------+-- IO Routines+-------------------------------------------------------------------------------++-- See System.POSIX.Internals in GHC base package++-------------------------------------------------------------------------------+-- Write without blocking the underlying OS thread+-------------------------------------------------------------------------------++#if !defined(mingw32_HOST_OS)++foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool++isNonBlocking :: FD -> Bool+isNonBlocking fd = fdIsNonBlocking fd /= 0++-- "poll"s the fd for data to become available or timeout+-- See cbits/inputReady.c in base package+#if __GLASGOW_HASKELL__ >= 804+foreign import ccall unsafe "fdReady"+    unsafe_fdReady :: CInt -> CBool -> Int64 -> CBool -> IO CInt+#else+foreign import ccall safe "fdReady"+    unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt+#endif++writeNonBlocking :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt+writeNonBlocking loc !fd !buf !off !len+    | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block+    | otherwise   = do+        let isWrite = 1+            isSocket = 0+            msecs = 0+        r <- unsafe_fdReady (fdFD fd) isWrite msecs isSocket+        when (r == 0) $ threadWaitWrite (fromIntegral (fdFD fd))+        if threaded then safe_write else unsafe_write++    where++    do_write call = fromIntegral `fmap`+                      throwErrnoIfMinus1RetryMayBlock loc call+                        (threadWaitWrite (fromIntegral (fdFD fd)))+    unsafe_write  = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)+    safe_write    = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)++writevNonBlocking :: String -> FD -> Ptr IOVec -> Int -> IO CInt+writevNonBlocking loc !fd !iov !cnt+    | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block+    | otherwise   = do+        let isWrite = 1+            isSocket = 0+            msecs = 0+        r <- unsafe_fdReady (fdFD fd) isWrite msecs isSocket+        when (r == 0) $ threadWaitWrite (fromIntegral (fdFD fd))+        if threaded then safe_write else unsafe_write++    where++    do_write call = fromIntegral `fmap`+                      throwErrnoIfMinus1RetryMayBlock loc call+                        (threadWaitWrite (fromIntegral (fdFD fd)))+    unsafe_write  = do_write (c_writev (fdFD fd) iov (fromIntegral cnt))+    safe_write    = do_write (c_safe_writev (fdFD fd) iov (fromIntegral cnt))++#else+writeNonBlocking :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt+writeNonBlocking = undefined++writevNonBlocking :: String -> FD -> Ptr IOVec -> Int -> IO CInt+writevNonBlocking = undefined+#endif++-- Windows code is disabled for now+#if 0++#if defined(mingw32_HOST_OS)+# if defined(i386_HOST_ARCH)+#  define WINDOWS_CCONV stdcall+# elif defined(x86_64_HOST_ARCH)+#  define WINDOWS_CCONV ccall+# else+#  error Unknown mingw32 arch+# endif+#endif++foreign import WINDOWS_CCONV safe "recv"+   c_safe_recv :: CInt -> Ptr Word8 -> CInt -> CInt{-flags-} -> IO CInt++foreign import WINDOWS_CCONV safe "send"+   c_safe_send :: CInt -> Ptr Word8 -> CInt -> CInt{-flags-} -> IO CInt++blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CSize -> IO CInt+blockingWriteRawBufferPtr loc !fd !buf !off !len+  = throwErrnoIfMinus1Retry loc $ do+        let start_ptr = buf `plusPtr` off+            send_ret = c_safe_send  (fdFD fd) start_ptr (fromIntegral len) 0+            write_ret = c_safe_write (fdFD fd) start_ptr (fromIntegral len)+        r <- bool write_ret send_ret (fdIsSocket fd)+        when (r == -1) c_maperrno+        return r+      -- We don't trust write() to give us the correct errno, and+      -- instead do the errno conversion from GetLastError()+      -- ourselves. The main reason is that we treat ERROR_NO_DATA+      -- (pipe is closing) as EPIPE, whereas write() returns EINVAL+      -- for this case. We need to detect EPIPE correctly, because it+      -- shouldn't be reported as an error when it happens on stdout.+      -- As for send()'s case, Winsock functions don't do errno+      -- conversion in any case so we have to do it ourselves.+      -- That means we're doing the errno conversion no matter if the+      -- fd is from a socket or not.++-- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.+-- These calls may block, but that's ok.++asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt+asyncWriteRawBufferPtr loc !fd !buf !off !len = do+    (l, rc) <- asyncWrite (fromIntegral (fdFD fd)) (fdIsSocket_ fd)+                  (fromIntegral len) (buf `plusPtr` off)+    if l == (-1)+      then let sock_errno = c_maperrno_func (fromIntegral rc)+               non_sock_errno = Errno (fromIntegral rc)+               errno = bool non_sock_errno sock_errno (fdIsSocket fd)+           in  ioError (errnoToIOError loc errno Nothing Nothing)+      else return (fromIntegral l)++writeNonBlocking :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt+writeNonBlocking loc !fd !buf !off !len+    | threaded  = blockingWriteRawBufferPtr loc fd buf off len+    | otherwise = asyncWriteRawBufferPtr    loc fd buf off len++#endif++-- | @write FD buffer offset length@ tries to write data on the given+-- filesystem fd (cannot be a socket) up to sepcified length starting from the+-- given offset in the buffer. The write will not block the OS thread, it may+-- suspend the Haskell thread until write can proceed.  Returns the actual+-- amount of data written.+write :: FD -> Ptr Word8 -> Int -> CSize -> IO CInt+write = writeNonBlocking "Streamly.Internal.FileSystem.FDIO"++-- XXX sendAll for sockets has a similar code, we can deduplicate the two.+-- XXX we need to check the errno to determine if the loop should continue. For+-- example, write may return without writing all data if the process file-size+-- limit has reached, in that case keep writing in a loop is fruitless.+--+-- | Keep writing in a loop until all data in the buffer has been written.+writeAll :: FD -> Ptr Word8 -> Int -> IO ()+writeAll fd ptr bytes = do+    res <- write fd ptr 0 (fromIntegral bytes)+    let res' = fromIntegral res+    when (res' < bytes) $+      writeAll fd (ptr `plusPtr` res') (bytes - res')++-------------------------------------------------------------------------------+-- Vector IO+-------------------------------------------------------------------------------++-- | @write FD iovec count@ tries to write data on the given filesystem fd+-- (cannot be a socket) from an iovec with specified number of entries.  The+-- write will not block the OS thread, it may suspend the Haskell thread until+-- write can proceed.  Returns the actual amount of data written.+writev :: FD -> Ptr IOVec -> Int -> IO CInt+writev = writevNonBlocking "Streamly.Internal.FileSystem.FDIO"++-- XXX incomplete+-- | Keep writing an iovec in a loop until all the iovec entries are written.+writevAll :: FD -> Ptr IOVec -> Int -> IO ()+writevAll fd iovec count = do+    _res <- writev fd iovec count+    {-+    let res' = fromIntegral res+    totalBytes = countIOVecBytes+    if res' < totalBytes+     then do+        let iovec' = createModifiedIOVec+            count' = ...+        writeAll fd iovec' count'+     else return ()+    -}+    return ()
src/Streamly/Internal/FileSystem/File.hs view
@@ -1,15 +1,12 @@-{-# LANGUAGE CPP              #-}-{-# LANGUAGE FlexibleContexts #-}- #include "inline.hs"  -- | -- Module      : Streamly.Internal.FileSystem.File--- Copyright   : (c) 2019 Harendra Kumar+-- Copyright   : (c) 2019 Composewell Technologies -- -- License     : BSD3 -- Maintainer  : streamly@composewell.com--- Stability   : experimental+-- Stability   : pre-release -- Portability : GHC -- -- Read and write streams and arrays to and from files specified by their paths@@ -47,19 +44,18 @@       withFile      -- ** Read From File+    , readWithBufferOf     , read     -- , readShared-    -- , readTailForever-     -- , readUtf8     -- , readLines     -- , readFrames-    -- , readChunks      , toBytes      -- -- * Array Read-    -- , readArrayOf+    , readChunksWithBufferOf+    , readChunks      , toChunksWithBufferOf     , toChunks@@ -98,9 +94,9 @@ import qualified Control.Monad.Catch as MC import qualified System.IO as SIO -import Streamly.Internal.Data.Fold.Types (Fold(..))-import Streamly.Internal.Data.Unfold.Types (Unfold(..))-import Streamly.Internal.Memory.Array.Types+import Streamly.Internal.Data.Fold.Type (Fold(..))+import Streamly.Internal.Data.Unfold.Type (Unfold(..))+import Streamly.Internal.Data.Array.Foreign.Type        (Array(..), defaultChunkSize, writeNUnsafe) import Streamly.Internal.Data.Stream.Serial (SerialT) import Streamly.Internal.Data.Stream.StreamK.Type (IsStream)@@ -108,12 +104,12 @@ -- import Streamly.Data.Fold (Fold) -- import Streamly.String (encodeUtf8, decodeUtf8, foldLines) -import qualified Streamly.Internal.Data.Fold.Types as FL+import qualified Streamly.Internal.Data.Fold.Type as FL import qualified Streamly.Internal.Data.Unfold as UF import qualified Streamly.Internal.FileSystem.Handle as FH-import qualified Streamly.Internal.Memory.ArrayStream as AS-import qualified Streamly.Memory.Array as A-import qualified Streamly.Prelude as S+import qualified Streamly.Internal.Data.Array.Stream.Foreign as AS+import qualified Streamly.Internal.Data.Stream.IsStream as S+import qualified Streamly.Data.Array.Foreign as A  ------------------------------------------------------------------------------- -- References@@ -139,10 +135,10 @@ -- this exception will be raised by 'withFile' rather than any exception -- raised by 'act'. ----- /Internal/+-- /Pre-release/ -- {-# INLINE withFile #-}-withFile :: (IsStream t, MonadCatch m, MonadIO m)+withFile :: (IsStream t, MonadCatch m, MonadAsync m)     => FilePath -> IOMode -> (Handle -> t m a) -> t m a withFile file mode = S.bracket (liftIO $ openFile file mode) (liftIO . hClose) @@ -152,15 +148,28 @@ -- or in case of an exception.  If closing the handle raises an exception, then -- this exception will be raised by 'usingFile'. ----- /Internal/+-- /Pre-release/ -- {-# INLINABLE usingFile #-}-usingFile :: (MonadCatch m, MonadIO m)+usingFile :: (MonadCatch m, MonadAsync m)     => Unfold m Handle a -> Unfold m FilePath a usingFile =     UF.bracket (\file -> liftIO $ openFile file ReadMode)                (liftIO . hClose) +{-# INLINABLE usingFile2 #-}+usingFile2 :: (MonadCatch m, MonadAsync m)+    => Unfold m (x, Handle) a -> Unfold m (x, FilePath) a+usingFile2 = UF.bracket before after++    where++    before (x, file) =  do+        h <- liftIO $ openFile file ReadMode+        return (x, h)++    after (_, h) = liftIO $ hClose h+ ------------------------------------------------------------------------------- -- Array IO (Input) -------------------------------------------------------------------------------@@ -193,7 +202,7 @@ -- The maximum size of a single array is specified by @size@. The actual size -- read may be less than or equal to @size@. {-# INLINABLE toChunksWithBufferOf #-}-toChunksWithBufferOf :: (IsStream t, MonadCatch m, MonadIO m)+toChunksWithBufferOf :: (IsStream t, MonadCatch m, MonadAsync m)     => Int -> FilePath -> t m (Array Word8) toChunksWithBufferOf size file =     withFile file ReadMode (FH.toChunksWithBufferOf size)@@ -208,7 +217,7 @@ -- -- @since 0.7.0 {-# INLINE toChunks #-}-toChunks :: (IsStream t, MonadCatch m, MonadIO m)+toChunks :: (IsStream t, MonadCatch m, MonadAsync m)     => FilePath -> t m (Array Word8) toChunks = toChunksWithBufferOf defaultChunkSize @@ -220,47 +229,54 @@ -- 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 readChunksWithBufferOf #-}+readChunksWithBufferOf :: (MonadCatch m, MonadAsync m)+    => Unfold m (Int, FilePath) (Array Word8)+readChunksWithBufferOf = usingFile2 FH.readChunksWithBufferOf++-- | 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.Foreign.Type.defaultChunkSize'. The+-- size of arrays in the resulting stream are therefore less than or equal to+-- 'Streamly.Internal.Data.Array.Foreign.Type.defaultChunkSize'.+--+-- /Pre-release/+{-# INLINE readChunks #-}+readChunks :: (MonadCatch m, MonadAsync m) => Unfold m FilePath (Array Word8)+readChunks = usingFile FH.readChunks+ -- | Unfolds the tuple @(bufsize, filepath)@ into a byte stream, read requests -- to the IO device are performed using buffers of @bufsize@. ----- @since 0.7.0+-- /Pre-release/ {-# INLINE readWithBufferOf #-}-readWithBufferOf :: MonadIO m => Unfold m (Int, FilePath) Word8-readWithBufferOf = UF.concat (usingFilexxx FH.readChunksWithBufferOf) A.read--}+readWithBufferOf :: (MonadCatch m, MonadAsync m) => Unfold m (Int, FilePath) Word8+readWithBufferOf = usingFile2 FH.readWithBufferOf  -- | Unfolds a file path into a byte stream. IO requests to the device are -- performed in sizes of--- 'Streamly.Internal.Memory.Array.Types.defaultChunkSize'.+-- 'Streamly.Internal.Data.Array.Foreign.Type.defaultChunkSize'. -- -- @since 0.7.0 {-# INLINE read #-}-read :: (MonadCatch m, MonadIO m) => Unfold m FilePath Word8-read = UF.concat (usingFile FH.readChunks) A.read--{---- | @readInChunksOf chunkSize handle@ reads a byte stream from a file--- handle, reads are performed in chunks of up to @chunkSize@.  The stream ends--- as soon as EOF is encountered.----{-# INLINE readInChunksOf #-}-readInChunksOf :: (IsStream t, MonadIO m) => Int -> Handle -> t m Word8-readInChunksOf chunkSize h = A.flattenArrays $ toChunksWithBufferOf chunkSize h--}+read :: (MonadCatch m, MonadAsync m) => Unfold m FilePath Word8+read = UF.many (usingFile FH.readChunks) A.read --- TODO--- read :: (IsStream t, MonadIO m, Storable a) => Handle -> t m a------ > read = 'readByChunks' defaultChunkSize -- | 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. ----- /Internal/+-- /Pre-release/ -- {-# INLINE toBytes #-}-toBytes :: (IsStream t, MonadCatch m, MonadIO m) => FilePath -> t m Word8+toBytes :: (IsStream t, MonadCatch m, MonadAsync m) => FilePath -> t m Word8 toBytes file = AS.concat $ withFile file ReadMode FH.toChunks  {-@@ -272,15 +288,6 @@ {-# INLINE readShared #-} readShared :: (IsStream t, MonadIO m) => Handle -> t m Word8 readShared = undefined---- | Read a stream from a given file path. When end of file (EOF) is reached--- this API waits for more data to be written to the file and keeps reading it--- as it is written.------ @since 0.7.0-{-# INLINE readTailForever #-}-readTailForever :: (IsStream t, MonadIO m) => Handle -> t m Word8-readTailForever = undefined -}  -------------------------------------------------------------------------------@@ -326,7 +333,7 @@ -- truncated to zero size before writing. If the file does not exist it is -- created. File is locked using single writer locking mode. ----- /Internal/+-- /Pre-release/ {-# INLINE fromBytes #-} fromBytes :: (MonadAsync m, MonadCatch m) => FilePath -> SerialT m Word8 -> m () fromBytes = fromBytesWithBufferOf defaultChunkSize@@ -340,7 +347,7 @@ -- | Write a stream of chunks to a handle. Each chunk in the stream is written -- to the device as a separate IO request. ----- /Internal/+-- /Pre-release/ {-# INLINE writeChunks #-} writeChunks :: (MonadIO m, MonadCatch m, Storable a)     => FilePath -> Fold m (Array a) ()@@ -350,32 +357,35 @@         h <- liftIO (openFile path WriteMode)         fld <- FL.initialize (FH.writeChunks h)                 `MC.onException` liftIO (hClose h)-        return (fld, h)+        return $ FL.Partial (fld, h)     step (fld, h) x = do         r <- FL.runStep fld x `MC.onException` liftIO (hClose h)-        return (r, h)+        return $ FL.Partial (r, h)     extract (Fold _ initial1 extract1, h) = do         liftIO $ hClose h-        initial1 >>= extract1+        res <- initial1+        case res of+            FL.Partial fs -> extract1 fs+            FL.Done fb -> return fb  -- | @writeWithBufferOf 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. ----- /Internal/+-- /Pre-release/ {-# INLINE writeWithBufferOf #-} writeWithBufferOf :: (MonadIO m, MonadCatch m)     => Int -> FilePath -> Fold m Word8 () writeWithBufferOf n path =-    FL.lchunksOf n (writeNUnsafe n) (writeChunks path)+    FL.chunksOf n (writeNUnsafe n) (writeChunks path)  -- > write = 'writeWithBufferOf' A.defaultChunkSize -- -- | Write a byte stream to a file. Accumulates the input in chunks of up to--- 'Streamly.Internal.Memory.Array.Types.defaultChunkSize' before writing to+-- 'Streamly.Internal.Data.Array.Foreign.Type.defaultChunkSize' before writing to -- the IO device. ----- /Internal/+-- /Pre-release/ -- {-# INLINE write #-} write :: (MonadIO m, MonadCatch m) => FilePath -> Fold m Word8 ()
src/Streamly/Internal/FileSystem/Handle.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE CPP             #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RecordWildCards #-}- #include "inline.hs"  -- |@@ -24,7 +20,6 @@      , toBytes     , toBytesWithBufferOf-    , getBytes      -- -- * Array Read     -- , readArrayUpto@@ -34,7 +29,6 @@      , toChunksWithBufferOf     , toChunks-    , getChunks      -- ** Write to Handle     -- Byte stream write (Folds)@@ -47,8 +41,8 @@     , writeWithBufferOf      -- Byte stream write (Streams)-    , fromBytes-    , fromBytesWithBufferOf+    , putBytes+    , putBytesWithBufferOf      -- -- * Array Write     , writeArray@@ -56,12 +50,8 @@     , writeChunksWithBufferOf      -- -- * Array stream Write-    , fromChunksWithBufferOf-    , fromChunks+    , putChunksWithBufferOf     , putChunks-    , putStrings-    , putBytes-    , putLines      -- -- * Random Access (Seek)     -- -- | Unlike the streaming APIs listed above, these APIs apply to devices or@@ -105,32 +95,32 @@  import Control.Monad.IO.Class (MonadIO(..)) import Data.Word (Word8)-import Foreign.ForeignPtr (withForeignPtr) import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)+import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr (minusPtr, plusPtr) import Foreign.Storable (Storable(..)) import GHC.ForeignPtr (mallocPlainForeignPtrBytes)-import System.IO (Handle, hGetBufSome, hPutBuf, stdin, stdout)+import System.IO (Handle, hGetBufSome, hPutBuf) import Prelude hiding (read) -import Streamly (MonadAsync)+import Streamly.Internal.BaseCompat import Streamly.Data.Fold (Fold)-import Streamly.Internal.Data.Fold.Types (Fold2(..))-import Streamly.Internal.Data.Unfold.Types (Unfold(..))-import Streamly.Internal.Memory.Array.Types-       (Array(..), writeNUnsafe, defaultChunkSize, shrinkToFit,-        lpackArraysChunksOf)+import Streamly.Internal.Data.Fold.Type (Fold2(..))+import Streamly.Internal.Data.Unfold.Type (Unfold(..))+import Streamly.Internal.Data.Array.Foreign.Type+       (Array(..), writeNUnsafe, defaultChunkSize , unsafeFreezeWithShrink)+import Streamly.Internal.Data.Array.Foreign.Mut.Type (mutableArray) import Streamly.Internal.Data.Stream.Serial (SerialT) import Streamly.Internal.Data.Stream.StreamK.Type (IsStream, mkStream)+import Streamly.Internal.Data.Array.Stream.Foreign (lpackArraysChunksOf) -- import Streamly.String (encodeUtf8, decodeUtf8, foldLines)  import qualified Streamly.Data.Fold as FL-import qualified Streamly.Internal.Data.Fold.Types as FL+import qualified Streamly.Internal.Data.Fold.Type as FL import qualified Streamly.Internal.Data.Unfold as UF-import qualified Streamly.Internal.Memory.Array as IA-import qualified Streamly.Internal.Memory.ArrayStream as AS-import qualified Streamly.Internal.Prelude as S-import qualified Streamly.Memory.Array as A+import qualified Streamly.Internal.Data.Array.Stream.Foreign as AS+import qualified Streamly.Internal.Data.Stream.IsStream as S+import qualified Streamly.Data.Array.Foreign as A import qualified Streamly.Internal.Data.Stream.StreamD.Type as D  -------------------------------------------------------------------------------@@ -161,13 +151,10 @@     -- ptr <- mallocPlainForeignPtrAlignedBytes size (alignment (undefined :: Word8))     withForeignPtr ptr $ \p -> do         n <- hGetBufSome h p size-        let v = Array-                { aStart = ptr-                , aEnd   = p `plusPtr` n-                , aBound = p `plusPtr` size-                }         -- XXX shrink only if the diff is significant-        shrinkToFit v+        return $+            unsafeFreezeWithShrink $+            mutableArray ptr (p `plusPtr` n) (p `plusPtr` size)  ------------------------------------------------------------------------------- -- Stream of Arrays IO@@ -237,38 +224,16 @@ toChunks :: (IsStream t, MonadIO m) => Handle -> t m (Array Word8) toChunks = toChunksWithBufferOf defaultChunkSize --- | 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@.------ > getChunks = toChunks stdin------ /Internal/----{-# INLINE getChunks #-}-getChunks :: (IsStream t, MonadIO m) => t m (Array Word8)-getChunks = toChunks stdin---- | Read a stream of bytes from standard input.------ > getBytes = toBytes stdin------ /Internal/----{-# INLINE getBytes #-}-getBytes :: (IsStream t, MonadIO m) => t m Word8-getBytes = toBytes stdin- -- | Unfolds a handle into a stream of 'Word8' arrays. Requests to the IO -- device are performed using a buffer of size--- 'Streamly.Internal.Memory.Array.Types.defaultChunkSize'. The+-- 'Streamly.Internal.Data.Array.Foreign.Type.defaultChunkSize'. The -- size of arrays in the resulting stream are therefore less than or equal to--- 'Streamly.Internal.Memory.Array.Types.defaultChunkSize'.+-- 'Streamly.Internal.Data.Array.Foreign.Type.defaultChunkSize'. -- -- @since 0.7.0 {-# INLINE readChunks #-} readChunks :: MonadIO m => Unfold m Handle (Array Word8)-readChunks = UF.supplyFirst readChunksWithBufferOf defaultChunkSize+readChunks = UF.supplyFirst defaultChunkSize readChunksWithBufferOf  ------------------------------------------------------------------------------- -- Read File to Stream@@ -284,12 +249,12 @@ -- @since 0.7.0 {-# INLINE readWithBufferOf #-} readWithBufferOf :: MonadIO m => Unfold m (Int, Handle) Word8-readWithBufferOf = UF.concat readChunksWithBufferOf A.read+readWithBufferOf = UF.many readChunksWithBufferOf A.read  -- | @toBytesWithBufferOf bufsize handle@ reads a byte stream from a file -- handle, reads are performed in chunks of up to @bufsize@. ----- /Internal/+-- /Pre-release/ {-# INLINE toBytesWithBufferOf #-} toBytesWithBufferOf :: (IsStream t, MonadIO m) => Int -> Handle -> t m Word8 toBytesWithBufferOf chunkSize h = AS.concat $ toChunksWithBufferOf chunkSize h@@ -300,16 +265,16 @@ -- -- | Unfolds a file handle into a byte stream. IO requests to the device are -- performed in sizes of--- 'Streamly.Internal.Memory.Array.Types.defaultChunkSize'.+-- 'Streamly.Internal.Data.Array.Foreign.Type.defaultChunkSize'. -- -- @since 0.7.0 {-# INLINE read #-} read :: MonadIO m => Unfold m Handle Word8-read = UF.supplyFirst readWithBufferOf defaultChunkSize+read = UF.supplyFirst defaultChunkSize readWithBufferOf  -- | Generate a byte stream from a file 'Handle'. ----- /Internal/+-- /Pre-release/ {-# INLINE toBytes #-} toBytes :: (IsStream t, MonadIO m) => Handle -> t m Word8 toBytes = AS.concat . toChunks@@ -328,7 +293,7 @@ {-# 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+writeArray h Array{..} = unsafeWithForeignPtr aStart $ \p -> hPutBuf h p aLen     where     aLen =         let p = unsafeForeignPtrToPtr aStart@@ -346,86 +311,44 @@ -- | Write a stream of arrays to a handle. -- -- @since 0.7.0-{-# INLINE fromChunks #-}-fromChunks :: (MonadIO m, Storable a)-    => Handle -> SerialT m (Array a) -> m ()-fromChunks h = S.mapM_ (liftIO . writeArray h)---- | Write a stream of chunks to standard output.------ /Internal/--- {-# INLINE putChunks #-}-putChunks :: (MonadIO m, Storable a) => SerialT m (Array a) -> m ()-putChunks = fromChunks stdout---- XXX use an unfold so that we can put any type of strings.--- | Write a stream of strings to standard output using the supplied encoding.--- Output is flushed to the device for each string.------ /Internal/----{-# INLINE putStrings #-}-putStrings :: MonadAsync m-    => (SerialT m Char -> SerialT m Word8) -> SerialT m String -> m ()-putStrings encode = putChunks . S.mapM (IA.fromStream . encode . S.fromList)---- XXX use an unfold so that we can put lines from any object--- | Write a stream of strings as separate lines to standard output using the--- supplied encoding. Output is line buffered i.e. the output is written to the--- device as soon as a newline is encountered.------ /Internal/----{-# INLINE putLines #-}-putLines :: MonadAsync m-    => (SerialT m Char -> SerialT m Word8) -> SerialT m String -> m ()-putLines encode = putChunks . S.mapM-    (\xs -> IA.fromStream $ encode (S.fromList (xs ++ "\n")))---- | Write a stream of bytes from standard output.------ > putBytes = fromBytes stdout------ /Internal/----{-# INLINE putBytes #-}-putBytes :: MonadIO m => SerialT m Word8 -> m ()-putBytes = fromBytes stdout+putChunks :: (MonadIO m, Storable a)+    => Handle -> SerialT m (Array a) -> m ()+putChunks h = S.mapM_ (liftIO . writeArray h) --- | @fromChunksWithBufferOf bufsize handle stream@ writes a stream of arrays+-- | @putChunksWithBufferOf 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)+{-# INLINE putChunksWithBufferOf #-}+putChunksWithBufferOf :: (MonadIO m, Storable a)     => Int -> Handle -> SerialT m (Array a) -> m ()-fromChunksWithBufferOf n h xs = fromChunks h $ AS.compact n xs+putChunksWithBufferOf n h xs = putChunks h $ AS.compact n xs --- | @fromBytesWithBufferOf bufsize handle stream@ writes @stream@ to @handle@+-- | @putBytesWithBufferOf 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 fromBytesWithBufferOf #-}-fromBytesWithBufferOf :: MonadIO m => Int -> Handle -> SerialT m Word8 -> m ()-fromBytesWithBufferOf n h m = fromChunks h $ S.arraysOf n m--- fromBytesWithBufferOf n h m = fromChunks h $ AS.arraysOf n m+{-# INLINE putBytesWithBufferOf #-}+putBytesWithBufferOf :: MonadIO m => Int -> Handle -> SerialT m Word8 -> m ()+putBytesWithBufferOf n h m = putChunks h $ S.arraysOf n m+-- putBytesWithBufferOf n h m = putChunks h $ AS.arraysOf n m  -- > write = 'writeWithBufferOf' A.defaultChunkSize -- -- | Write a byte stream to a file handle. Accumulates the input in chunks of--- up to 'Streamly.Internal.Memory.Array.Types.defaultChunkSize' before writing.+-- up to 'Streamly.Internal.Data.Array.Foreign.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 fromBytes #-}-fromBytes :: MonadIO m => Handle -> SerialT m Word8 -> m ()-fromBytes = fromBytesWithBufferOf defaultChunkSize+{-# INLINE putBytes #-}+putBytes :: MonadIO m => Handle -> SerialT m Word8 -> m ()+putBytes = putBytesWithBufferOf defaultChunkSize  -- | Write a stream of arrays to a handle. Each array in the stream is written -- to the device as a separate IO request.@@ -466,16 +389,16 @@ -- @since 0.7.0 {-# INLINE writeWithBufferOf #-} writeWithBufferOf :: MonadIO m => Int -> Handle -> Fold m Word8 ()-writeWithBufferOf n h = FL.lchunksOf n (writeNUnsafe n) (writeChunks h)+writeWithBufferOf n h = FL.chunksOf n (writeNUnsafe n) (writeChunks h)  {-# INLINE writeWithBufferOf2 #-} writeWithBufferOf2 :: MonadIO m => Int -> Fold2 m Handle Word8 ()-writeWithBufferOf2 n = FL.lchunksOf2 n (writeNUnsafe n) writeChunks2+writeWithBufferOf2 n = FL.chunksOf2 n (writeNUnsafe n) writeChunks2  -- > write = 'writeWithBufferOf' A.defaultChunkSize -- -- | Write a byte stream to a file handle. Accumulates the input in chunks of--- up to 'Streamly.Internal.Memory.Array.Types.defaultChunkSize' before writing+-- up to 'Streamly.Internal.Data.Array.Foreign.Type.defaultChunkSize' before writing -- to the IO device. -- -- @since 0.7.0
+ src/Streamly/Internal/FileSystem/IOVec.hsc view
@@ -0,0 +1,83 @@+#include "MachDeps.h"++-- |+-- Module      : Streamly.Internal.FileSystem.IOVec+-- Copyright   : (c) 2019 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- Low level IO routines interfacing the operating system.+--++module Streamly.Internal.FileSystem.IOVec+    ( IOVec(..)+    , c_writev+    , c_safe_writev+    )+where+++import Data.Word (Word8)+#if (WORD_SIZE_IN_BITS == 32)+import Data.Word (Word32)+#else+import Data.Word (Word64)+#endif+import Foreign.C.Types (CInt(..))+import Foreign.Ptr (Ptr)+import System.Posix.Types (CSsize(..))+#if !defined(mingw32_HOST_OS)+import Foreign.Storable (Storable(..))+#endif++-------------------------------------------------------------------------------+-- IOVec+-------------------------------------------------------------------------------++data IOVec = IOVec+  { iovBase :: {-# UNPACK #-} !(Ptr Word8)+#if (WORD_SIZE_IN_BITS == 32)+  , iovLen  :: {-# UNPACK #-} !Word32+#else+  , iovLen  :: {-# UNPACK #-} !Word64+#endif+  } deriving (Eq, Show)++#if !defined(mingw32_HOST_OS)++#include <sys/uio.h>++instance Storable IOVec where+  sizeOf _ = #{size struct iovec}+  alignment _ = #{alignment struct iovec}+  peek ptr = do+      base <- #{peek struct iovec, iov_base} ptr+      len  :: #{type size_t} <- #{peek struct iovec, iov_len}  ptr+      return $ IOVec base len+  poke ptr vec = do+      let base = iovBase vec+          len  :: #{type size_t} = iovLen vec+      #{poke struct iovec, iov_base} ptr base+      #{poke struct iovec, iov_len}  ptr len+#endif++-- capi calling convention does not work without -fobject-code option with GHCi+-- so using this in DEVBUILD only for now.+--+#if !defined(mingw32_HOST_OS) && defined DEVBUILD+foreign import capi unsafe "sys/uio.h writev"+   c_writev :: CInt -> Ptr IOVec -> CInt -> IO CSsize++foreign import capi safe "sys/uio.h writev"+   c_safe_writev :: CInt -> Ptr IOVec -> CInt -> IO CSsize++#else+c_writev :: CInt -> Ptr IOVec -> CInt -> IO CSsize+c_writev = error "writev not implemented"++c_safe_writev :: CInt -> Ptr IOVec -> CInt -> IO CSsize+c_safe_writev = error "writev not implemented"+#endif
+ src/Streamly/Internal/Foreign/Malloc.hs view
@@ -0,0 +1,49 @@+#include "inline.hs"++-- |+-- Module      : Streamly.Internal.Foreign.Malloc+-- Copyright   : (c) 2019 Composewell Technologies+--+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+module Streamly.Internal.Foreign.Malloc+    (+      mallocForeignPtrAlignedBytes+    , mallocForeignPtrAlignedUnmanagedBytes+    )+where+++-- We use GHC malloc by default++import Foreign.ForeignPtr (ForeignPtr, newForeignPtr_)+import Foreign.Marshal.Alloc (mallocBytes)+#ifdef USE_C_MALLOC+import Foreign.ForeignPtr (newForeignPtr)+import Foreign.Marshal.Alloc (finalizerFree)+#endif++import qualified GHC.ForeignPtr as GHC++{-# INLINE mallocForeignPtrAlignedBytes #-}+mallocForeignPtrAlignedBytes :: Int -> Int -> IO (GHC.ForeignPtr a)+#ifdef USE_C_MALLOC+mallocForeignPtrAlignedBytes size _alignment = do+    p <- mallocBytes size+    newForeignPtr finalizerFree p+#else+mallocForeignPtrAlignedBytes =+    GHC.mallocPlainForeignPtrAlignedBytes+#endif++-- memalign alignment size+-- foreign import ccall unsafe "stdlib.h posix_memalign" _memalign :: CSize -> CSize -> IO (Ptr a)++mallocForeignPtrAlignedUnmanagedBytes :: Int -> Int -> IO (ForeignPtr a)+mallocForeignPtrAlignedUnmanagedBytes size _alignment = do+    -- XXX use posix_memalign/aligned_alloc for aligned allocation+    p <- mallocBytes size+    newForeignPtr_ p
− src/Streamly/Internal/Memory/Array.hs 
@@ -1,510 +0,0 @@-{-# LANGUAGE BangPatterns        #-}-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE MagicHash           #-}-{-# LANGUAGE UnboxedTuples       #-}-{-# LANGUAGE ScopedTypeVariables #-}--#include "inline.hs"---- |--- Module      : Streamly.Internal.Memory.Array--- Copyright   : (c) 2019 Composewell Technologies------ License     : BSD3--- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC------ 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.Memory.ArrayStream.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.--module Streamly.Internal.Memory.Array-    (-      Array--    -- , defaultChunkSize--    -- * Construction--    -- Pure List APIs-    , A.fromListN-    , A.fromList--    -- Stream Folds-    , fromStreamN-    , fromStream--    -- Monadic APIs-    -- , newArray-    , A.writeN      -- drop new-    , A.writeNAligned-    , A.write       -- full buffer-    -- , writeLastN -- drop old (ring buffer)--    -- * Elimination--    , A.toList-    , toStream-    , toStreamRev-    , read-    , unsafeRead-    -- , readChunksOf--    -- * Random Access-    , length-    , null-    , last-    -- , (!!)-    , readIndex-    , A.unsafeIndex-    -- , readIndices-    -- , readRanges--    -- , readFrom    -- read from a given position to the end of file-    -- , readFromRev -- read from a given position to 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--    -- , readChunksOfFrom-    -- , ...--    -- , writeIndex-    -- , writeFrom -- start writing at the given position-    -- , writeFromRev-    -- , writeTo   -- write from beginning up to the given position-    -- , writeToRev-    -- , writeFromTo-    -- , writeFromThenTo-    ---    -- , writeChunksOfFrom-    -- , ...--    , writeIndex-    --, writeIndices-    --, writeRanges--    -- -- * Search-    -- , bsearch-    -- , bsearchIndex-    -- , find-    -- , findIndex-    -- , findIndices--    -- -- * In-pace mutation (for Mutable Array type)-    -- , partitionBy-    -- , shuffleBy-    -- , foldtWith-    -- , foldbWith--    -- * Immutable Transformations-    , streamTransform--    -- * Folding Arrays-    , streamFold-    , fold--    -- * Folds with Array as the container-    , D.lastN-    )-where--import  Control.Monad (when)-import Control.Monad.IO.Class (MonadIO(..))--- import Data.Functor.Identity (Identity)-import Foreign.ForeignPtr (withForeignPtr, touchForeignPtr)-import Foreign.Ptr (plusPtr)-import Foreign.Storable (Storable(..))-import Prelude hiding (length, null, last, map, (!!), read, concat)--import GHC.ForeignPtr (ForeignPtr(..))-import GHC.Ptr (Ptr(..))-import GHC.Prim (touch#)-import GHC.IO (IO(..))--import Streamly.Internal.Data.Fold.Types (Fold(..))-import Streamly.Internal.Data.Unfold.Types (Unfold(..))-import Streamly.Internal.Memory.Array.Types (Array(..), length)-import Streamly.Internal.Data.Stream.Serial (SerialT)-import Streamly.Internal.Data.Stream.StreamK.Type (IsStream)--import qualified Streamly.Internal.Memory.Array.Types as A-import qualified Streamly.Internal.Data.Stream.Prelude as P-import qualified Streamly.Internal.Data.Stream.Serial as Serial-import qualified Streamly.Internal.Data.Stream.StreamD as D-import qualified Streamly.Internal.Data.Stream.StreamK as K------------------------------------------------------------------------------------ Construction----------------------------------------------------------------------------------{---- | Create a new uninitialized array of given length.------ @since 0.7.0-newArray :: (MonadIO m, Storable a) => Int -> m (Array a)-newArray len = undefined--}---- | 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.------ /Internal/-{-# INLINE fromStreamN #-}-fromStreamN :: (MonadIO m, Storable a) => Int -> SerialT m a -> m (Array a)-fromStreamN n m = do-    when (n < 0) $ error "writeN: negative write count specified"-    A.fromStreamDN n $ D.toStreamD 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, `arraysOf` followed by--- processing of indvidual arrays in the resulting stream should be preferred.------ /Internal/-{-# INLINE fromStream #-}-fromStream :: (MonadIO m, Storable a) => SerialT m a -> m (Array a)-fromStream = P.runFold A.write--- write m = A.fromStreamD $ D.toStreamD m------------------------------------------------------------------------------------ Elimination------------------------------------------------------------------------------------ | Convert an 'Array' into a stream.------ /Internal/-{-# INLINE_EARLY toStream #-}-toStream :: (Monad m, K.IsStream t, Storable a) => Array a -> t m a-toStream = D.fromStreamD . A.toStreamD--- 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.------ /Internal/-{-# INLINE_EARLY toStreamRev #-}-toStreamRev :: (Monad m, IsStream t, Storable a) => Array a -> t m a-toStreamRev = D.fromStreamD . A.toStreamDRev--- XXX add fallback to StreamK rule--- {-# RULES "Streamly.Array.readRev fallback to StreamK" [1]---     forall a. S.toStreamK (readRev a) = K.revFromArray a #-}--data ReadUState a = ReadUState-    {-# UNPACK #-} !(ForeignPtr a)  -- foreign ptr with end of array pointer-    {-# UNPACK #-} !(Ptr a)         -- current pointer---- | Unfold an array into a stream.------ @since 0.7.0-{-# INLINE_NORMAL read #-}-read :: forall m a. (Monad m, Storable a) => Unfold m (Array a) a-read = Unfold step inject-    where--    inject (Array (ForeignPtr start contents) (Ptr end) _) =-        return $ ReadUState (ForeignPtr end contents) (Ptr start)--    {-# INLINE_LATE step #-}-    step (ReadUState fp@(ForeignPtr end _) p) | p == Ptr end =-        let x = A.unsafeInlineIO $ touchForeignPtr fp-        in x `seq` return D.Stop-    step (ReadUState fp 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 = A.unsafeInlineIO $ peek p-            return $ D.Yield x-                (ReadUState fp (p `plusPtr` sizeOf (undefined :: a)))---- | 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.------ /Internal/----{-# INLINE_NORMAL unsafeRead #-}-unsafeRead :: forall m a. (Monad m, Storable a) => Unfold m (Array a) a-unsafeRead = Unfold step inject-    where--    inject (Array fp _ _) = return fp--    {-# INLINE_LATE step #-}-    step (ForeignPtr p contents) = 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 = A.unsafeInlineIO $ do-                        r <- peek (Ptr p)-                        touch contents-                        return r-            let !(Ptr p1) = Ptr p `plusPtr` sizeOf (undefined :: a)-            return $ D.Yield x (ForeignPtr p1 contents)--    touch r = IO $ \s -> case touch# r s of s' -> (# s', () #)---- | > null arr = length arr == 0------ /Internal/-{-# INLINE null #-}-null :: Storable a => Array a -> Bool-null arr = length arr == 0---- | > last arr = readIndex arr (length arr - 1)------ /Internal/-{-# INLINE last #-}-last :: Storable a => Array a -> Maybe a-last arr = readIndex arr (length arr - 1)------------------------------------------------------------------------------------ Random Access-------------------------------------------------------------------------------------------------------------------------------------------------------------------- Searching----------------------------------------------------------------------------------{---- | Perform a binary search in the array to find an element.-bsearch :: a -> Array a -> Maybe Bool-bsearch = undefined---- | Perform a binary search in the array to find an element index.-{-# INLINE elemIndex #-}-bsearchIndex :: a -> Array a -> Maybe Int-bsearchIndex elem arr = undefined---- find/findIndex etc can potentially be implemented more efficiently on arrays--- compared to streams by using SIMD instructions.--find :: (a -> Bool) -> Array a -> Bool-find = undefined--findIndex :: (a -> Bool) -> Array a -> Maybe Int-findIndex = undefined--findIndices :: (a -> Bool) -> Array a -> Array Int-findIndices = undefined--}------------------------------------------------------------------------------------ Folds------------------------------------------------------------------------------------ XXX We can potentially use SIMD instructions on arrays to fold faster.------------------------------------------------------------------------------------ Slice and splice----------------------------------------------------------------------------------{--slice :: Int -> Int -> Array a-slice begin end arr = undefined--splitAt :: Int -> Array a -> (Array a, Array a)-splitAt i arr = undefined---- XXX This operation can be performed efficiently via streams.--- | Append two arrays together to create a single array.-splice :: Array a -> Array a -> Array a-splice arr1 arr2 = undefined------------------------------------------------------------------------------------ In-place mutation APIs------------------------------------------------------------------------------------ | 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'.-{-# INLINE partitionBy #-}-partitionBy :: (a -> Bool) -> Array a -> (Array a, Array a)-partitionBy f arr = undefined---- | 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.-shuffleBy :: (a -> a -> m Bool) -> Array a -> Array a -> m (Array a)-shuffleBy f arr1 arr2 = undefined---- XXX we can also make the folds partial by stopping at a certain level.------ | Perform a top down hierarchical recursive partitioning fold of items in--- the container using the given function as the partition function.------ This will perform a quick sort if the partition function is--- 'partitionBy (< pivot)'.------ @since 0.7.0-{-# INLINABLE foldtWith #-}-foldtWith :: Int -> (Array a -> Array a -> m (Array a)) -> Array a -> m (Array a)-foldtWith level f = undefined---- | Perform a pairwise bottom up fold recursively merging the pairs. Level--- indicates the level in the tree where the fold would stop.------ This will perform a random shuffle if the shuffle function is random.--- If we stop at level 0 and repeatedly apply the function then we can do a--- bubble sort.-foldbWith :: Int -> (Array a -> Array a -> m (Array a)) -> Array a -> m (Array a)-foldbWith level f = undefined--}---- XXX consider the bulk update/accumulation/permutation APIs from vector.------------------------------------------------------------------------------------ Random reads and writes------------------------------------------------------------------------------------ | /O(1)/ Lookup the element at the given index, starting from 0.------ /Internal/-{-# INLINE readIndex #-}-readIndex :: Storable a => Array a -> Int -> Maybe a-readIndex arr i =-    if i < 0 || i > length arr - 1-        then Nothing-        else A.unsafeInlineIO $-             withForeignPtr (aStart arr) $ \p -> Just <$> peekElemOff p i--{---- | @readSlice arr i count@ streams a slice of the array @arr@ 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 :: (IsStream t, Monad m, Storable a)-    => Array a -> Int -> Int -> t m a-readSlice arr i len = undefined---- | @readSliceRev arr i count@ streams a slice of the array @arr@ 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 :: (IsStream t, Monad m, Storable a)-    => Array a -> Int -> Int -> t m a-readSliceRev arr i len = undefined--}---- | /O(1)/ Write the given element at the given index in the array.--- Performs in-place mutation of the array.------ /Internal/-{-# INLINE writeIndex #-}-writeIndex :: (MonadIO m, Storable a) => Array a -> Int -> a -> m ()-writeIndex arr i a = do-    let maxIndex = length arr - 1-    if i < 0-    then error "writeIndex: negative array index"-    else if i > maxIndex-         then error $ "writeIndex: specified array index " ++ show i-                    ++ " is beyond the maximum index " ++ show maxIndex-         else-            liftIO $ withForeignPtr (aStart arr) $ \p ->-                pokeElemOff p i a--{---- | @writeSlice arr i count stream@ writes a stream to the array @arr@--- 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 :: (IsStream t, Monad m, Storable a)-    => Array a -> Int -> Int -> t m a -> m ()-writeSlice arr i len s = undefined---- | @writeSliceRev arr i count stream@ writes a stream to the array @arr@--- 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 :: (IsStream t, Monad m, Storable a)-    => Array a -> Int -> Int -> t m a -> m ()-writeSliceRev arr i len s = 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.------ @since 0.7.0-{-# INLINE runPipe #-}-runPipe :: (MonadIO m, Storable a, Storable b)-    => Pipe m a b -> Array a -> m (Array b)-runPipe f arr = P.runPipe (toArrayMinChunk (length arr)) $ f (A.read arr)--}---- | Transform an array into another array using a stream transformation--- operation.------ /Internal/-{-# INLINE streamTransform #-}-streamTransform :: forall m a b. (MonadIO m, Storable a, Storable b)-    => (SerialT m a -> SerialT m b) -> Array a -> m (Array b)-streamTransform f arr =-    P.runFold (A.toArrayMinChunk (alignment (undefined :: a)) (length arr))-        $ f (toStream arr)---- | Fold an array using a 'Fold'.------ /Internal/-{-# INLINE fold #-}-fold :: forall m a b. (MonadIO m, Storable a) => Fold m a b -> Array a -> m b-fold f arr = P.runFold f (toStream arr :: Serial.SerialT m a)---- | Fold an array using a stream fold operation.------ /Internal/-{-# INLINE streamFold #-}-streamFold :: (MonadIO m, Storable a) => (SerialT m a -> m b) -> Array a -> m b-streamFold f arr = f (toStream arr)
− src/Streamly/Internal/Memory/Array/Types.hs 
@@ -1,1366 +0,0 @@-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE BangPatterns              #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE MagicHash                 #-}-{-# LANGUAGE RecordWildCards           #-}-{-# LANGUAGE ScopedTypeVariables       #-}-{-# LANGUAGE TypeFamilies              #-}-{-# LANGUAGE UnboxedTuples             #-}-{-# LANGUAGE FlexibleContexts          #-}--#if MIN_VERSION_base(4,17,0)-{-# LANGUAGE TypeOperators             #-}-#endif--#include "inline.hs"---- |--- Module      : Streamly.Internal.Memory.Array.Types--- Copyright   : (c) 2019 Composewell Technologies------ License     : BSD3--- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC----module Streamly.Internal.Memory.Array.Types-    (-      Array (..)--    -- * Construction-    , withNewArray-    , newArray-    , unsafeSnoc-    , snoc-    , spliceWithDoubling-    , spliceTwo--    , fromList-    , fromListN-    , fromStreamDN-    -- , fromStreamD--    -- * Streams of arrays-    , fromStreamDArraysOf-    , FlattenState (..) -- for inspection testing-    , flattenArrays-    , flattenArraysRev-    , packArraysChunksOf-    , lpackArraysChunksOf-#if __GLASGOW_HASKELL__ < 900-#if !defined(mingw32_HOST_OS)-    , groupIOVecsOf-#endif-#endif-    , splitOn-    , breakOn--    -- * Elimination-    , unsafeIndexIO-    , unsafeIndex-    , length-    , byteLength-    , byteCapacity-    , foldl'-    , foldr-    , splitAt--    , toStreamD-    , toStreamDRev-    , toStreamK-    , toStreamKRev-    , toList-    , toArrayMinChunk-    , writeN-    , writeNUnsafe-    , writeNAligned-    , writeNAlignedUnmanaged-    , write-    , writeAligned--    -- * Utilities-    , defaultChunkSize-    , mkChunkSize-    , mkChunkSizeKB-    , unsafeInlineIO-    , realloc-    , shrinkToFit-    , memcpy-    , memcmp-    , bytesToElemCount--    , unlines-    )-where--import Control.Exception (assert)-import Control.DeepSeq (NFData(..))-import Control.Monad (when, void)-import Control.Monad.IO.Class (MonadIO(..))-import Data.Functor.Identity (runIdentity)-#if __GLASGOW_HASKELL__ < 808-import Data.Semigroup (Semigroup(..))-#endif-import Data.Word (Word8)-import Foreign.C.String (CString)-import Foreign.C.Types (CSize(..), CInt(..))-import Foreign.ForeignPtr (withForeignPtr, touchForeignPtr)-import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)-import Foreign.Ptr (plusPtr, minusPtr, castPtr, nullPtr)-import Foreign.Storable (Storable(..))-import Prelude hiding (length, foldr, read, unlines, splitAt)-import Text.Read (readPrec, readListPrec, readListPrecDefault)--import GHC.Base (Addr#, nullAddr#, realWorld#, build)-import GHC.Exts (IsList, IsString(..))-import GHC.ForeignPtr (ForeignPtr(..), newForeignPtr_)-import GHC.IO (IO(IO), unsafePerformIO)-import GHC.Ptr (Ptr(..))--import Streamly.Internal.Data.Fold.Types (Fold(..))-import Streamly.Internal.Data.Strict (Tuple'(..))-import Streamly.Internal.Data.SVar (adaptState)--#if __GLASGOW_HASKELL__ < 900-#if !defined(mingw32_HOST_OS)-import Streamly.FileSystem.FDIO (IOVec(..))-#endif-#endif--import qualified Streamly.Memory.Malloc as Malloc-import qualified Streamly.Internal.Data.Stream.StreamD.Type as D-import qualified Streamly.Internal.Data.Stream.StreamK as K-import qualified GHC.Exts as Exts--#ifdef DEVBUILD-import qualified Data.Foldable as F-#endif--#if MIN_VERSION_base(4,10,0)-import Foreign.ForeignPtr (plusForeignPtr)-#else-import GHC.Base (Int(..), plusAddr#)-import GHC.ForeignPtr (ForeignPtr(..))-plusForeignPtr :: ForeignPtr a -> Int -> ForeignPtr b-plusForeignPtr (ForeignPtr addr c) (I# d) = ForeignPtr (plusAddr# addr d) c-#endif------------------------------------------------------------------------------------ Design Notes------------------------------------------------------------------------------------ There are two goals that we want to fulfill with arrays.  One, holding large--- amounts of data in non-GC memory and the ability to pass this data to and--- from the operating system without an extra copy overhead. Two, allow random--- access to elements based on their indices. The first one falls in the--- category of storage buffers while the second one falls in the category of--- maps/multisets/hashmaps.------ For the first requirement we use an array of Storables and store it in a--- ForeignPtr. We can have both immutable and mutable variants of this array--- using wrappers over the same underlying type.------ For the second requirement, we need a separate type for arrays of--- polymorphic values, for example vectors of handler functions, lookup tables.--- We can call this type a "vector" in contrast to arrays.  It should not--- require Storable instance for the type. In that case we need to use an--- Array# instead of a ForeignPtr. This type of array would not reduce the GC--- overhead much because each element of the array still needs to be scanned by--- the GC.  However, it can store polymorphic elements and allow random access--- to those.  But in most cases random access means storage, and it means we--- need to avoid GC scanning except in cases of trivially small storage. One--- way to achieve that would be to put the array in a Compact region. However,--- if and when we mutate this, we will have to use a manual GC copying out to--- another CR and freeing the old one.------------------------------------------------------------------------------------ Array Data Type------------------------------------------------------------------------------------ We require that an array stores only Storable. Arrays are used for buffering--- data while streams are used for processing. If you want something to be--- buffered it better be Storable so that we can store it in non-GC memory.------ We can use a "Storable" 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.--- XXX Can this cost be alleviated in GHC-8.10 specialization fix?------ XXX Another way to not require the Storable constraint in array operations--- is to store the elemSize in the array at construction and use that instead--- of using sizeOf. Need to charaterize perf cost of this.------ XXX rename the fields to "start, next, end".----data Array a =-#ifdef DEVBUILD-    Storable a =>-#endif-    Array-    { aStart :: {-# UNPACK #-} !(ForeignPtr a) -- first address-    , aEnd   :: {-# UNPACK #-} !(Ptr a)        -- first unused address-    , aBound :: {-# UNPACK #-} !(Ptr a)        -- first address beyond allocated memory-    }------------------------------------------------------------------------------------ Utility functions----------------------------------------------------------------------------------foreign import ccall unsafe "string.h memcpy" c_memcpy-    :: Ptr Word8 -> Ptr Word8 -> CSize -> IO (Ptr Word8)--foreign import ccall unsafe "string.h strlen" c_strlen-    :: CString -> IO CSize--foreign import ccall unsafe "string.h memchr" c_memchr-    :: Ptr Word8 -> Word8 -> CSize -> IO (Ptr Word8)---- 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))--foreign import ccall unsafe "string.h memcmp" c_memcmp-    :: Ptr Word8 -> Ptr Word8 -> CSize -> IO CInt---- 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--{-# INLINE unsafeInlineIO #-}-unsafeInlineIO :: IO a -> a-unsafeInlineIO (IO m) = case m realWorld# of (# _, r #) -> r--{-# INLINE bytesToElemCount #-}-bytesToElemCount :: Storable a => a -> Int -> Int-bytesToElemCount x n =-    let elemSize = sizeOf x-    in n + elemSize - 1 `div` elemSize------------------------------------------------------------------------------------ Construction------------------------------------------------------------------------------------ | allocate a new array using the provided allocator function.-{-# INLINE newArrayAlignedAllocWith #-}-newArrayAlignedAllocWith :: forall a. Storable a-    => (Int -> Int -> IO (ForeignPtr a)) -> Int -> Int -> IO (Array a)-newArrayAlignedAllocWith alloc alignSize count = do-    let size = count * sizeOf (undefined :: a)-    fptr <- alloc size alignSize-    let p = unsafeForeignPtrToPtr fptr-    return $ Array-        { aStart = fptr-        , aEnd   = p-        , aBound = p `plusPtr` size-        }---- | Allocate a new array aligned to the specified alignmend and using--- unmanaged pinned memory. The memory will not be automatically freed by GHC.--- This could be useful in allocate once global data structures. Use carefully--- as incorrect use can lead to memory leak.-{-# INLINE newArrayAlignedUnmanaged #-}-newArrayAlignedUnmanaged :: forall a. Storable a => Int -> Int -> IO (Array a)-newArrayAlignedUnmanaged =-    newArrayAlignedAllocWith Malloc.mallocForeignPtrAlignedUnmanagedBytes--{-# INLINE newArrayAligned #-}-newArrayAligned :: forall a. Storable a => Int -> Int -> IO (Array a)-newArrayAligned = newArrayAlignedAllocWith Malloc.mallocForeignPtrAlignedBytes---- XXX can unaligned allocation be more efficient when alignment is not needed?------ | Allocate an array that can hold 'count' items.  The memory of the array is--- uninitialized.------ Note that this is internal routine, the reference to this array cannot be--- given out until the array has been written to and frozen.-{-# INLINE newArray #-}-newArray :: forall a. Storable a => Int -> IO (Array a)-newArray = newArrayAligned (alignment (undefined :: a))---- | Allocate an Array of the given size and run an IO action passing the array--- start pointer.-{-# INLINE withNewArray #-}-withNewArray :: forall a. Storable a => Int -> (Ptr a -> IO ()) -> IO (Array a)-withNewArray count f = do-    arr <- newArray count-    withForeignPtr (aStart arr) $ \p -> f p >> return arr---- XXX grow the array when we are beyond bound.------ Internal routine for when the array is being created. Appends one item at--- the end of the array. Useful when sequentially writing a stream to the--- array.-{-# INLINE unsafeSnoc #-}-unsafeSnoc :: forall a. Storable a => Array a -> a -> IO (Array a)-unsafeSnoc arr@Array{..} x = do-    when (aEnd == aBound) $-        error "BUG: unsafeSnoc: writing beyond array bounds"-    poke aEnd x-    touchForeignPtr aStart-    return $ arr {aEnd = aEnd `plusPtr` sizeOf (undefined :: a)}--{-# INLINE snoc #-}-snoc :: forall a. Storable a => Array a -> a -> IO (Array a)-snoc arr@Array {..} x =-    if aEnd == aBound-    then do-        let oldStart = unsafeForeignPtrToPtr aStart-            size = aEnd `minusPtr` oldStart-            newSize = size + sizeOf (undefined :: a)-        newPtr <- Malloc.mallocForeignPtrAlignedBytes-                    newSize (alignment (undefined :: a))-        withForeignPtr newPtr $ \pNew -> do-          memcpy (castPtr pNew) (castPtr oldStart) size-          poke (pNew `plusPtr` size) x-          touchForeignPtr aStart-          return $ Array-              { aStart = newPtr-              , aEnd   = pNew `plusPtr` (size + sizeOf (undefined :: a))-              , aBound = pNew `plusPtr` newSize-              }-    else do-        poke aEnd x-        touchForeignPtr aStart-        return $ arr {aEnd = aEnd `plusPtr` sizeOf (undefined :: a)}---- | Reallocate the array to the specified size in bytes. If the size is less--- than the original array the array gets truncated.-{-# NOINLINE reallocAligned #-}-reallocAligned :: Int -> Int -> Array a -> IO (Array a)-reallocAligned alignSize newSize Array{..} = do-    assert (aEnd <= aBound) (return ())-    let oldStart = unsafeForeignPtrToPtr aStart-    let size = aEnd `minusPtr` oldStart-    newPtr <- Malloc.mallocForeignPtrAlignedBytes newSize alignSize-    withForeignPtr newPtr $ \pNew -> do-        memcpy (castPtr pNew) (castPtr oldStart) size-        touchForeignPtr aStart-        return $ Array-            { aStart = newPtr-            , aEnd   = pNew `plusPtr` size-            , aBound = pNew `plusPtr` newSize-            }---- XXX can unaligned allocation be more efficient when alignment is not needed?-{-# INLINABLE realloc #-}-realloc :: forall a. Storable a => Int -> Array a -> IO (Array a)-realloc = reallocAligned (alignment (undefined :: a))---- | Remove the free space from an Array.-shrinkToFit :: forall a. Storable a => Array a -> IO (Array a)-shrinkToFit arr@Array{..} = do-    assert (aEnd <= aBound) (return ())-    let start = unsafeForeignPtrToPtr aStart-    let used = aEnd `minusPtr` start-        waste = aBound `minusPtr` aEnd-    -- if used == waste == 0 then do not realloc-    -- if the wastage is more than 25% of the array then realloc-    if used < 3 * waste-    then realloc used arr-    else return arr---- XXX when converting an array of Word8 from a literal string we can simply--- refer to the literal string. Is it possible to write rules such that--- fromList Word8 can be rewritten so that GHC does not first convert the--- literal to [Char] and then we convert it back to an Array Word8?------ Note that the address must be a read-only address (meant to be used for--- read-only string literals) because we are sharing it, any modification to--- the original address would change our array. That's why this function is--- unsafe.-{-# INLINE _fromCStringAddrUnsafe #-}-_fromCStringAddrUnsafe :: Addr# -> IO (Array Word8)-_fromCStringAddrUnsafe addr# = do-    ptr <- newForeignPtr_ (castPtr cstr)-    len <- c_strlen cstr-    let n = fromIntegral len-    let p = unsafeForeignPtrToPtr ptr-    let end = p `plusPtr` n-    return $ Array-        { aStart = ptr-        , aEnd   = end-        , aBound = end-        }-  where-    cstr :: CString-    cstr = Ptr addr#------------------------------------------------------------------------------------ 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. Storable a => Array a -> Int -> IO a-unsafeIndexIO Array {..} i =-     withForeignPtr aStart $ \p -> do-        let elemSize = sizeOf (undefined :: a)-            elemOff = p `plusPtr` (elemSize * i)-        assert (i >= 0 && elemOff `plusPtr` elemSize <= aEnd)-               (return ())-        peek elemOff---- | Return element at the specified index without checking the bounds.-{-# INLINE_NORMAL unsafeIndex #-}-unsafeIndex :: forall a. Storable a => Array a -> Int -> a-unsafeIndex arr i = let !r = unsafeInlineIO $ unsafeIndexIO arr i in r---- | /O(1)/ Get the byte length of the array.------ @since 0.7.0-{-# INLINE byteLength #-}-byteLength :: Array a -> Int-byteLength Array{..} =-    let p = unsafeForeignPtrToPtr aStart-        len = aEnd `minusPtr` p-    in assert (len >= 0) len---- | /O(1)/ Get the length of the array i.e. the number of elements in the--- array.------ @since 0.7.0-{-# INLINE length #-}-length :: forall a. Storable a => Array a -> Int-length arr = byteLength arr `div` sizeOf (undefined :: a)--{-# INLINE byteCapacity #-}-byteCapacity :: Array a -> Int-byteCapacity Array{..} =-    let p = unsafeForeignPtrToPtr aStart-        len = aBound `minusPtr` p-    in assert (len >= 0) len--{-# INLINE_NORMAL toStreamD #-}-toStreamD :: forall m a. (Monad m, Storable a) => Array a -> D.Stream m a-toStreamD Array{..} =-    let p = unsafeForeignPtrToPtr aStart-    in D.Stream step p--    where--    {-# INLINE_LATE step #-}-    step _ p | p == aEnd = return D.Stop-    step _ 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 $ do-                    r <- peek p-                    touchForeignPtr aStart-                    return r-        return $ D.Yield x (p `plusPtr` sizeOf (undefined :: a))--{-# INLINE toStreamK #-}-toStreamK :: forall t m a. (K.IsStream t, Storable a) => Array a -> t m a-toStreamK Array{..} =-    let p = unsafeForeignPtrToPtr aStart-    in go p--    where--    go p | p == aEnd = K.nil-         | otherwise =-        -- See Note in toStreamD.-        let !x = unsafeInlineIO $ do-                    r <- peek p-                    touchForeignPtr aStart-                    return r-        in x `K.cons` go (p `plusPtr` sizeOf (undefined :: a))--{-# INLINE_NORMAL toStreamDRev #-}-toStreamDRev :: forall m a. (Monad m, Storable a) => Array a -> D.Stream m a-toStreamDRev Array{..} =-    let p = aEnd `plusPtr` negate (sizeOf (undefined :: a))-    in D.Stream step p--    where--    {-# INLINE_LATE step #-}-    step _ p | p < unsafeForeignPtrToPtr aStart = return D.Stop-    step _ p = do-        -- See comments in toStreamD for why we use unsafeInlineIO-        let !x = unsafeInlineIO $ do-                    r <- peek p-                    touchForeignPtr aStart-                    return r-        return $ D.Yield x (p `plusPtr` negate (sizeOf (undefined :: a)))--{-# INLINE toStreamKRev #-}-toStreamKRev :: forall t m a. (K.IsStream t, Storable a) => Array a -> t m a-toStreamKRev Array {..} =-    let p = aEnd `plusPtr` negate (sizeOf (undefined :: a))-    in go p--    where--    go p | p < unsafeForeignPtrToPtr aStart = K.nil-         | otherwise =-        let !x = unsafeInlineIO $ do-                    r <- peek p-                    touchForeignPtr aStart-                    return r-        in x `K.cons` go (p `plusPtr` negate (sizeOf (undefined :: a)))--{-# INLINE_NORMAL foldl' #-}-foldl' :: forall a b. Storable a => (b -> a -> b) -> b -> Array a -> b-foldl' f z arr = runIdentity $ D.foldl' f z $ toStreamD arr--{-# INLINE_NORMAL foldr #-}-foldr :: Storable a => (a -> b -> b) -> b -> Array a -> b-foldr f z arr = runIdentity $ D.foldr f z $ toStreamD arr------------------------------------------------------------------------------------ Instances----------------------------------------------------------------------------------{-# INLINE_NORMAL writeNAllocWith #-}-writeNAllocWith :: forall m a. (MonadIO m, Storable a)-    => (Int -> IO (Array a)) -> Int -> Fold m a (Array a)-writeNAllocWith alloc n = Fold step initial extract--    where--    initial = liftIO $ alloc (max n 0)-    step arr@(Array _ end bound) _ | end == bound = return arr-    step (Array start end bound) x = do-        liftIO $ poke end x-        return $ Array start (end `plusPtr` sizeOf (undefined :: a)) bound-    -- XXX note that shirkToFit does not maintain alignment, in case we are-    -- using aligned allocation.-    extract = return -- liftIO . shrinkToFit---- | @writeN n@ folds a maximum of @n@ elements from the input stream to an--- 'Array'.------ @since 0.7.0-{-# INLINE_NORMAL writeN #-}-writeN :: forall m a. (MonadIO m, Storable a) => Int -> Fold m a (Array a)-writeN = writeNAllocWith newArray---- | @writeNAligned alignment n@ folds a maximum of @n@ elements from the input--- stream to an 'Array' aligned to the given size.------ /Internal/----{-# INLINE_NORMAL writeNAligned #-}-writeNAligned :: forall m a. (MonadIO m, Storable a)-    => Int -> Int -> Fold m a (Array a)-writeNAligned alignSize = writeNAllocWith (newArrayAligned alignSize)---- | @writeNAlignedUnmanaged n@ folds a maximum of @n@ elements from the input--- stream to an 'Array' aligned to the given size and using unmanaged memory.--- This could be useful to allocate memory that we need to allocate only once--- in the lifetime of the program.------ /Internal/----{-# INLINE_NORMAL writeNAlignedUnmanaged #-}-writeNAlignedUnmanaged :: forall m a. (MonadIO m, Storable a)-    => Int -> Int -> Fold m a (Array a)-writeNAlignedUnmanaged alignSize =-    writeNAllocWith (newArrayAlignedUnmanaged alignSize)--data ArrayUnsafe a = ArrayUnsafe-    {-# UNPACK #-} !(ForeignPtr a) -- first address-    {-# UNPACK #-} !(Ptr a)        -- first unused address---- | 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.------ @since 0.7.0-{-# INLINE_NORMAL writeNUnsafe #-}-writeNUnsafe :: forall m a. (MonadIO m, Storable a)-    => Int -> Fold m a (Array a)-writeNUnsafe n = Fold step initial extract--    where--    initial = do-        (Array start end _) <- liftIO $ newArray (max n 0)-        return $ ArrayUnsafe start end-    step (ArrayUnsafe start end) x = do-        liftIO $ poke end x-        return $ ArrayUnsafe start (end `plusPtr` sizeOf (undefined :: a))-    extract (ArrayUnsafe start end) = return $ Array start end end -- liftIO . shrinkToFit---- 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 seems 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.--{-# INLINE_NORMAL toArrayMinChunk #-}-toArrayMinChunk :: forall m a. (MonadIO m, Storable a)-    => Int -> Int -> Fold m a (Array a)--- toArrayMinChunk n = FL.mapM spliceArrays $ toArraysOf n-toArrayMinChunk alignSize elemCount = Fold step initial extract--    where--    insertElem (Array start end bound) x = do-        liftIO $ poke end x-        return $ Array start (end `plusPtr` sizeOf (undefined :: a)) bound--    initial = do-        when (elemCount < 0) $ error "toArrayMinChunk: elemCount is negative"-        liftIO $ newArrayAligned alignSize elemCount-    step arr@(Array start end bound) x | end == bound = do-        let p = unsafeForeignPtrToPtr start-            oldSize = end `minusPtr` p-            newSize = max (oldSize * 2) 1-        arr1 <- liftIO $ reallocAligned alignSize newSize arr-        insertElem arr1 x-    step arr x = insertElem arr x-    extract = liftIO . shrinkToFit---- | Fold the whole input to a single array.------ /Caution! Do not use this on infinite streams./------ @since 0.7.0-{-# INLINE write #-}-write :: forall m a. (MonadIO m, Storable a) => Fold m a (Array a)-write = toArrayMinChunk (alignment (undefined :: a))-                        (bytesToElemCount (undefined :: a)-                        (mkChunkSize 1024))---- | Like 'write' but the array memory is aligned according to the specified--- alignment size. This could be useful when we have specific alignment, for--- example, cache aligned arrays for lookup table etc.------ /Caution! Do not use this on infinite streams./------ @since 0.7.0-{-# INLINE writeAligned #-}-writeAligned :: forall m a. (MonadIO m, Storable a)-    => Int -> Fold m a (Array a)-writeAligned alignSize =-    toArrayMinChunk alignSize-                    (bytesToElemCount (undefined :: a)-                    (mkChunkSize 1024))--{-# INLINE_NORMAL fromStreamDN #-}-fromStreamDN :: forall m a. (MonadIO m, Storable a)-    => Int -> D.Stream m a -> m (Array a)-fromStreamDN limit str = do-    arr <- liftIO $ newArray limit-    end <- D.foldlM' fwrite (aEnd arr) $ D.take limit str-    return $ arr {aEnd = end}--    where--    fwrite ptr x = do-        liftIO $ poke ptr x-        return $ ptr `plusPtr` sizeOf (undefined :: a)--data GroupState s start end bound-    = GroupStart s-    | GroupBuffer s start end bound-    | GroupYield start end bound (GroupState s start end bound)-    | GroupFinish---- | @fromStreamArraysOf n stream@ groups the input stream into a stream of--- arrays of size n.-{-# INLINE_NORMAL fromStreamDArraysOf #-}-fromStreamDArraysOf :: forall m a. (MonadIO m, Storable a)-    => Int -> D.Stream m a -> D.Stream m (Array a)--- fromStreamDArraysOf n str = D.groupsOf n (writeN n) str-fromStreamDArraysOf 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.Memory.Array.Types.fromStreamDArraysOf: the size of "-                 ++ "arrays [" ++ show n ++ "] must be a natural number"-        Array start end bound <- liftIO $ newArray n-        return $ D.Skip (GroupBuffer st start end bound)--    step' gst (GroupBuffer st start end bound) = do-        r <- step (adaptState gst) st-        case r of-            D.Yield x s -> do-                liftIO $ poke end x-                let end' = end `plusPtr` sizeOf (undefined :: a)-                return $-                    if end' >= bound-                    then D.Skip (GroupYield start end' bound (GroupStart s))-                    else D.Skip (GroupBuffer s start end' bound)-            D.Skip s -> return $ D.Skip (GroupBuffer s start end bound)-            D.Stop -> return $ D.Skip (GroupYield start end bound GroupFinish)--    step' _ (GroupYield start end bound next) =-        return $ D.Yield (Array start end bound) next--    step' _ GroupFinish = return D.Stop---- XXX concatMap does not seem to have the best possible performance so we have--- a custom way to concat arrays.-data FlattenState s a =-      OuterLoop s-    | InnerLoop s !(ForeignPtr a) !(Ptr a) !(Ptr a)--{-# INLINE_NORMAL flattenArrays #-}-flattenArrays :: forall m a. (MonadIO m, Storable a)-    => D.Stream m (Array 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 Array{..} s ->-                let p = unsafeForeignPtrToPtr aStart-                in D.Skip (InnerLoop s aStart p aEnd)-            D.Skip s -> D.Skip (OuterLoop s)-            D.Stop -> D.Stop--    step' _ (InnerLoop st _ p end) | p == end =-        return $ D.Skip $ OuterLoop st--    step' _ (InnerLoop st startf p end) = do-        x <- liftIO $ do-                    r <- peek p-                    touchForeignPtr startf-                    return r-        return $ D.Yield x (InnerLoop st startf-                            (p `plusPtr` sizeOf (undefined :: a)) end)--{-# INLINE_NORMAL flattenArraysRev #-}-flattenArraysRev :: forall m a. (MonadIO m, Storable a)-    => D.Stream m (Array 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 Array{..} s ->-                let p = aEnd `plusPtr` negate (sizeOf (undefined :: a))-                -- XXX we do not need aEnd-                in D.Skip (InnerLoop s aStart p aEnd)-            D.Skip s -> D.Skip (OuterLoop s)-            D.Stop -> D.Stop--    step' _ (InnerLoop st start p _) | p < unsafeForeignPtrToPtr start =-        return $ D.Skip $ OuterLoop st--    step' _ (InnerLoop st startf p end) = do-        x <- liftIO $ do-                    r <- peek p-                    touchForeignPtr startf-                    return r-        return $ D.Yield x (InnerLoop st startf-                            (p `plusPtr` negate (sizeOf (undefined :: a))) end)---- 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.------ 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.----{-# INLINE fromStreamD #-}-fromStreamD :: (MonadIO m, Storable a) => D.Stream m a -> m (Array a)-fromStreamD m = do-    let s = fromStreamDArraysOf defaultChunkSize m-    buffered <- D.foldr K.cons K.nil s-    len <- K.foldl' (+) 0 (K.map length buffered)-    fromStreamDN len $ flattenArrays $ D.fromStreamK buffered-{--fromStreamD m = runFold write m-    where-    runFold (Fold step begin done) = D.foldlMx' step begin done--}---- 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. Storable a => (a -> b -> b) -> b -> Array a -> b-toListFB c n Array{..} = go (unsafeForeignPtrToPtr aStart)-    where--    go p | p == aEnd = 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.-        let !x = unsafeInlineIO $ do-                    r <- peek p-                    touchForeignPtr aStart-                    return r-        in c x (go (p `plusPtr` sizeOf (undefined :: a)))---- | Convert an 'Array' into a list.------ @since 0.7.0-{-# INLINE toList #-}-toList :: Storable a => Array a -> [a]-toList s = build (\c n -> toListFB c n s)--instance (Show a, Storable a) => Show (Array a) where-    {-# INLINE showsPrec #-}-    showsPrec _ = shows . toList---- | 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.------ @since 0.7.0-{-# INLINABLE fromListN #-}-fromListN :: Storable a => Int -> [a] -> Array a-fromListN n xs = unsafePerformIO $ fromStreamDN n $ D.fromList xs---- | Create an 'Array' from a list. The list must be of finite size.------ @since 0.7.0-{-# INLINABLE fromList #-}-fromList :: Storable a => [a] -> Array a-fromList xs = unsafePerformIO $ fromStreamD $ D.fromList xs--instance (Storable a, Read a, Show a) => Read (Array a) where-    {-# INLINE readPrec #-}-    readPrec = fromList <$> readPrec-    readListPrec = readListPrecDefault--instance (a ~ Char) => IsString (Array a) where-    {-# INLINE fromString #-}-    fromString = fromList---- GHC versions 8.0 and below cannot derive IsList-instance Storable a => IsList (Array a) where-    type (Item (Array a)) = a-    {-# INLINE fromList #-}-    fromList = fromList-    {-# INLINE fromListN #-}-    fromListN = fromListN-    {-# INLINE toList #-}-    toList = toList--{-# INLINE arrcmp #-}-arrcmp :: Array a -> Array a -> Bool-arrcmp arr1 arr2 =-    let !res = unsafeInlineIO $ do-            let ptr1 = unsafeForeignPtrToPtr $ aStart arr1-            let ptr2 = unsafeForeignPtrToPtr $ aStart arr2-            let len1 = aEnd arr1 `minusPtr` ptr1-            let len2 = aEnd arr2 `minusPtr` ptr2--            if len1 == len2-            then do-                r <- memcmp (castPtr ptr1) (castPtr ptr2) len1-                touchForeignPtr $ aStart arr1-                touchForeignPtr $ aStart arr2-                return r-            else return False-    in res---- XXX we are assuming that Storable equality means element equality. This may--- or may not be correct? arrcmp is 40% faster compared to stream equality.-instance (Storable a, Eq a) => Eq (Array a) where-    {-# INLINE (==) #-}-    (==) = arrcmp-    -- arr1 == arr2 = runIdentity $ D.eqBy (==) (toStreamD arr1) (toStreamD arr2)--instance (Storable a, NFData a) => NFData (Array a) where-    {-# INLINE rnf #-}-    rnf = foldl' (\_ x -> rnf x) ()--instance (Storable a, Ord a) => Ord (Array a) where-    {-# INLINE compare #-}-    compare arr1 arr2 = unsafePerformIO $-        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 Storable 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{..} =-    let p = unsafeForeignPtrToPtr aStart-    in D.Stream step p--    where--    {-# INLINE_LATE step #-}-    step _ p | p == aEnd = return D.Stop-    step _ p = do-        x <- liftIO $ do-                    r <- peek p-                    touchForeignPtr aStart-                    return r-        return $ D.Yield x (p `plusPtr` size)--{-# INLINE_NORMAL _foldr #-}-_foldr :: forall a b. (a -> b -> b) -> b -> Array a -> b-_foldr f z arr@Array {..} =-    let !n = sizeOf (undefined :: 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------------------------------------------------------------------------------------ Splice two immutable arrays creating a new array.-{-# INLINE spliceTwo #-}-spliceTwo :: (MonadIO m, Storable a) => Array a -> Array a -> m (Array a)-spliceTwo arr1 arr2 = do-    let src1 = unsafeForeignPtrToPtr (aStart arr1)-        src2 = unsafeForeignPtrToPtr (aStart arr2)-        len1 = aEnd arr1 `minusPtr` src1-        len2 = aEnd arr2 `minusPtr` src2--    arr <- liftIO $ newArray (len1 + len2)-    let dst = unsafeForeignPtrToPtr (aStart arr)--    -- XXX Should we use copyMutableByteArray# instead? Is there an overhead to-    -- ccall?-    liftIO $ do-        memcpy (castPtr dst) (castPtr src1) len1-        touchForeignPtr (aStart arr1)-        memcpy (castPtr (dst `plusPtr` len1)) (castPtr src2) len2-        touchForeignPtr (aStart arr2)-    return arr { aEnd = dst `plusPtr` (len1 + len2) }--instance Storable a => Semigroup (Array a) where-    arr1 <> arr2 = unsafePerformIO $ spliceTwo arr1 arr2--nullForeignPtr :: ForeignPtr a-nullForeignPtr = ForeignPtr nullAddr# (error "nullForeignPtr")--nil ::-#ifdef DEVBUILD-    Storable a =>-#endif-    Array a-nil = Array nullForeignPtr (Ptr nullAddr#) (Ptr nullAddr#)--instance Storable a => Monoid (Array a) where-    mempty = nil-    mappend = (<>)------------------------------------------------------------------------------------ IO------------------------------------------------------------------------------------ | GHC memory management allocation header overhead-allocOverhead :: Int-allocOverhead = 2 * sizeOf (undefined :: Int)--mkChunkSize :: Int -> Int-mkChunkSize n = let size = n - allocOverhead in max size 0--mkChunkSizeKB :: Int -> Int-mkChunkSizeKB n = mkChunkSize (n * k)-   where k = 1024---- | 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 = mkChunkSizeKB 32--{-# INLINE_NORMAL unlines #-}-unlines :: forall m a. (MonadIO m, Storable 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 ->-                let p = unsafeForeignPtrToPtr aStart-                in D.Skip (InnerLoop s aStart p aEnd)-            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 startf p end) = do-        x <- liftIO $ do-                    r <- peek p-                    touchForeignPtr startf-                    return r-        return $ D.Yield x (InnerLoop st startf-                            (p `plusPtr` sizeOf (undefined :: a)) end)---- Splice an array into a pre-reserved mutable array.  The user must ensure--- that there is enough space in the mutable array.-{-# INLINE spliceWith #-}-spliceWith :: (MonadIO m) => Array a -> Array a -> m (Array a)-spliceWith dst@(Array _ end bound) src  = liftIO $ do-    let srcLen = byteLength src-    if end `plusPtr` srcLen > bound-    then error "Bug: spliceIntoUnsafe: Not enough space in the target array"-    else-        withForeignPtr (aStart dst) $ \_ ->-            withForeignPtr (aStart src) $ \psrc -> do-                let pdst = aEnd dst-                memcpy (castPtr pdst) (castPtr psrc) srcLen-                return $ dst { aEnd = pdst `plusPtr` srcLen }---- Splice a new array into a preallocated mutable array, doubling the space if--- there is no space in the target array.-{-# INLINE spliceWithDoubling #-}-spliceWithDoubling :: (MonadIO m, Storable a)-    => Array a -> Array a -> m (Array a)-spliceWithDoubling dst@(Array start end bound) src  = do-    assert (end <= bound) (return ())-    let srcLen = aEnd src `minusPtr` unsafeForeignPtrToPtr (aStart src)--    dst1 <--        if end `plusPtr` srcLen >= bound-        then do-            let oldStart = unsafeForeignPtrToPtr start-                oldSize = end `minusPtr` oldStart-                newSize = max (oldSize * 2) (oldSize + srcLen)-            liftIO $ realloc newSize dst-        else return dst-    spliceWith dst1 src--data SpliceState s arr-    = SpliceInitial s-    | SpliceBuffering s arr-    | SpliceYielding arr (SpliceState s arr)-    | SpliceFinish---- XXX can use general grouping combinators to achieve this?--- | 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, Storable a)-    => Int -> D.Stream m (Array a) -> D.Stream m (Array 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.Memory.Array.Types.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 = 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 = byteLength buf + byteLength arr-                if len > n-                then return $-                    D.Skip (SpliceYielding buf (SpliceBuffering s arr))-                else do-                    buf' <- if byteCapacity buf < n-                            then liftIO $ realloc n buf-                            else return buf-                    buf'' <- spliceWith 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 instead of writing two different versions of this operation, we should--- write it as a pipe.-{-# INLINE_NORMAL lpackArraysChunksOf #-}-lpackArraysChunksOf :: (MonadIO m, Storable a)-    => Int -> Fold m (Array a) () -> Fold m (Array 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.Memory.Array.Types.packArraysChunksOf: the size of "-                 ++ "arrays [" ++ show n ++ "] must be a natural number"-        r1 <- initial1-        return (Tuple' Nothing r1)--    extract (Tuple' Nothing r1) = extract1 r1-    extract (Tuple' (Just buf) r1) = do-        r <- step1 r1 buf-        extract1 r--    step (Tuple' Nothing r1) arr =-            let len = byteLength arr-             in if len >= n-                then do-                    r <- step1 r1 arr-                    extract1 r-                    r1' <- initial1-                    return (Tuple' Nothing r1')-                else return (Tuple' (Just arr) r1)--    step (Tuple' (Just buf) r1) arr = do-            let len = byteLength buf + byteLength arr-            buf' <- if byteCapacity buf < len-                    then liftIO $ realloc (max n len) buf-                    else return buf-            buf'' <- spliceWith buf' arr--            if len >= n-            then do-                r <- step1 r1 buf''-                extract1 r-                r1' <- initial1-                return (Tuple' Nothing r1')-            else return (Tuple' (Just buf'') r1)--#if __GLASGOW_HASKELL__ < 900-#if !defined(mingw32_HOST_OS)-data GatherState s arr-    = GatherInitial s-    | GatherBuffering s arr Int-    | GatherYielding arr (GatherState s arr)-    | GatherFinish---- | @groupIOVecsOf maxBytes maxEntries@ groups arrays in the incoming stream--- to create a stream of 'IOVec' arrays with a maximum of @maxBytes@ bytes in--- each array and a maximum of @maxEntries@ entries in each array.------ @since 0.7.0-{-# INLINE_NORMAL groupIOVecsOf #-}-groupIOVecsOf :: MonadIO m-    => Int -> Int -> D.Stream m (Array a) -> D.Stream m (Array IOVec)-groupIOVecsOf n maxIOVLen (D.Stream step state) =-    D.Stream step' (GatherInitial state)--    where--    {-# INLINE_LATE step' #-}-    step' gst (GatherInitial st) = do-        when (n <= 0) $-            -- XXX we can pass the module string from the higher level API-            error $ "Streamly.Internal.Memory.Array.Types.groupIOVecsOf: the size of "-                 ++ "groups [" ++ show n ++ "] must be a natural number"-        when (maxIOVLen <= 0) $-            -- XXX we can pass the module string from the higher level API-            error $ "Streamly.Internal.Memory.Array.Types.groupIOVecsOf: the number of "-                 ++ "IOVec entries [" ++ show n ++ "] must be a natural number"-        r <- step (adaptState gst) st-        case r of-            D.Yield arr s -> do-                let p = unsafeForeignPtrToPtr (aStart arr)-                    len = byteLength arr-                iov <- liftIO $ newArray maxIOVLen-                iov' <- liftIO $ unsafeSnoc iov (IOVec (castPtr p)-                                                (fromIntegral len))-                if len >= n-                then return $ D.Skip (GatherYielding iov' (GatherInitial s))-                else return $ D.Skip (GatherBuffering s iov' len)-            D.Skip s -> return $ D.Skip (GatherInitial s)-            D.Stop -> return D.Stop--    step' gst (GatherBuffering st iov len) = do-        r <- step (adaptState gst) st-        case r of-            D.Yield arr s -> do-                let p = unsafeForeignPtrToPtr (aStart arr)-                    alen = byteLength arr-                    len' = len + alen-                if len' > n || length iov >= maxIOVLen-                then do-                    iov' <- liftIO $ newArray maxIOVLen-                    iov'' <- liftIO $ unsafeSnoc iov' (IOVec (castPtr p)-                                                      (fromIntegral alen))-                    return $ D.Skip (GatherYielding iov-                                        (GatherBuffering s iov'' alen))-                else do-                    iov' <- liftIO $ unsafeSnoc iov (IOVec (castPtr p)-                                                    (fromIntegral alen))-                    return $ D.Skip (GatherBuffering s iov' len')-            D.Skip s -> return $ D.Skip (GatherBuffering s iov len)-            D.Stop -> return $ D.Skip (GatherYielding iov GatherFinish)--    step' _ GatherFinish = return D.Stop--    step' _ (GatherYielding iov next) = return $ D.Yield iov next-#endif-#endif---- | Create two slices of an array without copying the original array. The--- specified index @i@ is the first index of the second slice.------ @since 0.7.0-splitAt :: forall a. Storable a => Int -> Array a -> (Array a, Array a)-splitAt i arr@Array{..} =-    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 * sizeOf (undefined :: a)-                      p = unsafeForeignPtrToPtr aStart `plusPtr` off-                in ( Array-                  { aStart = aStart-                  , aEnd = p-                  , aBound = p-                  }-                , Array-                  { aStart = aStart `plusForeignPtr` off-                  , aEnd = aEnd-                  , aBound = aBound-                  }-                )---- Drops the separator byte-{-# INLINE breakOn #-}-breakOn :: MonadIO m-    => Word8 -> Array Word8 -> m (Array Word8, Maybe (Array Word8))-breakOn sep arr@Array{..} = liftIO $ do-    let p = unsafeForeignPtrToPtr aStart-    loc <- c_memchr p sep (fromIntegral $ aEnd `minusPtr` p)-    return $-        if loc == nullPtr-        then (arr, Nothing)-        else-            ( Array-                { aStart = aStart-                , aEnd = loc-                , aBound = loc-                }-            , Just $ Array-                    { aStart = aStart `plusForeignPtr` (loc `minusPtr` p + 1)-                    , aEnd = aEnd-                    , aBound = aBound-                    }-            )--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) <- 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) <- breakOn byte arr-                buf' <- spliceTwo 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 byteLength buf == 0-                then D.Stop-                else D.Skip (Yielding buf Finishing)--    step' _ (Splitting st buf) = do-        (arr1, marr2) <- 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
− src/Streamly/Internal/Memory/ArrayStream.hs 
@@ -1,221 +0,0 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE RecordWildCards     #-}-{-# LANGUAGE ScopedTypeVariables #-}--#include "inline.hs"---- |--- Module      : Streamly.Internal.Memory.ArrayStream--- Copyright   : (c) 2019 Composewell Technologies------ License     : BSD3--- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC------ Combinators to efficiently manipulate streams of arrays.----module Streamly.Internal.Memory.ArrayStream-    (-    -- * Creation-      arraysOf--    -- * Flattening to elements-    , concat-    , concatRev-    , interpose-    , interposeSuffix-    , intercalateSuffix--    -- * Transformation-    , splitOn-    , splitOnSuffix-    , compact -- compact--    -- * Elimination-    , toArray-    )-where--import Control.Monad.IO.Class (MonadIO(..))--- import Data.Functor.Identity (Identity)-import Data.Word (Word8)-import Foreign.ForeignPtr (withForeignPtr)-import Foreign.Ptr (minusPtr, plusPtr, castPtr)-import Foreign.Storable (Storable(..))-import Prelude hiding (length, null, last, map, (!!), read, concat)--import Streamly.Internal.Memory.Array.Types (Array(..), length)-import Streamly.Internal.Data.Stream.Serial (SerialT)-import Streamly.Internal.Data.Stream.StreamK.Type (IsStream)--import qualified Streamly.Internal.Memory.Array as A-import qualified Streamly.Internal.Memory.Array.Types as A-import qualified Streamly.Internal.Prelude as S-import qualified Streamly.Internal.Data.Stream.StreamD as D-import qualified Streamly.Internal.Data.Stream.Prelude as P---- 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 but more efficient:------ > concat = S.concatMap A.read------ @since 0.7.0-{-# INLINE concat #-}-concat :: (IsStream t, MonadIO m, Storable a) => t m (Array a) -> t m a--- concat m = D.fromStreamD $ A.flattenArrays (D.toStreamD m)--- concat m = D.fromStreamD $ D.concatMap A.toStreamD (D.toStreamD m)-concat m = D.fromStreamD $ D.concatMapU A.read (D.toStreamD m)---- XXX should we have a reverseArrays API to reverse the stream of arrays--- instead?------ | Convert a stream of arrays into a stream of their elements reversing the--- contents of each array before flattening.------ @since 0.7.0-{-# INLINE concatRev #-}-concatRev :: (IsStream t, MonadIO m, Storable a) => t m (Array a) -> t m a-concatRev m = D.fromStreamD $ A.flattenArraysRev (D.toStreamD m)---- | Flatten a stream of arrays after inserting the given element between--- arrays.------ /Internal/-{-# INLINE interpose #-}-interpose :: (MonadIO m, IsStream t, Storable a) => a -> t m (Array a) -> t m a-interpose x = S.interpose x A.read--{-# INLINE intercalateSuffix #-}-intercalateSuffix :: (MonadIO m, IsStream t, Storable a)-    => Array a -> t m (Array a) -> t m a-intercalateSuffix arr = S.intercalateSuffix arr A.read---- | Flatten a stream of arrays appending the given element after each--- array.------ @since 0.7.0-{-# INLINE interposeSuffix #-}-interposeSuffix :: (MonadIO m, IsStream t, Storable a)-    => a -> t m (Array a) -> t m a--- interposeSuffix x = D.fromStreamD . A.unlines x . D.toStreamD-interposeSuffix x = S.interposeSuffix x A.read---- | 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-    :: (IsStream t, MonadIO m)-    => Word8-    -> t m (Array Word8)-    -> t m (Array Word8)-splitOn byte s =-    D.fromStreamD $ D.splitInnerBy (A.breakOn byte) A.spliceTwo $ D.toStreamD s--{-# INLINE splitOnSuffix #-}-splitOnSuffix-    :: (IsStream t, MonadIO m)-    => Word8-    -> t m (Array Word8)-    -> t m (Array Word8)--- splitOn byte s = D.fromStreamD $ A.splitOn byte $ D.toStreamD s-splitOnSuffix byte s =-    D.fromStreamD $ D.splitInnerBySuffix (A.breakOn byte) A.spliceTwo $ D.toStreamD s---- | 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, Storable a)-    => Int -> SerialT m (Array a) -> SerialT m (Array a)-compact n xs = D.fromStreamD $ A.packArraysChunksOf n (D.toStreamD xs)---- | @arraysOf n stream@ groups the elements in the input stream into arrays of--- @n@ elements each.------ Same as the following but more efficient:------ > arraysOf n = S.chunksOf n (A.writeN n)------ @since 0.7.0-{-# INLINE arraysOf #-}-arraysOf :: (IsStream t, MonadIO m, Storable a)-    => Int -> t m a -> t m (Array a)-arraysOf n str =-    D.fromStreamD $ A.fromStreamDArraysOf n (D.toStreamD str)---- 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, Storable a)-    => Int -> SerialT m (Array a) -> m (Array a)-spliceArraysLenUnsafe len buffered = do-    arr <- liftIO $ A.newArray len-    end <- S.foldlM' writeArr (aEnd arr) buffered-    return $ arr {aEnd = end}--    where--    writeArr dst Array{..} =-        liftIO $ withForeignPtr aStart $ \src -> do-                        let count = aEnd `minusPtr` src-                        A.memcpy (castPtr dst) (castPtr src) count-                        return $ dst `plusPtr` count--{-# INLINE _spliceArraysBuffered #-}-_spliceArraysBuffered :: (MonadIO m, Storable a)-    => SerialT m (Array a) -> m (Array a)-_spliceArraysBuffered s = do-    buffered <- P.foldr S.cons S.nil s-    len <- S.sum (S.map length buffered)-    spliceArraysLenUnsafe len s--{-# INLINE spliceArraysRealloced #-}-spliceArraysRealloced :: forall m a. (MonadIO m, Storable a)-    => SerialT m (Array a) -> m (Array a)-spliceArraysRealloced s = do-    idst <- liftIO $ A.newArray (A.bytesToElemCount (undefined :: a)-                                (A.mkChunkSizeKB 4))--    arr <- S.foldlM' A.spliceWithDoubling idst s-    liftIO $ A.shrinkToFit arr---- | 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, Storable a) => SerialT 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 :: (IsStream t, MonadIO m, Storable 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, Storable a)-    => Int -> Fold m a (SerialT Identity (Array a))-_toArraysOf n = FL.lchunksOf n (A.writeNF n) FL.toStream--}
− src/Streamly/Internal/Memory/Unicode/Array.hs 
@@ -1,86 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}---- |--- Module      : Streamly.Memory.Internal.Unicode.Array--- Copyright   : (c) 2018 Composewell Technologies------ License     : BSD3--- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC----module Streamly.Internal.Memory.Unicode.Array-    (-    -- * Streams of Strings-      lines-    , words-    , unlines-    , unwords-    )-where--import Control.Monad.IO.Class (MonadIO)-import Streamly (IsStream, MonadAsync)-import Prelude hiding (String, lines, words, unlines, unwords)-import Streamly.Memory.Array (Array)--import qualified Streamly.Internal.Data.Unicode.Stream as S-import qualified Streamly.Memory.Array as A---- | Break a string up into a stream of strings at newline characters.--- The resulting strings do not contain newlines.------ > lines = S.lines A.write------ >>> S.toList $ lines $ S.fromList "lines\nthis\nstring\n\n\n"--- ["lines","this","string","",""]----{-# INLINE lines #-}-lines :: (MonadIO m, IsStream t) => t m Char -> t 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------ >>> S.toList $ words $ S.fromList "A  newline\nis considered white space?"--- ["A", "newline", "is", "considered", "white", "space?"]----{-# INLINE words #-}-words :: (MonadIO m, IsStream t) => t m Char -> t 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'.------ >>> S.toList $ unlines $ S.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, IsStream t) => t m (Array Char) -> t m Char-unlines = S.unlines A.read---- | Flattens the stream of @Array Char@, after appending a separating--- space to each string.------ 'unwords' is an inverse operation to 'words'.------ >>> S.toList $ unwords $ S.fromList ["unwords", "this", "string"]--- "unwords this string"------ > unwords = S.unwords A.read------ Note that, in general------ > unwords . words /= id-{-# INLINE unwords #-}-unwords :: (MonadAsync m, IsStream t) => t m (Array Char) -> t m Char-unwords = S.unwords A.read
− src/Streamly/Internal/Mutable/Prim/Var.hs 
@@ -1,88 +0,0 @@-{-# LANGUAGE ConstraintKinds     #-}-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE MagicHash           #-}-{-# LANGUAGE UnboxedTuples       #-}-{-# LANGUAGE ScopedTypeVariables #-}--#include "inline.hs"---- |--- Module      : Streamly.Internal.Mutable.Prim.Var--- Copyright   : (c) 2019 Composewell Technologies------ License     : BSD3--- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC------ A mutable variable in a mutation capable monad (IO/ST) holding a 'Prim'--- 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 'Var' 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.Mutable.Prim.Var-    (-      Var-    , MonadMut-    , Prim--    -- * Construction-    , newVar--    -- * Write-    , writeVar-    , modifyVar'--    -- * Read-    , readVar-    )-where--import Control.Monad.Primitive (PrimMonad(..), primitive_)-import Data.Primitive.Types (Prim, sizeOf#, readByteArray#, writeByteArray#)-import GHC.Exts (MutableByteArray#, newByteArray#)---- | A 'Var' holds a single 'Prim' value.-data Var m a = Var (MutableByteArray# (PrimState m))---- The name PrimMonad does not give a clue what it means, an explicit "Mut"--- suffix provides a better hint. MonadMut is just a generalization of MonadIO.------ | A monad that allows mutable operations using a state token.-type MonadMut = PrimMonad---- | Create a new mutable variable.-{-# INLINE newVar #-}-newVar :: forall m a. (MonadMut m, Prim a) => a -> m (Var m a)-newVar x = primitive (\s# ->-      case newByteArray# (sizeOf# (undefined :: a)) s# of-        (# s1#, arr# #) ->-            case writeByteArray# arr# 0# x s1# of-                s2# -> (# s2#, Var arr# #)-    )---- | Write a value to a mutable variable.-{-# INLINE writeVar #-}-writeVar :: (MonadMut m, Prim a) => Var m a -> a -> m ()-writeVar (Var arr#) x = primitive_ (writeByteArray# arr# 0# x)---- | Read a value from a variable.-{-# INLINE readVar #-}-readVar :: (MonadMut m, Prim a) => Var m a -> m a-readVar (Var arr#) = primitive (readByteArray# arr# 0#)---- | Modify the value of a mutable variable using a function with strict--- application.-{-# INLINE modifyVar' #-}-modifyVar' :: (MonadMut m, Prim a) => Var m a -> (a -> a) -> m ()-modifyVar' (Var arr#) g = primitive_ $ \s# ->-  case readByteArray# arr# 0# s# of-    (# s'#, a #) -> let a' = g a in a' `seq` writeByteArray# arr# 0# a' s'#
src/Streamly/Internal/Network/Inet/TCP.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE CPP              #-}-{-# LANGUAGE FlexibleContexts #-}- #include "inline.hs"  -- |@@ -62,16 +59,16 @@     -- , writeUtf8ByLines     -- , writeByFrames     , writeWithBufferOf-    , fromBytes-    , fromBytesWithBufferOf+    , putBytes+    , putBytesWithBufferOf      -- -- * Array Write     -- , writeArray     , writeChunks-    , fromChunks+    , putChunks      -- ** Transformation-    , transformBytesWith+    , processBytes     {-     -- ** Sink Servers @@ -96,6 +93,7 @@     ) where +import Control.Exception (onException) import Control.Monad.Catch (MonadCatch, MonadMask, bracket) import Control.Monad.IO.Class (MonadIO(..)) import Data.Word (Word8)@@ -105,23 +103,24 @@         socket) import Prelude hiding (read) -import Streamly (MonadAsync)-import Streamly.Internal.Data.Fold.Types (Fold(..))+import Streamly.Internal.Data.Array.Foreign.Type (Array(..), defaultChunkSize, writeNUnsafe)+import Streamly.Internal.Data.Fold.Type (Fold(..))+import Streamly.Internal.Data.Stream.IsStream (MonadAsync) import Streamly.Internal.Data.SVar (fork)-import Streamly.Internal.Data.Unfold.Types (Unfold(..))-import Streamly.Internal.Network.Socket (SockSpec(..), accept, connections) import Streamly.Internal.Data.Stream.Serial (SerialT)-import Streamly.Internal.Memory.Array.Types (Array(..), defaultChunkSize, writeNUnsafe) import Streamly.Internal.Data.Stream.StreamK.Type (IsStream)+import Streamly.Internal.Data.Tuple.Strict (Tuple'(..))+import Streamly.Internal.Data.Unfold.Type (Unfold(..))+import Streamly.Internal.Network.Socket (SockSpec(..), accept, connections)  import qualified Control.Monad.Catch as MC import qualified Network.Socket as Net  import qualified Streamly.Internal.Data.Unfold as UF-import qualified Streamly.Internal.Memory.Array as A-import qualified Streamly.Internal.Memory.ArrayStream as AS-import qualified Streamly.Internal.Data.Fold.Types as FL-import qualified Streamly.Prelude as S+import qualified Streamly.Internal.Data.Array.Foreign as A+import qualified Streamly.Internal.Data.Array.Stream.Foreign as AS+import qualified Streamly.Internal.Data.Fold.Type as FL+import qualified Streamly.Internal.Data.Stream.IsStream as S import qualified Streamly.Network.Socket as SK import qualified Streamly.Internal.Network.Socket as ISK @@ -162,7 +161,7 @@ acceptOnPortWith :: MonadIO m     => [(SocketOption, Int)]     -> Unfold m PortNumber Socket-acceptOnPortWith opts = UF.supplyFirst (acceptOnAddrWith opts) (0,0,0,0)+acceptOnPortWith opts = UF.supplyFirst (0,0,0,0) (acceptOnAddrWith opts)  -- | Like 'acceptOnAddr' but binds on the IPv4 address @0.0.0.0@ i.e.  on all -- IPv4 addresses/interfaces of the machine and listens for TCP connections on@@ -173,7 +172,7 @@ -- @since 0.7.0 {-# INLINE acceptOnPort #-} acceptOnPort :: MonadIO m => Unfold m PortNumber Socket-acceptOnPort = UF.supplyFirst acceptOnAddr (0,0,0,0)+acceptOnPort = UF.supplyFirst (0,0,0,0) acceptOnAddr  -- | Like 'acceptOnAddr' but binds on the localhost IPv4 address @127.0.0.1@. -- The server can only be accessed from the local host, it cannot be accessed@@ -184,7 +183,7 @@ -- @since 0.7.0 {-# INLINE acceptOnPortLocal #-} acceptOnPortLocal :: MonadIO m => Unfold m PortNumber Socket-acceptOnPortLocal = UF.supplyFirst acceptOnAddr (127,0,0,1)+acceptOnPortLocal = UF.supplyFirst (127,0,0,1) acceptOnAddr  ------------------------------------------------------------------------------- -- Accept (streams)@@ -209,7 +208,7 @@ -- | Like 'connections' but binds on the specified IPv4 address of the machine -- and listens for TCP connections on the specified port. ----- /Internal/+-- /Pre-release/ {-# INLINE connectionsOnAddr #-} connectionsOnAddr     :: MonadAsync m@@ -224,7 +223,7 @@ -- -- > connectionsOnPort = connectionsOnAddr (0,0,0,0) ----- /Internal/+-- /Pre-release/ {-# INLINE connectionsOnPort #-} connectionsOnPort :: MonadAsync m => PortNumber -> SerialT m Socket connectionsOnPort = connectionsOnAddr (0,0,0,0)@@ -235,7 +234,7 @@ -- -- > connectionsOnLocalHost = connectionsOnAddr (127,0,0,1) ----- /Internal/+-- /Pre-release/ {-# INLINE connectionsOnLocalHost #-} connectionsOnLocalHost :: MonadAsync m => PortNumber -> SerialT m Socket connectionsOnLocalHost = connectionsOnAddr (127,0,0,1)@@ -244,13 +243,15 @@ -- TCP Clients ------------------------------------------------------------------------------- --- | Connect to the specified IP address and port number.+-- | Connect to the specified IP address and port number. Returns a connected+-- socket or throws an exception. -- -- @since 0.7.0 connect :: (Word8, Word8, Word8, Word8) -> PortNumber -> IO Socket connect addr port = do     sock <- socket AF_INET Stream defaultProtocol-    Net.connect sock $ SockAddrInet port (Net.tupleToHostAddress addr)+    Net.connect sock (SockAddrInet port (Net.tupleToHostAddress addr))+        `onException` Net.close sock     return sock  -- | Connect to a remote host using IP address and port and run the supplied@@ -259,7 +260,7 @@ -- closing the socket raises an exception, then this exception will be raised -- by 'withConnectionM'. ----- /Internal/+-- /Pre-release/ {-# INLINABLE withConnectionM #-} withConnectionM :: (MonadMask m, MonadIO m)     => (Word8, Word8, Word8, Word8) -> PortNumber -> (Socket -> m ()) -> m ()@@ -276,9 +277,9 @@ -- termination or in case of an exception.  If closing the socket raises an -- exception, then this exception will be raised by 'usingConnection'. ----- /Internal/+-- /Pre-release/ {-# INLINABLE usingConnection #-}-usingConnection :: (MonadCatch m, MonadIO m)+usingConnection :: (MonadCatch m, MonadAsync m)     => Unfold m Socket a     -> Unfold m ((Word8, Word8, Word8, Word8), PortNumber) a usingConnection =@@ -296,9 +297,9 @@ -- handle raises an exception, then this exception will be raised by -- 'withConnection' rather than any exception raised by 'act'. ----- /Internal/+-- /Pre-release/ {-# INLINABLE withConnection #-}-withConnection :: (IsStream t, MonadCatch m, MonadIO m)+withConnection :: (IsStream t, MonadCatch m, MonadAsync m)     => (Word8, Word8, Word8, Word8) -> PortNumber -> (Socket -> t m a) -> t m a withConnection addr port =     S.bracket (liftIO $ connect addr port) (liftIO . Net.close)@@ -311,15 +312,15 @@ -- -- @since 0.7.0 {-# INLINE read #-}-read :: (MonadCatch m, MonadIO m)+read :: (MonadCatch m, MonadAsync m)     => Unfold m ((Word8, Word8, Word8, Word8), PortNumber) Word8-read = UF.concat (usingConnection ISK.readChunks) A.read+read = UF.many (usingConnection ISK.readChunks) A.read  -- | Read a stream from the supplied IPv4 host address and port number. -- -- @since 0.7.0 {-# INLINE toBytes #-}-toBytes :: (IsStream t, MonadCatch m, MonadIO m)+toBytes :: (IsStream t, MonadCatch m, MonadAsync m)     => (Word8, Word8, Word8, Word8) -> PortNumber -> t m Word8 toBytes addr port = AS.concat $ withConnection addr port ISK.toChunks @@ -331,15 +332,15 @@ -- number. -- -- @since 0.7.0-{-# INLINE fromChunks #-}-fromChunks+{-# INLINE putChunks #-}+putChunks     :: (MonadCatch m, MonadAsync m)     => (Word8, Word8, Word8, Word8)     -> PortNumber     -> SerialT m (Array Word8)     -> m ()-fromChunks addr port xs =-    S.drain $ withConnection addr port (\sk -> S.yieldM $ ISK.fromChunks sk xs)+putChunks addr port xs =+    S.drain $ withConnection addr port (\sk -> S.fromEffect $ ISK.putChunks sk xs)  -- | Write a stream of arrays to the supplied IPv4 host address and port -- number.@@ -356,28 +357,31 @@     initial = do         skt <- liftIO (connect addr port)         fld <- FL.initialize (SK.writeChunks skt) `MC.onException` liftIO (Net.close skt)-        return (fld, skt)-    step (fld, skt) x = do+        return $ FL.Partial (Tuple' fld skt)+    step (Tuple' fld skt) x = do         r <- FL.runStep fld x `MC.onException` liftIO (Net.close skt)-        return (r, skt)-    extract (Fold _ initial1 extract1, skt) = do+        return $ FL.Partial (Tuple' r skt)+    extract (Tuple' (Fold _ initial1 extract1) skt) = do         liftIO $ Net.close skt-        initial1 >>= extract1+        res <- initial1+        case res of+            FL.Partial fs -> extract1 fs+            FL.Done fb -> return fb  -- | 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. -- -- @since 0.7.0-{-# INLINE fromBytesWithBufferOf #-}-fromBytesWithBufferOf+{-# INLINE putBytesWithBufferOf #-}+putBytesWithBufferOf     :: (MonadCatch m, MonadAsync m)     => Int     -> (Word8, Word8, Word8, Word8)     -> PortNumber     -> SerialT m Word8     -> m ()-fromBytesWithBufferOf n addr port m = fromChunks addr port $ AS.arraysOf n m+putBytesWithBufferOf n addr port m = putChunks addr port $ AS.arraysOf n m  -- | 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@@ -392,15 +396,15 @@     -> PortNumber     -> Fold m Word8 () writeWithBufferOf n addr port =-    FL.lchunksOf n (writeNUnsafe n) (writeChunks addr port)+    FL.chunksOf n (writeNUnsafe n) (writeChunks addr port)  -- | Write a stream to the supplied IPv4 host address and port number. -- -- @since 0.7.0-{-# INLINE fromBytes #-}-fromBytes :: (MonadCatch m, MonadAsync m)+{-# INLINE putBytes #-}+putBytes :: (MonadCatch m, MonadAsync m)     => (Word8, Word8, Word8, Word8) -> PortNumber -> SerialT m Word8 -> m ()-fromBytes = fromBytesWithBufferOf defaultChunkSize+putBytes = putBytesWithBufferOf defaultChunkSize  -- | Write a stream to the supplied IPv4 host address and port number. --@@ -428,7 +432,7 @@      pre = do         sk <- liftIO $ connect addr port-        tid <- fork (ISK.fromBytes sk input)+        tid <- fork (ISK.putBytes sk input)         return (sk, tid)      handler (sk, _) = f sk@@ -440,14 +444,13 @@ -- the host. The server host just acts as a transformation function on the -- input stream.  Both sending and receiving happen asynchronously. ----- /Internal/+-- /Pre-release/ ---{-# INLINABLE transformBytesWith #-}-transformBytesWith+{-# INLINABLE processBytes #-}+processBytes     :: (IsStream t, MonadAsync m, MonadCatch m)     => (Word8, Word8, Word8, Word8)     -> PortNumber     -> SerialT m Word8     -> t m Word8-transformBytesWith addr port input =-    withInputConnect addr port input ISK.toBytes+processBytes addr port input = withInputConnect addr port input ISK.toBytes
src/Streamly/Internal/Network/Socket.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE CPP              #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RecordWildCards  #-}- #include "inline.hs"  -- |@@ -17,12 +13,14 @@     (     SockSpec (..)     -- * Use a socket-    , handleWithM-    , handleWith+    , forSocketM+    , withSocket      -- * Accept connections     , accept     , connections+    , connect+    , connectFrom      -- * Read from connection     , read@@ -34,11 +32,10 @@      -- -- * Array Read     -- , readArrayUpto-    -- , readArrayOf-     -- , readChunksUpto-    , readChunksWithBufferOf+    , readChunk     , readChunks+    , readChunksWithBufferOf      , toChunksWithBufferOf     , toChunks@@ -51,26 +48,26 @@     -- , writeByFrames     , writeWithBufferOf -    , fromChunks-    , fromBytesWithBufferOf-    , fromBytes+    , putChunks+    , putBytesWithBufferOf+    , putBytes      -- -- * Array Write     , writeChunk     , writeChunks     , writeChunksWithBufferOf-    , writeStrings      -- reading/writing datagrams     ) where  import Control.Concurrent (threadWaitWrite, rtsSupportsBoundThreads)+import Control.Exception (onException) import Control.Monad.Catch (MonadCatch, finally, MonadMask) import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad (when)+import Control.Monad (forM_, when) import Data.Word (Word8)-import Foreign.ForeignPtr (withForeignPtr)+ import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) import Foreign.Ptr (minusPtr, plusPtr, Ptr, castPtr) import Foreign.Storable (Storable(..))@@ -88,43 +85,46 @@  import qualified Network.Socket as Net -import Streamly (MonadAsync)-import Streamly.Internal.Data.Unfold.Types (Unfold(..))-import Streamly.Internal.Memory.Array.Types (Array(..), lpackArraysChunksOf)+import Streamly.Internal.BaseCompat+import Streamly.Internal.Data.Unfold.Type (Unfold(..))+import Streamly.Internal.Data.Array.Stream.Foreign (lpackArraysChunksOf)+import Streamly.Internal.Data.Array.Foreign.Type (Array(..))+import Streamly.Internal.Data.Array.Foreign.Mut.Type (mutableArray)+import Streamly.Internal.Data.Stream.IsStream (MonadAsync) import Streamly.Internal.Data.Stream.Serial (SerialT) import Streamly.Internal.Data.Stream.StreamK.Type (IsStream, mkStream) import Streamly.Data.Fold (Fold) -- import Streamly.String (encodeUtf8, decodeUtf8, foldLines)  import qualified Streamly.Data.Fold as FL-import qualified Streamly.Internal.Data.Fold.Types as FL import qualified Streamly.Internal.Data.Unfold as UF-import qualified Streamly.Internal.Memory.Array as IA-import qualified Streamly.Memory.Array as A-import qualified Streamly.Internal.Memory.ArrayStream as AS-import qualified Streamly.Internal.Memory.Array.Types as A-import qualified Streamly.Prelude as S+import qualified Streamly.Data.Array.Foreign as A+import qualified Streamly.Internal.Data.Array.Stream.Foreign as AS+import qualified Streamly.Internal.Data.Array.Foreign.Type as A+import qualified Streamly.Internal.Data.Stream.IsStream as S import qualified Streamly.Internal.Data.Stream.StreamD.Type as D --- | @'handleWithM' socket act@ runs the monadic computation @act@ passing the--- socket handle to it.  The handle will be closed on exit from 'handleWithM',--- whether by normal termination or by raising an exception.  If closing the--- handle raises an exception, then this exception will be raised by--- 'handleWithM' rather than any exception raised by 'act'.+-- | @'forSocketM' action socket@ runs the monadic computation @action@ passing+-- the socket handle to it.  The handle will be closed on exit from+-- 'forSocketM', whether by normal termination or by raising an exception.  If+-- closing the handle raises an exception, then this exception will be raised+-- by 'forSocketM' rather than any exception raised by 'action'. ----- @since 0.7.0-{-# INLINE handleWithM #-}-handleWithM :: (MonadMask m, MonadIO m) => (Socket -> m ()) -> Socket -> m ()-handleWithM f sk = finally (f sk) (liftIO (Net.close sk))+-- @since 0.8.0+{-# INLINE forSocketM #-}+forSocketM :: (MonadMask m, MonadIO m) => (Socket -> m ()) -> Socket -> m ()+forSocketM f sk = finally (f sk) (liftIO (Net.close sk)) --- | Like 'handleWithM' but runs a streaming computation instead of a monadic+-- | Like 'forSocketM' but runs a streaming computation instead of a monadic -- computation. ----- @since 0.7.0-{-# INLINE handleWith #-}-handleWith :: (IsStream t, MonadCatch m, MonadIO m)+-- /Inhibits stream fusion/+--+-- /Internal/+{-# INLINE withSocket #-}+withSocket :: (IsStream t, MonadAsync m, MonadCatch m)     => Socket -> (Socket -> t m a) -> t m a-handleWith sk f = S.finally (liftIO $ Net.close sk) (f sk)+withSocket sk f = S.finally (liftIO $ Net.close sk) (f sk)  ------------------------------------------------------------------------------- -- Accept (Unfolds)@@ -146,21 +146,26 @@ initListener listenQLen SockSpec{..} addr =   withSocketsDo $ do     sock <- socket sockFamily sockType sockProto-    mapM_ (\(opt, val) -> setSocketOption sock opt val) sockOpts-    bind sock addr-    Net.listen sock listenQLen+    use sock `onException` Net.close sock     return sock +    where++    use sock = do+        mapM_ (\(opt, val) -> setSocketOption sock opt val) sockOpts+        bind sock addr+        Net.listen sock listenQLen+ {-# INLINE listenTuples #-} listenTuples :: MonadIO m     => Unfold m (Int, SockSpec, SockAddr) (Socket, SockAddr) listenTuples = Unfold step inject     where-    inject (listenQLen, spec, addr) = liftIO $ initListener listenQLen spec addr+    inject (listenQLen, spec, addr) =+        liftIO $ initListener listenQLen spec addr      step listener = do-        r <- liftIO $ Net.accept listener-        -- XXX error handling+        r <- liftIO (Net.accept listener `onException` Net.close listener)         return $ D.Yield r listener  -- | Unfold a three tuple @(listenQLen, spec, addr)@ into a stream of connected@@ -174,6 +179,39 @@ accept :: MonadIO m => Unfold m (Int, SockSpec, SockAddr) Socket accept = UF.map fst listenTuples +{-# INLINE connectCommon #-}+connectCommon :: SockSpec -> Maybe SockAddr -> SockAddr -> IO Socket+connectCommon SockSpec{..} local remote = withSocketsDo $ do+    sock <- socket sockFamily sockType sockProto+    use sock `onException` Net.close sock+    return sock++    where++    use sock = do+        mapM_ (\(opt, val) -> setSocketOption sock opt val) sockOpts+        forM_ local (bind sock)+        Net.connect sock remote++-- | Connect to a remote host using the given socket specification and remote+-- address. Returns a connected socket or throws an exception.+--+-- /Pre-release/+--+{-# INLINE connect #-}+connect :: SockSpec -> SockAddr -> IO Socket+connect spec = connectCommon spec Nothing++-- | Connect to a remote host using the given socket specification, a local+-- address to bind to and a remote address to connect to. Returns a connected+-- socket or throws an exception.+--+-- /Pre-release/+--+{-# INLINE connectFrom #-}+connectFrom :: SockSpec -> SockAddr -> SockAddr -> IO Socket+connectFrom spec local = connectCommon spec (Just local)+ ------------------------------------------------------------------------------- -- Listen (Streams) -------------------------------------------------------------------------------@@ -185,13 +223,11 @@     where     step Nothing = do         listener <- liftIO $ initListener tcpListenQ spec addr-        r <- liftIO $ Net.accept listener-        -- XXX error handling+        r <- liftIO (Net.accept listener `onException` Net.close listener)         return $ Just (r, Just listener)      step (Just listener) = do-        r <- liftIO $ Net.accept listener-        -- XXX error handling+        r <- liftIO (Net.accept listener `onException` Net.close listener)         return $ Just (r, Just listener)  -- | Start a TCP stream server that listens for connections on the supplied@@ -199,10 +235,11 @@ -- port). The server generates a stream of connected sockets.  The first -- argument is the maximum number of pending connections in the backlog. ----- /Internal/+-- /Pre-release/ {-# INLINE connections #-} connections :: MonadAsync m => Int -> SockSpec -> SockAddr -> SerialT m Socket-connections tcpListenQ spec addr = fst <$> recvConnectionTuplesWith tcpListenQ spec addr+connections tcpListenQ spec addr =+    fst <$> recvConnectionTuplesWith tcpListenQ spec addr  ------------------------------------------------------------------------------- -- Array IO (Input)@@ -217,24 +254,24 @@ readArrayUptoWith f size h = do     ptr <- mallocPlainForeignPtrBytes size     -- ptr <- mallocPlainForeignPtrAlignedBytes size (alignment (undefined :: Word8))-    withForeignPtr ptr $ \p -> do+    unsafeWithForeignPtr ptr $ \p -> do         n <- f h p size-        let v = Array-                { aStart = ptr-                , aEnd   = p `plusPtr` n-                , aBound = p `plusPtr` size-                }+        let v = A.unsafeFreeze+                $ mutableArray ptr (p `plusPtr` n) (p `plusPtr` size)+         -- XXX shrink only if the diff is significant         -- A.shrinkToFit v         return v --- | Read a 'ByteArray' from a file handle. If no data is available on the--- handle it blocks until some data becomes available. If data is available--- then it immediately returns that data without blocking. It reads a maximum--- of up to the size requested.-{-# INLINABLE readArrayOf #-}-readArrayOf :: Int -> Socket -> IO (Array Word8)-readArrayOf = readArrayUptoWith recvBuf+-- | Read a byte array from a file handle up to a maximum of the requested+-- size. If no data is available on the handle it blocks until some data+-- becomes available. If data is available then it immediately returns that+-- data without blocking.+--+-- @since 0.8.0+{-# INLINABLE readChunk #-}+readChunk :: Int -> Socket -> IO (Array Word8)+readChunk = readArrayUptoWith recvBuf  ------------------------------------------------------------------------------- -- Array IO (output)@@ -266,7 +303,7 @@     -> Array a     -> IO () writeArrayWith _ _ arr | A.length arr == 0 = return ()-writeArrayWith f h Array{..} = withForeignPtr aStart $ \p ->+writeArrayWith f h Array{..} = unsafeWithForeignPtr aStart $ \p ->     f h (castPtr p) aLen     where     aLen =@@ -275,7 +312,7 @@  -- | Write an Array to a file handle. ----- @since 0.7.0+-- @since 0.8.0 {-# INLINABLE writeChunk #-} writeChunk :: Storable a => Socket -> Array a -> IO () writeChunk = writeArrayWith sendAll@@ -304,12 +341,12 @@ {-# INLINE_NORMAL toChunksWithBufferOf #-} toChunksWithBufferOf :: (IsStream t, MonadIO m)     => Int -> Socket -> t m (Array Word8)--- toChunksWithBufferOf = _readChunksUptoWith readArrayOf+-- toChunksWithBufferOf = _readChunksUptoWith readChunk toChunksWithBufferOf size h = D.fromStreamD (D.Stream step ())     where     {-# INLINE_LATE step #-}     step _ _ = do-        arr <- liftIO $ readArrayOf size h+        arr <- liftIO $ readChunk size h         return $             case A.length arr of                 0 -> D.Stop@@ -337,7 +374,7 @@     where     {-# INLINE_LATE step #-}     step (size, h) = do-        arr <- liftIO $ readArrayOf size h+        arr <- liftIO $ readChunk size h         return $             case A.length arr of                 0 -> D.Stop@@ -345,14 +382,14 @@  -- | Unfolds a socket into a stream of 'Word8' arrays. Requests to the socket -- are performed using a buffer of size--- 'Streamly.Internal.Memory.Array.Types.defaultChunkSize'. The+-- 'Streamly.Internal.Data.Array.Foreign.Type.defaultChunkSize'. The -- size of arrays in the resulting stream are therefore less than or equal to--- 'Streamly.Internal.Memory.Array.Types.defaultChunkSize'.+-- 'Streamly.Internal.Data.Array.Foreign.Type.defaultChunkSize'. -- -- @since 0.7.0 {-# INLINE readChunks #-} readChunks :: MonadIO m => Unfold m Socket (Array Word8)-readChunks = UF.supplyFirst readChunksWithBufferOf A.defaultChunkSize+readChunks = UF.supplyFirst A.defaultChunkSize readChunksWithBufferOf  ------------------------------------------------------------------------------- -- Read File to Stream@@ -390,16 +427,16 @@ -- @since 0.7.0 {-# INLINE readWithBufferOf #-} readWithBufferOf :: MonadIO m => Unfold m (Int, Socket) Word8-readWithBufferOf = UF.concat readChunksWithBufferOf A.read+readWithBufferOf = UF.many readChunksWithBufferOf A.read  -- | Unfolds a 'Socket' into a byte stream.  IO requests to the socket are -- performed in sizes of--- 'Streamly.Internal.Memory.Array.Types.defaultChunkSize'.+-- 'Streamly.Internal.Data.Array.Foreign.Type.defaultChunkSize'. -- -- @since 0.7.0 {-# INLINE read #-} read :: MonadIO m => Unfold m Socket Word8-read = UF.supplyFirst readWithBufferOf A.defaultChunkSize+read = UF.supplyFirst A.defaultChunkSize readWithBufferOf  ------------------------------------------------------------------------------- -- Writing@@ -408,10 +445,10 @@ -- | Write a stream of arrays to a handle. -- -- @since 0.7.0-{-# INLINE fromChunks #-}-fromChunks :: (MonadIO m, Storable a)+{-# INLINE putChunks #-}+putChunks :: (MonadIO m, Storable a)     => Socket -> SerialT m (Array a) -> m ()-fromChunks h = S.mapM_ (liftIO . writeChunk h)+putChunks h = S.mapM_ (liftIO . writeChunk h)  -- | Write a stream of arrays to a socket.  Each array in the stream is written -- to the socket as a separate IO request.@@ -421,29 +458,18 @@ writeChunks :: (MonadIO m, Storable a) => Socket -> Fold m (Array a) () writeChunks h = FL.drainBy (liftIO . writeChunk h) --- | @writeChunksWithBufferOf bufsize socket@ writes a stream of arrays--- to @socket@ 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.+-- | @writeChunksWithBufferOf bufsize socket@ writes a stream of arrays to+-- @socket@ after coalescing the adjacent arrays in chunks of @bufsize@.+-- Multiple arrays are coalesed as long as the total size remains below the+-- specified size.  It never splits an array, if a single array is bigger than+-- the specified size it emitted as it is. ----- @since 0.7.0+-- @since 0.8.0 {-# INLINE writeChunksWithBufferOf #-} writeChunksWithBufferOf :: (MonadIO m, Storable a)     => Int -> Socket -> Fold m (Array a) () writeChunksWithBufferOf n h = lpackArraysChunksOf n (writeChunks h) --- | Write a stream of strings to a socket in Latin1 encoding.  Output is--- flushed to the socket for each string.------ /Internal/----{-# INLINE writeStrings #-}-writeStrings :: MonadIO m-    => (SerialT m Char -> SerialT m Word8) -> Socket -> Fold m String ()-writeStrings encode h =-    FL.lmapM (IA.fromStream . encode . S.fromList) (writeChunks h)- -- GHC buffer size dEFAULT_FD_BUFFER_SIZE=8192 bytes. -- -- XXX test this@@ -457,9 +483,9 @@ -- input elements. -- -- @since 0.7.0-{-# INLINE fromBytesWithBufferOf #-}-fromBytesWithBufferOf :: MonadIO m => Int -> Socket -> SerialT m Word8 -> m ()-fromBytesWithBufferOf n h m = fromChunks h $ AS.arraysOf n m+{-# INLINE putBytesWithBufferOf #-}+putBytesWithBufferOf :: MonadIO m => Int -> Socket -> SerialT m Word8 -> m ()+putBytesWithBufferOf n h m = putChunks h $ AS.arraysOf n m  -- | Write a byte stream to a socket. Accumulates the input in chunks of -- specified number of bytes before writing.@@ -467,7 +493,7 @@ -- @since 0.7.0 {-# INLINE writeWithBufferOf #-} writeWithBufferOf :: MonadIO m => Int -> Socket -> Fold m Word8 ()-writeWithBufferOf n h = FL.lchunksOf n (A.writeNUnsafe n) (writeChunks h)+writeWithBufferOf n h = FL.chunksOf n (A.writeNUnsafe n) (writeChunks h)  -- > write = 'writeWithBufferOf' A.defaultChunkSize --@@ -476,9 +502,9 @@ -- depends on the 'IOMode' and the current seek position of the handle. -- -- @since 0.7.0-{-# INLINE fromBytes #-}-fromBytes :: MonadIO m => Socket -> SerialT m Word8 -> m ()-fromBytes = fromBytesWithBufferOf A.defaultChunkSize+{-# INLINE putBytes #-}+putBytes :: MonadIO m => Socket -> SerialT m Word8 -> m ()+putBytes = putBytesWithBufferOf A.defaultChunkSize  -- | Write a byte stream to a socket. Accumulates the input in chunks of -- up to 'A.defaultChunkSize' bytes before writing.
− src/Streamly/Internal/Prelude.hs 
@@ -1,4571 +0,0 @@-{-# LANGUAGE BangPatterns     #-}-{-# LANGUAGE CPP              #-}-{-# LANGUAGE RankNTypes       #-}-{-# LANGUAGE RecordWildCards  #-}-{-# LANGUAGE KindSignatures   #-}-{-# LANGUAGE FlexibleContexts #-}--#if __GLASGOW_HASKELL__ >= 800-{-# OPTIONS_GHC -Wno-orphans  #-}-#endif--#include "inline.hs"---- |--- Module      : Streamly.Internal.Prelude--- Copyright   : (c) 2017 Harendra Kumar------ License     : BSD3--- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC------ This is an Internal module consisting of released, unreleased and--- unimplemented APIs. For stable and released APIs please see--- "Streamly.Prelude" module. This module provides documentation only for the--- unreleased and unimplemented APIs. For documentation on released APIs please--- see "Streamly.Prelude" module.--module Streamly.Internal.Prelude-    (-    -- * Construction-    -- ** Primitives-      K.nil-    , K.nilM-    , K.cons-    , (K..:)--    , consM-    , (|:)--    -- ** From Values-    , yield-    , yieldM-    , repeat-    , repeatM-    , replicate-    , replicateM--    -- ** Enumeration-    , Enumerable (..)-    , enumerate-    , enumerateTo--    -- ** From Generators-    , unfoldr-    , unfoldrM-    , unfold-    , iterate-    , iterateM-    , fromIndices-    , fromIndicesM--    -- ** From Containers-    , P.fromList-    , fromListM-    , K.fromFoldable-    , fromFoldableM-    , fromPrimVar-    , fromCallback--    -- ** Time related-    , currentTime--    -- * Elimination--    -- ** Deconstruction-    , uncons-    , tail-    , init--    -- ** Folding-    -- ** Right Folds-    , foldrM-    , foldrS-    , foldrT-    , foldr--    -- ** Left Folds-    , foldl'-    , foldl1'-    , foldlM'--    -- ** Composable Left Folds-    , fold-    , parse--    -- ** Concurrent Folds-    , foldAsync-    , (|$.)-    , (|&.)--    -- ** Full Folds--    -- -- ** To Summary (Full Folds)-    , drain-    , last-    , length-    , sum-    , product-    , mconcat--    -- -- ** To Summary (Maybe) (Full Folds)-    , maximumBy-    , maximum-    , minimumBy-    , minimum-    , the--    -- ** Lazy Folds-    -- -- ** To Containers (Full Folds)-    , toList-    , toListRev-    , toPure-    , toPureRev--    -- ** Composable Left Folds--    , toStream    -- XXX rename to write?-    , toStreamRev -- XXX rename to writeRev?--    -- ** Partial Folds--    -- -- ** To Elements (Partial Folds)-    , drainN-    , drainWhile--    -- -- | Folds that extract selected elements of a stream or their properties.-    , (!!)-    , head-    , headElse-    , findM-    , find-    , lookup-    , findIndex-    , elemIndex--    -- -- ** To Boolean (Partial Folds)-    , null-    , elem-    , notElem-    , all-    , any-    , and-    , or--    -- ** Multi-Stream folds-    -- Full equivalence-    , eqBy-    , cmpBy--    -- finding subsequences-    , isPrefixOf-    , isSuffixOf-    , isInfixOf-    , isSubsequenceOf--    -- trimming sequences-    , stripPrefix-    , stripSuffix-    -- , stripInfix-    , dropPrefix-    , dropInfix-    , dropSuffix--    -- * Transformation-    , transform--    -- ** Mapping-    , Serial.map-    , sequence-    , mapM--    -- ** Special Maps-    , mapM_-    , trace-    , tap-    , tapOffsetEvery-    , tapAsync-    , tapRate-    , pollCounts--    -- ** Scanning-    -- ** Left scans-    , scanl'-    , scanlM'-    , postscanl'-    , postscanlM'-    , prescanl'-    , prescanlM'-    , scanl1'-    , scanl1M'--    -- ** Scan Using Fold-    , scan-    , postscan--    -- XXX Once we have pipes the contravariant transformations can be-    -- represented by attaching pipes before a transformation.-    ---    -- , lscanl'-    -- , lscanlM'-    -- , lscanl1'-    -- , lscanl1M'-    ---    -- , lpostscanl'-    -- , lpostscanlM'-    -- , lprescanl'-    -- , lprescanlM'--    -- ** Concurrent Transformation-    , D.mkParallel-    -- Par.mkParallel-    , applyAsync-    , (|$)-    , (|&)--    -- ** Filtering--    , filter-    , filterM--    -- ** Mapping Filters-    , mapMaybe-    , mapMaybeM--    -- ** Deleting Elements-    , deleteBy-    , uniq-    -- , uniqBy -- by predicate e.g. to remove duplicate "/" in a path-    -- , uniqOn -- to remove duplicate sequences-    -- , pruneBy -- dropAround + uniqBy - like words--    -- ** Inserting Elements--    , insertBy-    , intersperseM-    , intersperse-    , intersperseSuffix-    , intersperseSuffixBySpan-    -- , intersperseBySpan-    -- , intersperseByIndices -- using an index function/stream--    -- time domain intersperse-    -- , intersperseByTime-    -- , intersperseByEvent-    , interjectSuffix-    , delayPost--    -- ** Indexing-    , indexed-    , indexedR-    -- , timestamped-    -- , timestampedR -- timer--    -- ** Reordering-    , reverse-    , reverse'--    -- ** Parsing-    , splitParse--    -- ** Trimming-    , take-    , takeByTime-    -- , takeEnd-    , takeWhile-    , takeWhileM-    -- , takeWhileEnd-    , drop-    , dropByTime-    -- , dropEnd-    , dropWhile-    , dropWhileM-    -- , dropWhileEnd-    -- , dropAround--    -- ** Breaking--    -- Nary-    , chunksOf-    , chunksOf2-    , arraysOf-    , intervalsOf--    -- ** Searching-    -- -- *** Searching Elements-    , findIndices-    , elemIndices--    -- -- *** Searching Sequences-    -- , seqIndices -- search a sequence in the stream--    -- -- *** Searching Multiple Sequences-    -- , seqIndicesAny -- search any of the given sequence in the stream--    -- -- -- ** Searching Streams-    -- -- | Finding a stream within another stream.--    -- ** Splitting-    -- | Streams can be sliced 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).--    -- -- *** Using Element Separators-    , splitOn-    , splitOnSuffix-    -- , splitOnPrefix--    -- , splitBy-    , splitWithSuffix-    -- , splitByPrefix-    , wordsBy -- stripAndCompactBy--    -- -- *** Splitting By Sequences-    , splitOnSeq-    , splitOnSuffixSeq-    -- , splitOnPrefixSeq--    -- Keeping the delimiters-    , splitBySeq-    , splitWithSuffixSeq-    -- , splitByPrefixSeq-    -- , wordsBySeq--    -- Splitting using multiple sequence separators-    -- , splitOnAnySeq-    -- , splitOnAnySuffixSeq-    -- , splitOnAnyPrefixSeq--    -- -- *** Splitting By Streams-    -- -- | Splitting a stream using another stream as separator.--    -- Nested splitting-    , splitInnerBy-    , splitInnerBySuffix--    -- ** Grouping-    -- 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.--    -- , groupScan--    , groups-    , groupsBy-    , groupsByRolling--    -- ** Group map-    , rollingMapM-    , rollingMap--    -- * 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-    , classifySessionsBy-    , 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--    -- * Combining Streams--    -- ** Appending-    , append--    -- ** Interleaving-    , interleave-    , interleaveMin-    , interleaveSuffix-    , interleaveInfix--    , Serial.wSerialFst-    , Serial.wSerialMin--    -- ** Scheduling-    , roundrobin--    -- ** Parallel-    , Par.parallelFst-    , Par.parallelMin--    -- ** Merging--    -- , merge-    , mergeBy-    , mergeByM-    , mergeAsyncBy-    , mergeAsyncByM--    -- ** Zipping-    , Z.zipWith-    , Z.zipWithM-    , Z.zipAsyncWith-    , Z.zipAsyncWithM--    -- ** Folding Containers of Streams-    , foldWith-    , foldMapWith-    , forEachWith--    -- Flattening Nested Streams-    -- ** Folding Streams of Streams-    , concat-    , concatM-    , concatMap-    , concatMapM-    -- XXX add stateful concatMapWith?-    , concatMapWith-    -- , bindWith--    -- ** Flattening Using Unfolds-    , concatUnfold-    , concatUnfoldInterleave-    , concatUnfoldRoundrobin--    -- ** Feedback Loops-    , concatMapIterateWith-    , concatMapTreeWith-    , concatMapLoopWith-    , concatMapTreeYieldLeavesWith-    , K.mfix--    -- ** Inserting Streams in Streams-    , gintercalate-    , gintercalateSuffix-    , intercalate-    , intercalateSuffix-    , interpose-    , interposeSuffix-    -- , interposeBy--    -- * Exceptions-    , before-    , after-    , afterIO-    , bracket-    , bracketIO-    , onException-    , finally-    , finallyIO-    , handle--    -- * Generalize Inner Monad-    , hoist-    , generally--    -- * Transform Inner Monad-    , liftInner-    , usingReaderT-    , runReaderT-    , evalStateT-    , usingStateT-    , runStateT--    -- * Diagnostics-    , inspectMode--    -- * Deprecated-    , K.once-    , each-    , scanx-    , foldx-    , foldxM-    , foldr1-    , runStream-    , runN-    , runWhile-    , fromHandle-    , toHandle-    )-where--import Control.Concurrent (threadDelay)-import Control.Exception (Exception, assert)-import Control.Monad (void)-import Control.Monad.Catch (MonadCatch, MonadThrow)-import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad.Reader (ReaderT)-import Control.Monad.State.Strict (StateT)-import Control.Monad.Trans (MonadTrans(..))-import Control.Monad.Trans.Control (MonadBaseControl)-import Data.Functor.Identity (Identity (..))-#if __GLASGOW_HASKELL__ >= 800-import Data.Kind (Type)-#endif-import Data.Heap (Entry(..))-import Data.Maybe (isJust, fromJust, isNothing)-import Foreign.Storable (Storable)-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, replicate, concatMap, span, splitAt, break,-               repeat, concat, mconcat)--import qualified Data.Heap as H-import qualified Data.Map.Strict as Map-import qualified Prelude-import qualified System.IO as IO--import Streamly.Internal.Data.Stream.Enumeration (Enumerable(..), enumerate, enumerateTo)-import Streamly.Internal.Data.Fold.Types (Fold (..), Fold2 (..))-import Streamly.Internal.Data.Parser.Types (Parser (..))-import Streamly.Internal.Data.Unfold.Types (Unfold)-import Streamly.Internal.Memory.Array.Types (Array, writeNUnsafe)--- import Streamly.Memory.Ring (Ring)-import Streamly.Internal.Data.SVar (MonadAsync, defState)-import Streamly.Internal.Data.Stream.Combinators (inspectMode, maxYields)-import Streamly.Internal.Data.Stream.Prelude-       (fromStreamS, toStreamS, foldWith, foldMapWith, forEachWith)-import Streamly.Internal.Data.Stream.StreamD (fromStreamD, toStreamD)-import Streamly.Internal.Data.Stream.StreamK (IsStream((|:), consM))-import Streamly.Internal.Data.Stream.Serial (SerialT, WSerialT)-import Streamly.Internal.Data.Stream.Zip (ZipSerialM)-import Streamly.Internal.Data.Pipe.Types (Pipe (..))-import Streamly.Internal.Data.Time.Units-       (AbsTime, MilliSecond64(..), addToAbsTime, toRelTime,-       toAbsTime, TimeUnit64)-import Streamly.Internal.Mutable.Prim.Var (Prim, Var)--import Streamly.Internal.Data.Strict--import qualified Streamly.Internal.Memory.Array as A-import qualified Streamly.Data.Fold as FL-import qualified Streamly.Internal.Data.Fold.Types as FL-import qualified Streamly.Internal.Data.Stream.Prelude as P-import qualified Streamly.Internal.Data.Stream.StreamK as K-import qualified Streamly.Internal.Data.Stream.StreamD as D--#ifdef USE_STREAMK_ONLY-import qualified Streamly.Internal.Data.Stream.StreamK as S-#else-import qualified Streamly.Internal.Data.Stream.StreamD as S-#endif---- import qualified Streamly.Internal.Data.Stream.Async as Async-import qualified Streamly.Internal.Data.Stream.Serial as Serial-import qualified Streamly.Internal.Data.Stream.Parallel as Par-import qualified Streamly.Internal.Data.Stream.Zip as Z----------------------------------------------------------------------------------- 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.------ This is a brute force primitive. Avoid using it as long as possible, use it--- when no other combinator can do the job. This can be used to do pretty much--- anything in an imperative manner, 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.------ @since 0.1.0-{-# INLINE uncons #-}-uncons :: (IsStream t, Monad m) => SerialT m a -> m (Maybe (a, t m a))-uncons m = K.uncons (K.adapt m)----------------------------------------------------------------------------------- Generation by Unfolding----------------------------------------------------------------------------------- |--- @--- unfoldr step s =---     case step s of---         Nothing -> 'K.nil'---         Just (a, b) -> a \`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 > 3---         then Nothing---         else Just (b, b + 1)--- in toList $ unfoldr f 0--- @--- @--- [0,1,2,3]--- @------ @since 0.1.0-{-# INLINE_EARLY unfoldr #-}-unfoldr :: (Monad m, IsStream t) => (b -> Maybe (a, b)) -> b -> t m a-unfoldr step seed = fromStreamS (S.unfoldr step seed)-{-# RULES "unfoldr fallback to StreamK" [1]-    forall a b. S.toStreamK (S.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 > 3---         then return Nothing---         else print b >> return (Just (b, b + 1))--- in drain $ unfoldrM f 0--- @--- @---  0---  1---  2---  3--- @--- When run concurrently, the next unfold step can run concurrently with the--- processing of the output of the previous step.  Note that more than one step--- cannot run concurrently as the next step depends on the output of the--- previous step.------ @--- (asyncly $ S.unfoldrM (\\n -> liftIO (threadDelay 1000000) >> return (Just (n, n + 1))) 0)---     & S.foldlM' (\\_ a -> threadDelay 1000000 >> print a) ()--- @------ /Concurrent/------ /Since: 0.1.0/-{-# INLINE_EARLY unfoldrM #-}-unfoldrM :: (IsStream t, MonadAsync m) => (b -> m (Maybe (a, b))) -> b -> t m a-unfoldrM = K.unfoldrM--{-# RULES "unfoldrM serial" unfoldrM = unfoldrMSerial #-}-{-# INLINE_EARLY unfoldrMSerial #-}-unfoldrMSerial :: MonadAsync m => (b -> m (Maybe (a, b))) -> b -> SerialT m a-unfoldrMSerial = Serial.unfoldrM--{-# RULES "unfoldrM wSerial" unfoldrM = unfoldrMWSerial #-}-{-# INLINE_EARLY unfoldrMWSerial #-}-unfoldrMWSerial :: MonadAsync m => (b -> m (Maybe (a, b))) -> b -> WSerialT m a-unfoldrMWSerial = Serial.unfoldrM--{-# RULES "unfoldrM zipSerial" unfoldrM = unfoldrMZipSerial #-}-{-# INLINE_EARLY unfoldrMZipSerial #-}-unfoldrMZipSerial :: MonadAsync m => (b -> m (Maybe (a, b))) -> b -> ZipSerialM m a-unfoldrMZipSerial = Serial.unfoldrM---- | Convert an 'Unfold' into a stream by supplying it an input seed.------ >>> unfold (UF.replicateM 10) (putStrLn "hello")------ /Since: 0.7.0/-{-# INLINE unfold #-}-unfold :: (IsStream t, Monad m) => Unfold m a b -> a -> t m b-unfold unf x = fromStreamD $ D.unfold unf x----------------------------------------------------------------------------------- Specialized Generation----------------------------------------------------------------------------------- Faster than yieldM because there is no bind.------ |--- @--- yield a = a \`cons` nil--- @------ Create a singleton stream from a pure value.------ The following holds in monadic streams, but not in Zip streams:------ @--- yield = pure--- yield = yieldM . pure--- @------ In Zip applicative streams 'yield' is not the same as 'pure' because in that--- case 'pure' is equivalent to 'repeat' instead. 'yield' and 'pure' are--- equally efficient, in other cases 'yield' may be slightly more efficient--- than the other equivalent definitions.------ @since 0.4.0-{-# INLINE yield #-}-yield :: IsStream t => a -> t m a-yield = K.yield---- |--- @--- yieldM m = m \`consM` nil--- @------ Create a singleton stream from a monadic action.------ @--- > toList $ yieldM getLine--- hello--- ["hello"]--- @------ @since 0.4.0-{-# INLINE yieldM #-}-yieldM :: (Monad m, IsStream t) => m a -> t m a-yieldM = K.yieldM---- |--- @--- fromIndices f = let g i = f i \`cons` g (i + 1) in g 0--- @------ Generate an infinite stream, whose values are the output of a function @f@--- applied on the corresponding index.  Index starts at 0.------ @--- > S.toList $ S.take 5 $ S.fromIndices id--- [0,1,2,3,4]--- @------ @since 0.6.0-{-# INLINE fromIndices #-}-fromIndices :: (IsStream t, Monad m) => (Int -> a) -> t m a-fromIndices = fromStreamS . S.fromIndices------- |--- @--- fromIndicesM f = let g i = f i \`consM` g (i + 1) in g 0--- @------ Generate an infinite stream, whose values are the output of a monadic--- function @f@ applied on the corresponding index. Index starts at 0.------ /Concurrent/------ @since 0.6.0-{-# INLINE_EARLY fromIndicesM #-}-fromIndicesM :: (IsStream t, MonadAsync m) => (Int -> m a) -> t m a-fromIndicesM = K.fromIndicesM--{-# RULES "fromIndicesM serial" fromIndicesM = fromIndicesMSerial #-}-{-# INLINE fromIndicesMSerial #-}-fromIndicesMSerial :: MonadAsync m => (Int -> m a) -> SerialT m a-fromIndicesMSerial = fromStreamS . S.fromIndicesM---- |--- @--- replicateM = take n . repeatM--- @------ Generate a stream by performing a monadic action @n@ times. Same as:------ @--- drain $ serially $ S.replicateM 10 $ (threadDelay 1000000 >> print 1)--- drain $ asyncly  $ S.replicateM 10 $ (threadDelay 1000000 >> print 1)--- @------ /Concurrent/------ @since 0.1.1-{-# INLINE_EARLY replicateM #-}-replicateM :: (IsStream t, MonadAsync m) => Int -> m a -> t m a-replicateM = K.replicateM--{-# RULES "replicateM serial" replicateM = replicateMSerial #-}-{-# INLINE replicateMSerial #-}-replicateMSerial :: MonadAsync m => Int -> m a -> SerialT m a-replicateMSerial n = fromStreamS . S.replicateM n---- |--- @--- replicate = take n . repeat--- @------ Generate a stream of length @n@ by repeating a value @n@ times.------ @since 0.6.0-{-# INLINE_NORMAL replicate #-}-replicate :: (IsStream t, Monad m) => Int -> a -> t m a-replicate n = fromStreamS . S.replicate n---- |--- Generate an infinite stream by repeating a pure value.------ @since 0.4.0-{-# INLINE_NORMAL repeat #-}-repeat :: (IsStream t, Monad m) => a -> t m a-repeat = fromStreamS . S.repeat---- |--- @--- repeatM = fix . consM--- repeatM = cycle1 . yieldM--- @------ Generate a stream by repeatedly executing a monadic action forever.------ @--- drain $ serially $ S.take 10 $ S.repeatM $ (threadDelay 1000000 >> print 1)--- drain $ asyncly  $ S.take 10 $ S.repeatM $ (threadDelay 1000000 >> print 1)--- @------ /Concurrent, infinite (do not use with 'parallely')/------ @since 0.2.0-{-# INLINE_EARLY repeatM #-}-repeatM :: (IsStream t, MonadAsync m) => m a -> t m a-repeatM = K.repeatM--{-# RULES "repeatM serial" repeatM = repeatMSerial #-}-{-# INLINE repeatMSerial #-}-repeatMSerial :: MonadAsync m => m a -> SerialT m a-repeatMSerial = fromStreamS . S.repeatM---- |--- @--- iterate f x = x \`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.------ @--- > S.toList $ S.take 5 $ S.iterate (+1) 1--- [1,2,3,4,5]--- @------ @since 0.1.2-{-# INLINE_NORMAL iterate #-}-iterate :: (IsStream t, Monad m) => (a -> a) -> a -> t m a-iterate step = fromStreamS . S.iterate step---- |--- @--- iterateM f m = m >>= \a -> return a \`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.------ When run concurrently, the next iteration can run concurrently with the--- processing of the previous iteration. Note that more than one iteration--- cannot run concurrently as the next iteration depends on the output of the--- previous iteration.------ @--- drain $ serially $ S.take 10 $ S.iterateM---      (\\x -> threadDelay 1000000 >> print x >> return (x + 1)) (return 0)------ drain $ asyncly  $ S.take 10 $ S.iterateM---      (\\x -> threadDelay 1000000 >> print x >> return (x + 1)) (return 0)--- @------ /Concurrent/------ /Since: 0.7.0 (signature change)/------ /Since: 0.1.2/-{-# INLINE_EARLY iterateM #-}-iterateM :: (IsStream t, MonadAsync m) => (a -> m a) -> m a -> t m a-iterateM = K.iterateM--{-# RULES "iterateM serial" iterateM = iterateMSerial #-}-{-# INLINE iterateMSerial #-}-iterateMSerial :: MonadAsync m => (a -> m a) -> m a -> SerialT m a-iterateMSerial step = fromStreamS . S.iterateM step----------------------------------------------------------------------------------- Conversions----------------------------------------------------------------------------------- |--- @--- fromListM = 'Prelude.foldr' 'K.consM' 'K.nil'--- @------ Construct a stream from a list of monadic actions. This is more efficient--- than 'fromFoldableM' for serial streams.------ @since 0.4.0-{-# INLINE_EARLY fromListM #-}-fromListM :: (MonadAsync m, IsStream t) => [m a] -> t m a-fromListM = fromStreamD . D.fromListM-{-# RULES "fromListM fallback to StreamK" [1]-    forall a. D.toStreamK (D.fromListM a) = fromFoldableM a #-}---- |--- @--- fromFoldableM = 'Prelude.foldr' 'consM' 'K.nil'--- @------ Construct a stream from a 'Foldable' containing monadic actions.------ @--- drain $ serially $ S.fromFoldableM $ replicateM 10 (threadDelay 1000000 >> print 1)--- drain $ asyncly  $ S.fromFoldableM $ replicateM 10 (threadDelay 1000000 >> print 1)--- @------ /Concurrent (do not use with 'parallely' on infinite containers)/------ @since 0.3.0-{-# INLINE fromFoldableM #-}-fromFoldableM :: (IsStream t, MonadAsync m, Foldable f) => f (m a) -> t m a-fromFoldableM = Prelude.foldr consM K.nil---- | Same as 'fromFoldable'.------ @since 0.1.0-{-# DEPRECATED each "Please use fromFoldable instead." #-}-{-# INLINE each #-}-each :: (IsStream t, Foldable f) => f a -> t m a-each = K.fromFoldable---- | Read lines from an IO Handle into a stream of Strings.------ @since 0.1.0-{-# DEPRECATED fromHandle-   "Please use Streamly.FileSystem.Handle module (see the changelog)" #-}-fromHandle :: (IsStream t, MonadIO m) => IO.Handle -> t m String-fromHandle h = go-  where-  go = K.mkStream $ \_ yld _ stp -> do-        eof <- liftIO $ IO.hIsEOF h-        if eof-        then stp-        else do-            str <- liftIO $ IO.hGetLine h-            yld str go---- | Construct a stream by reading a 'Prim' 'Var' repeatedly.------ /Internal/----{-# INLINE fromPrimVar #-}-fromPrimVar :: (IsStream t, MonadIO m, Prim a) => Var IO a -> t m a-fromPrimVar = fromStreamD . D.fromPrimVar---- | Takes a callback setter function and provides it with a callback.  The--- callback when invoked adds a value at the tail of the stream. Returns a--- stream of values generated by the callback.------ /Internal/----{-# INLINE fromCallback #-}-fromCallback :: MonadAsync m => ((a -> m ()) -> m ()) -> SerialT m a-fromCallback setCallback = concatM $ do-    (callback, stream) <- D.newCallbackStream-    setCallback callback-    return stream----------------------------------------------------------------------------------- Time related----------------------------------------------------------------------------------- XXX Some related/interesting combinators:------ 1) emit the relative time elapsed since last evaluation. That would just be--- a rollingMap on the currentTime stream.------ 2) Generate ticks at specified interval. Drop ticks when blocked.--- ticks :: Double -> t m ()------ 3) Emit relative time at specified tick interval. If a tick is dropped--- combine the interval with the next tick.--- ticks :: Double -> t m RelTime------ | @currentTime 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.------ Note: This API is not safe on 32-bit machines.------ /Internal/----{-# INLINE currentTime #-}-currentTime :: (IsStream t, MonadAsync m) => Double -> t m AbsTime-currentTime g = fromStreamD $ D.currentTime g----------------------------------------------------------------------------------- Elimination by Folding----------------------------------------------------------------------------------- | 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.foldrM (\x xs -> if odd x then return True else xs) (return False) $ S.fromList (2:4:5:undefined)--- > True------ /Since: 0.7.0 (signature changed)/------ /Since: 0.2.0 (signature changed)/------ /Since: 0.1.0/-{-# INLINE foldrM #-}-foldrM :: Monad m => (a -> m b -> m b) -> m b -> SerialT m a -> m b-foldrM = P.foldrM---- | Right fold to a streaming monad.------ > foldrS S.cons S.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.------ >>> S.toList $ S.foldrS S.cons S.nil $ S.fromList [1..5]--- > [1,2,3,4,5]------ Find if any element in the stream is 'True':------ >>> S.toList $ S.foldrS (\x xs -> if odd x then return True else xs) (return False) $ (S.fromList (2:4:5:undefined) :: SerialT IO Int)--- > [True]------ Map (+2) on odd elements and filter out the even elements:------ >>> S.toList $ S.foldrS (\x xs -> if odd x then (x + 2) `S.cons` xs else xs) S.nil $ (S.fromList [1..5] :: SerialT IO Int)--- > [3,5,7]------ 'foldrM' can also be represented in terms of 'foldrS', however, the former--- is much more efficient:------ > foldrM f z s = runIdentityT $ foldrS (\x xs -> lift $ f x (runIdentityT xs)) (lift z) s------ /Internal/-{-# INLINE foldrS #-}-foldrS :: IsStream t => (a -> t m b -> t m b) -> t m b -> t m a -> t m b-foldrS = K.foldrS---- | 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 = foldrT--- > foldrM f z s = runIdentityT $ foldrT (\x xs -> lift $ f x (runIdentityT xs)) (lift z) s------ 'foldrT' can be used to translate streamly streams to other transformer--- monads e.g.  to a different streaming type.------ /Internal/-{-# INLINE foldrT #-}-foldrT :: (IsStream t, Monad m, Monad (s m), MonadTrans s)-    => (a -> s m b -> s m b) -> s m b -> t m a -> s m b-foldrT f z s = S.foldrT f z (toStreamS s)---- | 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.------ @since 0.1.0-{-# INLINE foldr #-}-foldr :: Monad m => (a -> b -> b) -> b -> SerialT m a -> m b-foldr = P.foldr---- XXX This seems to be of limited use as it cannot be used to construct--- recursive structures and for reduction foldl1' is better.------ | Lazy right fold for non-empty streams, using first element as the starting--- value. Returns 'Nothing' if the stream is empty.------ @since 0.5.0-{-# INLINE foldr1 #-}-{-# DEPRECATED foldr1 "Use foldrM instead." #-}-foldr1 :: Monad m => (a -> a -> a) -> SerialT m a -> m (Maybe a)-foldr1 f m = S.foldr1 f (toStreamS m)---- | 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.------ @since 0.2.0-{-# DEPRECATED foldx "Please use foldl' followed by fmap instead." #-}-{-# INLINE foldx #-}-foldx :: Monad m => (x -> a -> x) -> x -> (x -> b) -> SerialT m a -> m b-foldx = P.foldlx'---- | Left associative/strict push fold. @foldl' reduce initial stream@ invokes--- @reduce@ with the accumulator and the next input in the input stream, using--- @initial@ as the initial value of the current value of the accumulator. When--- the input is exhausted the current value of the accumulator is returned.--- Make sure to use a strict data structure for accumulator to not build--- unnecessary lazy expressions unless that's what you want. See the previous--- section for more details.------ @since 0.2.0-{-# INLINE foldl' #-}-foldl' :: Monad m => (b -> a -> b) -> b -> SerialT m a -> m b-foldl' = P.foldl'---- | Strict left fold, for non-empty streams, using first element as the--- starting value. Returns 'Nothing' if the stream is empty.------ @since 0.5.0-{-# INLINE foldl1' #-}-foldl1' :: Monad m => (a -> a -> a) -> SerialT m a -> m (Maybe a)-foldl1' step m = do-    r <- uncons m-    case r of-        Nothing -> return Nothing-        Just (h, t) -> do-            res <- foldl' step h t-            return $ Just res---- | Like 'foldx', but with a monadic step function.------ @since 0.2.0-{-# DEPRECATED foldxM "Please use foldlM' followed by fmap instead." #-}-{-# INLINE foldxM #-}-foldxM :: Monad m => (x -> a -> m x) -> m x -> (x -> m b) -> SerialT m a -> m b-foldxM = P.foldlMx'---- | Like 'foldl'' but with a monadic step function.------ @since 0.2.0-{-# INLINE foldlM' #-}-foldlM' :: Monad m => (b -> a -> m b) -> b -> SerialT m a -> m b-foldlM' step begin m = S.foldlM' step begin $ toStreamS m----------------------------------------------------------------------------------- Running a Fold----------------------------------------------------------------------------------- | Fold a stream using the supplied left fold.------ >>> S.fold FL.sum (S.enumerateFromTo 1 100)--- 5050------ @since 0.7.0-{-# INLINE fold #-}-fold :: Monad m => Fold m a b -> SerialT m a -> m b-fold = P.runFold----------------------------------------------------------------------------------- Running a sink---------------------------------------------------------------------------------{---- | Drain a stream to a 'Sink'.-{-# INLINE runSink #-}-runSink :: Monad m => Sink m a -> SerialT m a -> m ()-runSink = fold . toFold--}----------------------------------------------------------------------------------- Running a Parse----------------------------------------------------------------------------------- | Parse a stream using the supplied 'Parse'.------ /Internal/----{-# INLINE parse #-}-parse :: MonadThrow m => Parser m a b -> SerialT m a -> m b-parse (Parser step initial extract) = P.parselMx' step initial extract----------------------------------------------------------------------------------- Specialized folds----------------------------------------------------------------------------------- |--- > drain = mapM_ (\_ -> return ())------ Run a stream, discarding the results. By default it interprets the stream--- as 'SerialT', to run other types of streams use the type adapting--- combinators for example @drain . 'asyncly'@.------ @since 0.7.0-{-# INLINE drain #-}-drain :: Monad m => SerialT m a -> m ()-drain = P.drain---- | Run a stream, discarding the results. By default it interprets the stream--- as 'SerialT', to run other types of streams use the type adapting--- combinators for example @runStream . 'asyncly'@.------ @since 0.2.0-{-# DEPRECATED runStream "Please use \"drain\" instead" #-}-{-# INLINE runStream #-}-runStream :: Monad m => SerialT m a -> m ()-runStream = drain---- |--- > drainN n = drain . take n------ Run maximum up to @n@ iterations of a stream.------ @since 0.7.0-{-# INLINE drainN #-}-drainN :: Monad m => Int -> SerialT m a -> m ()-drainN n = drain . take n---- |--- > runN n = runStream . take n------ Run maximum up to @n@ iterations of a stream.------ @since 0.6.0-{-# DEPRECATED runN "Please use \"drainN\" instead" #-}-{-# INLINE runN #-}-runN :: Monad m => Int -> SerialT m a -> m ()-runN = drainN---- |--- > drainWhile p = drain . takeWhile p------ Run a stream as long as the predicate holds true.------ @since 0.7.0-{-# INLINE drainWhile #-}-drainWhile :: Monad m => (a -> Bool) -> SerialT m a -> m ()-drainWhile p = drain . takeWhile p---- |--- > runWhile p = runStream . takeWhile p------ Run a stream as long as the predicate holds true.------ @since 0.6.0-{-# DEPRECATED runWhile "Please use \"drainWhile\" instead" #-}-{-# INLINE runWhile #-}-runWhile :: Monad m => (a -> Bool) -> SerialT m a -> m ()-runWhile = drainWhile---- | Determine whether the stream is empty.------ @since 0.1.1-{-# INLINE null #-}-null :: Monad m => SerialT m a -> m Bool-null = S.null . toStreamS---- | Extract the first element of the stream, if any.------ > head = (!! 0)------ @since 0.1.0-{-# INLINE head #-}-head :: Monad m => SerialT m a -> m (Maybe a)-head = S.head . toStreamS---- | Extract the first element of the stream, if any, otherwise use the--- supplied default value. It can help avoid one branch in high performance--- code.------ /Internal/-{-# INLINE headElse #-}-headElse :: Monad m => a -> SerialT m a -> m a-headElse x = D.headElse x . toStreamD---- |--- > tail = fmap (fmap snd) . uncons------ Extract all but the first element of the stream, if any.------ @since 0.1.1-{-# INLINE tail #-}-tail :: (IsStream t, Monad m) => SerialT m a -> m (Maybe (t m a))-tail m = K.tail (K.adapt m)---- | Extract all but the last element of the stream, if any.------ @since 0.5.0-{-# INLINE init #-}-init :: (IsStream t, Monad m) => SerialT m a -> m (Maybe (t m a))-init m = K.init (K.adapt m)---- | Extract the last element of the stream, if any.------ > last xs = xs !! (length xs - 1)------ @since 0.1.1-{-# INLINE last #-}-last :: Monad m => SerialT m a -> m (Maybe a)-last m = S.last $ toStreamS m---- | Determine whether an element is present in the stream.------ @since 0.1.0-{-# INLINE elem #-}-elem :: (Monad m, Eq a) => a -> SerialT m a -> m Bool-elem e m = S.elem e (toStreamS m)---- | Determine whether an element is not present in the stream.------ @since 0.1.0-{-# INLINE notElem #-}-notElem :: (Monad m, Eq a) => a -> SerialT m a -> m Bool-notElem e m = S.notElem e (toStreamS m)---- | Determine the length of the stream.------ @since 0.1.0-{-# INLINE length #-}-length :: Monad m => SerialT m a -> m Int-length = foldl' (\n _ -> n + 1) 0---- | Determine whether all elements of a stream satisfy a predicate.------ @since 0.1.0-{-# INLINE all #-}-all :: Monad m => (a -> Bool) -> SerialT m a -> m Bool-all p m = S.all p (toStreamS m)---- | Determine whether any of the elements of a stream satisfy a predicate.------ @since 0.1.0-{-# INLINE any #-}-any :: Monad m => (a -> Bool) -> SerialT m a -> m Bool-any p m = S.any p (toStreamS m)---- | Determines if all elements of a boolean stream are True.------ @since 0.5.0-{-# INLINE and #-}-and :: Monad m => SerialT m Bool -> m Bool-and = all (==True)---- | Determines whether at least one element of a boolean stream is True.------ @since 0.5.0-{-# INLINE or #-}-or :: Monad m => SerialT m Bool -> m Bool-or = any (==True)---- | Determine the sum of all elements of a stream of numbers. Returns @0@ when--- the stream is empty. Note that this is not numerically stable for floating--- point numbers.------ @since 0.1.0-{-# INLINE sum #-}-sum :: (Monad m, Num a) => SerialT m a -> m a-sum = foldl' (+) 0---- | Determine the product of all elements of a stream of numbers. Returns @1@--- when the stream is empty.------ @since 0.1.1-{-# INLINE product #-}-product :: (Monad m, Num a) => SerialT m a -> m a-product = foldl' (*) 1---- | Fold a stream of monoid elements by appending them.------ /Internal/-{-# INLINE mconcat #-}-mconcat :: (Monad m, Monoid a) => SerialT m a -> m a-mconcat = foldr mappend mempty---- |--- @--- minimum = 'minimumBy' compare--- @------ Determine the minimum element in a stream.------ @since 0.1.0-{-# INLINE minimum #-}-minimum :: (Monad m, Ord a) => SerialT m a -> m (Maybe a)-minimum m = S.minimum (toStreamS m)---- | Determine the minimum element in a stream using the supplied comparison--- function.------ @since 0.6.0-{-# INLINE minimumBy #-}-minimumBy :: Monad m => (a -> a -> Ordering) -> SerialT m a -> m (Maybe a)-minimumBy cmp m = S.minimumBy cmp (toStreamS m)---- |--- @--- maximum = 'maximumBy' compare--- @------ Determine the maximum element in a stream.------ @since 0.1.0-{-# INLINE maximum #-}-maximum :: (Monad m, Ord a) => SerialT m a -> m (Maybe a)-maximum = P.maximum---- | Determine the maximum element in a stream using the supplied comparison--- function.------ @since 0.6.0-{-# INLINE maximumBy #-}-maximumBy :: Monad m => (a -> a -> Ordering) -> SerialT m a -> m (Maybe a)-maximumBy cmp m = S.maximumBy cmp (toStreamS m)---- | Lookup the element at the given index.------ @since 0.6.0-{-# INLINE (!!) #-}-(!!) :: Monad m => SerialT m a -> Int -> m (Maybe a)-m !! i = toStreamS m S.!! i---- | 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@.------ > lookup = snd <$> find ((==) . fst)------ @since 0.5.0-{-# INLINE lookup #-}-lookup :: (Monad m, Eq a) => a -> SerialT m (a, b) -> m (Maybe b)-lookup a m = S.lookup a (toStreamS m)---- | Like 'findM' but with a non-monadic predicate.------ > find p = findM (return . p)------ @since 0.5.0-{-# INLINE find #-}-find :: Monad m => (a -> Bool) -> SerialT m a -> m (Maybe a)-find p m = S.find p (toStreamS m)---- | Returns the first element that satisfies the given predicate.------ @since 0.6.0-{-# INLINE findM #-}-findM :: Monad m => (a -> m Bool) -> SerialT m a -> m (Maybe a)-findM p m = S.findM p (toStreamS m)---- | Find all the indices where the element in the stream satisfies the given--- predicate.------ @since 0.5.0-{-# INLINE findIndices #-}-findIndices :: (IsStream t, Monad m) => (a -> Bool) -> t m a -> t m Int-findIndices p m = fromStreamS $ S.findIndices p (toStreamS m)---- | Returns the first index that satisfies the given predicate.------ @since 0.5.0-{-# INLINE findIndex #-}-findIndex :: Monad m => (a -> Bool) -> SerialT m a -> m (Maybe Int)-findIndex p = head . findIndices p---- | Find all the indices where the value of the element in the stream is equal--- to the given value.------ @since 0.5.0-{-# INLINE elemIndices #-}-elemIndices :: (IsStream t, Eq a, Monad m) => a -> t m a -> t m Int-elemIndices a = findIndices (==a)---- | Returns the first index where a given value is found in the stream.------ > elemIndex a = findIndex (== a)------ @since 0.5.0-{-# INLINE elemIndex #-}-elemIndex :: (Monad m, Eq a) => a -> SerialT m a -> m (Maybe Int)-elemIndex a = findIndex (== a)----------------------------------------------------------------------------------- Substreams----------------------------------------------------------------------------------- | Returns 'True' if the first stream is the same as or a prefix of the--- second. A stream is a prefix of itself.------ @--- > S.isPrefixOf (S.fromList "hello") (S.fromList "hello" :: SerialT IO Char)--- True--- @------ @since 0.6.0-{-# INLINE isPrefixOf #-}-isPrefixOf :: (Eq a, IsStream t, Monad m) => t m a -> t m a -> m Bool-isPrefixOf m1 m2 = D.isPrefixOf (toStreamD m1) (toStreamD m2)---- 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.------ @--- > S.isSuffixOf (S.fromList "hello") (S.fromList "hello" :: SerialT IO Char)--- True--- @------ Space: @O(n)@, buffers entire input stream and the suffix.------ /Internal/------ /Suboptimal/ - Help wanted.----{-# INLINE isSuffixOf #-}-isSuffixOf :: (Monad m, Eq a) => SerialT m a -> SerialT m a -> m Bool-isSuffixOf suffix stream = isPrefixOf (reverse suffix) (reverse stream)---- | Returns 'True' if the first stream is an infix of the second. A stream is--- considered an infix of itself.------ @--- > S.isInfixOf (S.fromList "hello") (S.fromList "hello" :: SerialT IO Char)--- True--- @------ Space: @O(n)@ worst case where @n@ is the length of the infix.------ /Internal/------ /Requires 'Storable' constraint/ - Help wanted.----{-# INLINE isInfixOf #-}-isInfixOf :: (MonadIO m, Eq a, Enum a, Storable a)-    => SerialT m a -> SerialT m a -> m Bool-isInfixOf infx stream = do-    arr <- fold A.write infx-    -- XXX can use breakOnSeq instead (when available)-    r <- null $ drop 1 $ splitOnSeq arr FL.drain stream-    return (not r)---- | 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.------ @--- > S.isSubsequenceOf (S.fromList "hlo") (S.fromList "hello" :: SerialT IO Char)--- True--- @------ @since 0.6.0-{-# INLINE isSubsequenceOf #-}-isSubsequenceOf :: (Eq a, IsStream t, Monad m) => t m a -> t m a -> m Bool-isSubsequenceOf m1 m2 = D.isSubsequenceOf (toStreamD m1) (toStreamD m2)---- | Strip prefix if present and tell whether it was stripped or not. Returns--- 'Nothing' if the stream does not start with the given prefix, stripped--- stream otherwise. Returns @Just nil@ when the prefix is the same as the--- stream.------ Space: @O(1)@------ @since 0.6.0-{-# INLINE stripPrefix #-}-stripPrefix-    :: (Eq a, IsStream t, Monad m)-    => t m a -> t m a -> m (Maybe (t m a))-stripPrefix m1 m2 = fmap fromStreamD <$>-    D.stripPrefix (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.------ | 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.------ Space: @O(n)@, buffers the entire input stream as well as the suffix------ /Internal/-{-# INLINE stripSuffix #-}-stripSuffix-    :: (Monad m, Eq a)-    => SerialT m a -> SerialT m a -> m (Maybe (SerialT m a))-stripSuffix m1 m2 = fmap reverse <$> stripPrefix (reverse m1) (reverse m2)---- | Drop prefix from the input stream if present.------ Space: @O(1)@------ /Unimplemented/ - Help wanted.-{-# INLINE dropPrefix #-}-dropPrefix ::-    -- (Eq a, IsStream t, Monad m) =>-    t m a -> t m a -> t 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/ - Help wanted.-{-# INLINE dropInfix #-}-dropInfix ::-    -- (Eq a, IsStream t, Monad m) =>-    t m a -> t m a -> t 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/ - Help wanted.-{-# INLINE dropSuffix #-}-dropSuffix ::-    -- (Eq a, IsStream t, Monad m) =>-    t m a -> t m a -> t m a-dropSuffix = error "Not implemented yet!"----------------------------------------------------------------------------------- Map and Fold----------------------------------------------------------------------------------- XXX this can utilize parallel mapping if we implement it as drain . mapM--- |--- > mapM_ = drain . mapM------ Apply a monadic action to each element of the stream and discard the output--- of the action. This is not really a pure transformation operation but a--- transformation followed by fold.------ @since 0.1.0-{-# INLINE mapM_ #-}-mapM_ :: Monad m => (a -> m b) -> SerialT m a -> m ()-mapM_ f m = S.mapM_ f $ toStreamS m----------------------------------------------------------------------------------- Conversions----------------------------------------------------------------------------------- |--- @--- toList = S.foldr (:) []--- @------ 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.Array" instead.------ @since 0.1.0-{-# INLINE toList #-}-toList :: Monad m => SerialT m a -> m [a]-toList = P.toList---- |--- @--- toListRev = S.foldl' (flip (:)) []--- @------ Convert a stream into a list in reverse order in the underlying monad.------ /Warning!/ working on large lists accumulated as buffers in memory could be--- very inefficient, consider using "Streamly.Array" instead.------ /Internal/-{-# INLINE toListRev #-}-toListRev :: Monad m => SerialT m a -> m [a]-toListRev = D.toListRev . toStreamD---- |--- @--- toHandle h = S.mapM_ $ hPutStrLn h--- @------ Write a stream of Strings to an IO Handle.------ @since 0.1.0-{-# DEPRECATED toHandle-   "Please use Streamly.FileSystem.Handle module (see the changelog)" #-}-toHandle :: MonadIO m => IO.Handle -> SerialT m String -> m ()-toHandle h m = go m-    where-    go m1 =-        let stop = return ()-            single a = liftIO (IO.hPutStrLn h a)-            yieldk a r = liftIO (IO.hPutStrLn h a) >> go r-        in K.foldStream defState yieldk single stop m1---- XXX rename these to write/writeRev to make the naming consistent with folds--- in other modules.------ | 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.Array" instead.------ /Internal/-{-# INLINE toStream #-}-toStream :: Monad m => Fold m a (SerialT Identity a)-toStream = Fold (\f x -> return $ f . (x `K.cons`))-                (return id)-                (return . ($ K.nil))---- 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.------ /Warning!/ working on large streams accumulated as buffers in memory could--- be very inefficient, consider using "Streamly.Array" instead.------ /Internal/----  xn : ... : x2 : x1 : []-{-# INLINABLE toStreamRev #-}-toStreamRev :: Monad m => Fold m a (SerialT Identity a)-toStreamRev = Fold (\xs x -> return $ x `K.cons` xs) (return K.nil) return---- | Convert a stream to a pure stream.------ @--- toPure = foldr cons nil--- @------ /Internal/----{-# INLINE toPure #-}-toPure :: Monad m => SerialT m a -> m (SerialT Identity a)-toPure = foldr K.cons K.nil---- | Convert a stream to a pure stream in reverse order.------ @--- toPureRev = foldl' (flip cons) nil--- @------ /Internal/----{-# INLINE toPureRev #-}-toPureRev :: Monad m => SerialT m a -> m (SerialT Identity a)-toPureRev = foldl' (flip K.cons) K.nil----------------------------------------------------------------------------------- Concurrent Application---------------------------------------------------------------------------------infixr 0 |$-infixr 0 |$.--infixl 1 |&-infixl 1 |&.---- | Parallel transform application operator; applies a stream transformation--- function @t m a -> t m b@ to a stream @t m a@ concurrently; the input stream--- is evaluated asynchronously in an independent thread yielding elements to a--- buffer and the transformation function runs in another thread consuming the--- input from the buffer.  '|$' is just like regular function application--- operator '$' except that it is concurrent.------ If you read the signature as @(t m a -> t m b) -> (t m a -> t m b)@ you can--- look at it as a transformation that converts a transform function to a--- buffered concurrent transform function.------ The following code prints a value every second even though each stage adds a--- 1 second delay.--------- @--- drain $---    S.mapM (\\x -> threadDelay 1000000 >> print x)---      |$ S.repeatM (threadDelay 1000000 >> return 1)--- @------ /Concurrent/------ @since 0.3.0-{-# INLINE (|$) #-}-(|$) :: (IsStream t, MonadAsync m) => (t m a -> t m b) -> (t m a -> t m b)--- (|$) f = f . Async.mkAsync-(|$) f = f . D.mkParallel---- | Same as '|$'.------  /Internal/----{-# INLINE applyAsync #-}-applyAsync :: (IsStream t, MonadAsync m)-    => (t m a -> t m b) -> (t m a -> t m b)-applyAsync = (|$)---- | Parallel reverse function application operator for streams; just like the--- regular reverse function application operator '&' except that it is--- concurrent.------ @--- drain $---       S.repeatM (threadDelay 1000000 >> return 1)---    |& S.mapM (\\x -> threadDelay 1000000 >> print x)--- @------ /Concurrent/------ @since 0.3.0-{-# INLINE (|&) #-}-(|&) :: (IsStream t, MonadAsync m) => t m a -> (t m a -> t m b) -> t m b-x |& f = f |$ x---- | Parallel fold application operator; applies a fold function @t m a -> m b@--- to a stream @t m a@ concurrently; The the input stream is evaluated--- asynchronously in an independent thread yielding elements to a buffer and--- the folding action runs in another thread consuming the input from the--- buffer.------ If you read the signature as @(t m a -> m b) -> (t m a -> m b)@ you can look--- at it as a transformation that converts a fold function to a buffered--- concurrent fold function.------ The @.@ at the end of the operator is a mnemonic for termination of the--- stream.------ @---    S.foldlM' (\\_ a -> threadDelay 1000000 >> print a) ()---       |$. S.repeatM (threadDelay 1000000 >> return 1)--- @------ /Concurrent/------ @since 0.3.0-{-# INLINE (|$.) #-}-(|$.) :: (IsStream t, MonadAsync m) => (t m a -> m b) -> (t m a -> m b)--- (|$.) f = f . Async.mkAsync-(|$.) f = f . D.mkParallel---- | Same as '|$.'.------  /Internal/----{-# INLINE foldAsync #-}-foldAsync :: (IsStream t, MonadAsync m) => (t m a -> m b) -> (t m a -> m b)-foldAsync = (|$.)---- | Parallel reverse function application operator for applying a run or fold--- functions to a stream. Just like '|$.' except that the operands are reversed.------ @---        S.repeatM (threadDelay 1000000 >> return 1)---    |&. S.foldlM' (\\_ a -> threadDelay 1000000 >> print a) ()--- @------ /Concurrent/------ @since 0.3.0-{-# INLINE (|&.) #-}-(|&.) :: (IsStream t, MonadAsync m) => t m a -> (t m a -> m b) -> m b-x |&. f = f |$. x----------------------------------------------------------------------------------- General Transformation----------------------------------------------------------------------------------- | Use a 'Pipe' to transform a stream.------ /Internal/----{-# INLINE transform #-}-transform :: (IsStream t, Monad m) => Pipe m a b -> t m a -> t m b-transform pipe xs = fromStreamD $ D.transform pipe (toStreamD xs)----------------------------------------------------------------------------------- Transformation by Folding (Scans)----------------------------------------------------------------------------------- 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. Or we can change the signature of scanx to--- accommodate this.------ | Strict left scan with an extraction function. Like 'scanl'', but applies a--- user supplied extraction function (the third argument) at each step. This is--- designed to work with the @foldl@ library. The suffix @x@ is a mnemonic for--- extraction.------ /Since: 0.7.0 (Monad m constraint)/------ /Since 0.2.0/-{-# DEPRECATED scanx "Please use scanl followed by map instead." #-}-{-# INLINE scanx #-}-scanx :: (IsStream t, Monad m) => (x -> a -> x) -> x -> (x -> b) -> t m a -> t m b-scanx = P.scanlx'---- XXX this needs to be concurrent--- | Like 'scanl'' but with a monadic fold function.------ @since 0.4.0-{-# INLINE scanlM' #-}-scanlM' :: (IsStream t, Monad m) => (b -> a -> m b) -> b -> t m a -> t m b-scanlM' step begin m = fromStreamD $ D.scanlM' step begin $ toStreamD m---- | Strict left scan. Like 'map', 'scanl'' too is a one to one transformation,--- however it adds an extra element.------ @--- > S.toList $ S.scanl' (+) 0 $ fromList [1,2,3,4]--- [0,1,3,6,10]--- @------ @--- > S.toList $ S.scanl' (flip (:)) [] $ S.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'@:------ @--- > S.foldl' (\\(s, p) x -> (s + x, p * x)) (0,1) $ S.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:------ @--- >   S.foldl' (\\(_, p) (s, x) -> (s, p * x)) (0,1)---   $ S.scanl' (\\(s, _) x -> (s + x, x)) (0,1)---   $ S.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.------ @since 0.2.0-{-# INLINE scanl' #-}-scanl' :: (IsStream t, Monad m) => (b -> a -> b) -> b -> t m a -> t m b-scanl' step z m = fromStreamS $ S.scanl' step z $ toStreamS m---- | Like 'scanl'' but does not stream the initial value of the accumulator.------ > postscanl' f z xs = S.drop 1 $ S.scanl' f z xs------ @since 0.7.0-{-# INLINE postscanl' #-}-postscanl' :: (IsStream t, Monad m) => (b -> a -> b) -> b -> t m a -> t m b-postscanl' step z m = fromStreamD $ D.postscanl' step z $ toStreamD m---- XXX this needs to be concurrent--- | Like 'postscanl'' but with a monadic step function.------ @since 0.7.0-{-# INLINE postscanlM' #-}-postscanlM' :: (IsStream t, Monad m) => (b -> a -> m b) -> b -> t m a -> t m b-postscanlM' step z m = fromStreamD $ D.postscanlM' step z $ toStreamD m---- XXX prescanl does not sound very useful, enable only if there is a--- compelling use case.------ | Like scanl' but does not stream the final value of the accumulator.------ /Internal/-{-# INLINE prescanl' #-}-prescanl' :: (IsStream t, Monad m) => (b -> a -> b) -> b -> t m a -> t m b-prescanl' step z m = fromStreamD $ D.prescanl' step z $ toStreamD m---- XXX this needs to be concurrent--- | Like postscanl' but with a monadic step function.------ /Internal/-{-# INLINE prescanlM' #-}-prescanlM' :: (IsStream t, Monad m) => (b -> a -> m b) -> m b -> t m a -> t m b-prescanlM' step z m = fromStreamD $ D.prescanlM' step z $ toStreamD m---- XXX this needs to be concurrent--- | Like 'scanl1'' but with a monadic step function.------ @since 0.6.0-{-# INLINE scanl1M' #-}-scanl1M' :: (IsStream t, Monad m) => (a -> a -> m a) -> t m a -> t m a-scanl1M' step m = fromStreamD $ D.scanl1M' step $ toStreamD m---- | 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.------ @--- > S.toList $ S.scanl1 (+) $ fromList [1,2,3,4]--- [1,3,6,10]--- @------ @since 0.6.0-{-# INLINE scanl1' #-}-scanl1' :: (IsStream t, Monad m) => (a -> a -> a) -> t m a -> t m a-scanl1' step m = fromStreamD $ D.scanl1' step $ toStreamD m----------------------------------------------------------------------------------- Scanning with a Fold----------------------------------------------------------------------------------- | Scan a stream using the given monadic fold.------ @since 0.7.0-{-# INLINE scan #-}-scan :: (IsStream t, Monad m) => Fold m a b -> t m a -> t m b-scan (Fold step begin done) = P.scanlMx' step begin done---- | Postscan a stream using the given monadic fold.------ @since 0.7.0-{-# INLINE postscan #-}-postscan :: (IsStream t, Monad m) => Fold m a b -> t m a -> t m b-postscan (Fold step begin done) = P.postscanlMx' step begin done----------------------------------------------------------------------------------- Stateful Transformations----------------------------------------------------------------------------------- | Apply a function on every two successive elements of a stream. If the--- stream consists of a single element the output is an empty stream.------ /Internal/----{-# INLINE rollingMap #-}-rollingMap :: (IsStream t, Monad m) => (a -> a -> b) -> t m a -> t m b-rollingMap f m = fromStreamD $ D.rollingMap f $ toStreamD m---- | Like 'rollingMap' but with an effectful map function.------ /Internal/----{-# INLINE rollingMapM #-}-rollingMapM :: (IsStream t, Monad m) => (a -> a -> m b) -> t m a -> t m b-rollingMapM f m = fromStreamD $ D.rollingMapM f $ toStreamD m----------------------------------------------------------------------------------- Transformation by Filtering----------------------------------------------------------------------------------- | Include only those elements that pass a predicate.------ @since 0.1.0-{-# INLINE filter #-}-#if __GLASGOW_HASKELL__ != 802--- GHC 8.2.2 crashes with this code, when used with "stack"-filter :: (IsStream t, Monad m) => (a -> Bool) -> t m a -> t m a-filter p m = fromStreamS $ S.filter p $ toStreamS m-#else-filter :: IsStream t => (a -> Bool) -> t m a -> t m a-filter = K.filter-#endif---- | Same as 'filter' but with a monadic predicate.------ @since 0.4.0-{-# INLINE filterM #-}-filterM :: (IsStream t, Monad m) => (a -> m Bool) -> t m a -> t m a-filterM p m = fromStreamD $ D.filterM p $ toStreamD m---- | Drop repeated elements that are adjacent to each other.------ @since 0.6.0-{-# INLINE uniq #-}-uniq :: (Eq a, IsStream t, Monad m) => t m a -> t m a-uniq = fromStreamD . D.uniq . toStreamD---- | Ensures that all the elements of the stream are identical and then returns--- that unique element.------ @since 0.6.0-{-# INLINE the #-}-the :: (Eq a, Monad m) => SerialT m a -> m (Maybe a)-the m = S.the (toStreamS m)---- | Take first 'n' elements from the stream and discard the rest.------ @since 0.1.0-{-# INLINE take #-}-take :: (IsStream t, Monad m) => Int -> t m a -> t m a-take n m = fromStreamS $ S.take n $ toStreamS-    (maxYields (Just (fromIntegral n)) m)---- | End the stream as soon as the predicate fails on an element.------ @since 0.1.0-{-# INLINE takeWhile #-}-takeWhile :: (IsStream t, Monad m) => (a -> Bool) -> t m a -> t m a-takeWhile p m = fromStreamS $ S.takeWhile p $ toStreamS m---- | Same as 'takeWhile' but with a monadic predicate.------ @since 0.4.0-{-# INLINE takeWhileM #-}-takeWhileM :: (IsStream t, Monad m) => (a -> m Bool) -> t m a -> t m a-takeWhileM p m = fromStreamD $ D.takeWhileM p $ toStreamD m---- | @takeByTime duration@ yields stream elements upto specified time--- @duration@. The duration starts when the stream is evaluated for the first--- time, before the first element is yielded. The time duration is checked--- before generating each element, if the duration has expired the stream--- stops.------ The total time taken in executing the stream is guaranteed to be /at least/--- @duration@, however, because the duration is checked before generating an--- element, the upper bound is indeterminate and depends on the time taken in--- generating and processing the last element.------ No element is yielded if the duration is zero. At least one element is--- yielded if the duration is non-zero.------ /Internal/----{-# INLINE takeByTime #-}-takeByTime ::(MonadIO m, IsStream t, TimeUnit64 d) => d -> t m a -> t m a-takeByTime d = fromStreamD . D.takeByTime d . toStreamD---- | Discard first 'n' elements from the stream and take the rest.------ @since 0.1.0-{-# INLINE drop #-}-drop :: (IsStream t, Monad m) => Int -> t m a -> t m a-drop n m = fromStreamS $ S.drop n $ toStreamS m---- | Drop elements in the stream as long as the predicate succeeds and then--- take the rest of the stream.------ @since 0.1.0-{-# INLINE dropWhile #-}-dropWhile :: (IsStream t, Monad m) => (a -> Bool) -> t m a -> t m a-dropWhile p m = fromStreamS $ S.dropWhile p $ toStreamS m---- | Same as 'dropWhile' but with a monadic predicate.------ @since 0.4.0-{-# INLINE dropWhileM #-}-dropWhileM :: (IsStream t, Monad m) => (a -> m Bool) -> t m a -> t m a-dropWhileM p m = fromStreamD $ D.dropWhileM p $ toStreamD m---- | @dropByTime duration@ drops stream elements until specified @duration@ has--- passed.  The duration begins when the stream is evaluated for the first--- time. The time duration is checked /after/ generating a stream element, the--- element is yielded if the duration has expired otherwise it is dropped.------ The time elapsed before starting to generate the first element is /at most/--- @duration@, however, because the duration expiry is checked after the--- element is generated, the lower bound is indeterminate and depends on the--- time taken in generating an element.------ All elements are yielded if the duration is zero.------ /Internal/----{-# INLINE dropByTime #-}-dropByTime ::(MonadIO m, IsStream t, TimeUnit64 d) => d -> t m a -> t m a-dropByTime d = fromStreamD . D.dropByTime d . toStreamD----------------------------------------------------------------------------------- Transformation by Mapping----------------------------------------------------------------------------------- |--- @--- mapM f = sequence . map f--- @------ Apply a monadic function to each element of the stream and replace it with--- the output of the resulting action.------ @--- > drain $ S.mapM putStr $ S.fromList ["a", "b", "c"]--- abc------ drain $ S.replicateM 10 (return 1)---           & (serially . S.mapM (\\x -> threadDelay 1000000 >> print x))------ drain $ S.replicateM 10 (return 1)---           & (asyncly . S.mapM (\\x -> threadDelay 1000000 >> print x))--- @------ /Concurrent (do not use with 'parallely' on infinite streams)/------ @since 0.1.0-{-# INLINE_EARLY mapM #-}-mapM :: (IsStream t, MonadAsync m) => (a -> m b) -> t m a -> t m b-mapM = K.mapM--{-# RULES "mapM serial" mapM = mapMSerial #-}-{-# INLINE mapMSerial #-}-mapMSerial :: Monad m => (a -> m b) -> SerialT m a -> SerialT m b-mapMSerial = Serial.mapM---- |--- @--- sequence = mapM id--- @------ Replace the elements of a stream of monadic actions with the outputs of--- those actions.------ @--- > drain $ S.sequence $ S.fromList [putStr "a", putStr "b", putStrLn "c"]--- abc------ drain $ S.replicateM 10 (return $ threadDelay 1000000 >> print 1)---           & (serially . S.sequence)------ drain $ S.replicateM 10 (return $ threadDelay 1000000 >> print 1)---           & (asyncly . S.sequence)--- @------ /Concurrent (do not use with 'parallely' on infinite streams)/------ @since 0.1.0-{-# INLINE sequence #-}-sequence :: (IsStream t, MonadAsync m) => t m (m a) -> t m a-sequence m = fromStreamS $ S.sequence (toStreamS m)----------------------------------------------------------------------------------- Transformation by Map and Filter----------------------------------------------------------------------------------- | 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 = S.map 'fromJust' . S.filter 'isJust' . S.map f--- @------ @since 0.3.0-{-# INLINE mapMaybe #-}-mapMaybe :: (IsStream t, Monad m) => (a -> Maybe b) -> t m a -> t m b-mapMaybe f m = fromStreamS $ S.mapMaybe f $ toStreamS m---- | Like 'mapMaybe' but maps a monadic function.------ Equivalent to:------ @--- mapMaybeM f = S.map 'fromJust' . S.filter 'isJust' . S.mapM f--- @------ /Concurrent (do not use with 'parallely' on infinite streams)/------ @since 0.3.0-{-# INLINE_EARLY mapMaybeM #-}-mapMaybeM :: (IsStream t, MonadAsync m, Functor (t m))-          => (a -> m (Maybe b)) -> t m a -> t m b-mapMaybeM f = fmap fromJust . filter isJust . K.mapM f--{-# RULES "mapMaybeM serial" mapMaybeM = mapMaybeMSerial #-}-{-# INLINE mapMaybeMSerial #-}-mapMaybeMSerial :: Monad m => (a -> m (Maybe b)) -> SerialT m a -> SerialT m b-mapMaybeMSerial f m = fromStreamD $ D.mapMaybeM f $ toStreamD m----------------------------------------------------------------------------------- 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.------ > reverse = S.foldlT (flip S.cons) S.nil------ | Returns the elements of the stream in reverse order.  The stream must be--- finite. Note that this necessarily buffers the entire stream in memory.------ /Since 0.7.0 (Monad m constraint)/------ /Since: 0.1.1/-{-# INLINE reverse #-}-reverse :: (IsStream t, Monad m) => t m a -> t m a-reverse s = fromStreamS $ S.reverse $ toStreamS s---- | Like 'reverse' but several times faster, requires a 'Storable' instance.------ /Internal/-{-# INLINE reverse' #-}-reverse' :: (IsStream t, MonadIO m, Storable a) => t m a -> t m a-reverse' s = fromStreamD $ D.reverse' $ toStreamD s----------------------------------------------------------------------------------- Transformation by Inserting----------------------------------------------------------------------------------- intersperseM = intersperseBySpan 1---- | Generate a stream by inserting the result of a monadic action between--- consecutive elements of the given stream. Note that the monadic action is--- performed after the stream action before which its result is inserted.------ @--- > S.toList $ S.intersperseM (return ',') $ S.fromList "hello"--- "h,e,l,l,o"--- @------ @since 0.5.0-{-# INLINE intersperseM #-}-intersperseM :: (IsStream t, MonadAsync m) => m a -> t m a -> t m a-intersperseM m = fromStreamS . S.intersperseM m . toStreamS---- | Generate a stream by inserting a given element between consecutive--- elements of the given stream.------ @--- > S.toList $ S.intersperse ',' $ S.fromList "hello"--- "h,e,l,l,o"--- @------ @since 0.7.0-{-# INLINE intersperse #-}-intersperse :: (IsStream t, MonadAsync m) => a -> t m a -> t m a-intersperse a = fromStreamS . S.intersperse a . toStreamS---- | Insert a monadic action after each element in the stream.------ /Internal/-{-# INLINE intersperseSuffix #-}-intersperseSuffix :: (IsStream t, MonadAsync m) => m a -> t m a -> t m a-intersperseSuffix m = fromStreamD . D.intersperseSuffix m . toStreamD---- | Perform a side effect after each element of a stream. The output of the--- effectful action is discarded, therefore, the input stream remains--- unchanged.------ @--- > S.mapM_ putChar $ S.intersperseSuffix_ (threadDelay 1000000) $ S.fromList "hello"--- @------ /Internal/----{-# INLINE intersperseSuffix_ #-}-intersperseSuffix_ :: (IsStream t, Monad m) => m b -> t m a -> t m a-intersperseSuffix_ m = Serial.mapM (\x -> void m >> return x)---- | Introduces a delay of specified seconds after each element of a stream.------ /Internal/----{-# INLINE delayPost #-}-delayPost :: (IsStream t, MonadIO m) => Double -> t m a -> t m a-delayPost n = intersperseSuffix_ $ liftIO $ threadDelay $ round $ n * 1000000---- | Like 'intersperseSuffix' but intersperses a monadic action into the input--- stream after every @n@ elements and after the last element.------ @--- > S.toList $ S.intersperseSuffixBySpan 2 (return ',') $ S.fromList "hello"--- "he,ll,o,"--- @------ /Internal/----{-# INLINE intersperseSuffixBySpan #-}-intersperseSuffixBySpan :: (IsStream t, MonadAsync m)-    => Int -> m a -> t m a -> t m a-intersperseSuffixBySpan n eff =-    fromStreamD . D.intersperseSuffixBySpan n eff . toStreamD--{---- | Intersperse a monadic action into the input stream after every @n@--- elements.------ @--- > S.toList $ S.intersperseBySpan 2 (return ',') $ S.fromList "hello"--- "he,ll,o"--- @------ @since 0.7.0-{-# INLINE intersperseBySpan #-}-intersperseBySpan :: IsStream t => Int -> m a -> t m a -> t m a-intersperseBySpan _n _f _xs = undefined--}---- | Intersperse a monadic action into the input stream after every @n@--- seconds.------ @--- > S.drain $ S.interjectSuffix 1 (putChar ',') $ S.mapM (\\x -> threadDelay 1000000 >> putChar x) $ S.fromList "hello"--- "h,e,l,l,o"--- @------ /Internal/-{-# INLINE interjectSuffix #-}-interjectSuffix-    :: (IsStream t, MonadAsync m)-    => Double -> m a -> t m a -> t m a-interjectSuffix n f xs = xs `Par.parallelFst` repeatM timed-    where timed = liftIO (threadDelay (round $ n * 1000000)) >> f---- | @insertBy cmp elem stream@ inserts @elem@ before the first element in--- @stream@ that is less than @elem@ when compared using @cmp@.------ @--- insertBy cmp x = 'mergeBy' cmp ('yield' x)--- @------ @--- > S.toList $ S.insertBy compare 2 $ S.fromList [1,3,5]--- [1,2,3,5]--- @------ @since 0.6.0-{-# INLINE insertBy #-}-insertBy ::-       (IsStream t, Monad m) => (a -> a -> Ordering) -> a -> t m a -> t m a-insertBy cmp x m = fromStreamS $ S.insertBy cmp x (toStreamS m)----------------------------------------------------------------------------------- Deleting----------------------------------------------------------------------------------- | Deletes the first occurrence of the element in the stream that satisfies--- the given equality predicate.------ @--- > S.toList $ S.deleteBy (==) 3 $ S.fromList [1,3,3,5]--- [1,3,5]--- @------ @since 0.6.0-{-# INLINE deleteBy #-}-deleteBy :: (IsStream t, Monad m) => (a -> a -> Bool) -> a -> t m a -> t m a-deleteBy cmp x m = fromStreamS $ S.deleteBy cmp x (toStreamS m)----------------------------------------------------------------------------------- Zipping----------------------------------------------------------------------------------- |--- > indexed = S.postscanl' (\(i, _) x -> (i + 1, x)) (-1,undefined)--- > indexed = S.zipWith (,) (S.enumerateFrom 0)------ Pair each element in a stream with its index, starting from index 0.------ @--- > S.toList $ S.indexed $ S.fromList "hello"--- [(0,'h'),(1,'e'),(2,'l'),(3,'l'),(4,'o')]--- @------ @since 0.6.0-{-# INLINE indexed #-}-indexed :: (IsStream t, Monad m) => t m a -> t m (Int, a)-indexed = fromStreamD . D.indexed . toStreamD---- |--- > indexedR n = S.postscanl' (\(i, _) x -> (i - 1, x)) (n + 1,undefined)--- > indexedR n = S.zipWith (,) (S.enumerateFromThen n (n - 1))------ Pair each element in a stream with its index, starting from the--- given index @n@ and counting down.------ @--- > S.toList $ S.indexedR 10 $ S.fromList "hello"--- [(10,'h'),(9,'e'),(8,'l'),(7,'l'),(6,'o')]--- @------ @since 0.6.0-{-# INLINE indexedR #-}-indexedR :: (IsStream t, Monad m) => Int -> t m a -> t m (Int, a)-indexedR n = fromStreamD . D.indexedR n . toStreamD----------------------------------------------------------------------------------- Comparison----------------------------------------------------------------------------------- | Compare two streams for equality using an equality function.------ @since 0.6.0-{-# INLINABLE eqBy #-}-eqBy :: (IsStream t, Monad m) => (a -> b -> Bool) -> t m a -> t m b -> m Bool-eqBy = P.eqBy---- | Compare two streams lexicographically using a comparison function.------ @since 0.6.0-{-# INLINABLE cmpBy #-}-cmpBy-    :: (IsStream t, Monad m)-    => (a -> b -> Ordering) -> t m a -> t m b -> m Ordering-cmpBy = P.cmpBy----------------------------------------------------------------------------------- Merge----------------------------------------------------------------------------------- | 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.------ @--- > S.toList $ S.mergeBy compare (S.fromList [1,3,5]) (S.fromList [2,4,6,8])--- [1,2,3,4,5,6,8]--- @------ @since 0.6.0-{-# INLINABLE mergeBy #-}-mergeBy ::-       (IsStream t, Monad m) => (a -> a -> Ordering) -> t m a -> t m a -> t m a-mergeBy f m1 m2 = fromStreamS $ S.mergeBy f (toStreamS m1) (toStreamS m2)---- | Like 'mergeBy' but with a monadic comparison function.------ Merge two streams randomly:------ @--- > randomly _ _ = randomIO >>= \x -> return $ if x then LT else GT--- > S.toList $ S.mergeByM randomly (S.fromList [1,1,1,1]) (S.fromList [2,2,2,2])--- [2,1,2,2,2,1,1,1]--- @------ Merge two streams in a proportion of 2:1:------ @--- proportionately m n = do---  ref <- newIORef $ cycle $ concat [replicate m LT, replicate n GT]---  return $ \\_ _ -> do---      r <- readIORef ref---      writeIORef ref $ tail r---      return $ head r------ main = do---  f <- proportionately 2 1---  xs <- S.toList $ S.mergeByM f (S.fromList [1,1,1,1,1,1]) (S.fromList [2,2,2])---  print xs--- @--- @--- [1,1,2,1,1,2,1,1,2]--- @------ @since 0.6.0-{-# INLINABLE mergeByM #-}-mergeByM-    :: (IsStream t, Monad m)-    => (a -> a -> m Ordering) -> t m a -> t m a -> t m a-mergeByM f m1 m2 = fromStreamS $ S.mergeByM f (toStreamS m1) (toStreamS m2)--{---- | Like 'mergeByM' but stops merging as soon as any of the two streams stops.-{-# INLINABLE mergeEndByAny #-}-mergeEndByAny-    :: (IsStream t, Monad m)-    => (a -> a -> m Ordering) -> t m a -> t m a -> t m a-mergeEndByAny f m1 m2 = fromStreamD $-    D.mergeEndByAny f (toStreamD m1) (toStreamD m2)---- Like 'mergeByM' but stops merging as soon as the first stream stops.-{-# INLINABLE mergeEndByFirst #-}-mergeEndByFirst-    :: (IsStream t, Monad m)-    => (a -> a -> m Ordering) -> t m a -> t m a -> t m a-mergeEndByFirst f m1 m2 = fromStreamS $-    D.mergeEndByFirst f (toStreamD m1) (toStreamD m2)--}---- Holding this back for now, we may want to use the name "merge" differently-{---- | Same as @'mergeBy' 'compare'@.------ @--- > S.toList $ S.merge (S.fromList [1,3,5]) (S.fromList [2,4,6,8])--- [1,2,3,4,5,6,8]--- @------ @since 0.6.0-{-# INLINABLE merge #-}-merge ::-       (IsStream t, Monad m, Ord a) => t m a -> t m a -> t m a-merge = mergeBy compare--}---- | Like 'mergeBy' but merges concurrently (i.e. both the elements being--- merged are generated concurrently).------ @since 0.6.0-{-# INLINE mergeAsyncBy #-}-mergeAsyncBy :: (IsStream t, MonadAsync m)-    => (a -> a -> Ordering) -> t m a -> t m a -> t m a-mergeAsyncBy f = mergeAsyncByM (\a b -> return $ f a b)---- | Like 'mergeByM' but merges concurrently (i.e. both the elements being--- merged are generated concurrently).------ @since 0.6.0-{-# INLINE mergeAsyncByM #-}-mergeAsyncByM :: (IsStream t, MonadAsync m)-    => (a -> a -> m Ordering) -> t m a -> t m a -> t m a-mergeAsyncByM f m1 m2 = fromStreamD $-    D.mergeByM f (D.mkParallelD $ toStreamD m1) (D.mkParallelD $ toStreamD m2)----------------------------------------------------------------------------------- Nesting----------------------------------------------------------------------------------- | @concatMapWith merge map stream@ is a two dimensional looping combinator.--- The first argument specifies a merge or concat function that is used to--- merge the streams generated by applying the second argument i.e. the @map@--- function to each element of the input stream. The concat function could be--- 'serial', 'parallel', 'async', 'ahead' or any other zip or merge function--- and the second argument could be any stream generation function using a--- seed.------ /Compare 'foldMapWith'/------ @since 0.7.0-{-# INLINE concatMapWith #-}-concatMapWith-    :: IsStream t-    => (forall c. t m c -> t m c -> t m c)-    -> (a -> t m b)-    -> t m a-    -> t m b-concatMapWith = K.concatMapBy---- | Map a stream producing function on each element of the stream and then--- flatten the results into a single stream.------ @--- concatMap = 'concatMapWith' 'Serial.serial'--- concatMap f = 'concatMapM' (return . f)--- @------ @since 0.6.0-{-# INLINE concatMap #-}-concatMap ::(IsStream t, Monad m) => (a -> t m b) -> t m a -> t m b-concatMap f m = fromStreamD $ D.concatMap (toStreamD . f) (toStreamD m)---- | Flatten a stream of streams to a single stream.------ @--- concat = concatMap id--- @------ /Internal/-{-# INLINE concat #-}-concat :: (IsStream t, Monad m) => t m (t m a) -> t m a-concat = concatMap id---- | Append the outputs of two streams, yielding all the elements from the--- first stream and then yielding all the elements from the second stream.------ IMPORTANT NOTE: This could be 100x faster than @serial/<>@ for appending a--- few (say 100) streams because it can fuse via stream fusion. However, it--- does not scale for a large number of streams (say 1000s) and becomes--- qudartically slow. Therefore use this for custom appending of a few streams--- but use 'concatMap' or 'concatMapWith serial' for appending @n@ streams or--- infinite containers of streams.------ /Internal/-{-# INLINE append #-}-append ::(IsStream t, Monad m) => t m b -> t m b -> t m b-append m1 m2 = fromStreamD $ D.append (toStreamD m1) (toStreamD m2)---- XXX Same as 'wSerial'. We should perhaps rename wSerial to interleave.--- XXX Document the interleaving behavior of side effects in all the--- interleaving combinators.--- XXX Write time-domain equivalents of these. In the time domain we can--- interleave two streams such that the value of second stream is always taken--- from its last value even if no new value is being yielded, like--- zipWithLatest. It would be something like interleaveWithLatest.------ | Interleaves the outputs of two streams, yielding elements from each stream--- alternately, starting from the first stream. If any of the streams finishes--- early the other stream continues alone until it too finishes.------ >>> :set -XOverloadedStrings--- >>> interleave "ab" ",,,," :: SerialT Identity Char--- fromList "a,b,,,"--- >>> interleave "abcd" ",," :: SerialT Identity Char--- fromList "a,b,cd"------ 'interleave' is dual to 'interleaveMin', it can be called @interleaveMax@.------ Do not use at scale in concatMapWith.------ /Internal/-{-# INLINE interleave #-}-interleave ::(IsStream t, Monad m) => t m b -> t m b -> t m b-interleave m1 m2 = fromStreamD $ D.interleave (toStreamD m1) (toStreamD m2)---- | 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--- >>> interleaveSuffix "abc" ",,,," :: SerialT Identity Char--- fromList "a,b,c,"--- >>> interleaveSuffix "abc" "," :: SerialT Identity Char--- fromList "a,bc"------ 'interleaveSuffix' is a dual of 'interleaveInfix'.------ Do not use at scale in concatMapWith.------ /Internal/-{-# INLINE interleaveSuffix #-}-interleaveSuffix ::(IsStream t, Monad m) => t m b -> t m b -> t m b-interleaveSuffix m1 m2 =-    fromStreamD $ D.interleaveSuffix (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--- >>> interleaveInfix "abc" ",,,," :: SerialT Identity Char--- fromList "a,b,c"--- >>> interleaveInfix "abc" "," :: SerialT Identity Char--- fromList "a,bc"------ 'interleaveInfix' is a dual of 'interleaveSuffix'.------ Do not use at scale in concatMapWith.------ /Internal/-{-# INLINE interleaveInfix #-}-interleaveInfix ::(IsStream t, Monad m) => t m b -> t m b -> t m b-interleaveInfix m1 m2 =-    fromStreamD $ D.interleaveInfix (toStreamD m1) (toStreamD m2)---- | Interleaves the outputs of two streams, yielding elements from each stream--- alternately, starting from the first stream. The output stops as soon as any--- of the two streams finishes, discarding the remaining part of the other--- stream. The last element of the resulting stream would be from the longer--- stream.------ >>> :set -XOverloadedStrings--- >>> interleaveMin "ab" ",,,," :: SerialT Identity Char--- fromList "a,b,"--- >>> interleaveMin "abcd" ",," :: SerialT Identity Char--- fromList "a,b,c"------ 'interleaveMin' is dual to 'interleave'.------ Do not use at scale in concatMapWith.------ /Internal/-{-# INLINE interleaveMin #-}-interleaveMin ::(IsStream t, Monad m) => t m b -> t m b -> t m b-interleaveMin m1 m2 = fromStreamD $ D.interleaveMin (toStreamD m1) (toStreamD m2)---- | 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.------ /Internal/-{-# INLINE roundrobin #-}-roundrobin ::(IsStream t, Monad m) => t m b -> t m b -> t m b-roundrobin m1 m2 = fromStreamD $ D.roundRobin (toStreamD m1) (toStreamD m2)---- | 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.------ @since 0.6.0-{-# INLINE concatMapM #-}-concatMapM :: (IsStream t, Monad m) => (a -> m (t m b)) -> t m a -> t m b-concatMapM f m = fromStreamD $ D.concatMapM (fmap toStreamD . f) (toStreamD m)---- | Given a stream value in the underlying monad, lift and join the underlying--- monad with the stream monad.------ Compare with 'concat' and 'sequence'.------  /Internal/----{-# INLINE concatM #-}-concatM :: (IsStream t, Monad m) => m (t m a) -> t m a-concatM generator = concatMapM (\() -> generator) (yield ())---- | 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.------ @since 0.7.0-{-# INLINE concatUnfold #-}-concatUnfold ::(IsStream t, Monad m) => Unfold m a b -> t m a -> t m b-concatUnfold u m = fromStreamD $ D.concatMapU u (toStreamD m)---- | Like 'concatUnfold' but interleaves the streams in the same way as--- 'interleave' behaves instead of appending them.------ /Internal/-{-# INLINE concatUnfoldInterleave #-}-concatUnfoldInterleave ::(IsStream t, Monad m)-    => Unfold m a b -> t m a -> t m b-concatUnfoldInterleave u m =-    fromStreamD $ D.concatUnfoldInterleave u (toStreamD m)---- | Like 'concatUnfold' but executes the streams in the same way as--- 'roundrobin'.------ /Internal/-{-# INLINE concatUnfoldRoundrobin #-}-concatUnfoldRoundrobin ::(IsStream t, Monad m)-    => Unfold m a b -> t m a -> t m b-concatUnfoldRoundrobin u m =-    fromStreamD $ D.concatUnfoldRoundrobin u (toStreamD m)---- XXX we can swap the order of arguments to gintercalate so that the--- definition of concatUnfold 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.------ > concatUnfold unf str =--- >     gintercalate unf str (UF.nilM (\_ -> return ())) (repeat ())------ | 'interleaveInfix' followed by unfold and concat.------ /Internal/-{-# INLINE gintercalate #-}-gintercalate-    :: (IsStream t, Monad m)-    => Unfold m a c -> t m a -> Unfold m b c -> t m b -> t m c-gintercalate unf1 str1 unf2 str2 =-    D.fromStreamD $ D.gintercalate-        unf1 (D.toStreamD str1)-        unf2 (D.toStreamD str2)---- XXX The order of arguments in "intercalate" is consistent with the list--- intercalate but inconsistent with gintercalate and other stream interleaving--- combinators. We can change the order of the arguments in other combinators--- but then 'interleave' combinator may become a bit unintuitive because we--- will be starting with the second stream.---- > intercalate seed unf str = gintercalate unf str unf (repeatM seed)--- > intercalate a unf str = concatUnfold unf $ intersperse a str------ | 'intersperse' followed by unfold and concat.------ > unwords = intercalate " " UF.fromList------ >>> intercalate " " UF.fromList ["abc", "def", "ghi"]--- > "abc def ghi"------ /Internal/-{-# INLINE intercalate #-}-intercalate :: (IsStream t, Monad m)-    => b -> Unfold m b c -> t m b -> t m c-intercalate seed unf str = D.fromStreamD $-    D.concatMapU unf $ D.intersperse seed (toStreamD str)---- > 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 = S.interpose ' '------ /Internal/-{-# INLINE interpose #-}-interpose :: (IsStream t, Monad m)-    => c -> Unfold m b c -> t m b -> t m c-interpose x unf str =-    D.fromStreamD $ D.interpose (return x) unf (D.toStreamD str)---- | 'interleaveSuffix' followed by unfold and concat.------ /Internal/-{-# INLINE gintercalateSuffix #-}-gintercalateSuffix-    :: (IsStream t, Monad m)-    => Unfold m a c -> t m a -> Unfold m b c -> t m b -> t m c-gintercalateSuffix unf1 str1 unf2 str2 =-    D.fromStreamD $ D.gintercalateSuffix-        unf1 (D.toStreamD str1)-        unf2 (D.toStreamD str2)---- > intercalateSuffix seed unf str = gintercalateSuffix unf str unf (repeatM seed)--- > intercalateSuffix a unf str = concatUnfold unf $ intersperseSuffix a str------ | 'intersperseSuffix' followed by unfold and concat.------ > unlines = intercalateSuffix "\n" UF.fromList------ >>> intercalate "\n" UF.fromList ["abc", "def", "ghi"]--- > "abc\ndef\nghi\n"------ /Internal/-{-# INLINE intercalateSuffix #-}-intercalateSuffix :: (IsStream t, Monad m)-    => b -> Unfold m b c -> t m b -> t m c-intercalateSuffix seed unf str = fromStreamD $ D.concatMapU unf-    $ D.intersperseSuffix (return seed) (D.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 = S.interposeSuffix '\n'------ /Internal/-{-# INLINE interposeSuffix #-}-interposeSuffix :: (IsStream t, Monad m)-    => c -> Unfold m b c -> t m b -> t m c-interposeSuffix x unf str =-    D.fromStreamD $ D.interposeSuffix (return x) unf (D.toStreamD str)----------------------------------------------------------------------------------- Flattening Trees----------------------------------------------------------------------------------- | Like 'iterateM' but using a stream generator function.------ /Internal/----{-# INLINE concatMapIterateWith #-}-concatMapIterateWith-    :: IsStream t-    => (forall c. t m c -> t m c -> t m c)-    -> (a -> t m a)-    -> t m a-    -> t m a-concatMapIterateWith combine f xs = concatMapWith combine go xs-    where-    go x = yield x `combine` concatMapWith combine go (f x)---- concatMapIterateLeftsWith------ | Traverse a forest with recursive tree structures whose non-leaf nodes are--- of type @a@ and leaf nodes are of type @b@, flattening all the trees into--- streams and combining the streams into a single stream consisting of both--- leaf and non-leaf nodes.------ 'concatMapTreeWith' is a generalization of 'concatMap', using a recursive--- feedback loop to append the non-leaf nodes back to the input stream enabling--- recursive traversal.  'concatMap' flattens a single level nesting whereas--- 'concatMapTreeWith' flattens a recursively nested structure.------ Traversing a directory tree recursively is a canonical use case of--- 'concatMapTreeWith'.------ @--- concatMapTreeWith combine f xs = concatMapIterateWith combine g xs---      where---      g (Left tree)  = f tree---      g (Right leaf) = nil--- @------ /Internal/----{-# INLINE concatMapTreeWith #-}-concatMapTreeWith-    :: IsStream t-    => (forall c. t m c -> t m c -> t m c)-    -> (a -> t m (Either a b))-    -> t m (Either a b) -- Should be t m a?-    -> t m (Either a b)-concatMapTreeWith combine f xs = concatMapWith combine go xs-    where-    go (Left tree)  = yield (Left tree) `combine` concatMapWith combine go (f tree)-    go (Right leaf) = yield $ Right leaf--{---- | Like concatMapTreeWith but produces only stream of leaf elements.--- On an either stream, iterate lefts but yield only rights.------ concatMapEitherYieldRightsWith combine f xs =---  catRights $ concatMapTreeWith combine f xs----{-# INLINE concatMapEitherYieldRightsWith #-}-concatMapEitherYieldRightsWith :: (IsStream t, MonadAsync m)-    => _ -> (a -> t m (Either a b)) -> t m (Either a b) -> t m b-concatMapEitherYieldRightsWith combine f xs = undefined--}--{--{-# INLINE concatUnfoldTree #-}-concatUnfoldTree :: (IsStream t, MonadAsync m)-    => Unfold m a (Either a b) -> t m (Either a b) -> t m (Either a b)-concatUnfoldTree unf xs = undefined--}----------------------------------------------------------------------------------- Feedback loop----------------------------------------------------------------------------------- We can perhaps even implement the SVar using this. The stream we are mapping--- on is the work queue. When evaluated it results in either a leaf element to--- yield or a tail stream to queue back to the work queue.------ | Flatten a stream with a feedback loop back into the input.------ For example, exceptions generated by the output stream can be fed back to--- the input to take any corrective action. The corrective action may be to--- retry the action or do nothing or log the errors. For the retry case we need--- a feedback loop.------ /Internal/----{-# INLINE concatMapLoopWith #-}-concatMapLoopWith-    :: (IsStream t, MonadAsync m)-    => (forall x. t m x -> t m x -> t m x)-    -> (a -> t m (Either b c))-    -> (b -> t m a)  -- ^ feedback function to feed @b@ back into input-    -> t m a-    -> t m c-concatMapLoopWith combine f fb xs =-    concatMapWith combine go $ concatMapWith combine f xs-    where-    go (Left b) = concatMapLoopWith combine f fb $ fb b-    go (Right c) = yield c---- | Concat a stream of trees, generating only leaves.------ Compare with 'concatMapTreeWith'. While the latter returns all nodes in the--- tree, this one returns only the leaves.------ Traversing a directory tree recursively and yielding on the files  is a--- canonical use case of 'concatMapTreeYieldLeavesWith'.------ @--- concatMapTreeYieldLeavesWith combine f = concatMapLoopWith combine f yield--- @------ /Internal/----{-# INLINE concatMapTreeYieldLeavesWith #-}-concatMapTreeYieldLeavesWith-    :: (IsStream t, MonadAsync m)-    => (forall x. t m x -> t m x -> t m x)-    -> (a -> t m (Either a b))-    -> t m a-    -> t m b-concatMapTreeYieldLeavesWith combine f = concatMapLoopWith combine f yield----------------------------------------------------------------------------------- Parsing----------------------------------------------------------------------------------- Splitting operations that take a predicate and a Fold can be--- expressed using splitParse. Operations like chunksOf, intervalsOf, split*,--- can be expressed using splitParse when used with an appropriate Parse.------ | Apply a 'Parse' repeatedly on a stream and emit the parsed values in the--- output stream.------ >>> S.toList $ S.splitParse (PR.take 2 $ PR.fromFold FL.sum) $ S.fromList [1..10]--- > [3,7,11,15,19]------ >>> S.toList $ S.splitParse (PR.line FL.toList) $ S.fromList "hello\nworld"--- > ["hello\n","world"]----{-# INLINE splitParse #-}-splitParse-    :: (IsStream t, MonadThrow m)-    => Parser m a b-    -> t m a-    -> t m b-splitParse f m = D.fromStreamD $ D.splitParse f (D.toStreamD m)----------------------------------------------------------------------------------- Grouping/Splitting------------------------------------------------------------------------------------------------------------------------------------------------------------------ Grouping without looking at elements-------------------------------------------------------------------------------------------------------------------------------------------------------------------- Binary APIs--------------------------------------------------------------------------------------------------------------------------------------------------------------------- N-ary APIs------------------------------------------------------------------------------------------------------------------------------------------------------------------ Generalized grouping----------------------------------------------------------------------------------- This combinator is the most general grouping combinator and can be used to--- implement all other grouping combinators.------ XXX check if this can implement the splitOn combinator i.e. we can slide in--- new elements, slide out old elements and incrementally compute the hash.--- Also, can we implement the windowed classification combinators using this?------ In fact this is a parse. Instead of using a special return value in the fold--- we are using a mapping function.------ Note that 'scanl'' (usually followed by a map to extract the desired value--- from the accumulator) can be used to realize many implementations e.g. a--- sliding window implementation. A scan followed by a mapMaybe is also a good--- pattern to express many problems where we want to emit a filtered output and--- not emit an output on every input.------ Passing on of the initial accumulator value to the next fold is equivalent--- to returning the leftover concept.--{---- | @groupScan splitter fold stream@ folds the input stream using @fold@.--- @splitter@ is applied on the accumulator of the fold every time an item is--- consumed by the fold. The fold continues until @splitter@ returns a 'Just'--- value.  A 'Just' result from the @splitter@ specifies a result to be emitted--- in the output stream and the initial value of the accumulator for the next--- group's fold. This allows us to control whether to start fresh for the next--- fold or to continue from the previous fold's output.----{-# INLINE groupScan #-}-groupScan-    :: (IsStream t, Monad m)-    => (x -> m (Maybe (b, x))) -> Fold m a x -> t m a -> t m b-groupScan split fold m = undefined--}---- | Group the input stream into groups of @n@ elements each and then fold each--- group using the provided fold function.------ >> S.toList $ S.chunksOf 2 FL.sum (S.enumerateFromTo 1 10)--- > [3,7,11,15,19]------ This can be considered as an n-fold version of 'ltake' where we apply--- 'ltake' repeatedly on the leftover stream until the stream exhausts.------ @since 0.7.0-{-# INLINE chunksOf #-}-chunksOf-    :: (IsStream t, Monad m)-    => Int -> Fold m a b -> t m a -> t m b-chunksOf n f m = D.fromStreamD $ D.groupsOf n f (D.toStreamD m)---- |------ /Internal/-{-# INLINE chunksOf2 #-}-chunksOf2-    :: (IsStream t, Monad m)-    => Int -> m c -> Fold2 m c a b -> t m a -> t m b-chunksOf2 n action f m = D.fromStreamD $ D.groupsOf2 n action f (D.toStreamD m)---- | @arraysOf n stream@ groups the elements in the input stream into arrays of--- @n@ elements each.------ Same as the following but may be more efficient:------ > arraysOf n = S.chunksOf n (A.writeN n)------ /Internal/-{-# INLINE arraysOf #-}-arraysOf :: (IsStream t, MonadIO m, Storable a)-    => Int -> t m a -> t m (Array a)-arraysOf n = chunksOf n (writeNUnsafe n)---- XXX we can implement this by repeatedly applying the 'lrunFor' fold.--- XXX add this example after fixing the serial stream rate control--- >>> S.toList $ S.take 5 $ intervalsOf 1 FL.sum $ constRate 2 $ S.enumerateFrom 1--- > [3,7,11,15,19]------ | Group the input stream into windows of @n@ second each and then fold each--- group using the provided fold function.------ @since 0.7.0-{-# INLINE intervalsOf #-}-intervalsOf-    :: (IsStream t, MonadAsync m)-    => Double -> Fold m a b -> t m a -> t m b-intervalsOf n f xs =-    splitWithSuffix isNothing (FL.lcatMaybes f)-        (interjectSuffix n (return Nothing) (Serial.map Just xs))----------------------------------------------------------------------------------- N-ary APIs------------------------------------------------------------------------------------- | @groupsBy cmp f $ S.fromList [a,b,c,...]@ assigns the element @a@ to the--- first group, if @a \`cmp` b@ is 'True' then @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 a new group is started. Each--- group is folded using the fold @f@ and the result of the fold is emitted in--- the output stream.------ >>> S.toList $ S.groupsBy (>) FL.toList $ S.fromList [1,3,7,0,2,5]--- > [[1,3,7],[0,2,5]]------ @since 0.7.0-{-# INLINE groupsBy #-}-groupsBy-    :: (IsStream t, Monad m)-    => (a -> a -> Bool)-    -> Fold m a b-    -> t m a-    -> t m b-groupsBy cmp f m = D.fromStreamD $ D.groupsBy cmp f (D.toStreamD m)---- | Unlike @groupsBy@ this function performs a rolling comparison of two--- successive elements in the input stream. @groupsByRolling cmp f $ S.fromList--- [a,b,c,...]@ assigns the element @a@ to the first group, if @a \`cmp` b@ is--- 'True' then @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 a new group is started. Each group is folded using the fold--- @f@.------ >>> S.toList $ S.groupsByRolling (\a b -> a + 1 == b) FL.toList $ S.fromList [1,2,3,7,8,9]--- > [[1,2,3],[7,8,9]]------ @since 0.7.0-{-# INLINE groupsByRolling #-}-groupsByRolling-    :: (IsStream t, Monad m)-    => (a -> a -> Bool)-    -> Fold m a b-    -> t m a-    -> t m b-groupsByRolling cmp f m =  D.fromStreamD $ D.groupsRollingBy cmp f (D.toStreamD m)---- |--- > groups = groupsBy (==)--- > groups = groupsByRolling (==)------ Groups contiguous spans of equal elements together in individual groups.------ >>> S.toList $ S.groups FL.toList $ S.fromList [1,1,2,2]--- > [[1,1],[2,2]]------ @since 0.7.0-groups :: (IsStream t, Monad m, Eq a) => Fold m a b -> t m a -> t m b-groups = groupsBy (==)----------------------------------------------------------------------------------- N-ary split on a predicate----------------------------------------------------------------------------------- TODO: Use a Splitter configuration similar to the "split" package to make it--- possible to express all splitting combinations. In general, we can have--- infix/suffix/prefix/condensing of separators, dropping both leading/trailing--- separators. We can have a single split operation taking the splitter config--- as argument.---- | Split on an infixed separator element, dropping the separator. Splits the--- stream on separator elements determined by the supplied predicate, separator--- is considered as infixed between two segments, if one side of the separator--- is missing then it is parsed as an empty stream.  The supplied 'Fold' is--- applied on the split segments. With '-' representing non-separator elements--- and '.' as separator, 'splitOn' splits as follows:------ @--- "--.--" => "--" "--"--- "--."   => "--" ""--- ".--"   => ""   "--"--- @------ @splitOn (== x)@ is an inverse of @intercalate (S.yield x)@------ Let's use the following definition for illustration:------ > splitOn' p xs = S.toList $ S.splitOn p (FL.toList) (S.fromList xs)------ >>> splitOn' (== '.') ""--- [""]------ >>> splitOn' (== '.') "."--- ["",""]------ >>> splitOn' (== '.') ".a"--- > ["","a"]------ >>> splitOn' (== '.') "a."--- > ["a",""]------ >>> splitOn' (== '.') "a.b"--- > ["a","b"]------ >>> splitOn' (== '.') "a..b"--- > ["a","","b"]------ @since 0.7.0---- This can be considered as an n-fold version of 'breakOn' where we apply--- 'breakOn' successively on the input stream, dropping the first element--- of the second segment after each break.----{-# INLINE splitOn #-}-splitOn-    :: (IsStream t, Monad m)-    => (a -> Bool) -> Fold m a b -> t m a -> t m b-splitOn predicate f m =-    D.fromStreamD $ D.splitBy predicate f (D.toStreamD m)---- | Like 'splitOn' but the separator is considered as suffixed to the segments--- in the stream. A missing suffix at the end is allowed. A separator at the--- beginning is parsed as empty segment.  With '-' representing elements and--- '.' as separator, 'splitOnSuffix' splits as follows:------ @---  "--.--." => "--" "--"---  "--.--"  => "--" "--"---  ".--."   => "" "--"--- @------ > splitOnSuffix' p xs = S.toList $ S.splitSuffixBy p (FL.toList) (S.fromList xs)------ >>> splitOnSuffix' (== '.') ""--- []------ >>> splitOnSuffix' (== '.') "."--- [""]------ >>> splitOnSuffix' (== '.') "a"--- ["a"]------ >>> splitOnSuffix' (== '.') ".a"--- > ["","a"]------ >>> splitOnSuffix' (== '.') "a."--- > ["a"]------ >>> splitOnSuffix' (== '.') "a.b"--- > ["a","b"]------ >>> splitOnSuffix' (== '.') "a.b."--- > ["a","b"]------ >>> splitOnSuffix' (== '.') "a..b.."--- > ["a","","b",""]------ > lines = splitOnSuffix (== '\n')------ @since 0.7.0---- This can be considered as an n-fold version of 'breakPost' where we apply--- 'breakPost' successively on the input stream, dropping the first element--- of the second segment after each break.----{-# INLINE splitOnSuffix #-}-splitOnSuffix-    :: (IsStream t, Monad m)-    => (a -> Bool) -> Fold m a b -> t m a -> t m b-splitOnSuffix predicate f m =-    D.fromStreamD $ D.splitSuffixBy predicate f (D.toStreamD m)---- | Like 'splitOn' after stripping leading, trailing, and repeated separators.--- Therefore, @".a..b."@ with '.' as the separator would be parsed as--- @["a","b"]@.  In other words, its like parsing words from whitespace--- separated text.------ > wordsBy' p xs = S.toList $ S.wordsBy p (FL.toList) (S.fromList xs)------ >>> wordsBy' (== ',') ""--- > []------ >>> wordsBy' (== ',') ","--- > []------ >>> wordsBy' (== ',') ",a,,b,"--- > ["a","b"]------ > words = wordsBy isSpace------ @since 0.7.0---- It is equivalent to splitting in any of the infix/prefix/suffix styles--- followed by removal of empty segments.-{-# INLINE wordsBy #-}-wordsBy-    :: (IsStream t, Monad m)-    => (a -> Bool) -> Fold m a b -> t m a -> t m b-wordsBy predicate f m =-    D.fromStreamD $ D.wordsBy predicate f (D.toStreamD m)---- | Like 'splitOnSuffix' but keeps the suffix attached to the resulting--- splits.------ > splitWithSuffix' p xs = S.toList $ S.splitWithSuffix p (FL.toList) (S.fromList xs)------ >>> splitWithSuffix' (== '.') ""--- []------ >>> splitWithSuffix' (== '.') "."--- ["."]------ >>> splitWithSuffix' (== '.') "a"--- ["a"]------ >>> splitWithSuffix' (== '.') ".a"--- > [".","a"]------ >>> splitWithSuffix' (== '.') "a."--- > ["a."]------ >>> splitWithSuffix' (== '.') "a.b"--- > ["a.","b"]------ >>> splitWithSuffix' (== '.') "a.b."--- > ["a.","b."]------ >>> splitWithSuffix' (== '.') "a..b.."--- > ["a.",".","b.","."]------ @since 0.7.0---- This can be considered as an n-fold version of 'breakPost' where we apply--- 'breakPost' successively on the input stream.----{-# INLINE splitWithSuffix #-}-splitWithSuffix-    :: (IsStream t, Monad m)-    => (a -> Bool) -> Fold m a b -> t m a -> t m b-splitWithSuffix predicate f m =-    D.fromStreamD $ D.splitSuffixBy' predicate f (D.toStreamD m)----------------------------------------------------------------------------------- Split on a delimiter sequence----------------------------------------------------------------------------------- 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]--- > [[],[]]---- | Like 'splitOn' but the separator is a sequence of elements instead of a--- single element.------ For illustration, let's define a function that operates on pure lists:------ @--- splitOnSeq' pat xs = S.toList $ S.splitOnSeq (A.fromList pat) (FL.toList) (S.fromList xs)--- @------ >>> splitOnSeq' "" "hello"--- > ["h","e","l","l","o"]------ >>> splitOnSeq' "hello" ""--- > [""]------ >>> splitOnSeq' "hello" "hello"--- > ["",""]------ >>> splitOnSeq' "x" "hello"--- > ["hello"]------ >>> splitOnSeq' "h" "hello"--- > ["","ello"]------ >>> splitOnSeq' "o" "hello"--- > ["hell",""]------ >>> splitOnSeq' "e" "hello"--- > ["h","llo"]------ >>> splitOnSeq' "l" "hello"--- > ["he","","o"]------ >>> splitOnSeq' "ll" "hello"--- > ["he","o"]------ 'splitOnSeq' is an inverse of 'intercalate'. The following law always holds:------ > intercalate . splitOn == id------ The following law holds when the separator is non-empty and contains none of--- the elements present in the input lists:------ > splitOn . intercalate == id------ /Internal/---- XXX We can use a polymorphic vector implemented by Array# to represent the--- sequence, that way we can avoid the Storable constraint. If we still need--- Storable Array for performance, we can use a separate splitOnArray API for--- that. We can also have an API where the sequence itself is a lazy stream, so--- that we can search files in files for example.-{-# INLINE splitOnSeq #-}-splitOnSeq-    :: (IsStream t, MonadIO m, Storable a, Enum a, Eq a)-    => Array a -> Fold m a b -> t m a -> t m b-splitOnSeq patt f m = D.fromStreamD $ D.splitOn patt f (D.toStreamD m)--{---- This can be implemented easily using Rabin Karp--- | Split on any one of the given patterns.-{-# INLINE splitOnAny #-}-splitOnAny-    :: (IsStream t, Monad m, Storable a, Integral a)-    => [Array a] -> Fold m a b -> t m a -> t m b-splitOnAny subseq f m = undefined -- D.fromStreamD $ D.splitOnAny f subseq (D.toStreamD m)--}---- | Like 'splitSuffixBy' but the separator is a sequence of elements, instead--- of a predicate for a single element.------ > splitSuffixOn_ pat xs = S.toList $ S.splitSuffixOn (A.fromList pat) (FL.toList) (S.fromList xs)------ >>> splitSuffixOn_ "." ""--- [""]------ >>> splitSuffixOn_ "." "."--- [""]------ >>> splitSuffixOn_ "." "a"--- ["a"]------ >>> splitSuffixOn_ "." ".a"--- > ["","a"]------ >>> splitSuffixOn_ "." "a."--- > ["a"]------ >>> splitSuffixOn_ "." "a.b"--- > ["a","b"]------ >>> splitSuffixOn_ "." "a.b."--- > ["a","b"]------ >>> splitSuffixOn_ "." "a..b.."--- > ["a","","b",""]------ > lines = splitSuffixOn "\n"------ /Internal/-{-# INLINE splitOnSuffixSeq #-}-splitOnSuffixSeq-    :: (IsStream t, MonadIO m, Storable a, Enum a, Eq a)-    => Array a -> Fold m a b -> t m a -> t m b-splitOnSuffixSeq patt f m =-    D.fromStreamD $ D.splitSuffixOn False patt f (D.toStreamD m)--{---- | Like 'splitOn' but drops any empty splits.----{-# INLINE wordsOn #-}-wordsOn-    :: (IsStream t, Monad m, Storable a, Eq a)-    => Array a -> Fold m a b -> t m a -> t m b-wordsOn subseq f m = undefined -- D.fromStreamD $ D.wordsOn f subseq (D.toStreamD m)--}---- XXX use a non-monadic intersperse to remove the MonadAsync constraint.------ | Like 'splitOnSeq' but splits the separator as well, as an infix token.------ > splitOn'_ pat xs = S.toList $ S.splitOn' (A.fromList pat) (FL.toList) (S.fromList xs)------ >>> splitOn'_ "" "hello"--- > ["h","","e","","l","","l","","o"]------ >>> splitOn'_ "hello" ""--- > [""]------ >>> splitOn'_ "hello" "hello"--- > ["","hello",""]------ >>> splitOn'_ "x" "hello"--- > ["hello"]------ >>> splitOn'_ "h" "hello"--- > ["","h","ello"]------ >>> splitOn'_ "o" "hello"--- > ["hell","o",""]------ >>> splitOn'_ "e" "hello"--- > ["h","e","llo"]------ >>> splitOn'_ "l" "hello"--- > ["he","l","","l","o"]------ >>> splitOn'_ "ll" "hello"--- > ["he","ll","o"]------ /Internal/-{-# INLINE splitBySeq #-}-splitBySeq-    :: (IsStream t, MonadAsync m, Storable a, Enum a, Eq a)-    => Array a -> Fold m a b -> t m a -> t m b-splitBySeq patt f m =-    intersperseM (fold f (A.toStream patt)) $ splitOnSeq patt f m---- | Like 'splitSuffixOn' but keeps the suffix intact in the splits.------ > splitSuffixOn'_ pat xs = S.toList $ FL.splitSuffixOn' (A.fromList pat) (FL.toList) (S.fromList xs)------ >>> splitSuffixOn'_ "." ""--- [""]------ >>> splitSuffixOn'_ "." "."--- ["."]------ >>> splitSuffixOn'_ "." "a"--- ["a"]------ >>> splitSuffixOn'_ "." ".a"--- > [".","a"]------ >>> splitSuffixOn'_ "." "a."--- > ["a."]------ >>> splitSuffixOn'_ "." "a.b"--- > ["a.","b"]------ >>> splitSuffixOn'_ "." "a.b."--- > ["a.","b."]------ >>> splitSuffixOn'_ "." "a..b.."--- > ["a.",".","b.","."]------ /Internal/-{-# INLINE splitWithSuffixSeq #-}-splitWithSuffixSeq-    :: (IsStream t, MonadIO m, Storable a, Enum a, Eq a)-    => Array a -> Fold m a b -> t m a -> t m b-splitWithSuffixSeq patt f m =-    D.fromStreamD $ D.splitSuffixOn True patt f (D.toStreamD m)--{---- This can be implemented easily using Rabin Karp--- | Split post any one of the given patterns.-{-# INLINE splitSuffixOnAny #-}-splitSuffixOnAny-    :: (IsStream t, Monad m, Storable a, Integral a)-    => [Array a] -> Fold m a b -> t m a -> t m b-splitSuffixOnAny subseq f m = undefined-    -- D.fromStreamD $ D.splitPostAny f subseq (D.toStreamD m)--}----------------------------------------------------------------------------------- Nested Split----------------------------------------------------------------------------------- | @splitInnerBy splitter joiner stream@ splits the inner containers @f a@ of--- an input stream @t m (f a)@ using the @splitter@ function. Container--- elements @f a@ are collected until a split occurs, then all the elements--- before the split are joined using the @joiner@ function.------ For example, if we have a stream of @Array Word8@, we may want to split the--- stream into arrays representing lines separated by '\n' byte such that the--- resulting stream after a split would be one array for each line.------ CAUTION! This is not a true streaming function as the container size after--- the split and merge may not be bounded.------ /Internal/-{-# INLINE splitInnerBy #-}-splitInnerBy-    :: (IsStream t, Monad m)-    => (f a -> m (f a, Maybe (f a)))  -- splitter-    -> (f a -> f a -> m (f a))        -- joiner-    -> t m (f a)-    -> t m (f a)-splitInnerBy splitter joiner xs =-    D.fromStreamD $ D.splitInnerBy splitter joiner $ D.toStreamD xs---- | Like 'splitInnerBy' but splits assuming the separator joins the segment in--- a suffix style.------ /Internal/-{-# INLINE splitInnerBySuffix #-}-splitInnerBySuffix-    :: (IsStream t, 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-    -> t m (f a)-    -> t m (f a)-splitInnerBySuffix splitter joiner xs =-    D.fromStreamD $ D.splitInnerBySuffix splitter joiner $ D.toStreamD xs----------------------------------------------------------------------------------- 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.-{-# INLINE reassembleBy #-}-reassembleBy-    :: (IsStream t, Monad m)-    => Fold m a b-    -> (a -> a -> Int)-    -> t m a-    -> t m b-reassembleBy = undefined--}----------------------------------------------------------------------------------- Distributing----------------------------------------------------------------------------------- | 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.drain $ S.tap (FL.drainBy print) (S.enumerateFromTo 1 2)--- 1--- 2--- @------ Compare with 'trace'.------ @since 0.7.0-{-# INLINE tap #-}-tap :: (IsStream t, Monad m) => FL.Fold m a b -> t m a -> t m a-tap f xs = D.fromStreamD $ D.tap f (D.toStreamD xs)---- | @tapOffsetEvery offset n@ taps every @n@th element in the stream--- starting at @offset@. @offset@ can be between @0@ and @n - 1@. Offset 0--- means start at the first element in the stream. If the offset is outside--- this range then @offset `mod` n@ is used as offset.------ @--- >>> S.drain $ S.tapOffsetEvery 0 2 (FL.mapM print FL.toList) $ S.enumerateFromTo 0 10--- > [0,2,4,6,8,10]--- @------ /Internal/----{-# INLINE tapOffsetEvery #-}-tapOffsetEvery :: (IsStream t, Monad m)-    => Int -> Int -> FL.Fold m a b -> t m a -> t m a-tapOffsetEvery offset n f xs =-    D.fromStreamD $ D.tapOffsetEvery offset n f (D.toStreamD xs)---- | Redirect a copy of the stream to a supplied fold and run it concurrently--- in an independent thread. The fold may buffer some elements. The buffer size--- is determined by the prevailing 'maxBuffer' setting.------ @---               Stream m a -> m b---                       |--- -----stream m a ---------------stream m a----------- @------ @--- > S.drain $ S.tapAsync (S.mapM_ print) (S.enumerateFromTo 1 2)--- 1--- 2--- @------ Exceptions from the concurrently running fold are propagated to the current--- computation.  Note that, because of buffering in the fold, exceptions may be--- delayed and may not correspond to the current element being processed in the--- parent stream, but we guarantee that before the parent stream stops the tap--- finishes and all exceptions from it are drained.--------- Compare with 'tap'.------ /Internal/-{-# INLINE tapAsync #-}-tapAsync :: (IsStream t, MonadAsync m) => FL.Fold m a b -> t m a -> t m a-tapAsync f xs = D.fromStreamD $ D.tapAsync f (D.toStreamD xs)---- | @pollCounts predicate transform fold stream@ counts those elements in the--- stream that pass the @predicate@. The resulting count stream is sent to--- another thread which transforms it using @transform@ and then folds it using--- @fold@.  The thread is automatically cleaned up if the stream stops or--- aborts due to exception.------ For example, to print the count of elements processed every second:------ @--- > S.drain $ S.pollCounts (const True) (S.rollingMap (-) . S.delayPost 1) (FL.drainBy print)---           $ S.enumerateFrom 0--- @------ Note: This may not work correctly on 32-bit machines.------ /Internal/----{-# INLINE pollCounts #-}-pollCounts ::-       (IsStream t, MonadAsync m)-    => (a -> Bool)-    -> (t m Int -> t m Int)-    -> Fold m Int b-    -> t m a-    -> t m a-pollCounts predicate transf f xs =-      D.fromStreamD-    $ D.pollCounts predicate (D.toStreamD . transf . D.fromStreamD) f-    $ (D.toStreamD xs)---- | Calls the supplied function with the number of elements consumed--- every @n@ seconds. The given function is run in a separate thread--- until the end of the stream. In case there is an exception in the--- stream the thread is killed during the next major GC.------ Note: The action is not guaranteed to run if the main thread exits.------ @--- > delay n = threadDelay (round $ n * 1000000) >> return n--- > S.drain $ S.tapRate 2 (\\n -> print $ show n ++ " elements processed") (delay 1 S.|: delay 0.5 S.|: delay 0.5 S.|: S.nil)--- 2 elements processed--- 1 elements processed--- @------ Note: This may not work correctly on 32-bit machines.------ /Internal/-{-# INLINE tapRate #-}-tapRate ::-       (IsStream t, MonadAsync m, MonadCatch m)-    => Double-    -> (Int -> m b)-    -> t m a-    -> t m a-tapRate n f xs = D.fromStreamD $ D.tapRate n f $ (D.toStreamD xs)---- | Apply a monadic function to each element flowing through the stream and--- discard the results.------ @--- > S.drain $ S.trace print (S.enumerateFromTo 1 2)--- 1--- 2--- @------ Compare with 'tap'.------ @since 0.7.0-{-# INLINE trace #-}-trace :: (IsStream t, MonadAsync m) => (a -> m b) -> t m a -> t m a-trace f = mapM (\x -> void (f x) >> return x)----------------------------------------------------------------------------------- Windowed classification----------------------------------------------------------------------------------- We divide the stream into windows or chunks in space or time and 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 can be split into--- windows by size or by using a split predicate on the elements in the stream.--- For example, when we receive a closing flag, we can close the window.------ A "chunk" is a space window and a "session" is a time window. Are there any--- other better short words to describe them. An alternative is to use--- "swindow" and "twindow". Another word for "session" could be "spell".------ TODO: To mark the position in space or time we can have Indexed or--- TimeStamped types. That can make it easy to deal with the position indices--- or timestamps.----------------------------------------------------------------------------------- Keyed Sliding Windows---------------------------------------------------------------------------------{--{-# INLINABLE classifySlidingChunks #-}-classifySlidingChunks-    :: (IsStream t, MonadAsync m, Ord k)-    => Int              -- ^ window size-    -> Int              -- ^ window slide-    -> Fold m a b       -- ^ Fold to be applied to window events-    -> t m (k, a, Bool) -- ^ window key, data, close event-    -> t m (k, b)-classifySlidingChunks wsize wslide (Fold step initial extract) str-    = undefined---- XXX Another variant could be to slide the window on an event, e.g. in TCP we--- slide the send window when an ack is received and we slide the receive--- window when a sequence is complete. Sliding is stateful in case of TCP,--- sliding releases the send buffer or makes data available to the user from--- the receive buffer.-{-# INLINABLE classifySlidingSessions #-}-classifySlidingSessions-    :: (IsStream t, MonadAsync m, Ord k)-    => Double         -- ^ timer tick in seconds-    -> Double         -- ^ time window size-    -> Double         -- ^ window slide-    -> Fold m a b     -- ^ Fold to be applied to window events-    -> t m (k, a, Bool, AbsTime) -- ^ window key, data, close flag, timestamp-    -> t m (k, b)-classifySlidingSessions tick interval slide (Fold step initial extract) str-    = undefined--}----------------------------------------------------------------------------------- Sliding Window Buffers----------------------------------------------------------------------------------- These buffered versions could be faster than concurrent incremental folds of--- all overlapping windows as in many cases we may not need all the values to--- compute the fold, we can just compute the result using the old value and new--- value.  However, we may need the buffer once in a while, for example for--- string search we usually compute the hash incrementally but when the hash--- matches the hash of the pattern we need to compare the whole string.------ XXX we should be able to implement sequence based splitting combinators--- using this combinator.--{---- | Buffer n elements of the input in a ring buffer. When t new elements are--- collected, slide the window to remove the same number of oldest elements,--- insert the new elements, and apply an incremental fold on the sliding--- window, supplying the outgoing elements, the new ring buffer as arguments.-slidingChunkBuffer-    :: (IsStream t, Monad m, Ord a, Storable a)-    => Int -- window size-    -> Int -- window slide-    -> Fold m (Ring a, Array a) b-    -> t m a-    -> t m b-slidingChunkBuffer = undefined---- Buffer n seconds worth of stream elements of the input in a radix tree.--- Every t seconds, remove the items that are older than n seconds, and apply--- an incremental fold on the sliding window, supplying the outgoing elements,--- and the new radix tree buffer as arguments.-slidingSessionBuffer-    :: (IsStream t, Monad m, Ord a, Storable a)-    => Int    -- window size-    -> Int    -- tick size-    -> Fold m (RTree a, Array a) b-    -> t m a-    -> t m b-slidingSessionBuffer = undefined--}----------------------------------------------------------------------------------- Keyed Session Windows---------------------------------------------------------------------------------{---- | Keyed variable size space windows. Close the window if we do not receive a--- window event in the next "spaceout" elements.-{-# INLINABLE classifyChunksBy #-}-classifyChunksBy-    :: (IsStream t, MonadAsync m, Ord k)-    => Int   -- ^ window spaceout (spread)-    -> Bool  -- ^ reset the spaceout when a chunk window element is received-    -> Fold m a b       -- ^ Fold to be applied to chunk window elements-    -> t m (k, a, Bool) -- ^ chunk key, data, last element-    -> t m (k, b)-classifyChunksBy spanout reset (Fold step initial extract) str = undefined---- | Like 'classifyChunksOf' but the chunk size is reset if an element is--- received within the chunk size window. The chunk gets closed only if no--- element is received within the chunk window.----{-# INLINABLE classifyKeepAliveChunks #-}-classifyKeepAliveChunks-    :: (IsStream t, MonadAsync m, Ord k)-    => Int   -- ^ window spaceout (spread)-    -> Fold m a b       -- ^ Fold to be applied to chunk window elements-    -> t m (k, a, Bool) -- ^ chunk key, data, last element-    -> t m (k, b)-classifyKeepAliveChunks spanout = classifyChunksBy spanout True--}--#if __GLASGOW_HASKELL__ < 800-#define Type *-#endif--data SessionState t m k a b = SessionState-    { sessionCurTime :: !AbsTime  -- ^ time since last event-    , sessionEventTime :: !AbsTime -- ^ time as per last event-    , sessionCount :: !Int -- ^ total number sessions in progress-    , sessionTimerHeap :: H.Heap (H.Entry AbsTime k) -- ^ heap for timeouts-    , sessionKeyValueMap :: Map.Map k a -- ^ Stored sessions for keys-    , sessionOutputStream :: t (m :: Type -> Type) (k, b) -- ^ Completed sessions-    }--#undef Type---- | @classifySessionsBy tick timeout idle pred f stream@ groups timestamped--- events in an input event stream into sessions based on a session key. Each--- element in the stream is an event consisting of a triple @(session key,--- sesssion data, timestamp)@.  @session key@ is a key that uniquely identifies--- the session.  All the events belonging to a session are folded using the--- fold @f@ until the fold returns a 'Left' result or a timeout has occurred.--- The session key and the result of the fold are emitted in the output stream--- when the session is purged.------ When @idle@ is 'False', @timeout@ is the maximum lifetime of a session in--- seconds, measured from the @timestamp@ of the first event in that session.--- When @idle@ is 'True' then the timeout is an idle timeout, it is reset after--- every event received in the session.------ @timestamp@ in an event characterizes the time when the input event was--- generated, this is an absolute time measured from some @Epoch@.  The notion--- of current time is maintained by a monotonic event time clock using the--- timestamps seen in the input stream. The latest timestamp seen till now is--- used as the base for the current time.  When no new events are seen, a timer--- is started with a tick duration specified by @tick@. This timer is used to--- detect session timeouts in the absence of new events.------ The predicate @pred@ is invoked with the current session count, if it--- returns 'True' a session is ejected from the session cache before inserting--- a new session. This could be useful to alert or eject sessions when the--- number of sessions becomes too high.------ /Internal/------- XXX Perhaps we should use an "Event a" type to represent timestamped data.-{-# INLINABLE classifySessionsBy #-}-classifySessionsBy-    :: (IsStream t, MonadAsync m, Ord k)-    => Double         -- ^ timer tick in seconds-    -> Double         -- ^ session timeout in seconds-    -> Bool           -- ^ reset the timeout when an event is received-    -> (Int -> m Bool) -- ^ predicate to eject sessions based on session count-    -> Fold m a (Either b b) -- ^ Fold to be applied to session events-    -> t m (k, a, AbsTime) -- ^ session key, data, timestamp-    -> t m (k, b) -- ^ session key, fold result-classifySessionsBy tick timeout reset ejectPred-    (Fold step initial extract) str =-      concatMap (\session -> sessionOutputStream session)-    $ scanlM' sstep szero stream--    where--    timeoutMs = toRelTime (round (timeout * 1000) :: MilliSecond64)-    tickMs = toRelTime (round (tick * 1000) :: MilliSecond64)-    szero = SessionState-        { sessionCurTime = toAbsTime (0 :: MilliSecond64)-        , sessionEventTime = toAbsTime (0 :: MilliSecond64)-        , sessionCount = 0-        , sessionTimerHeap = H.empty-        , sessionKeyValueMap = Map.empty-        , sessionOutputStream = K.nil-        }--    -- We can eject sessions based on the current session count to limit-    -- memory consumption. There are two possible strategies:-    ---    -- 1) Eject old sessions or sessions beyond a certain/lower timeout-    -- threshold even before timeout, effectively reduce the timeout.-    -- 2) Drop creation of new sessions but keep accepting new events for the-    -- old ones.-    ---    -- We use the first strategy as of now.--    -- Got a new stream input element-    sstep (session@SessionState{..}) (Just (key, value, timestamp)) = do-        -- XXX we should use a heap in pinned memory to scale it to a large-        -- size-        ---        -- To detect session inactivity we keep a timestamp of the latest event-        -- in the Map along with the fold result.  When we purge the session-        -- from the heap we match the timestamp in the heap with the timestamp-        -- in the Map, if the latest timestamp is newer and has not expired we-        -- reinsert the key in the heap.-        ---        -- XXX if the key is an Int, we can also use an IntMap for slightly-        -- better performance.-        ---        let curTime = max sessionEventTime timestamp-            accumulate v = do-                old <- case v of-                    Nothing -> initial-                    Just (Tuple' _ acc) -> return acc-                new <- step old value-                return $ Tuple' timestamp new-            mOld = Map.lookup key sessionKeyValueMap--        acc@(Tuple' _ fres) <- accumulate mOld-        res <- extract fres-        case res of-            Left x -> do-                -- deleting a key from the heap is expensive, so we never-                -- delete a key from heap, we just purge it from the Map and it-                -- gets purged from the heap on timeout. We just need an extra-                -- lookup in the Map when the key is purged from the heap, that-                -- should not be expensive.-                ---                let (mp, cnt) = case mOld of-                        Nothing -> (sessionKeyValueMap, sessionCount)-                        Just _ -> (Map.delete key sessionKeyValueMap-                                  , sessionCount - 1)-                return $ session-                    { sessionCurTime = curTime-                    , sessionEventTime = curTime-                    , sessionCount = cnt-                    , sessionKeyValueMap = mp-                    , sessionOutputStream = yield (key, x)-                    }-            Right _ -> do-                (hp1, mp1, out1, cnt1) <- do-                        let vars = (sessionTimerHeap, sessionKeyValueMap,-                                           K.nil, sessionCount)-                        case mOld of-                            -- inserting new entry-                            Nothing -> do-                                -- Eject a session from heap and map is needed-                                eject <- ejectPred sessionCount-                                (hp, mp, out, cnt) <--                                    if eject-                                    then ejectOne vars-                                    else return vars--                                -- Insert the new session in heap-                                let expiry = addToAbsTime timestamp timeoutMs-                                    hp' = H.insert (Entry expiry key) hp-                                 in return $ (hp', mp, out, (cnt + 1))-                            -- updating old entry-                            Just _ -> return vars--                let mp2 = Map.insert key acc mp1-                return $ SessionState-                    { sessionCurTime = curTime-                    , sessionEventTime = curTime-                    , sessionCount = cnt1-                    , sessionTimerHeap = hp1-                    , sessionKeyValueMap = mp2-                    , sessionOutputStream = out1-                    }--    -- Got a timer tick event-    sstep (sessionState@SessionState{..}) Nothing =-        let curTime = addToAbsTime sessionCurTime tickMs-        in ejectExpired sessionState curTime--    fromEither e =-        case e of-            Left  x -> x-            Right x -> x--    -- delete from map and output the fold accumulator-    ejectEntry hp mp out cnt acc key = do-        sess <- extract acc-        let out1 = (key, fromEither sess) `K.cons` out-        let mp1 = Map.delete key mp-        return (hp, mp1, out1, (cnt - 1))--    ejectOne (hp, mp, out, !cnt) = do-        let hres = H.uncons hp-        case hres of-            Just (Entry expiry key, hp1) -> do-                case Map.lookup key mp of-                    Nothing -> ejectOne (hp1, mp, out, cnt)-                    Just (Tuple' latestTS acc) -> do-                        let expiry1 = addToAbsTime latestTS timeoutMs-                        if not reset || expiry1 <= expiry-                        then ejectEntry hp1 mp out cnt acc key-                        else-                            -- reset the session timeout and continue-                            let hp2 = H.insert (Entry expiry1 key) hp1-                            in ejectOne (hp2, mp, out, cnt)-            Nothing -> do-                assert (Map.null mp) (return ())-                return (hp, mp, out, cnt)--    ejectExpired (session@SessionState{..}) curTime = do-        (hp', mp', out, count) <--            ejectLoop sessionTimerHeap sessionKeyValueMap K.nil sessionCount-        return $ session-            { sessionCurTime = curTime-            , sessionCount = count-            , sessionTimerHeap = hp'-            , sessionKeyValueMap = mp'-            , sessionOutputStream = out-            }--        where--        ejectLoop hp mp out !cnt = do-            let hres = H.uncons hp-            case hres of-                Just (Entry expiry key, hp1) -> do-                    (eject, force) <- do-                        if curTime >= expiry-                        then return (True, False)-                        else do-                            r <- ejectPred cnt-                            return (r, r)-                    if eject-                    then do-                        case Map.lookup key mp of-                            Nothing -> ejectLoop hp1 mp out cnt-                            Just (Tuple' latestTS acc) -> do-                                let expiry1 = addToAbsTime latestTS timeoutMs-                                if expiry1 <= curTime || not reset || force-                                then do-                                    (hp2,mp1,out1,cnt1) <--                                        ejectEntry hp1 mp out cnt acc key-                                    ejectLoop hp2 mp1 out1 cnt1-                                else-                                    -- reset the session timeout and continue-                                    let hp2 = H.insert (Entry expiry1 key) hp1-                                    in ejectLoop hp2 mp out cnt-                    else return (hp, mp, out, cnt)-                Nothing -> do-                    assert (Map.null mp) (return ())-                    return (hp, mp, out, cnt)--    -- merge timer events in the stream-    stream = Serial.map Just str `Par.parallel` repeatM timer-    timer = do-        liftIO $ threadDelay (round $ tick * 1000000)-        return Nothing---- | Like 'classifySessionsOf' but the session is kept alive if an event is--- received within the session window. The session times out and gets closed--- only if no event is received within the specified session window size.------ If the ejection predicate returns 'True', the session that was idle for--- the longest time is ejected before inserting a new session.------ @--- classifyKeepAliveSessions timeout pred = classifySessionsBy 1 timeout True pred--- @------ /Internal/----{-# INLINABLE classifyKeepAliveSessions #-}-classifyKeepAliveSessions-    :: (IsStream t, MonadAsync m, Ord k)-    => Double         -- ^ session inactive timeout-    -> (Int -> m Bool) -- ^ predicate to eject sessions on session count-    -> Fold m a (Either b b) -- ^ Fold to be applied to session payload data-    -> t m (k, a, AbsTime) -- ^ session key, data, timestamp-    -> t m (k, b)-classifyKeepAliveSessions timeout ejectPred =-    classifySessionsBy 1 timeout True ejectPred----------------------------------------------------------------------------------- Keyed tumbling windows----------------------------------------------------------------------------------- Tumbling windows is a special case of sliding windows where the window slide--- is the same as the window size. Or it can be a special case of session--- windows where the reset flag is set to False.---- XXX instead of using the early termination flag in the stream, we can use an--- early terminating fold instead.--{---- | Split the stream into fixed size chunks of specified size. Within each--- such chunk fold the elements in buckets identified by the keys. A particular--- bucket fold can be terminated early if a closing flag is encountered in an--- element for that key.------ @since 0.7.0-{-# INLINABLE classifyChunksOf #-}-classifyChunksOf-    :: (IsStream t, MonadAsync m, Ord k)-    => Int              -- ^ window size-    -> Fold m a b       -- ^ Fold to be applied to window events-    -> t m (k, a, Bool) -- ^ window key, data, close event-    -> t m (k, b)-classifyChunksOf wsize = classifyChunksBy wsize False--}---- | Split the stream into fixed size time windows of specified interval in--- seconds. Within each such window, fold the elements in sessions identified--- by the session keys. The fold result is emitted in the output stream if the--- fold returns a 'Left' result or if the time window ends.------ Session @timestamp@ in the input stream is an absolute time from some epoch,--- characterizing the time when the input element was generated.  To detect--- session window end, a monotonic event time clock is maintained synced with--- the timestamps with a clock resolution of 1 second.------ If the ejection predicate returns 'True', the session with the longest--- lifetime is ejected before inserting a new session.------ @--- classifySessionsOf interval pred = classifySessionsBy 1 interval False pred--- @------ /Internal/----{-# INLINABLE classifySessionsOf #-}-classifySessionsOf-    :: (IsStream t, MonadAsync m, Ord k)-    => Double         -- ^ time window size-    -> (Int -> m Bool) -- ^ predicate to eject sessions on session count-    -> Fold m a (Either b b) -- ^ Fold to be applied to session events-    -> t m (k, a, AbsTime) -- ^ session key, data, timestamp-    -> t m (k, b)-classifySessionsOf interval ejectPred =-    classifySessionsBy 1 interval False ejectPred----------------------------------------------------------------------------------- Exceptions----------------------------------------------------------------------------------- | Run a side effect before the stream yields its first element.------ @since 0.7.0-{-# INLINE before #-}-before :: (IsStream t, Monad m) => m b -> t m a -> t m a-before action xs = D.fromStreamD $ D.before action $ D.toStreamD xs---- | Run a side effect whenever the stream stops normally.------ Prefer 'afterIO' over this as the @after@ action in this combinator is not--- executed if the unfold is partially evaluated lazily and then garbage--- collected.------ @since 0.7.0-{-# INLINE after #-}-after :: (IsStream t, Monad m) => m b -> t m a -> t m a-after action xs = D.fromStreamD $ D.after action $ D.toStreamD xs---- | Run a side effect whenever the stream stops normally--- or is garbage collected after a partial lazy evaluation.------ /Internal/----{-# INLINE afterIO #-}-afterIO :: (IsStream t, MonadIO m, MonadBaseControl IO m) => m b -> t m a -> t m a-afterIO action xs = D.fromStreamD $ D.afterIO action $ D.toStreamD xs---- | Run a side effect whenever the stream aborts due to an exception.------ @since 0.7.0-{-# INLINE onException #-}-onException :: (IsStream t, MonadCatch m) => m b -> t m a -> t m a-onException action xs = D.fromStreamD $ D.onException action $ D.toStreamD xs---- | Run a side effect whenever the stream stops normally or aborts due to an--- exception.------ Prefer 'finallyIO' over this as the @after@ action in this combinator is not--- executed if the unfold is partially evaluated lazily and then garbage--- collected.------ @since 0.7.0-{-# INLINE finally #-}-finally :: (IsStream t, MonadCatch m) => m b -> t m a -> t m a-finally action xs = D.fromStreamD $ D.finally action $ D.toStreamD xs---- | Run a side effect whenever the stream stops normally, aborts due to an--- exception or if it is garbage collected after a partial lazy evaluation.------ /Internal/----{-# INLINE finallyIO #-}-finallyIO :: (IsStream t, MonadAsync m, MonadCatch m) => m b -> t m a -> t m a-finallyIO action xs = D.fromStreamD $ D.finallyIO action $ D.toStreamD xs---- | Run the first action before the stream starts and remember its output,--- generate a stream using the output, run the second action using the--- remembered value as an argument whenever the stream ends normally or due to--- an exception.------ Prefer 'bracketIO' over this as the @after@ action in this combinator is not--- executed if the unfold is partially evaluated lazily and then garbage--- collected.------ @since 0.7.0-{-# INLINE bracket #-}-bracket :: (IsStream t, MonadCatch m)-    => m b -> (b -> m c) -> (b -> t m a) -> t m a-bracket bef aft bet = D.fromStreamD $-    D.bracket bef aft (\x -> toStreamD $ bet x)---- | Run the first action before the stream starts and remember its output,--- generate a stream using the output, run the second action using the--- remembered value as an argument whenever the stream ends normally, due to--- an exception or if it is garbage collected after a partial lazy evaluation.------ /Internal/----{-# INLINE bracketIO #-}-bracketIO :: (IsStream t, MonadAsync m, MonadCatch m)-    => m b -> (b -> m c) -> (b -> t m a) -> t m a-bracketIO bef aft bet = D.fromStreamD $-    D.bracketIO bef aft (\x -> toStreamD $ bet x)---- | When evaluating a stream if an exception occurs, stream evaluation aborts--- and the specified exception handler is run with the exception as argument.------ @since 0.7.0-{-# INLINE handle #-}-handle :: (IsStream t, MonadCatch m, Exception e)-    => (e -> t m a) -> t m a -> t m a-handle handler xs =-    D.fromStreamD $ D.handle (\e -> D.toStreamD $ handler e) $ D.toStreamD xs----------------------------------------------------------------------------------- Generalize the underlying monad----------------------------------------------------------------------------------- | Transform the inner monad of a stream using a natural transformation.------ / Internal/----{-# INLINE hoist #-}-hoist :: (Monad m, Monad n)-    => (forall x. m x -> n x) -> SerialT m a -> SerialT n a-hoist f xs = fromStreamS $ S.hoist f (toStreamS xs)---- | Generalize the inner monad of the stream from 'Identity' to any monad.------ / Internal/----{-# INLINE generally #-}-generally :: (IsStream t, Monad m) => t Identity a -> t m a-generally xs = fromStreamS $ S.hoist (return . runIdentity) (toStreamS xs)----------------------------------------------------------------------------------- Add and remove a monad transformer----------------------------------------------------------------------------------- | Lift the inner monad of a stream using a monad transformer.------ / Internal/----{-# INLINE liftInner #-}-liftInner :: (Monad m, IsStream t, MonadTrans tr, Monad (tr m))-    => t m a -> t (tr m) a-liftInner xs = fromStreamD $ D.liftInner (toStreamD xs)---- | Evaluate the inner monad of a stream as 'ReaderT'.------ / Internal/----{-# INLINE runReaderT #-}-runReaderT :: (IsStream t, Monad m) => s -> t (ReaderT s m) a -> t m a-runReaderT s xs = fromStreamD $ D.runReaderT s (toStreamD xs)---- | Evaluate the inner monad of a stream as 'StateT'.------ This is supported only for 'SerialT' as concurrent state updation may not be--- safe.------ / Internal/----{-# INLINE evalStateT #-}-evalStateT ::  Monad m => s -> SerialT (StateT s m) a -> SerialT m a-evalStateT s xs = fromStreamD $ D.evalStateT s (toStreamD xs)---- | Run a stateful (StateT) stream transformation using a given state.------ This is supported only for 'SerialT' as concurrent state updation may not be--- safe.------ / Internal/----{-# INLINE usingStateT #-}-usingStateT-    :: Monad m-    => s-    -> (SerialT (StateT s m) a -> SerialT (StateT s m) a)-    -> SerialT m a-    -> SerialT m a-usingStateT s f xs = evalStateT s $ f $ liftInner xs---- | Evaluate the inner monad of a stream as 'StateT' and emit the resulting--- state and value pair after each step.------ This is supported only for 'SerialT' as concurrent state updation may not be--- safe.------ / Internal/----{-# INLINE runStateT #-}-runStateT :: Monad m => s -> SerialT (StateT s m) a -> SerialT m (s, a)-runStateT s xs = fromStreamD $ D.runStateT s (toStreamD xs)---- | Run a stream transformation using a given environment.------ / Internal/----{-# INLINE usingReaderT #-}-usingReaderT-    :: (Monad m, IsStream t)-    => r-    -> (t (ReaderT r m) a -> t (ReaderT r m) a)-    -> t m a-    -> t m a-usingReaderT r f xs = runReaderT r $ f $ liftInner xs
+ src/Streamly/Internal/Ring/Foreign.hs view
@@ -0,0 +1,250 @@+-- |+-- Module      : Streamly.Internal.Ring.Foreign+-- Copyright   : (c) 2019 Composewell Technologies+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--++module Streamly.Internal.Ring.Foreign+    ( Ring(..)++    -- * Construction+    , new+    , advance+    , moveBy+    , startOf++    -- * Modification+    , unsafeInsert++    -- * Folds+    , unsafeFoldRing+    , unsafeFoldRingM+    , unsafeFoldRingFullM+    , unsafeFoldRingNM++    -- * Fast Byte Comparisons+    , unsafeEqArray+    , unsafeEqArrayN+    ) where++import Control.Exception (assert)+import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, touchForeignPtr)+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)+import Foreign.Ptr (plusPtr, minusPtr, castPtr)+import Foreign.Storable (Storable(..))+import GHC.ForeignPtr (mallocPlainForeignPtrAlignedBytes)+import GHC.Ptr (Ptr(..))+import Prelude hiding (length, concat)++import Control.Monad.IO.Class (MonadIO(..))++import qualified Streamly.Internal.Data.Array.Foreign.Type as A++-- | 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+    }++-- | 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 * sizeOf (undefined :: a)+    fptr <- mallocPlainForeignPtrAlignedBytes size (alignment (undefined :: a))+    let p = unsafeForeignPtrToPtr fptr+    return (Ring+        { ringStart = fptr+        , ringBound = p `plusPtr` size+        }, p)++-- | 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 = ringHead `plusPtr` sizeOf (undefined :: 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 = sizeOf (undefined :: 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++-- | 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++-- XXX remove all usage of A.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{..} n =+    let !res = A.unsafeInlineIO $ do+            let rs = unsafeForeignPtrToPtr ringStart+                as = unsafeForeignPtrToPtr aStart+            assert (aEnd `minusPtr` as >= ringBound `minusPtr` rs) (return ())+            let len = ringBound `minusPtr` rh+            r1 <- A.memcmp (castPtr rh) (castPtr as) (min len n)+            r2 <- if n > len+                then A.memcmp (castPtr rs) (castPtr (as `plusPtr` len))+                              (min (rh `minusPtr` rs) (n - len))+                else return True+            -- XXX enable these, check perf impact+            -- touchForeignPtr ringStart+            -- touchForeignPtr aStart+            return (r1 && r2)+    in res++-- | 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{..} =+    let !res = A.unsafeInlineIO $ do+            let rs = unsafeForeignPtrToPtr ringStart+            let as = unsafeForeignPtrToPtr aStart+            assert (aEnd `minusPtr` as >= ringBound `minusPtr` rs)+                   (return ())+            let len = ringBound `minusPtr` rh+            r1 <- A.memcmp (castPtr rh) (castPtr as) len+            r2 <- A.memcmp (castPtr rs) (castPtr (as `plusPtr` len))+                           (rh `minusPtr` rs)+            -- XXX enable these, check perf impact+            -- touchForeignPtr ringStart+            -- touchForeignPtr aStart+            return (r1 && r2)+    in res++-- 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 = A.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) (p `plusPtr` sizeOf (undefined :: 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 = A.unsafeInlineIO $ peek start+            acc' <- f acc x+            go acc' (start `plusPtr` sizeOf (undefined :: 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 = A.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 = A.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
+ src/Streamly/Internal/Unicode/Array/Char.hs view
@@ -0,0 +1,92 @@+-- |+-- Module      : Streamly.Internal.Unicode.Array.Char+-- Copyright   : (c) 2018 Composewell Technologies+--+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+module Streamly.Internal.Unicode.Array.Char+    (+    -- * Streams of Strings+      lines+    , words+    , unlines+    , unwords+    )+where++import Control.Monad.IO.Class (MonadIO)+import Streamly.Prelude (MonadAsync)+import Prelude hiding (String, lines, words, unlines, unwords)+import Streamly.Data.Array.Foreign (Array)+import Streamly.Internal.Data.Stream.IsStream (IsStream)++import qualified Streamly.Internal.Unicode.Stream as S+import qualified Streamly.Data.Array.Foreign as A++-- $setup+-- >>> :m+-- >>> :set -XOverloadedStrings+-- >>> import Prelude hiding (String, lines, words, unlines, unwords)+-- >>> import qualified Streamly.Prelude as Stream+-- >>> import qualified Streamly.Internal.Unicode.Array.Char 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.toList $ Unicode.lines $ Stream.fromList "lines\nthis\nstring\n\n\n"+-- ["lines","this","string","",""]+--+{-# INLINE lines #-}+lines :: (MonadIO m, IsStream t) => t m Char -> t 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.toList $ Unicode.words $ Stream.fromList "A  newline\nis considered white space?"+-- ["A","newline","is","considered","white","space?"]+--+{-# INLINE words #-}+words :: (MonadIO m, IsStream t) => t m Char -> t 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.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, IsStream t) => t m (Array Char) -> t m Char+unlines = S.unlines A.read++-- | Flattens the stream of @Array Char@, after appending a separating+-- space to each string.+--+-- 'unwords' is an inverse operation to 'words'.+--+-- >>> Stream.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 :: (MonadAsync m, IsStream t) => t m (Array Char) -> t m Char+unwords = S.unwords A.read
+ src/Streamly/Internal/Unicode/Array/Prim/Pinned.hs view
@@ -0,0 +1,91 @@+-- |+-- Module      : Streamly.Internal.Unicode.Array.Prim.Pinned+-- Copyright   : (c) 2020 Composewell Technologies+--+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+module Streamly.Internal.Unicode.Array.Prim.Pinned+    (+    -- * Streams of Strings+      lines+    , words+    , unlines+    , unwords+    )+where++import Control.Monad.IO.Class (MonadIO(..))+import Streamly.Prelude (MonadAsync)+import Prelude hiding (String, lines, words, unlines, unwords)+import Streamly.Internal.Data.Stream.IsStream (IsStream)+import Streamly.Internal.Data.Array.Prim.Pinned (Array)++import qualified Streamly.Internal.Unicode.Stream as S+import qualified Streamly.Internal.Data.Array.Prim.Pinned as A++-- $setup+-- >>> :m+-- >>> :set -XOverloadedStrings+-- >>> import qualified Streamly.Prelude as Stream+-- >>> import qualified Streamly.Internal.Unicode.Array.Prim.Pinned 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.toList $ Unicode.lines $ Stream.fromList "lines\nthis\nstring\n\n\n"+-- [fromListN 5 "lines",fromListN 4 "this",fromListN 6 "string",fromListN 0 "",fromListN 0 ""]+--+{-# INLINE lines #-}+lines :: (MonadIO m, IsStream t) => t m Char -> t 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.toList $ Unicode.words $ Stream.fromList "A  newline\nis considered white space?"+-- [fromListN 1 "A",fromListN 7 "newline",fromListN 2 "is",fromListN 10 "considered",fromListN 5 "white",fromListN 6 "space?"]+--+{-# INLINE words #-}+words :: (MonadIO m, IsStream t) => t m Char -> t 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.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 :: (MonadAsync m, IsStream t) => t m (Array Char) -> t m Char+unlines = S.unlines A.read++-- | Flattens the stream of @Array Char@, after appending a separating+-- space to each string.+--+-- 'unwords' is an inverse operation to 'words'.+--+-- >>> Stream.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 :: (MonadAsync m, IsStream t) => t m (Array Char) -> t m Char+unwords = S.unwords A.read
+ src/Streamly/Internal/Unicode/Char.hs view
@@ -0,0 +1,65 @@+-- |+-- Module      : Streamly.Internal.Unicode.Char+-- Copyright   : (c) 2018 Composewell Technologies+--+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+module Streamly.Internal.Unicode.Char+    (+    -- * Predicates+      isAsciiAlpha++    -- * Unicode aware operations+    {-+      toCaseFold+    , toLower+    , toUpper+    , toTitle+    -}+    )+where++import Data.Char (isAsciiUpper, isAsciiLower)++-- import Streamly.Prelude (IsStream)++-------------------------------------------------------------------------------+-- Unicode aware operations on strings+-------------------------------------------------------------------------------++-- | Select alphabetic characters in the ascii character set.+--+-- /Pre-release/+--+{-# INLINE isAsciiAlpha #-}+isAsciiAlpha :: Char -> Bool+isAsciiAlpha c = isAsciiUpper c || isAsciiLower c++-------------------------------------------------------------------------------+-- Unicode aware operations on strings+-------------------------------------------------------------------------------++{-+-- |+-- /undefined/+toCaseFold :: IsStream t => Char -> t m Char+toCaseFold = undefined++-- |+-- /undefined/+toLower :: IsStream t => Char -> t m Char+toLower = undefined++-- |+-- /undefined/+toUpper :: IsStream t => Char -> t m Char+toUpper = undefined++-- |+-- /undefined/+toTitle :: IsStream t => Char -> t m Char+toTitle = undefined+-}
+ src/Streamly/Internal/Unicode/Stream.hs view
@@ -0,0 +1,1020 @@+-- |+-- 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+    , decodeUtf8+    , decodeUtf8'+    , decodeUtf8_++    -- ** Resumable UTF-8 Decoding+    , DecodeError(..)+    , DecodeState+    , CodePoint+    , decodeUtf8Either+    , resumeDecodeUtf8Either++    -- ** UTF-8 Array Stream Decoding+    , decodeUtf8Arrays+    , decodeUtf8Arrays'+    , decodeUtf8Arrays_++    -- * Elimination (Encoding)+    -- ** Latin1 Encoding+    , encodeLatin1+    , encodeLatin1'+    , encodeLatin1_++    -- ** UTF-8 Encoding+    , 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+    , decodeUtf8ArraysD+    , decodeUtf8ArraysD'+    , decodeUtf8ArraysD_++    -- * Deprecations+    , decodeUtf8Lax+    , encodeLatin1Lax+    , encodeUtf8Lax+    )+where++#include "inline.hs"++import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Bits (shiftR, shiftL, (.|.), (.&.))+import Data.Char (chr, ord)+import Data.Word (Word8)+import Foreign.ForeignPtr (touchForeignPtr)+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)+import Foreign.Storable (Storable(..))+import Fusion.Plugin.Types (Fuse(..))+import GHC.Base (assert, unsafeChr)+import GHC.ForeignPtr (ForeignPtr (..))+import GHC.IO.Encoding.Failure (isSurrogate)+import GHC.Ptr (Ptr (..), plusPtr)+import System.IO.Unsafe (unsafePerformIO)+import Streamly.Data.Fold (Fold)+import Streamly.Data.Array.Foreign (Array)+import Streamly.Internal.Data.Unfold (Unfold)+import Streamly.Internal.Data.SVar (adaptState)+import Streamly.Internal.Data.Stream.IsStream (IsStream)+import Streamly.Internal.Data.Stream.Serial (SerialT)+import Streamly.Internal.Data.Stream.StreamD (Stream(..), Step (..))+import Streamly.Internal.Data.Tuple.Strict (Tuple'(..))++import qualified Streamly.Internal.Data.Unfold as Unfold+import qualified Streamly.Internal.Data.Stream.Serial as Serial+import qualified Streamly.Internal.Data.Array.Foreign as Array+import qualified Streamly.Internal.Data.Array.Foreign.Type as A+import qualified Streamly.Internal.Data.Stream.IsStream as S+import qualified Streamly.Internal.Data.Stream.StreamD as D++import Prelude hiding (lines, words, unlines, unwords)++-- $setup+-- >>> :m+-- >>> import Prelude hiding (lines, words, unlines, unwords)+-- >>> import qualified Streamly.Prelude as Stream+-- >>> import qualified Streamly.Data.Fold as Fold+-- >>> 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.+--+-- /Since: 0.7.0 ("Streamly.Data.Unicode.Stream")/+--+-- @since 0.8.0+{-# INLINE decodeLatin1 #-}+decodeLatin1 :: (IsStream t, Monad m) => t m Word8 -> t m Char+decodeLatin1 = S.map (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.+--+-- @since 0.8.0+{-# INLINE encodeLatin1' #-}+encodeLatin1' :: (IsStream t, Monad m) => t m Char -> t m Word8+encodeLatin1' = S.map 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.+--+-- /Since: 0.7.0 ("Streamly.Data.Unicode.Stream")/+--+-- /Since: 0.8.0 (Lenient Behaviour)/+{-# INLINE encodeLatin1 #-}+encodeLatin1 :: (IsStream t, Monad m) => t m Char -> t m Word8+encodeLatin1 = S.map (fromIntegral . ord)++-- | Like 'encodeLatin1' but drops the input characters beyond 255.+--+-- @since 0.8.0+{-# INLINE encodeLatin1_ #-}+encodeLatin1_ :: (IsStream t, Monad m) => t m Char -> t m Word8+encodeLatin1_ = S.map (fromIntegral . ord) . S.filter (<= chr 255)++-- | Same as 'encodeLatin1'+--+{-# DEPRECATED encodeLatin1Lax "Please use 'encodeLatin1' instead" #-}+{-# INLINE encodeLatin1Lax #-}+encodeLatin1Lax :: (IsStream t, Monad m) => t m Char -> t 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+  ]++{-# NOINLINE utf8d #-}+utf8d :: A.Array Word8+utf8d =+      unsafePerformIO+    -- Aligning to cacheline makes a barely noticeable difference+    -- XXX currently alignment is not implemented for unmanaged allocation+    $ D.fold (A.writeNAlignedUnmanaged 64 (length decodeTable))+              (D.fromList decodeTable)++-- | 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 = A.unsafeInlineIO $ peekElemOff p i in x++-- 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++    utf8table =+        let !(Ptr addr) = table+            end = table `plusPtr` 364+        in A.Array (ForeignPtr addr undefined) end :: A.Array Word8+    showByte = "Streamly: decode0: byte: " ++ show byte+    showTable = " table: " ++ show utf8table++-- 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++    utf8table =+        let !(Ptr addr) = table+            end = table `plusPtr` 364+        in A.Array (ForeignPtr addr undefined) end :: A.Array Word8+    showByte = "Streamly: decode1: byte: " ++ show byte+    showState st cp =+        " state: " ++ show st +++        " codepoint: " ++ show cp +++        " table: " ++ show utf8table++-------------------------------------------------------------------------------+-- Resumable UTF-8 decoding+-------------------------------------------------------------------------------++{-# ANN type UTF8DecodeState Fuse #-}+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+    -> Stream m Word8+    -> Stream m (Either DecodeError Char)+resumeDecodeUtf8EitherD dst codep (Stream step state) =+    let A.Array p _ = utf8d+        !ptr = unsafeForeignPtrToPtr p+        stt =+            if dst == 0+            then UTF8DecodeInit state+            else UTF8Decoding state dst codep+    in Stream (step' ptr) 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+    => Stream m Word8 -> Stream m (Either DecodeError Char)+decodeUtf8EitherD = resumeDecodeUtf8EitherD 0 0++-- |+--+-- /Pre-release/+{-# INLINE decodeUtf8Either #-}+decodeUtf8Either :: (Monad m, IsStream t)+    => t m Word8 -> t m (Either DecodeError Char)+decodeUtf8Either = D.fromStreamD . decodeUtf8EitherD . D.toStreamD++-- |+--+-- /Pre-release/+{-# INLINE resumeDecodeUtf8Either #-}+resumeDecodeUtf8Either+    :: (Monad m, IsStream t)+    => DecodeState+    -> CodePoint+    -> t m Word8+    -> t m (Either DecodeError Char)+resumeDecodeUtf8Either st cp =+    D.fromStreamD . resumeDecodeUtf8EitherD st cp . D.toStreamD++-------------------------------------------------------------------------------+-- One shot decoding+-------------------------------------------------------------------------------++data CodingFailureMode+    = TransliterateCodingFailure+    | ErrorOnCodingFailure+    | DropOnCodingFailure+    deriving (Show)++{-# INLINE replacementChar #-}+replacementChar :: Char+replacementChar = '\xFFFD'++-- 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 -> Stream m Word8 -> Stream m Char+decodeUtf8WithD cfm (Stream step state) =+    let A.Array p _ = utf8d+        !ptr = unsafeForeignPtrToPtr p+    in Stream (step' ptr) (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 => Stream m Word8 -> 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.+--+-- /Since: 0.7.0 ("Streamly.Data.Unicode.Stream")/+--+-- /Since: 0.8.0 (Lenient Behaviour)/+{-# INLINE decodeUtf8 #-}+decodeUtf8 :: (Monad m, IsStream t) => t m Word8 -> t m Char+decodeUtf8 = D.fromStreamD . decodeUtf8D . D.toStreamD++{-# INLINE decodeUtf8D' #-}+decodeUtf8D' :: Monad m => Stream m Word8 -> 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.+--+-- @since 0.8.0+{-# INLINE decodeUtf8' #-}+decodeUtf8' :: (Monad m, IsStream t) => t m Word8 -> t m Char+decodeUtf8' = D.fromStreamD . decodeUtf8D' . D.toStreamD++{-# INLINE decodeUtf8D_ #-}+decodeUtf8D_ :: Monad m => Stream m Word8 -> Stream m Char+decodeUtf8D_ = decodeUtf8WithD DropOnCodingFailure++-- | Decode a UTF-8 encoded bytestream to a stream of Unicode characters.+-- Any invalid codepoint encountered is dropped.+--+-- @since 0.8.0+{-# INLINE decodeUtf8_ #-}+decodeUtf8_ :: (Monad m, IsStream t) => t m Word8 -> t m Char+decodeUtf8_ = D.fromStreamD . decodeUtf8D_ . D.toStreamD++-- | Same as 'decodeUtf8'+--+{-# DEPRECATED decodeUtf8Lax "Please use 'decodeUtf8' instead" #-}+{-# INLINE decodeUtf8Lax #-}+decodeUtf8Lax :: (IsStream t, Monad m) => t m Word8 -> t m Char+decodeUtf8Lax = decodeUtf8++-------------------------------------------------------------------------------+-- Decoding Array Streams+-------------------------------------------------------------------------------++{-# ANN type FlattenState Fuse #-}+data FlattenState s a+    = OuterLoop s !(Maybe (DecodeState, CodePoint))+    | InnerLoopDecodeInit s (ForeignPtr a) !(Ptr a) !(Ptr a)+    | InnerLoopDecodeFirst s (ForeignPtr a) !(Ptr a) !(Ptr a) Word8+    | InnerLoopDecoding s (ForeignPtr a) !(Ptr a) !(Ptr a)+        !DecodeState !CodePoint+    | YAndC !Char (FlattenState s a) -- 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+    -> Stream m (A.Array Word8)+    -> Stream m Char+decodeUtf8ArraysWithD cfm (Stream step state) =+    let A.Array p _ = utf8d+        !ptr = unsafeForeignPtrToPtr p+    in Stream (step' ptr) (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 A.Array {..} s ->+                    let p = unsafeForeignPtrToPtr aStart+                     in Skip (InnerLoopDecodeInit s aStart p aEnd)+                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 A.Array {..} s ->+                    let p = unsafeForeignPtrToPtr aStart+                     in Skip (InnerLoopDecoding s aStart p aEnd ds cp)+                Skip s -> Skip (OuterLoop s dst)+                Stop -> Skip inputUnderflow+    step' _ _ (InnerLoopDecodeInit st startf p end)+        | p == end = do+            liftIO $ touchForeignPtr startf+            return $ Skip $ OuterLoop st Nothing+    step' _ _ (InnerLoopDecodeInit st startf p end) = do+        x <- liftIO $ peek 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 startf (p `plusPtr` 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 startf p end x++    step' table _ (InnerLoopDecodeFirst st startf 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 startf (p `plusPtr` 1) end)+                0 -> error "unreachable state"+                _ -> Skip (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)+    step' _ _ (InnerLoopDecoding st startf p end sv cp)+        | p == end = do+            liftIO $ touchForeignPtr startf+            return $ Skip $ OuterLoop st (Just (sv, cp))+    step' table _ (InnerLoopDecoding st startf p end statePtr codepointPtr) = do+        x <- liftIO $ peek p+        let (Tuple' sv cp) = decode1 table statePtr codepointPtr x+        return $+            case sv of+                0 ->+                    Skip $+                    YAndC+                        (unsafeChr cp)+                        (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)+                12 ->+                    Skip $+                    transliterateOrError+                        (+                           "Streamly.Internal.Data.Stream.StreamD."+                        ++ "decodeUtf8ArraysWith: Invalid UTF8"+                        ++ " codepoint encountered"+                        )+                        (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)+                _ ->+                    Skip+                    (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)+    step' _ _ (YAndC c s) = return $ Yield c s+    step' _ _ D = return Stop++{-# INLINE decodeUtf8ArraysD #-}+decodeUtf8ArraysD ::+       MonadIO m+    => Stream m (A.Array Word8)+    -> Stream m Char+decodeUtf8ArraysD = decodeUtf8ArraysWithD TransliterateCodingFailure++-- |+--+-- /Pre-release/+{-# INLINE decodeUtf8Arrays #-}+decodeUtf8Arrays ::+       (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char+decodeUtf8Arrays =+    D.fromStreamD . decodeUtf8ArraysD . D.toStreamD++{-# INLINE decodeUtf8ArraysD' #-}+decodeUtf8ArraysD' ::+       MonadIO m+    => Stream m (A.Array Word8)+    -> Stream m Char+decodeUtf8ArraysD' = decodeUtf8ArraysWithD ErrorOnCodingFailure++-- |+--+-- /Pre-release/+{-# INLINE decodeUtf8Arrays' #-}+decodeUtf8Arrays' :: (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char+decodeUtf8Arrays' = D.fromStreamD . decodeUtf8ArraysD' . D.toStreamD++{-# INLINE decodeUtf8ArraysD_ #-}+decodeUtf8ArraysD_ ::+       MonadIO m+    => Stream m (A.Array Word8)+    -> Stream m Char+decodeUtf8ArraysD_ = decodeUtf8ArraysWithD DropOnCodingFailure++-- |+--+-- /Pre-release/+{-# INLINE decodeUtf8Arrays_ #-}+decodeUtf8Arrays_ ::+       (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char+decodeUtf8Arrays_ =+    D.fromStreamD . decodeUtf8ArraysD_ . D.toStreamD++-------------------------------------------------------------------------------+-- 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++{-# ANN type EncodeState Fuse #-}+data EncodeState s = EncodeState s !WList++{-# ANN type InvalidAction Fuse #-}+data InvalidAction =+    DropInvalid | ErrorInvalid | IgnoreInvalid | ReplaceInvalid++replaceInvalid :: s -> Step (EncodeState s) a+replaceInvalid s =+    Skip $ EncodeState s (WCons 239 (WCons 191 (WCons 189 WNil)))++dropInvalid :: s -> Step (EncodeState s) a+dropInvalid s = Skip (EncodeState s WNil)++errorOnInvalid :: s -> Step (EncodeState s) a+errorOnInvalid _ =+    error $+    show "Streamly.Internal.Data.Stream.StreamD.encodeUtf8:"+    ++ "Encountered a surrogate"++{-# INLINE_NORMAL encodeUtf8DGeneric #-}+encodeUtf8DGeneric ::+       Monad m+    => InvalidAction+    -> Stream m Char+    -> Stream m Word8+encodeUtf8DGeneric act (Stream step state) =+    Stream step' (EncodeState state WNil)++    where++    {-# INLINE_LATE step' #-}+    step' gst (EncodeState st WNil) = do+        r <- step (adaptState gst) st+        return $+            case r of+                Yield c s ->+                    case ord c of+                        x | x <= 0x7F ->+                                Yield (fromIntegral x) (EncodeState s WNil)+                            | x <= 0x7FF -> Skip (EncodeState s (ord2 c))+                            | x <= 0xFFFF ->+                                case act of+                                    DropInvalid ->+                                        if isSurrogate c+                                        then dropInvalid s+                                        else Skip (EncodeState s (ord3 c))++                                    ErrorInvalid ->+                                        if isSurrogate c+                                        then errorOnInvalid s+                                        else Skip (EncodeState s (ord3 c))++                                    IgnoreInvalid ->+                                        Skip (EncodeState s (ord3 c))++                                    ReplaceInvalid ->+                                        if isSurrogate c+                                        then replaceInvalid s+                                        else Skip (EncodeState s (ord3 c))++                            | otherwise -> Skip (EncodeState s (ord4 c))+                Skip s -> Skip (EncodeState s WNil)+                Stop -> Stop+    step' _ (EncodeState s (WCons x xs)) = return $ Yield x (EncodeState s xs)++-- 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 => Stream m Char -> Stream m Word8+encodeUtf8D' = encodeUtf8DGeneric ErrorInvalid++-- | 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.+--+-- @since 0.8.0+{-# INLINE encodeUtf8' #-}+encodeUtf8' :: (Monad m, IsStream t) => t m Char -> t m Word8+encodeUtf8' = D.fromStreamD . encodeUtf8D' . D.toStreamD++-- | 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 => Stream m Char -> Stream m Word8+encodeUtf8D = encodeUtf8DGeneric ReplaceInvalid++-- | 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.+--+-- /Since: 0.7.0 ("Streamly.Data.Unicode.Stream")/+--+-- /Since: 0.8.0 (Lenient Behaviour)/+{-# INLINE encodeUtf8 #-}+encodeUtf8 :: (Monad m, IsStream t) => t m Char -> t m Word8+encodeUtf8 = D.fromStreamD . encodeUtf8D . D.toStreamD++{-# INLINE_NORMAL encodeUtf8D_ #-}+encodeUtf8D_ :: Monad m => Stream m Char -> Stream m Word8+encodeUtf8D_  = encodeUtf8DGeneric DropInvalid++-- | 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.+--+-- @since 0.8.0+{-# INLINE encodeUtf8_ #-}+encodeUtf8_ :: (Monad m, IsStream t) => t m Char -> t m Word8+encodeUtf8_ = D.fromStreamD . encodeUtf8D_ . D.toStreamD++-- | Same as 'encodeUtf8'+--+{-# DEPRECATED encodeUtf8Lax "Please use 'encodeUtf8' instead" #-}+{-# INLINE encodeUtf8Lax #-}+encodeUtf8Lax :: (IsStream t, Monad m) => t m Char -> t m Word8+encodeUtf8Lax = encodeUtf8++-------------------------------------------------------------------------------+-- 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 =>+       (SerialT m Char -> SerialT m Word8)+    -> Unfold m a Char+    -> a+    -> m (Array Word8)+encodeObject encode u = S.fold Array.write . encode . S.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, IsStream t) =>+       (SerialT m Char -> SerialT m Word8)+    -> Unfold m a Char+    -> t m a+    -> t m (Array Word8)+encodeObjects encode u = Serial.mapM (encodeObject encode u)++-- | Encode a stream of 'String' using the supplied encoding scheme. Each+-- string is encoded as an @Array Word8@.+--+-- @since 0.8.0+{-# INLINE encodeStrings #-}+encodeStrings :: (MonadIO m, IsStream t) =>+    (SerialT m Char -> SerialT m Word8) -> t m String -> t m (Array Word8)+encodeStrings encode = encodeObjects encode Unfold.fromList++{-+-------------------------------------------------------------------------------+-- Utility operations on strings+-------------------------------------------------------------------------------++strip :: IsStream t => t m Char -> t m Char+strip = undefined++stripTail :: IsStream t => t m Char -> t m Char+stripTail = undefined+-}++-- | Remove leading whitespace from a string.+--+-- > stripHead = S.dropWhile isSpace+--+-- /Pre-release/+{-# INLINE stripHead #-}+stripHead :: (Monad m, IsStream t) => t m Char -> t m Char+stripHead = S.dropWhile isSpace++-- | Fold each line of the stream using the supplied 'Fold'+-- and stream the result.+--+-- >>> Stream.toList $ lines Fold.toList (Stream.fromList "lines\nthis\nstring\n\n\n")+-- ["lines","this","string","",""]+--+-- > lines = S.splitOnSuffix (== '\n')+--+-- /Pre-release/+{-# INLINE lines #-}+lines :: (Monad m, IsStream t) => Fold m Char b -> t m Char -> t m b+lines = S.splitOnSuffix (== '\n')++foreign import ccall unsafe "u_iswspace"+  iswspace :: Int -> Int++-- | 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+  | otherwise = iswspace (ord c) /= 0+  where+    uc = fromIntegral (ord c) :: Word++-- | Fold each word of the stream using the supplied 'Fold'+-- and stream the result.+--+-- >>>  Stream.toList $ words Fold.toList (Stream.fromList "fold these     words")+-- ["fold","these","words"]+--+-- > words = S.wordsBy isSpace+--+-- /Pre-release/+{-# INLINE words #-}+words :: (Monad m, IsStream t) => Fold m Char b -> t m Char -> t m b+words = S.wordsBy isSpace++-- | 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, IsStream t) => Unfold m a Char -> t m a -> t m Char+unlines = S.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, IsStream t) => Unfold m a Char -> t m a -> t m Char+unwords = S.interpose ' '
src/Streamly/Memory/Array.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}- #include "inline.hs"  -- |@@ -35,9 +32,10 @@ -- -- > import qualified Streamly.Array as A ----- For experimental APIs see "Streamly.Internal.Memory.Array".+-- For experimental APIs see "Streamly.Internal.Data.Array.Foreign".  module Streamly.Memory.Array+    {-# DEPRECATED "Use Streamly.Data.Array.Foreign instead" #-}     (       A.Array @@ -73,4 +71,4 @@     ) where -import Streamly.Internal.Memory.Array as A+import Streamly.Internal.Data.Array.Foreign as A
− src/Streamly/Memory/Malloc.hs 
@@ -1,54 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}--#include "inline.hs"---- |--- Module      : Streamly.Memory.Malloc--- Copyright   : (c) 2019 Composewell Technologies------ License     : BSD3--- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC----module Streamly.Memory.Malloc-    (-      mallocForeignPtrAlignedBytes-    , mallocForeignPtrAlignedUnmanagedBytes-    )-where--#define USE_GHC_MALLOC--import Foreign.ForeignPtr (ForeignPtr, newForeignPtr_)-import Foreign.Marshal.Alloc (mallocBytes)-#ifndef USE_GHC_MALLOC-import Foreign.ForeignPtr (newForeignPtr)-import Foreign.Marshal.Alloc (finalizerFree)-#endif--import qualified GHC.ForeignPtr as GHC--{-# INLINE mallocForeignPtrAlignedBytes #-}-mallocForeignPtrAlignedBytes :: Int -> Int -> IO (GHC.ForeignPtr a)-#ifdef USE_GHC_MALLOC-mallocForeignPtrAlignedBytes =-    GHC.mallocPlainForeignPtrAlignedBytes-#else-mallocForeignPtrAlignedBytes size _alignment = do-    p <- mallocBytes size-    newForeignPtr finalizerFree p-#endif---- memalign alignment size--- foreign import ccall unsafe "stdlib.h posix_memalign" _memalign :: CSize -> CSize -> IO (Ptr a)--mallocForeignPtrAlignedUnmanagedBytes :: Int -> Int -> IO (ForeignPtr a)-mallocForeignPtrAlignedUnmanagedBytes size _alignment = do-    -- XXX use posix_memalign/aligned_alloc for aligned allocation-    p <- mallocBytes size-    newForeignPtr_ p
− src/Streamly/Memory/Ring.hs 
@@ -1,205 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ExistentialQuantification #-}---- |--- Module      : Streamly.Memory.Ring--- Copyright   : (c) 2019 Composewell Technologies--- License     : BSD3--- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC-----module Streamly.Memory.Ring-    ( Ring(..)--    -- * Construction-    , new--    -- * Modification-    , unsafeInsert--    -- * Folds-    , unsafeFoldRing-    , unsafeFoldRingM-    , unsafeFoldRingFullM--    -- * Fast Byte Comparisons-    , unsafeEqArray-    , unsafeEqArrayN-    ) where--import Control.Exception (assert)-import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, touchForeignPtr)-import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)-import Foreign.Ptr (plusPtr, minusPtr, castPtr)-import Foreign.Storable (Storable(..))-import GHC.ForeignPtr (mallocPlainForeignPtrAlignedBytes)-import GHC.Ptr (Ptr(..))-import Prelude hiding (length, concat)--import Control.Monad.IO.Class (MonadIO(..))--import qualified Streamly.Internal.Memory.Array.Types as A---- | 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 :: !(ForeignPtr a) -- first address-    , ringBound :: !(Ptr a)        -- first address beyond allocated memory-    }---- | 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 * sizeOf (undefined :: a)-    fptr <- mallocPlainForeignPtrAlignedBytes size (alignment (undefined :: a))-    let p = unsafeForeignPtrToPtr fptr-    return (Ring-        { ringStart = fptr-        , ringBound = p `plusPtr` size-        }, p)---- | 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 = ringHead `plusPtr` sizeOf (undefined :: a)-    in if ptr <  ringBound-       then ptr-       else unsafeForeignPtrToPtr ringStart---- | 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---- XXX remove all usage of A.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{..} n =-    let !res = A.unsafeInlineIO $ do-            let rs = unsafeForeignPtrToPtr ringStart-                as = unsafeForeignPtrToPtr aStart-            assert (aBound `minusPtr` as >= ringBound `minusPtr` rs) (return ())-            let len = ringBound `minusPtr` rh-            r1 <- A.memcmp (castPtr rh) (castPtr as) (min len n)-            r2 <- if n > len-                then A.memcmp (castPtr rs) (castPtr (as `plusPtr` len))-                              (min (rh `minusPtr` rs) (n - len))-                else return True-            -- XXX enable these, check perf impact-            -- touchForeignPtr ringStart-            -- touchForeignPtr aStart-            return (r1 && r2)-    in res---- | 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{..} =-    let !res = A.unsafeInlineIO $ do-            let rs = unsafeForeignPtrToPtr ringStart-            let as = unsafeForeignPtrToPtr aStart-            assert (aBound `minusPtr` as >= ringBound `minusPtr` rs)-                   (return ())-            let len = ringBound `minusPtr` rh-            r1 <- A.memcmp (castPtr rh) (castPtr as) len-            r2 <- A.memcmp (castPtr rs) (castPtr (as `plusPtr` len))-                           (rh `minusPtr` rs)-            -- XXX enable these, check perf impact-            -- touchForeignPtr ringStart-            -- touchForeignPtr aStart-            return (r1 && r2)-    in res---- 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 = A.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) (p `plusPtr` sizeOf (undefined :: 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 = A.unsafeInlineIO $ peek start-            acc' <- f acc x-            go acc' (start `plusPtr` sizeOf (undefined :: 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.-{-# 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 = A.unsafeInlineIO $ peek start-        acc' <- f acc x-        let ptr = advance rb start-        if ptr == rh-            then return acc'-            else go acc' ptr
src/Streamly/Network/Inet/TCP.hs view
@@ -4,7 +4,7 @@ -- -- License     : BSD3 -- Maintainer  : streamly@composewell.com--- Stability   : experimental+-- Stability   : released -- Portability : GHC -- -- Combinators to build Inet/TCP clients and servers.@@ -21,6 +21,10 @@      -- * Connect to Servers     , connect++    -- XXX Expose this as a pipe when we have pipes.+    -- * Transformation+    -- , processBytes      {-     -- ** Sink Servers
src/Streamly/Network/Socket.hs view
@@ -2,9 +2,9 @@ -- Module      : Streamly.Network.Socket -- Copyright   : (c) 2018 Composewell Technologies ----- License     : BSD3+-- License     : BSD-3-Clause -- Maintainer  : streamly@composewell.com--- Stability   : experimental+-- Stability   : released -- Portability : GHC -- -- This module provides Array and stream based socket operations to connect to@@ -24,20 +24,18 @@ -- of bytes or a stream of chunks of bytes ('Array'). -- -- Following is a short example of a concurrent echo server.  Please note that--- this example can be written more succinctly by using higher level operations--- from "Streamly.Network.Inet.TCP" module.+-- this example can be written even more succinctly by using higher level+-- operations from "Streamly.Network.Inet.TCP" module. -- -- @ -- {-\# LANGUAGE FlexibleContexts #-} -- -- import Data.Function ((&)) -- import Network.Socket--- import Streamly.Internal.Network.Socket (handleWithM) -- import Streamly.Network.Socket (SockSpec(..)) ----- import Streamly--- import qualified Streamly.Prelude as S--- import qualified Streamly.Network.Socket as SK+-- import qualified Streamly.Prelude as Stream+-- import qualified Streamly.Network.Socket as Socket -- -- main = do --     let spec = SockSpec@@ -52,24 +50,25 @@ --     where -- --     server spec addr =---           S.unfold SK.accept (maxListenQueue, spec, addr) -- SerialT IO Socket---         & parallely . S.mapM (handleWithM echo)           -- SerialT IO ()---         & S.drain                                         -- IO ()+--           Stream.unfold Socket.accept (maxListenQueue, spec, addr) -- ParallelT IO Socket+--         & Stream.mapM (Socket.forSocketM echo)                     -- ParallelT IO ()+--         & Stream.fromParallel                                      -- SerialT IO ()+--         & Stream.drain                                             -- IO () -- --     echo sk =---           S.unfold SK.readChunks sk  -- SerialT IO (Array Word8)---         & S.fold (SK.writeChunks sk) -- IO ()+--           Stream.unfold Socket.readChunks sk  -- SerialT IO (Array Word8)+--         & Stream.fold (Socket.writeChunks sk) -- IO () -- @ -- -- = Programmer Notes -- -- Read IO requests to connected stream sockets are performed in chunks of--- 'Streamly.Internal.Memory.Array.Types.defaultChunkSize'.  Unless specified--- otherwise in the API, writes are collected into chunks of--- 'Streamly.Internal.Memory.Array.Types.defaultChunkSize' before they are+-- 'Streamly.Internal.Data.Array.Foreign.Type.defaultChunkSize'.  Unless+-- specified otherwise in the API, writes are collected into chunks of+-- 'Streamly.Internal.Data.Array.Foreign.Type.defaultChunkSize' before they are -- written to the socket. APIs are provided to control the chunking behavior. ----- > import qualified Streamly.Network.Socket as SK+-- > import qualified Streamly.Network.Socket as Socket -- -- = See Also --@@ -89,7 +88,7 @@ -- APIs for unconnected sockets need to explicitly specify the remote endpoint. -- -- By design, connected socket IO APIs are similar to--- "Streamly.Memory.Array" read write APIs. They are almost identical to the+-- "Streamly.Data.Array.Foreign" read write APIs. They are almost identical to the -- sequential streaming APIs in "Streamly.Internal.FileSystem.File". -- module Streamly.Network.Socket@@ -105,11 +104,17 @@     , readWithBufferOf     , readChunks     , readChunksWithBufferOf+    , readChunk      -- * Write     , write     , writeWithBufferOf     , writeChunks+    , writeChunksWithBufferOf+    , writeChunk++    -- * Exceptions+    , forSocketM     ) where
src/Streamly/Prelude.hs view
@@ -1,28 +1,312 @@-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE RankNTypes                #-}-{-# LANGUAGE FlexibleContexts          #-}--#if __GLASGOW_HASKELL__ >= 800 {-# OPTIONS_GHC -Wno-orphans #-}-#endif  #include "inline.hs"  -- | -- Module      : Streamly.Prelude--- Copyright   : (c) 2017 Harendra Kumar+-- Copyright   : (c) 2017 Composewell Technologies -- -- License     : BSD3 -- Maintainer  : streamly@composewell.com--- Stability   : experimental+-- Stability   : released -- Portability : GHC ----- This module is designed to be imported qualified:+-- To run examples in this module: --+-- >>> import qualified Streamly.Data.Fold as Fold+-- >>> import qualified Streamly.Prelude as Stream+--+-- We will add some more imports in the examples as needed.+--+-- For effectful streams we will use the following IO action that blocks for+-- @n@ seconds:+--+-- >>> import Control.Concurrent (threadDelay)+-- >>> :{+--  delay n = do+--      threadDelay (n * 1000000)   -- sleep for n seconds+--      putStrLn (show n ++ " sec") -- print "n sec"+--      return n                    -- IO Int+-- :}+--+-- >>> delay 1+-- 1 sec+-- 1+--+-- = 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.+--+-- The basic stream type is 'SerialT'. The type @SerialT IO a@ is an effectful+-- equivalent of a list @[a]@ using the IO monad.  Streams can be constructed+-- like lists, except that they use 'nil' instead of '[]' and 'cons' instead of+-- ':'.+--+-- `cons` constructs a pure stream which is more or less the same as a list:+--+-- >>> import Streamly.Prelude (SerialT, cons, consM, nil)+-- >>> stream = 1 `cons` 2 `cons` nil :: SerialT IO Int+-- >>> Stream.toList stream -- IO [Int]+-- [1,2]+--+-- 'consM' constructs a stream from effectful actions:+--+-- >>> stream = delay 1 `consM` delay 2 `consM` nil+-- >>> Stream.toList stream+-- 1 sec+-- 2 sec+-- [1,2]+--+-- == Console Echo Program+--+-- 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 ((&))+-- -- @--- import qualified Streamly.Prelude as S+-- > :{+--  Stream.repeatM getLine      -- SerialT IO String+--      & Stream.mapM putStrLn  -- SerialT IO ()+--      & Stream.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. Also see "Streamly.Internal.Data.Stream.IsStream"+-- module for many more @Pre-release@ combinators. See the+-- <https://github.com/composewell/streamly-examples> repository for many more+-- real world examples of stream programming.+--+-- == Polymorphic Combinators+--+-- Streamly has several stream types, 'SerialT' is one type of stream with+-- serial execution of actions, 'AsyncT' is another with concurrent execution.+-- The combinators in this module are polymorphic in stream type. For example,+--+-- @+-- repeatM :: (IsStream t, MonadAsync m) => m a -> t m a+-- @+--+-- @t@ is the stream type, @m@ is the underlying 'Monad' of the stream (e.g.+-- IO) and @a@ is the type of elements in the stream (e.g. Int).+--+-- Stream elimination combinators accept a 'SerialT' type instead of a+-- polymorphic type to force a concrete monomorphic type by default, reducing+-- type errors. That's why in the console echo example above the stream type is+-- 'SerialT'.+--+-- @+-- drain :: Monad m => SerialT m a -> m ()+-- @+--+-- We can force a certain stream type in polymorphic code by using "Stream Type+-- Adaptors". For example, to force 'AsyncT':+--+-- >>> Stream.drain $ Stream.fromAsync $ Stream.replicateM 10 $ delay 1+-- ...+--+-- == Combining two streams+--+-- Two streams can be combined to form a single stream in various interesting+-- ways. 'serial' (append), 'wSerial' (interleave), 'ahead' (concurrent,+-- ordered append), 'async' (lazy concurrent, unordered append) , 'wAsync'+-- (lazy concurrent, unordered interleave), 'parallel' (strict concurrent+-- merge), 'zipWith', 'zipAsyncWith' (concurrent zip), 'mergeBy',+-- 'mergeAsyncBy' (concurrent merge) are some ways of combining two streams.+--+-- For example, the `parallel` combinator schedules both the streams+-- concurrently.+--+-- >>> stream1 = Stream.fromListM [delay 3, delay 4]+-- >>> stream2 = Stream.fromListM [delay 1, delay 2]+-- >>> Stream.toList $ stream1 `parallel` stream2+-- ...+--+-- We can chain the operations to combine more than two streams:+--+-- >>> stream3 = Stream.fromListM [delay 1, delay 2]+-- >>> Stream.toList $ stream1 `parallel` stream2 `parallel` stream3+-- ...+--+-- Concurrent generation ('consM') and concurrent merging of streams is the+-- fundamental basis of all concurrency in streamly.+--+-- == Combining many streams+--+-- The 'concatMapWith' combinator can be used to generalize the two stream+-- combining combinators to @n@ streams.  For example, we can use+-- @concatMapWith parallel@ to read concurrently from all incoming network+-- connections and combine the input streams into a single output stream:+--+-- @+-- import qualified Streamly.Network.Inet.TCP as TCP+-- import qualified Streamly.Network.Socket as Socket+--+-- Stream.unfold TCP.acceptOnPort 8090+--  & Stream.concatMapWith Stream.parallel (Stream.unfold Socket.read)+-- @+--+-- See the @streamly-examples@ repository for a full working example.+--+-- == Concurrent Nested Loops+--+-- The Monad instance of 'SerialT' is an example of nested looping. It is in+-- fact a list transformer. Different stream types provide different variants+-- of nested looping.  For example, the 'Monad' instance of 'ParallelT' uses+-- @concatMapWith parallel@ as its bind operation. Therefore, each iteration of+-- the loop for 'ParallelT' stream can run concurrently.  See the documentation+-- for individual stream types for the specific execution behavior of the+-- stream as well as the behavior of 'Semigroup' and 'Monad' instances.+--+-- == Stream Types+--+-- Streamly has several stream types. These types differ in three fundamental+-- operations, 'consM' ('IsStream' instance), '<>' ('Semigroup' instance) and+-- '>>=' ('Monad' instance).  Below we will see how 'consM' behaves for+-- 'SerialT', 'AsyncT' and 'AheadT' stream types.+--+-- 'SerialT' executes actions serially, so the total delay in the following+-- example is @2 + 1 = 3@ seconds:+--+-- >>> stream = delay 2 `consM` delay 1 `consM` nil+-- >>> Stream.toList stream -- IO [Int]+-- 2 sec+-- 1 sec+-- [2,1]+--+-- 'AsyncT' executes the actions concurrently, so the total delay is @max 2 1 =+-- 2@ seconds:+--+-- >>> Stream.toList $ Stream.fromAsync stream -- IO [Int]+-- 1 sec+-- 2 sec+-- [1,2]+--+-- 'AsyncT' produces the results in the order in which execution finishes.+-- Notice the order of elements in the list above, it is not the same as the+-- order of actions in the stream.+--+-- 'AheadT' is similar to 'AsyncT' but the order of results is the same as the+-- order of actions, even though they execute concurrently:+--+-- >>> Stream.toList $ Stream.fromAhead stream -- IO [Int]+-- 1 sec+-- 2 sec+-- [2,1]+--+-- == Semigroup Instance+--+-- Earlier we distinguished stream types based on the execution behavior of+-- actions within a stream. Stream types are also distinguished based on how+-- actions from different streams are scheduled for execution when two streams+-- are combined together.+--+-- For example, both 'SerialT' and 'WSerialT' execute actions within the stream+-- serially, however, they differ in how actions from individual streams are+-- executed when two streams are combined with '<>' (the 'Semigroup' instance).+--+-- For 'SerialT', '<>' has an appending behavior i.e. it executes the actions+-- from the second stream after executing actions from the first stream:+--+-- >>> stream1 = Stream.fromListM [delay 1, delay 2]+-- >>> stream2 = Stream.fromListM [delay 3, delay 4]+-- >>> Stream.toList $ stream1 <> stream2+-- 1 sec+-- 2 sec+-- 3 sec+-- 4 sec+-- [1,2,3,4]+--+-- For 'WSerialT', '<>' has an interleaving behavior i.e. it executes one+-- action from the first stream and then one action from the second stream and+-- so on:+--+-- >>> Stream.toList $ Stream.fromWSerial $ stream1 <> stream2+-- 1 sec+-- 3 sec+-- 2 sec+-- 4 sec+-- [1,3,2,4]+--+-- The '<>' operation of 'SerialT' and 'WSerialT' is the same as 'serial' and+-- 'wSerial' respectively. The 'serial' combinator combines two streams of any+-- type in the same way as a serial stream combines.+--+-- == Concurrent Combinators+--+-- Like 'consM', there are several other stream generation operations whose+-- execution behavior depends on the stream type, they all follow behavior+-- similar to 'consM'.+--+-- By default, folds like 'drain' force the stream type to be 'SerialT', so+-- 'replicateM' in the following code runs serially, and takes 10 seconds:+--+-- >>> Stream.drain $ Stream.replicateM 10 $ delay 1+-- ...+--+-- We can use the 'fromAsync' combinator to force the argument stream to be of+-- 'AsyncT' type, 'replicateM' in the following example executes the replicated+-- actions concurrently, thus taking only 1 second:+--+-- >>> Stream.drain $ Stream.fromAsync $ Stream.replicateM 10 $ delay 1+-- ...+--+-- We can use 'mapM' to map an action concurrently:+--+-- >>> f x = delay 1 >> return (x + 1)+-- >>> Stream.toList $ Stream.fromAhead $ Stream.mapM f $ Stream.fromList [1..3]+-- ...+-- [2,3,4]+--+-- 'fromAhead' forces mapM to happen in 'AheadT' style, thus all three actions+-- take only one second even though each individual action blocks for a second.+--+-- See the documentation of individual combinators to check if it is concurrent+-- or not. The concurrent combinators necessarily have a @MonadAsync m@+-- constraint. However, a @MonadAsync m@ constraint does not necessarily mean+-- that the combinator is concurrent.+--+-- == Automatic Concurrency Control+--+-- 'SerialT' (and 'WSerialT') runs all tasks serially whereas 'ParallelT' runs+-- all tasks concurrently i.e. one thread per task. The stream types 'AsyncT',+-- 'WAsyncT', and 'AheadT' provide demand driven concurrency. It means that+-- based on the rate at which the consumer is consuming the stream, it+-- maintains the optimal number of threads to increase or decrease parallelism.+--+-- However, the programmer can control the maximum number of threads using+-- 'maxThreads'. It provides an upper bound on the concurrent IO requests or+-- CPU cores that can be used. 'maxBuffer' limits the number of evaluated+-- stream elements that we can buffer.  See the "Concurrency Control" section+-- for details.+--+-- == Caveats+--+-- When we use combinators like 'fromAsync' on a piece of code, all combinators+-- inside the argument of fromAsync become concurrent which is often counter+-- productive.  Therefore, we recommend that in a pipeline, you identify the+-- combinators that you really want to be concurrent and add a 'fromSerial' after+-- those combinators so that the code following the combinator remains serial:+--+-- @+-- Stream.fromAsync $ ... concurrent combinator here ... $ Stream.fromSerial $ ...+-- @+--+-- == Conventions+-- -- Functions with the suffix @M@ are general functions that work on monadic -- arguments. The corresponding functions without the suffix @M@ work on pure -- arguments and can in general be derived from their monadic versions but are@@ -32,20 +316,15 @@ -- In many cases, short definitions of the combinators are provided in the -- documentation for illustration. The actual implementation may differ for -- performance reasons.------ Functions having a 'MonadAsync' constraint work concurrently when used with--- appropriate stream type combinator. Please be careful to not use 'parallely'--- with infinite streams.------ Deconstruction and folds accept a 'SerialT' type instead of a polymorphic--- type to ensure that streams always have a concrete monomorphic type by--- default, reducing type errors. In case you want to use any other type of--- stream you can use one of the type combinators provided in the "Streamly"--- module to convert the stream type.  module Streamly.Prelude     (     -- * Construction+    -- | Functions ending in the general shape @b -> t m a@.+    --+    -- See also: "Streamly.Internal.Data.Stream.IsStream.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@@ -60,10 +339,16 @@     , consM     , (|:) +    -- ** Unfolding+    -- | Generalized way of generating a stream efficiently.+    , unfold+    , unfoldr+    , unfoldrM+     -- ** From Values     -- | Generate a monadic stream from a seed value or values.-    , yield-    , yieldM+    , fromPure+    , fromEffect     , repeat     , repeatM     , replicate@@ -88,13 +373,12 @@     , enumerate     , enumerateTo -    -- ** From Generators-    -- | Generate a monadic stream from a seed value and a generator function.-    , unfoldr-    , unfoldrM-    , unfold+    -- ** Iteration     , iterate     , iterateM++    -- ** From Generators+    -- | Generate a monadic stream from a seed value and a generator function.     , fromIndices     , fromIndicesM @@ -107,29 +391,52 @@     , fromFoldableM      -- * Elimination+    -- | Functions ending in the general shape @t m a -> m b@+    --+    -- See also: "Streamly.Internal.Data.Stream.IsStream.Eliminate" for+    -- @Pre-release@ functions. +    -- ** Running a 'Fold'+    -- $runningfolds++    , fold+     -- ** Deconstruction-    -- | It is easy to express all the folds in terms of the 'uncons' primitive,-    -- however the specific implementations provided later are generally more-    -- efficient.-    --+    -- | Functions ending in the general shape @t m a -> m (b, t m a)@+     , uncons     , tail     , init -    -- ** Folding+    -- ** General Folds -- | 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 use a fold function @f@ and an identity element @z@--- (@zero@) to recursively deconstruct a structure and then combine and reduce--- the values or transform and reconstruct a new container.+-- 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. ----- In general, a right fold is suitable for transforming and reconstructing a--- right associated structure (e.g. cons lists and streamly streams) and a left--- fold is suitable for reducing a right associated structure.  The behavior of--- right and left folds are described in detail in the individual fold's--- documentation.  To illustrate the two folds for cons lists:+-- 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@@ -171,23 +478,19 @@ -- the previous step. However, it is possible to fold parts of the stream in -- parallel and then combine the results using a monoid. -    -- ** Right Folds+    -- *** Right Folds     -- $rightfolds     , foldrM     , foldr -    -- ** Left Folds+    -- *** Left Folds     -- $leftfolds     , foldl'     , foldl1'     , foldlM' -    -- ** Composable Left Folds-    -- $runningfolds--    , fold--    -- ** Full Folds+    -- ** Specific Folds+    -- *** Full Folds     -- | Folds that are guaranteed to evaluate the whole stream.      -- -- ** To Summary (Full Folds)@@ -207,17 +510,7 @@     , minimum     , the -    -- ** Lazy Folds-    ---    -- | Folds that generate a lazy structure. Note that the generated-    -- structure may not be lazy if the underlying monad is strict.--    -- -- ** To Containers (Full Folds)-    -- -- | Convert or divert a stream into an output structure, container or-    -- sink.-    , toList--    -- ** Partial Folds+    -- *** Partial Folds     -- | Folds that may terminate before evaluating the whole stream. These     -- folds strictly evaluate the stream until the result is determined. @@ -244,6 +537,14 @@     , and     , or +    -- *** To Containers+    -- | Convert a stream into a container holding all the values.+    , toList++    -- ** Folding Concurrently+    , (|$.)+    , (|&.)+     -- ** Multi-Stream folds     , eqBy     , cmpBy@@ -254,6 +555,8 @@     , stripPrefix      -- * Transformation+    -- | See also: "Streamly.Internal.Data.Stream.IsStream.Transform" for+    -- @Pre-release@ functions.      -- ** Mapping     -- | In imperative terms a map operation can be considered as a loop over@@ -271,10 +574,11 @@     , sequence     , mapM -    -- ** Special Maps+    -- ** Mapping Side Effects     , mapM_     , trace     , tap+    , delay      -- ** Scanning     --@@ -336,7 +640,7 @@     , scanl1'     , scanl1M' -    -- ** Scan Using Fold+    -- ** Scanning By 'Fold'     , scan     , postscan @@ -345,20 +649,20 @@     -- imperative terms a filter over a stream corresponds to a loop with a     -- @continue@ clause for the cases when the predicate fails. +    , deleteBy     , filter     , filterM--    -- ** Mapping Filters-    -- | Mapping along with filtering--    , mapMaybe-    , mapMaybeM--    -- ** Deleting Elements-    -- | Deleting elements is a special case of de-interleaving streams.-    , deleteBy     , uniq +    -- ** Trimming+    -- | Take or remove elements from one or both ends of a stream.+    , take+    , takeWhile+    , takeWhileM+    , drop+    , dropWhile+    , dropWhileM+     -- ** Inserting Elements     -- | Inserting elements is a special case of interleaving/merging streams. @@ -366,29 +670,15 @@     , intersperseM     , intersperse +    -- ** Reordering Elements+    , reverse+     -- ** Indexing     -- | Indexing can be considered as a special type of zipping where we zip a     -- stream with an index stream.     , indexed     , indexedR -    -- ** Reordering Elements-    , reverse--    -- ** Trimming-    -- | Take or remove elements from one or both ends of a stream.-    , take-    , takeWhile-    , takeWhileM-    , drop-    , dropWhile-    , dropWhileM--    -- -- ** Breaking--    , chunksOf-    , intervalsOf-     -- ** Searching     -- | Finding the presence or location of an element, a sequence of elements     -- or another stream within a stream.@@ -397,110 +687,79 @@     , findIndices     , elemIndices -    -- ** Splitting-    -- | In general we can express splitting in terms of parser combinators.-    -- These are some common use functions for convenience and efficiency.-    -- While parsers can fail these functions are designed to transform a-    -- stream without failure with a predefined behavior for all cases.-    ---    -- In general, there are three possible ways of combining stream segments-    -- with a separator. The separator could be prefixed to each segment,-    -- suffixed to each segment, or it could be infixed between segments.-    -- 'intersperse' and 'intercalate' operations are examples of infixed-    -- combining whereas 'unlines' is an example of suffixed combining. When we-    -- split a stream with separators we can split in three different ways,-    -- each being an opposite of the three ways of combining.-    ---    -- Splitting may keep the separator or drop it. Depending on how we split,-    -- the separator may be kept attached to the stream segments in prefix or-    -- suffix position or as a separate element in infix position. Combinators-    -- like 'splitOn' that use @On@ in their names drop the separator and-    -- combinators that use 'With' in their names keep the separator. When a-    -- segment is missing it is considered as empty, therefore, we never-    -- encounter an error in parsing.+    -- ** Maybe Streams+    , mapMaybe+    , mapMaybeM -    -- -- ** Splitting By Elements-    , splitOn-    , splitOnSuffix+    -- * Concurrent Transformation+    -- ** Concurrent Pipelines+    -- $application+    , (|$)+    , (|&)+    , mkAsync -    , splitWithSuffix-    , wordsBy -- strip, compact and split+    -- ** Concurrency Control+    -- $concurrency+    , maxThreads+    , maxBuffer -    -- ** Grouping-    -- | Splitting a stream by combining multiple contiguous elements into-    -- groups using some criterion.-    , groups-    , groupsBy-    , groupsByRolling+    -- ** Rate Limiting+    , Rate (..)+    , rate+    , avgRate+    , minRate+    , maxRate+    , constRate      -- * Combining Streams     -- | New streams can be constructed by appending, merging or zipping     -- existing streams.--    -- ** Appending-    -- | Streams form a 'Semigroup' and a 'Monoid' under the append-    -- operation. Appending can be considered as a generalization of the `cons`-    -- operation to consing a stream to a stream.     ---    -- @-    ---    -- -------Stream m a------|-------Stream m a------|=>----Stream m a---+    -- Any exceptions generated by concurrent evaluation are propagated to+    -- the consumer of the stream as soon as they occur.  Exceptions from a+    -- particular stream are guaranteed to arrive in the same order in the+    -- output stream as they were generated in the input stream.     ---    -- @+    -- See 'maxThreads' and 'maxBuffer' to control the concurrency of the+    -- concurrent combinators.     ---    -- @-    -- >> S.toList $ S.fromList [1,2] \<> S.fromList [3,4]-    -- [1,2,3,4]-    -- >> S.toList $ fold $ [S.fromList [1,2], S.fromList [3,4]]-    -- [1,2,3,4]-    -- @+    -- See also: "Streamly.Internal.Data.Stream.IsStream.Expand" for+    -- @Pre-release@ functions. -    -- ** Merging-    -- | Streams form a commutative semigroup under the merge-    -- operation. Merging can be considered as a generalization of inserting an-    -- element in a stream to interleaving a stream with another stream.-    ---    -- @-    ---    -- -------Stream m a------|-    --                        |=>----Stream m a----    -- -------Stream m a------|-    -- @-    --+    -- ** Linear combinators+    -- | These functions have O(n) append performance.  They can be used+    -- efficiently with 'concatMapWith' et. al. +    , serial+    , wSerial+    , ahead+    , async+    , wAsync+    , parallel++    -- ** PairWise combinators+    -- | These functions have O(n^2) append performance when used linearly e.g.+    -- using 'concatMapWith'. However, they can be combined pair wise using+    -- 'Streamly.Internal.Data.Stream.IsStream.Expand.concatPairsWith' to give+    -- O(n * log n) complexity.+     -- , merge     , mergeBy     , mergeByM     , mergeAsyncBy     , mergeAsyncByM -    -- ** Zipping-    -- |-    -- @-    ---    -- -------Stream m a------|-    --                        |=>----Stream m c----    -- -------Stream m b------|-    -- @-    --     , zipWith     , zipWithM     , zipAsyncWith     , zipAsyncWithM -    {--    -- ** Folding Containers of Streams-    -- | These are variants of standard 'Foldable' fold functions that use a-    -- polymorphic stream sum operation (e.g. 'async' or 'wSerial') to fold a-    -- finite container of streams. Note that these are just special cases of-    -- the more general 'concatMapWith' operation.-    ---    , foldMapWith-    , forEachWith-    , foldWith-    -}+    -- ** Nested Unfolds+    , unfoldMany+    , intercalate+    , intercalateSuffix -    -- ** Folding Streams of Streams+    -- ** Nested 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'@@ -516,20 +775,83 @@     -- 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.yield (f x)) m+    -- > 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.yield x else S.nil) m+    -- > filter p m = S.concatMap (\x -> if p x then S.fromPure x else S.nil) m     --      , concatMapWith     , concatMap     , concatMapM-    , concatUnfold +    -- ** Containers of Streams+    -- | These are variants of standard 'Foldable' fold functions that use a+    -- polymorphic stream sum operation (e.g. 'async' or 'wSerial') to fold a+    -- finite container of streams. Note that these are just special cases of+    -- the more general 'concatMapWith' operation.+    --+    , concatFoldableWith+    , concatMapFoldableWith+    , concatForFoldableWith++    -- * Reducing+    -- |+    -- See also: "Streamly.Internal.Data.Stream.IsStream.Reduce" for+    -- @Pre-release@ functions.++    -- ** Nested Folds+    , foldMany+    , chunksOf+    , intervalsOf++    -- ** Splitting+    -- | In general we can express splitting in terms of parser combinators.+    -- These are some common use functions for convenience and efficiency.+    -- While parsers can fail these functions are designed to transform a+    -- stream without failure with a predefined behavior for all cases.+    --+    -- In general, there are three possible ways of combining stream segments+    -- with a separator. The separator could be prefixed to each segment,+    -- suffixed to each segment, or it could be infixed between segments.+    -- 'intersperse' and 'intercalate' operations are examples of infixed+    -- combining whereas 'unlines' is an example of suffixed combining. When we+    -- split a stream with separators we can split in three different ways,+    -- each being an opposite of the three ways of combining.+    --+    -- Splitting may keep the separator or drop it. Depending on how we split,+    -- the separator may be kept attached to the stream segments in prefix or+    -- suffix position or as a separate element in infix position. Combinators+    -- like 'splitOn' that use @On@ in their names drop the separator and+    -- combinators that use 'With' in their names keep the separator. When a+    -- segment is missing it is considered as empty, therefore, we never+    -- encounter an error in parsing.++    -- -- ** Splitting By Elements+    , splitOn+    , splitOnSuffix++    , splitWithSuffix+    , wordsBy -- strip, compact and split++    -- ** Grouping+    -- | Splitting a stream by combining multiple contiguous elements into+    -- groups using some criterion.+    , groups+    , groupsBy+    , groupsByRolling+     -- * 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.IsStream.Exception" for+    -- @Pre-release@ functions.+     , before     , after     , bracket@@ -537,8 +859,69 @@     , finally     , handle +    -- * Lifting Inner Monad+    -- | See also: "Streamly.Internal.Data.Stream.IsStream.Lift" for+    -- @Pre-release@ functions.++    , liftInner+    , runReaderT+    , runStateT++    -- * Stream Types+    -- | Stream types that end with a @T@ (e.g. 'SerialT') are monad+    -- transformers.++    -- ** Serial Streams+    -- $serial+    , SerialT+    , WSerialT++    -- ** Speculative Streams+    -- $ahead+    , AheadT++    -- ** Asynchronous Streams+    -- $async+    , AsyncT+    , WAsyncT+    , ParallelT++    -- ** Zipping Streams+    -- $zipping+    , ZipSerialM+    , ZipAsyncM++    -- * IO Streams+    , Serial+    , WSerial+    , Ahead+    , Async+    , WAsync+    , Parallel+    , ZipSerial+    , ZipAsync++    -- * Type Synonyms+    , MonadAsync++    -- * Stream Type Adapters+    -- $adapters+    , IsStream ()++    , fromSerial+    , fromWSerial+    , fromAsync+    , fromAhead+    , fromWAsync+    , fromParallel+    , fromZipSerial+    , fromZipAsync+    , adapt+     -- * Deprecated     , once+    , yield+    , yieldM     , each     , scanx     , foldx@@ -549,6 +932,7 @@     , runWhile     , fromHandle     , toHandle+    , concatUnfold     ) where @@ -559,11 +943,54 @@                reverse, iterate, init, and, or, lookup, foldr1, (!!),                scanl, scanl1, repeat, replicate, concatMap, span) -import Streamly.Internal.Prelude+import Streamly.Internal.Data.Stream.IsStream +-- $setup+-- >>> import qualified Streamly.Data.Fold as Fold+-- >>> import qualified Streamly.Prelude as Stream++-- $serial+--+-- Serial streams are /spatially ordered/, they execute the actions in the+-- stream strictly one after the other.+--+-- There are two serial stream types 'SerialT' and 'WSerialT'.  They differ+-- only in the 'Semigroup' and 'Monad' instance behavior.++-- $ahead+--+-- Speculative streams evaluate some future actions speculatively and+-- concurrently, and keep the results ready for consumption. As in serial+-- streams, results are consumed in the same order as the actions in the+-- stream.+--+-- Even though the results of actions are ordered, the side effects are only+-- partially ordered.  Therefore, the semigroup operation is not commutative+-- from the pure outputs perspective but commutative from side effects+-- perspective.++-- $async+--+-- Asynchronous streams evaluate some future actions concurrently, the results+-- are given to the consumer as soon as they become available, they may not be+-- in the same order as the actions in the stream.+--+-- The results of the actions as well as their side effects are partially+-- ordered. Since the order of elements does not matter the 'Semigroup'+-- operation is effectively commutative.+--+-- There are two asynchronous stream types 'AsyncT' and 'WAsyncT'.  They differ+-- only in the 'Semigroup' and 'Monad' instance behavior.++-- $zipping+--+-- 'ZipSerialM' and 'ZipAsyncM', provide 'Applicative' instances for zipping the+-- corresponding elements of two streams together. Note that these types are+-- not monads.+ -- $rightfolds ----- Let's take a closer look at the @foldr@ definition for lists, as given+-- Let's take a closer look at the @foldr@ definition for lists, as given3 -- earlier: -- -- @@@ -703,8 +1130,9 @@ -- works. For example: -- -- @--- > S.foldl' (+) 0 $ S.fromList [1,2,3,4]+-- >>> Stream.foldl' (+) 0 $ Stream.fromList [1,2,3,4] -- 10+-- -- @ -- -- @@@ -727,8 +1155,9 @@ -- reverse (LIFO) order: -- -- @--- > S.foldl' (flip (:)) [] $ S.fromList [1,2,3,4]+-- >>> Stream.foldl' (flip (:)) [] $ Stream.fromList [1,2,3,4] -- [4,3,2,1]+-- -- @ -- -- A left fold is a push fold. The producer pushes its contents to the step@@ -750,45 +1179,62 @@  -- $runningfolds ----- "Streamly.Data.Fold" module defines composable left folds which can be combined--- together in many interesting ways. Those folds can be run using 'fold'.--- The following two ways of folding are equivalent in functionality and--- performance,------ >>> S.fold FL.sum (S.enumerateFromTo 1 100)--- 5050--- >>> S.sum (S.enumerateFromTo 1 100)--- 5050------ However, left folds cannot terminate early even if it does not need to--- consume more input to determine the result.  Therefore, the performance is--- equivalent only for full folds like 'sum' and 'length'. For partial folds--- like 'head' or 'any' the the folds defined in this module may be much more--- efficient because they are implemented as right folds that terminate as soon--- as we get the result. Note that when a full fold is composed with a partial--- fold in parallel the performance is not impacted as we anyway have to--- consume the whole stream due to the full fold.+-- See "Streamly.Data.Fold" for an overview of composable folds. All folds in+-- this module can be expressed in terms of composable folds using 'fold'. ----- >>> S.head (1 `S.cons` undefined)--- Just 1--- >>> S.fold FL.head (1 `S.cons` undefined)--- *** Exception: Prelude.undefined+-- $application ----- However, we can wrap the fold in a scan to convert it into a lazy stream of--- fold steps. We can then terminate the stream whenever we want.  For example,+-- Stream processing functions can be composed in a chain using function+-- application with or without the '$' operator, or with reverse function+-- application operator '&'. Streamly provides concurrent versions of these+-- operators applying stream processing functions such that each stage of the+-- stream can run in parallel. The operators start with a @|@; we can read '|$'+-- as "@parallel dollar@" to remember that @|@ comes before '$'.++-- $concurrency ----- >>> S.toList $ S.take 1 $ S.scan FL.head (1 `S.cons` undefined)--- [Nothing]+-- These combinators can be used at any point in a stream composition to set+-- parameters to control the concurrency of the /argument stream/.  A control+-- parameter set at any point remains effective for any concurrent combinators+-- used in the argument stream until it is reset by using the combinator again.+-- These control parameters have no effect on non-concurrent combinators in the+-- stream, or on non-concurrent streams. ----- The following example extracts the input stream up to a point where the--- running average of elements is no more than 10:+-- /Pitfall:/ Remember that 'maxBuffer' in the following example applies to+-- 'mapM' and any other combinators that may follow it, and it does not apply+-- to the combinators before it: -- -- @--- > S.toList---   $ S.map (fromJust . fst)---   $ S.takeWhile (\\(_,x) -> x <= 10)---   $ S.postscan ((,) \<$> FL.last \<*> avg) (S.enumerateFromTo 1.0 100.0)+--  ...+--  $ Stream.maxBuffer 10+--  $ Stream.mapM ...+--  ... -- @+--+-- If we use '&' instead of '$' the situation will reverse, in the following+-- example, 'maxBuffer' does not apply to 'mapM', it applies to combinators+-- that come before it, because those are the arguments to 'maxBuffer':+-- -- @---  [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]+--  ...+--  & Stream.maxBuffer 10+--  & Stream.mapM ...+--  ... -- @++-- $adapters+--+-- You may want to use different stream composition styles at different points+-- in your program. Stream types can be freely converted or adapted from one+-- type to another.  The 'IsStream' type class facilitates type conversion of+-- one stream type to another. It is not used directly, instead the type+-- combinators provided below are used for conversions.+--+-- To adapt from one monomorphic type (e.g. 'AsyncT') to another monomorphic+-- type (e.g. 'SerialT') use the 'adapt' combinator. To give a polymorphic code+-- a specific interpretation or to adapt a specific type to a polymorphic type+-- use the type specific combinators e.g. 'fromAsync' or 'fromWSerial'. You+-- cannot adapt polymorphic code to polymorphic code, as the compiler would not know+-- which specific type you are converting from or to. If you see a an+-- @ambiguous type variable@ error then most likely you are using 'adapt'+-- unnecessarily on polymorphic code.
− src/Streamly/Tutorial.hs 
@@ -1,1742 +0,0 @@-{-# OPTIONS_GHC -fno-warn-unused-imports #-}--- |--- Module      : Streamly.Tutorial--- Copyright   : (c) 2017 Harendra Kumar------ License     : BSD3--- Maintainer  : streamly@composewell.com------ Streamly is a general computing framework based on concurrent data flow--- programming. The IO monad and pure lists are a special case of streamly. On--- one hand, streamly extends the lists of pure values to lists of monadic--- actions, on the other hand it extends the IO monad with concurrent--- non-determinism. In simple imperative terms we can say that streamly extends--- the IO monad with @for@ loops and nested @for@ loops with concurrency--- support. Hopefully, this analogy becomes clearer once you go through this--- tutorial.------ Streaming in general enables writing modular, composable and scalable--- applications with ease, and concurrency allows you to make them scale and--- perform well.  Streamly enables writing scalable concurrent applications--- without being aware of threads or synchronization. No explicit thread--- control is needed. Where applicable, concurrency rate is automatically--- controlled based on the demand by the consumer. However, combinators can be--- used to fine tune the concurrency control.------ Streaming and concurrency together enable expressing reactive applications--- conveniently. See the @CirclingSquare@ example in the examples directory for--- a simple SDL based FRP example. To summarize, streamly provides a unified--- computing framework for streaming, non-determinism and functional reactive--- programming in an elegant and simple API that is a natural extension of pure--- lists to monadic streams.------ In this tutorial we will go over the basic concepts and how to use the--- library.  Before you go through this tutorial we recommend that you take a--- look at:------  * The quick overview in the package <README.md README file>.---  * The overview of streams and folds in the "Streamly" module.------ Once you finish this tutorial, see the last section for further reading--- resources.--module Streamly.Tutorial-    (-    -- * Stream Types-    -- $streams--    -- * Concurrent Streams-    -- $concurrentStreams--    -- * Combining Streams-    -- $flavors--    -- * Imports and Supporting Code-    -- $imports--    -- * Generating Streams-    -- $generating--    -- * Generating Streams Concurrently-    -- $generatingConcurrently--    -- * Eliminating Streams-    -- $eliminating--    -- * Concurrent Pipeline Stages-    -- $concurrentApplication--    -- * Transforming Streams-    -- $transformation--    -- * Mapping Concurrently-    -- $concurrentTransformation--    -- * Merging Streams--    -- ** Semigroup Style-    -- $semigroup--    -- *** Deep Serial Composition ('Serial')-    -- $serial--    -- *** Wide Serial Composition ('WSerial')-    -- $interleaved--    -- *** Deep Speculative Composition ('Ahead')-    -- $ahead--    -- *** Deep Asynchronous Composition ('Async')-    -- $async--    -- *** Wide Asynchronous Composition ('WAsync')-    -- $wasync--    -- *** Parallel Asynchronous Composition ('Parallel')-    -- $parallel--    -- XXX we should deprecate and remove the mkAsync API-    -- Custom composition-    -- custom--    -- ** Monoid Style-    -- $monoid--    -- * Nesting Streams-    -- $nesting--    -- ** Monad-    -- $monad--    -- *** Deep Serial Nesting ('Serial')-    -- $regularSerial--    -- *** Wide Serial Nesting ('WSerial')-    -- $interleavedNesting--    -- *** Deep Speculative Nesting ('Ahead')-    -- $aheadNesting--    -- *** Deep Asynchronous Nesting ('Async')-    -- $concurrentNesting--    -- *** Wide Asynchronous Nesting ('WAsync')-    -- $wasyncNesting--    -- *** Parallel Asynchronous Nesting ('Parallel')-    -- $parallelNesting--    -- *** Exercise-    -- $monadExercise--    -- ** Applicative-    -- $applicative--    -- ** Functor-    -- $functor--    -- * Zipping Streams-    -- $zipping--    -- ** Serial Zipping-    -- $serialzip--    -- ** Parallel Zipping-    -- $parallelzip--    -- * Monad transformers-    -- $monadtransformers--    -- * Concurrent Programming-    -- $concurrent--    -- * Reactive Programming-    -- $reactive--    -- * Writing Concurrent Programs-    -- $programs--    -- * Performance-    -- $performance--    -- * Interoperation with Streaming Libraries-    -- $interop--    -- * Comparison with Existing Packages-    -- $comparison--    -- * Where to go next?-    -- $furtherReading-    )-where--import Streamly hiding (foldWith, foldMapWith, forEachWith)-import Streamly.Prelude-import Data.Semigroup-import Control.Applicative-import Control.Monad-import Control.Monad.IO.Class      (MonadIO(..))-import Control.Monad.Trans.Class   (MonadTrans (lift))---- $streams------ The monadic stream API offered by Streamly is very close to the Haskell--- "Prelude" pure lists' API, it can be considered as a natural extension of--- lists to monadic actions. Streamly streams provide concurrent composition--- and merging of streams. It can be considered as a concurrent list--- transformer.------ The basic stream type is 'Serial', it represents a sequence of IO actions,--- and is a 'Monad'.  The 'Serial' monad is almost a drop in replacement for--- the 'IO' monad, IO monad is a special case of the 'Serial' monad; IO monad--- represents a single IO action whereas the 'Serial' monad represents a series--- of IO actions.  The only change you need to make to go from 'IO' to 'Serial'--- is to use 'drain' to run the monad and to prefix the IO actions with--- either 'yieldM' or 'liftIO'.  If you use liftIO you can switch from 'Serial'--- to IO monad by simply removing the 'drain' function; no other changes--- are needed unless you have used some stream specific composition or--- combinators.------ Similarly, the 'Serial' type is almost a drop in replacement for pure lists,--- pure lists are a special case of monadic streams. If you use 'nil' in place--- of '[]' and '|:' in place ':' you can replace a list with a 'Serial' stream.--- The only difference is that the elements must be monadic type and to operate--- on the streams we must use the corresponding functions from--- "Streamly.Prelude" instead of using the base "Prelude".---- $concurrentStreams------ Many stream operations can be done concurrently:------ * Streams can be generated concurrently.------ * Streams can be merged concurrently.------ * Multiple stages in a streaming pipeline can run concurrently.------ * Streams can be mapped and zipped concurrently.------ * In monadic composition they combine like a list transformer,---   providing concurrent non-determinism.------ There are three basic concurrent stream styles, 'Ahead', 'Async', and--- 'Parallel'. The 'Ahead' style streams are similar to 'Serial' except that--- they can speculatively execute multiple stream actions concurrently in--- advance. 'Ahead' would return exactly the same stream as 'Serial' except--- that it may execute the actions concurrently. The 'Async' style streams,--- like 'Ahead', speculatively execute multiple stream actions in advance but--- return the results in their finishing order rather than in the stream--- traversal order.  'Parallel' is like 'Async' except that it provides--- unbounded parallelism instead of controlled parallelism.------ For easy reference, we can classify the stream types based on /execution order/,--- /consumption order/, and /bounded or unbounded/ concurrency.--- Execution could be serial (i.e. synchronous) or asynchronous. In serial--- execution we execute the next action in the stream only after the previous--- one has finished executing. In asynchronous execution multiple actions in--- the stream can be executed asynchronously i.e. the next action can start--- executing even before the first one has finished. Consumption order--- determines the order in which the outputs generated by the composition are--- consumed.  Consumption could be serial or asynchronous. In serial--- consumption, the outputs are consumed in the traversal order, in--- asynchronous consumption the outputs are consumed as they arrive i.e. first--- come first serve order.------ +------------+--------------+--------------+--------------+--- | Type       | Execution    | Consumption  | Concurrency  |--- +============+==============+==============+==============+--- | 'Serial'   | Serial       | Serial       | None         |--- +------------+--------------+--------------+--------------+--- | 'Ahead'    | Asynchronous | Serial       | bounded      |--- +------------+--------------+--------------+--------------+--- | 'Async'    | Asynchronous | Asynchronous | bounded      |--- +------------+--------------+--------------+--------------+--- | 'Parallel' | Asynchronous | Asynchronous | unbounded    |--- +------------+--------------+--------------+--------------+------ All these types can be freely inter-converted using type conversion--- combinators or type annotations, without any cost, to achieve the desired--- composition style.  To force a particular type of composition, we coerce the--- stream type using the corresponding type adapting combinator from--- 'serially', 'aheadly', 'asyncly', or 'parallely'.  The default stream type--- is inferred as 'Serial' unless you change it by using one of the combinators--- or by using a type annotation.---- $flavors------ Streams can be combined using '<>' or 'mappend' to form a--- composite. Composite streams can be interpreted in a depth first or--- breadth first manner using an appropriate type conversion before--- consumption. Deep (e.g. 'Serial') stream type variants traverse a--- composite stream in a depth first manner, such that each stream is--- traversed fully before traversing the next stream. Wide--- (e.g. 'WSerial') stream types traverse it in a breadth first--- manner, such that one element from each stream is traversed before--- coming back to the first stream again.------ Each stream type has a wide traversal variant prefixed by 'W'. The wide--- variant differs only in the Semigroup\/Monoid, Applicative\/Monad--- compositions of the streams.--- The following table summarizes the basic types and the corresponding wide--- variants:------ @--- +------------+-----------+--- | Deep       | Wide      |--- +============+===========+--- | 'Serial'     | 'WSerial'   |--- +------------+-----------+--- | 'Ahead'      | 'WAhead'    |--- +------------+-----------+--- | 'Async'      | 'WAsync'    |--- +------------+-----------+--- @------ Other than these types there are also 'ZipSerial' and 'ZipAsync' types that--- zip streams serially or concurrently using 'Applicative' operation. These--- types are not monads they are only applicatives and they do not differ in--- 'Semigroup' composition.------- $programs------ When writing concurrent programs it is advised to not use the concurrent--- style stream combinators blindly at the top level. That might create too--- much concurrency where it is not even required, and can even degrade--- performance in some cases. In some cases it can also lead to surprising--- behavior because of some code that is supposed to be serial becoming--- concurrent. Please be aware that all concurrency capable APIs that you may--- have used under the scope of a concurrent stream combinator will become--- concurrent. For example if you have a 'repeatM' somewhere in your program--- and you use 'parallely' on top, the 'repeatM' becomes fully parallel,--- resulting into an infinite parallel execution . Instead, use the--- /Keep It Serial and Stupid/ principle, start with the default serial--- composition and enable concurrent combinators only when and where necessary.--- When you use a concurrent combinator you can use an explicit 'serially'--- combinator to suppress any unnecessary concurrency under the scope of that--- combinator.---- $monadtransformers------ To represent streams in an arbitrary monad use the more general monad--- transformer types for example the monad transformer type corresponding to--- the 'Serial' type is 'SerialT'.  @SerialT m a@ represents a stream of values--- of type 'a' in some underlying monad 'm'. For example, @SerialT IO Int@ is a--- stream of 'Int' in 'IO' monad.  In fact, the type 'Serial' is a synonym for--- @SerialT IO@.------ Similarly we have monad transformer types for other stream types as well viz.--- 'WSerialT', 'AsyncT', 'WAsyncT' and 'ParallelT'.------ To lift a value from an underlying monad in a monad transformer stack into a--- singleton stream use 'lift' and to lift from an IO action use 'liftIO'.------ @--- > S.'drain' $ liftIO $ putStrLn "Hello world!"--- Hello world!--- > S.'drain' $ lift $ putStrLn "Hello world!"--- Hello world!--- @------- $generating------ We will assume the following imports in this tutorial. Go ahead, fire up a--- GHCi session and import these lines to start playing.------ @--- > import "Streamly"--- > import "Streamly.Prelude" ((|:))--- > import qualified "Streamly.Prelude" as S------ > import Control.Concurrent--- @------ 'nil' represents an empty stream and 'consM' or its operator form '|:' adds--- a monadic action at the head of the stream.------ @--- > S.'toList' S.'nil'--- []--- > S.'toList' $ 'getLine' |: 'getLine' |: S.'nil'--- hello--- world--- ["hello","world"]--- @------ To create a singleton stream from a pure value use 'yield' or 'pure' and to--- create a singleton stream from a monadic action use 'yieldM'. Note that in--- case of Zip applicative streams "pure" repeats the value to generate an--- infinite stream.------ @--- > S.'toList' $ 'pure' 1--- [1]--- > S.'toList' $ S.'yield' 1--- [1]--- > S.'toList' $ S.'yieldM' 'getLine'--- hello--- ["hello"]--- @------ To create a stream from pure values in a 'Foldable' container use--- 'fromFoldable' which is equivalent to a fold using 'cons' and 'nil':------ @--- > S.'toList' $ S.'fromFoldable' [1..3]--- [1,2,3]--- > S.'toList' $ 'Prelude.foldr' S.'cons' S.'nil' [1..3]--- [1,2,3]--- @------ To create a stream from monadic actions in a 'Foldable' container just use a--- right fold using 'consM' and 'nil':------ @--- > S.'drain' $ 'Prelude.foldr' ('|:') S.'nil' ['putStr' "Hello ", 'putStrLn' "world!"]--- Hello world!--- @------ For more ways to construct a stream see the module "Streamly.Prelude".---- $generatingConcurrently------ Monadic construction and generation functions like 'consM', 'unfoldrM',--- 'replicateM', 'repeatM', 'iterateM' and 'fromFoldableM' work concurrently--- when used with appropriate stream type combinator. The pure versions of--- these APIs are not concurrent, however you can use the monadic versions even--- for pure computations by wrapping the pure value in a monad to get the--- concurrent generation capability where required.------ The following code finishes in 3 seconds (6 seconds when serial):------ @--- > let p n = threadDelay (n * 1000000) >> return n--- > S.'toList' $ 'parallely' $ p 3 |: p 2 |: p 1 |: S.'nil'--- [1,2,3]--- > S.'toList' $ 'aheadly' $ p 3 |: p 2 |: p 1 |: S.'nil'--- [3,2,1]--- @--- The following finishes in 10 seconds (100 seconds when serial):------ @--- > S.drain $ 'asyncly' $ S.'replicateM' 10 $ p 10--- @------- $eliminating------ We have already seen 'drain' and 'toList' to eliminate a stream in the--- examples above.  'drain' runs a stream discarding the results i.e. only--- for effects.  'toList' runs the stream and collects the results in a list.------ For other ways to eliminate a stream see the @Folding@ section in--- "Streamly.Prelude" module.---- $transformation------ Transformation over a stream is the equivalent of a @for@ loop construct in--- imperative paradigm. We iterate over every element in the stream and perform--- certain transformations for each element.  Transformations may involve--- mapping functions over the elements, filtering elements from the stream or--- folding all the elements in the stream into a single value. Streamly streams--- are exactly like lists and you can perform all the transformations in the--- same way as you would on lists.------ Here is a simple console echo program that just echoes every input line,--- forever:------ @--- > import Data.Function ((&))--- > S.'drain' $ S.'repeatM' getLine & S.'mapM' putStrLn--- @------ The following code snippet reads lines from standard input, filters blank--- lines, drops the first non-blank line, takes the next two, up cases them,--- numbers them and prints them:------ @--- import "Streamly"--- import qualified "Streamly.Prelude" as S--- import Data.Char (toUpper)--- import Data.Function ((&))------ main = S.'drain' $---        S.'repeatM' getLine---      & S.'filter' (not . null)---      & S.'drop' 1---      & S.'take' 2---      & fmap (map toUpper)---      & S.'zipWith' (\\n s -> show n ++ " " ++ s) (S.'fromFoldable' [1..])---      & S.'mapM' putStrLn--- @---- $concurrentTransformation------ Monadic transformation functions 'mapM' and 'sequence' work concurrently--- when used with appropriate stream type combinators. The pure versions do not--- work concurrently, however you can use the monadic versions even for pure--- computations to get the concurrent transformation capability where required.------ This would print a value every second (2 seconds when serial):------ @--- > let p n = threadDelay (n * 1000000) >> return n--- > S.'drain' $ S.aheadly $ S.'mapM' (\\x -> p 1 >> print x) (serially $ S.repeatM (p 1))--- @------- $concurrentApplication------ The concurrent function application operators '|$' and '|&' apply a stream--- argument to a stream function concurrently to compose a concurrent pipeline--- of stream processing functions:------ Because both the stages run concurrently, we would see a delay of only 1--- second instead of 2 seconds in the following:------ @--- > let p n = threadDelay (n * 1000000) >> return n--- > S.'drain' $ S.'repeatM' (p 1) '|&' S.'mapM' (\\x -> p 1 >> print x)--- @---- $semigroup------ We can combine two streams into a single stream using semigroup composition--- operation '<>'.  Streams can be combined in many different ways as described--- in the following sections, the '<>' operation behaves differently depending--- on the stream type in effect. The stream type and therefore the composition--- style can be changed at any point using one of the type combinators as--- discussed earlier.---- $imports------ In most of example snippets we do not repeat the imports. Where imports are--- not explicitly specified use the imports shown below.------ @--- import "Streamly"--- import "Streamly.Prelude" ((|:), nil)--- import qualified "Streamly.Prelude" as S------ import Control.Concurrent--- import Control.Monad (forever)--- @------ To illustrate concurrent vs serial composition aspects, we will use the--- following @delay@ function to introduce a sleep or delay specified in--- seconds. After the delay it prints the number of seconds it slept.------ @--- delay n = S.'yieldM' $ do---  threadDelay (n * 1000000)---  tid \<- myThreadId---  putStrLn (show tid ++ ": Delay " ++ show n)--- @---- $serial------ The 'Semigroup' operation '<>' of the 'Serial' type combines the two streams--- in a /serial depth first/ manner. We use the 'serially' type combinator to--- effect 'Serial' style of composition. We can also use an explicit 'Serial'--- type annotation for the stream to achieve the same effect.  However, since--- 'Serial' is the default type unless explicitly specified by using a--- combinator, we can omit using an explicit combinator or type annotation for--- this style of composition.------ When two streams with multiple elements are combined in this manner, the--- monadic actions in the two streams are performed sequentially i.e. first all--- actions in the first stream are performed sequentially and then all actions--- in the second stream are performed sequentially. We call it--- /serial depth first/ as the full depth of one stream is fully traversed--- before we move to the next. The following example prints the sequence 1, 2,--- 3, 4:------ @--- main = S.'drain' $ (print 1 |: print 2 |: nil) <> (print 3 |: print 4 |: nil)--- @--- @--- 1--- 2--- 3--- 4--- @------ All actions in both the streams are performed serially in the same thread.--- In the following example we can see that all actions are performed in the--- same thread and take a combined total of @3 + 2 + 1 = 6@ seconds:------ @--- main = S.'drain' $ delay 3 <> delay 2 <> delay 1--- @--- @--- ThreadId 36: Delay 3--- ThreadId 36: Delay 2--- ThreadId 36: Delay 1--- @------ The polymorphic version of the binary operation '<>' of the 'Serial' type is--- 'serial'. We can use 'serial' to join streams in a sequential manner--- irrespective of the type of stream:------ @--- main = S.'drain' $ (print 1 |: print 2 |: nil) \`serial` (print 3 |: print 4 |: nil)--- @---- $interleaved------ The 'Semigroup' operation '<>' of the 'WSerial' type combines the two--- streams in a /serial breadth first/ manner. We use the 'wSerially' type--- combinator to effect 'WSerial' style of composition. We can also use the--- 'WSerial' type annotation for the stream to achieve the same effect.------ When two streams with multiple elements are combined in this manner, we--- traverse all the streams in a breadth first manner i.e. one action from each--- stream is performed and yielded to the resulting stream before we come back--- to the first stream again and so on.--- The following example prints the sequence 1, 3, 2, 4------ @--- main = S.'drain' . 'wSerially' $ (print 1 |: print 2 |: nil) <> (print 3 |: print 4 |: nil)--- @--- @--- 1--- 3--- 2--- 4--- @------ Even though the monadic actions of the two streams are performed in an--- interleaved manner they are all performed serially in the same thread. In--- the following example we can see that all actions are performed in the same--- thread and take a combined total of @3 + 2 + 1 = 6@ seconds:------ @--- main = S.'drain' . 'wSerially' $ delay 3 <> delay 2 <> delay 1--- @--- @--- ThreadId 36: Delay 3--- ThreadId 36: Delay 2--- ThreadId 36: Delay 1--- @------ The polymorphic version of the 'WSerial' binary operation '<>' is called--- 'wSerial'. We can use 'wSerial' to join streams in an interleaved manner--- irrespective of the type, notice that we have not used the 'wSerially'--- combinator in the following example:------ @--- main = S.'drain' $ (print 1 |: print 2 |: nil) \`wSerial` (print 3 |: print 4 |: nil)--- @--- @--- 1--- 3--- 2--- 4--- @------ Note that this composition cannot be used to fold infinite number of streams--- since it requires preserving the state until a stream is finished.---- $ahead------ The 'Semigroup' operation '<>' of the 'Ahead' type combines two streams in a--- /serial depth first/ manner with concurrent lookahead. We use the 'aheadly'--- type combinator to effect 'Ahead' style of composition. We can also use an--- explicit 'Ahead' type annotation for the stream to achieve the same effect.------ When two streams are combined in this manner, the streams are traversed in--- depth first manner just like 'Serial', however it can execute the next--- stream concurrently and keep the results ready when its turn arrives.--- Concurrent execution of the next stream(s) is performed if the first stream--- blocks or if it cannot produce output at the rate that is enough to meet the--- consumer demand. Multiple streams can be executed concurrently to meet the--- demand.  The following example would print the result in a second even--- though each action in each stream takes one second:------ @--- main = do---  xs \<- S.'toList' . 'aheadly' $ (p 1 |: p 2 |: nil) <> (p 3 |: p 4 |: nil)---  print xs---  where p n = threadDelay 1000000 >> return n--- @--- @--- [1,2,3,4]--- @------ Each stream is constructed 'aheadly' and then both the streams are merged--- 'aheadly', therefore, all the actions can run concurrently but the result is--- presented in serial order.------ You can also use the polymorphic combinator 'ahead' in place of '<>' to--- compose any type of streams in this manner.---- $async------ The 'Semigroup' operation '<>' of the 'Async' type combines the two--- streams in a depth first manner with parallel look ahead. We use the--- 'asyncly' type combinator to effect 'Async' style of composition. We--- can also use the 'Async' type annotation for the stream type to achieve--- the same effect.------ When two streams with multiple elements are combined in this manner, the--- streams are traversed in depth first manner just like 'Serial', however it--- can execute the next stream concurrently and return the results from it--- as they arrive i.e. the results from the next stream may be yielded even--- before the results from the first stream. Concurrent execution of the next--- stream(s) is performed if the first stream blocks or if it cannot produce--- output at the rate that is enough to meet the consumer demand. Multiple--- streams can be executed concurrently to meet the demand.--- In the example below each element in the stream introduces a constant delay--- of 1 second, however, it takes just one second to produce all the results.--- The results are not guaranteed to be in any particular order:------ @--- main = do---   xs \<- S.'toList' . 'asyncly' $ (p 1 |: p 2 |: nil) <> (p 3 |: p 4 |: nil)---   print xs---   where p n = threadDelay 1000000 >> return n--- @--- @--- [4,2,1,3]--- @------ The constituent streams are also composed in 'Async' manner and the--- composition of streams too. We can compose the constituent streams to run--- serially, in that case it would take 2 seconds to produce all the results.--- The elements in the serial streams would be in serial order in the results:------ @--- main = do---   xs \<- S.'toList' . 'asyncly' $ (serially $ p 1 |: p 2 |: nil) <> (serially $ p 3 |: p 4 |: nil)---   print xs---   where p n = threadDelay 1000000 >> return n--- @--- @--- [3,1,2,4]--- @------ In the following example we can see that new threads are started when a--- computation blocks.  Notice that the output from the stream with the--- shortest delay is printed first. The whole computation takes @maximum of--- (3, 2, 1) = 3@ seconds:------ @--- main = S.'drain' . 'asyncly' $ delay 3 '<>' delay 2 '<>' delay 1--- @--- @--- ThreadId 42: Delay 1--- ThreadId 41: Delay 2--- ThreadId 40: Delay 3--- @------ When we have a tree of computations composed using this style, the tree is--- traversed in DFS style just like the 'Serial' style, the only difference is--- that here we can move on to executing the next stream if a stream blocks.--- However, we will not start new threads if we have sufficient output to--- saturate the consumer.  This is why we call it left-biased demand driven or--- adaptive concurrency style, the concurrency tends to stay on the left side--- of the composition as long as possible. More threads are started based on--- the pull rate of the consumer. The following example prints an output every--- second as all of the actions are concurrent.------ @--- main = S.'drain' . 'asyncly' $ (delay 1 <> delay 2) <> (delay 3 <> delay 4)--- @--- @--- 1--- 2--- 3--- 4--- @------ All the computations may even run in a single thread when more threads are--- not needed. As you can see, in the following example the computations are--- run in a single thread one after another, because none of them blocks.--- However, if the thread consuming the stream were faster than the producer--- then it would have started parallel threads for each computation to keep up--- even if none of them blocks:------ @--- main = S.'drain' . 'asyncly' $ traced (sqrt 9) '<>' traced (sqrt 16) '<>' traced (sqrt 25)---  where traced m = S.'yieldM' (myThreadId >>= print) >> return m--- @--- @--- ThreadId 40--- ThreadId 40--- ThreadId 40--- @------ Note that the order of printing in the above examples may change due to--- variations in scheduling latencies for concurrent threads.------ The polymorphic version of the 'Async' binary operation '<>' is called--- 'async'. We can use 'async' to join streams in a left biased--- adaptively concurrent manner irrespective of the type, notice that we have--- not used the 'asyncly' combinator in the following example:------ @--- main = S.'drain' $ delay 3 \`async` delay 2 \`async` delay 1--- @--- @--- ThreadId 42: Delay 1--- ThreadId 41: Delay 2--- ThreadId 40: Delay 3--- @------ Since the concurrency provided by this operator is demand driven it cannot--- be used when the composed computations start timers that are relative to--- each other because all computations may not be started at the same time and--- therefore timers in all of them may not start at the same time.  When--- relative timing among all computations is important or when we need to start--- all computations at once for any reason 'Parallel' style must be used--- instead.------ 'Async' style utilizes resources optimally and should be preferred over--- 'Parallel' or 'WAsync' unless you really need those. 'Async' should be used--- when we know that the computations can run in parallel but we do not care if--- they actually run in parallel or not, that decision can be left to the--- scheduler based on demand. Also, note that 'async' operator can be used to fold--- infinite number of streams in contrast to the 'Parallel' or 'WAsync' styles,--- because it does not require us to run all of them at the same time in a fair--- manner.---- $wasync------ The 'Semigroup' operation '<>' of the 'WAsync' type combines two streams in--- a concurrent manner using /breadth first traversal/. We use the 'wAsyncly'--- type combinator to effect 'WAsync' style of composition. We can also use the--- 'WAsync' type annotation for the stream to achieve the same effect.------ When streams with multiple elements are combined in this manner, we traverse--- all the streams concurrently in a breadth first manner i.e. one action from--- each stream is performed and yielded to the resulting stream before we come--- back to the first stream again and so on. Even though we execute the actions--- in a breadth first order the outputs are consumed on a first come first--- serve basis.------ In the following example we can see that outputs are produced in the breadth--- first traversal order but this is not guaranteed.------ @--- main = S.'drain' . 'wAsyncly' $ (serially $ print 1 |: print 2 |: nil) <> (serially $ print 3 |: print 4 |: nil)--- @--- @--- 1--- 3--- 2--- 4--- @------ The polymorphic version of the binary operation '<>' of the 'WAsync' type is--- 'wAsync'.  We can use 'wAsync' to join streams using a breadth first--- concurrent traversal irrespective of the type, notice that we have not used--- the 'wAsyncly' combinator in the following example:------ @--- main = S.'drain' $ delay 3 \`wAsync` delay 2 \`wAsync` delay 1--- @--- @--- ThreadId 42: Delay 1--- ThreadId 41: Delay 2--- ThreadId 40: Delay 3--- @------ Since the concurrency provided by this style is demand driven it may not--- be used when the composed computations start timers that are relative to--- each other because all computations may not be started at the same time and--- therefore timers in all of them may not start at the same time.  When--- relative timing among all computations is important or when we need to start--- all computations at once for any reason 'Parallel' style must be used--- instead.------- $parallel------ The 'Semigroup' operation '<>' of the 'Parallel' type combines the two--- streams in a fairly concurrent manner with round robin scheduling. We use--- the 'parallely' type combinator to effect 'Parallel' style of composition.--- We can also use the 'Parallel' type annotation for the stream type to--- achieve the same effect.------ When two streams with multiple elements are combined in this manner, the--- monadic actions in both the streams are performed concurrently with a fair--- round robin scheduling.  The outputs are yielded in the order in which the--- actions complete. This is pretty similar to the 'WAsync' type, the--- difference is that 'WAsync' is adaptive to the consumer demand and may or--- may not execute all actions in parallel depending on the demand, whereas--- 'Parallel' runs all the streams in parallel irrespective of the demand.------ The following example sends a query to all the three search engines in--- parallel and prints the name of the search engines in the order in which the--- responses arrive. You need the [http-conduit](http://hackage.haskell.org/package/http-conduit)--- package to run this example:------ @--- import "Streamly"--- import qualified Streamly.Prelude as S--- import Network.HTTP.Simple------ main = S.'drain' . 'parallely' $ google \<> bing \<> duckduckgo---     where---         google     = get "https://www.google.com/search?q=haskell"---         bing       = get "https://www.bing.com/search?q=haskell"---         duckduckgo = get "https://www.duckduckgo.com/?q=haskell"---         get s = S.'yieldM' (httpNoBody (parseRequest_ s) >> putStrLn (show s))--- @------ The polymorphic version of the binary operation '<>' of the 'Parallel' type--- is 'parallel'. We can use 'parallel' to join streams in a fairly concurrent--- manner irrespective of the type, notice that we have not used the--- 'parallely' combinator in the following example:------ @--- main = S.'drain' $ delay 3 \`parallel` delay 2 \`wAsync` delay 1--- @--- @--- ThreadId 42: Delay 1--- ThreadId 41: Delay 2--- ThreadId 40: Delay 3--- @------ Note that this style of composition cannot be used to combine infinite--- number of streams, as it will lead to an infinite sized scheduling queue.------- XXX to be removed--- $custom------ The 'mkAsync' API can be used to create references to asynchronously running--- stream computations. We can then use 'uncons' to explore the streams--- arbitrarily and then recompose individual elements to create a new stream.--- This way we can dynamically decide which stream to explore at any given--- time.  Take an example of a merge sort of two sorted streams. We need to--- keep consuming items from the stream which has the lowest item in the sort--- order.  This can be achieved using async references to streams. See--- "MergeSort.hs" in the examples directory.---- $monoid------ We can use 'Monoid' instances to fold a container of streams in the desired--- style using 'fold' or 'foldMap'.  We have also provided some fold utilities--- to fold streams using the polymorphic combine operations:------ * 'foldWith' is like 'fold', it folds a 'Foldable' container of streams--- using the given composition operator.--- * 'foldMapWith' is like 'foldMap', it folds like @foldWith@ but also maps a--- function before folding.--- * 'forEachWith' is like @foldMapwith@ but the container argument comes before--- the function argument.------ All of the following are equivalent and start ten concurrent tasks each with--- a delay from 1 to 10 seconds, resulting in the printing of each number every--- second:------ @--- import "Streamly"--- import qualified "Streamly.Prelude" as S--- import Control.Concurrent------ main = do---  S.'drain' $ 'asyncly' $ foldMap delay [1..10]---  S.'drain' $ S.'foldWith'    'async' (map delay [1..10])---  S.'drain' $ S.'foldMapWith' 'async' delay [1..10]---  S.'drain' $ S.'forEachWith' 'async' [1..10] delay---  where delay n = S.'yieldM' $ threadDelay (n * 1000000) >> print n--- @---- $nesting------ Till now we discussed ways to apply transformations on a stream or to merge--- streams together to create another stream. We mentioned earlier that--- transforming a stream is similar to a @for@ loop in the imperative paradigm.--- We will now discuss the concept of a nested composition of streams which is--- analogous to nested @for@ loops in the imperative paradigm. Functional--- programmers call this style of composition a list transformer or @ListT@.--- Logic programmers call it a logic monad or non-deterministic composition,--- but for ordinary imperative minded people like me it is easier to think in--- terms of good old nested @for@ loops.------ $monad------ In functional programmer's parlance the 'Monad' instances of different--- 'IsStream' types implement non-determinism, exploring all possible--- combination of choices from both the streams. From an imperative--- programmer's point of view it behaves like nested loops i.e.  for each--- element in the first stream and for each element in the second stream--- execute the body of the loop.------ The 'Monad' instances of 'Serial', 'WSerial', 'Async' and 'WAsync'--- stream types support different flavors of nested looping.  In other words,--- they are all variants of list transformer.  The nesting behavior of these--- types correspond exactly to the way they merge streams as we discussed in--- the previous section.------- $regularSerial------ The 'Monad' composition of the 'Serial' type behaves like a standard list--- transformer. This is the default when we do not use an explicit type--- combinator. However, the 'serially' type combinator can be used to switch to--- this style of composition. We will see how this style of composition works--- in the following examples.------ Let's start with an example with a simple @for@ loop without any nesting.--- For simplicity of illustration we are using streams of pure values in all--- the examples.  However, the streams could also be made of monadic actions--- instead.------ @--- import "Streamly"--- import qualified "Streamly.Prelude" as S------ main = S.'drain' $ do---     x <- S.'fromFoldable' [3,2,1]---     delay x--- @--- @--- ThreadId 30: Delay 3--- ThreadId 30: Delay 2--- ThreadId 30: Delay 1--- @------ As we can see, the code after the @fromFoldable@ statement is run three--- times, once for each value of @x@ drawn from the stream. All the three--- iterations are serial and run in the same thread one after another. In--- imperative terms this is equivalent to a @for@ loop with three iterations.------ A console echo loop copying standard input to standard output can simply be--- written like this:------ @--- import "Streamly"--- import qualified "Streamly.Prelude" as S------ import Control.Monad (forever)------ main = S.'drain' $ forever $ S.yieldM getLine >>= S.yieldM . putStrLn--- @------ When multiple streams are composed using this style they nest in a DFS--- manner i.e. nested iterations of a loop are executed before we proceed to--- the next iteration of the parent loop. This behaves just like nested @for@--- loops in imperative programming.------ @--- import "Streamly"--- import qualified "Streamly.Prelude" as S------ main = S.'drain' $ do---     x <- S.'fromFoldable' [1,2]---     y <- S.'fromFoldable' [3,4]---     S.'yieldM' $ putStrLn $ show (x, y)--- @--- @--- (1,3)--- (1,4)--- (2,3)--- (2,4)--- @------ Notice that this is analogous to merging streams of type 'Serial' or merging--- streams using 'serial'.---- $aheadNesting------ The 'Monad' composition of 'Ahead' type behaves just like 'Serial' except--- that it can speculatively perform a bounded number of next iterations of a--- loop concurrently.------ The 'aheadly' type combinator can be used to switch to this style of--- composition. Alternatively, a type annotation can be used to specify the--- type of the stream as 'Ahead'.------ @--- import "Streamly"--- import qualified "Streamly.Prelude" as S------ comp = S.'toList' . 'aheadly' $ do---     x <- S.'fromFoldable' [3,2,1]---     delay x >> return x------ main = comp >>= print--- @--- @--- ThreadId 40: Delay 1--- ThreadId 39: Delay 2--- ThreadId 38: Delay 3--- [3,2,1]--- @------ This code finishes in 3 seconds, 'Serial' would take 6 seconds.  As we can--- see all the three iterations are concurrent and run in different threads,--- however, the results are returned in the serial order.------ Concurrency is demand driven, when multiple streams are composed using this--- style, the iterations are executed in a depth first manner just like--- 'Serial' i.e. nested iterations are executed before we proceed to the next--- outer iteration. The only difference is that we may execute multiple future--- iterations concurrently and keep the results ready.------- $concurrentNesting------ The 'Monad' composition of 'Async' type can perform the iterations of a--- loop concurrently.  Concurrency is demand driven i.e. more concurrent--- iterations are started only if the previous iterations are not able to--- produce enough output for the consumer of the output stream.  This works--- exactly the same way as the merging of two streams 'asyncly' works.--- This is the concurrent analogue of 'Serial' style monadic composition.------ The 'asyncly' type combinator can be used to switch to this style of--- composition. Alternatively, a type annotation can be used to specify the--- type of the stream as 'Async'.------ @--- import "Streamly"--- import qualified "Streamly.Prelude" as S------ main = S.'drain' . 'asyncly' $ do---     x <- S.'fromFoldable' [3,2,1]---     delay x--- @--- @--- ThreadId 40: Delay 1--- ThreadId 39: Delay 2--- ThreadId 38: Delay 3--- @------ As we can see the code after the @fromFoldable@ statement is run three--- times, once for each value of @x@. All the three iterations are concurrent--- and run in different threads. The iteration with least delay finishes first.--- When compared to imperative programming, this can be viewed as a @for@ loop--- with three concurrent iterations.------ Concurrency is demand driven just as in the case of 'async' merging.--- When multiple streams are composed using this style, the iterations are--- triggered in a depth first manner just like 'Serial' i.e. nested iterations are--- executed before we proceed to the next iteration at higher level. However,--- unlike 'Serial' more than one iterations may be started concurrently based--- on the demand from the consumer of the stream.------ @--- import "Streamly"--- import qualified "Streamly.Prelude" as S------ main = S.'drain' . 'asyncly' $ do---     x <- S.'fromFoldable' [1,2]---     y <- S.'fromFoldable' [3,4]---     S.'yieldM' $ putStrLn $ show (x, y)--- @--- @--- (1,3)--- (1,4)--- (2,3)--- (2,4)--- @---- $interleavedNesting------ The 'Monad' composition of 'WSerial' type interleaves the iterations of--- outer and inner loops in a nested loop composition. This works exactly the--- same way as the merging of two streams in 'wSerially' fashion works.  The--- 'wSerially' type combinator can be used to switch to this style of--- composition. Alternatively, a type annotation can be used to specify the--- type of the stream as 'WSerial'.------ @--- import "Streamly"--- import qualified "Streamly.Prelude" as S------ main = S.'drain' . 'wSerially' $ do---     x <- S.'fromFoldable' [1,2]---     y <- S.'fromFoldable' [3,4]---     S.yieldM $ putStrLn $ show (x, y)--- @--- @--- (1,3)--- (2,3)--- (1,4)--- (2,4)--- @------- $wasyncNesting------ Just like 'Async' the 'Monad' composition of 'WAsync' runs the iterations of--- a loop concurrently. The difference is in the nested loop behavior. The--- nested loops in this type are traversed and executed in a breadth first--- manner rather than the depth first manner of 'Async' style.--- The loop nesting works exactly the same way as the merging of streams--- 'wAsyncly' works.  The 'wAsyncly' type combinator can be used to switch to--- this style of composition. Alternatively, a type annotation can be used to--- specify the type of the stream as 'WAsync'.------ @--- import "Streamly"--- import qualified "Streamly.Prelude" as S------ main = S.'drain' . 'wAsyncly' $ do---     x <- S.'fromFoldable' [1,2]---     y <- S.'fromFoldable' [3,4]---     S.'yieldM' $ putStrLn $ show (x, y)--- @--- @--- (1,3)--- (2,3)--- (1,4)--- (2,4)--- @---- $parallelNesting------ Just like 'Async' or 'WAsync' the 'Monad' composition of 'Parallel' runs the--- iterations of a loop concurrently. The difference is in the nested loop--- behavior. The streams at each nest level is run fully concurrently--- irrespective of the demand.  The loop nesting works exactly the same way as--- the merging of streams 'parallely' works.  The 'parallely' type combinator--- can be used to switch to this style of composition. Alternatively, a type--- annotation can be used to specify the type of the stream as 'Parallel'.------ @--- import "Streamly"--- import qualified "Streamly.Prelude" as S------ main = S.'drain' . 'parallely' $ do---     x <- S.'fromFoldable' [3,2,1]---     delay x--- @--- @--- ThreadId 40: Delay 1--- ThreadId 39: Delay 2--- ThreadId 38: Delay 3--- @---- $monadExercise------ Streamly code is usually written in a way that is agnostic of the--- specific monadic composition type. We use a polymorphic type with a--- 'IsStream' type class constraint. When running the stream we can choose the--- specific mode of composition. For example take a look at the following code.------ @--- import "Streamly"--- import qualified "Streamly.Prelude" as S------ composed :: (IsStream t, Monad (t IO)) => t IO ()--- composed = do---     sz <- sizes---     cl <- colors---     sh <- shapes---     S.'yieldM' $ putStrLn $ show (sz, cl, sh)------     where------     sizes  = S.'fromFoldable' [1, 2, 3]---     colors = S.'fromFoldable' ["red", "green", "blue"]---     shapes = S.'fromFoldable' ["triangle", "square", "circle"]--- @------ Now we can interpret this in whatever way we want:------ @--- main = S.'drain' . 'serially'  $ composed--- main = S.'drain' . 'wSerially' $ composed--- main = S.'drain' . 'asyncly'   $ composed--- main = S.'drain' . 'wAsyncly'  $ composed--- main = S.'drain' . 'parallely' $ composed--- @------  As an exercise try to figure out the output of this code for each mode of---  composition.---- $functor------ 'fmap' transforms a stream by mapping a function on all elements of the--- stream. 'fmap' behaves in the same way for all stream types, it is always--- serial.------ @--- import "Streamly"--- import qualified "Streamly.Prelude" as S------ main = (S.'toList' $ fmap show $ S.'fromFoldable' [1..10]) >>= print--- @------ Also see the 'mapM' and 'sequence' functions for mapping actions, in the--- "Streamly.Prelude" module.---- $applicative------ Applicative is precisely the same as the 'ap' operation of 'Monad'. For--- zipping applicatives separate types 'ZipSerial' and 'ZipAsync' are--- provided.------ The following example uses the 'Serial' applicative, it runs all iterations--- serially and takes a total 17 seconds (1 + 3 + 4 + 2 + 3 + 4):------ @--- import "Streamly"--- import qualified "Streamly.Prelude" as S--- import Control.Concurrent------ s1 = d 1 <> d 2--- s2 = d 3 <> d 4--- d n = delay n >> return n------ main = (S.'toList' . 'serially' $ (,) \<$> s1 \<*> s2) >>= print--- @--- @--- ThreadId 36: Delay 1--- ThreadId 36: Delay 3--- ThreadId 36: Delay 4--- ThreadId 36: Delay 2--- ThreadId 36: Delay 3--- ThreadId 36: Delay 4--- [(1,3),(1,4),(2,3),(2,4)]--- @------ Similarly 'WSerial' applicative runs the iterations in an interleaved--- order but since it is serial it takes a total of 17 seconds:------ @--- main = (S.'toList' . 'wSerially' $ (,) \<$> s1 \<*> s2) >>= print--- @--- @--- ThreadId 36: Delay 1--- ThreadId 36: Delay 3--- ThreadId 36: Delay 2--- ThreadId 36: Delay 3--- ThreadId 36: Delay 4--- ThreadId 36: Delay 4--- [(1,3),(2,3),(1,4),(2,4)]--- @------ 'Async' can run the iterations concurrently and therefore takes a total--- of 6 seconds which is max (1, 2) + max (3, 4):------ @--- main = (S.'toList' . 'asyncly' $ (,) \<$> s1 \<*> s2) >>= print--- @--- @--- ThreadId 34: Delay 1--- ThreadId 36: Delay 2--- ThreadId 35: Delay 3--- ThreadId 36: Delay 3--- ThreadId 35: Delay 4--- ThreadId 36: Delay 4--- [(1,3),(2,3),(1,4),(2,4)]--- @------ Similarly 'WAsync' as well can run the iterations concurrently and--- therefore takes a total of 6 seconds (2 + 4):------ @--- main = (S.'toList' . 'wAsyncly' $ (,) \<$> s1 \<*> s2) >>= print--- @--- @--- ThreadId 34: Delay 1--- ThreadId 36: Delay 2--- ThreadId 35: Delay 3--- ThreadId 36: Delay 3--- ThreadId 35: Delay 4--- ThreadId 36: Delay 4--- [(1,3),(2,3),(1,4),(2,4)]--- @---- $zipping------ Zipping is a special transformation where the corresponding elements of two--- streams are combined together using a zip function producing a new stream of--- outputs. Two different types are provided for serial and concurrent zipping.--- These types provide an applicative instance that can be used to lift--- functions to zip the argument streams.--- Also see the zipping functions in the "Streamly.Prelude" module.---- $serialzip------ The applicative instance of 'ZipSerial' type zips streams serially.--- 'zipSerially' type combinator can be used to switch to serial applicative--- zip composition:------ @--- import "Streamly"--- import qualified "Streamly.Prelude" as S--- import Control.Concurrent------ d n = delay n >> return n--- s1 = 'serially' $ d 1 <> d 2--- s2 = 'serially' $ d 3 <> d 4------ main = (S.'toList' . 'zipSerially' $ (,) \<$> s1 \<*> s2) >>= print--- @------ This takes total 10 seconds to zip, which is (1 + 2 + 3 + 4) since--- everything runs serially:------ @--- ThreadId 29: Delay 1--- ThreadId 29: Delay 3--- ThreadId 29: Delay 2--- ThreadId 29: Delay 4--- [(1,3),(2,4)]--- @---- $parallelzip------ The applicative instance of 'ZipAsync' type zips streams concurrently.--- 'zipAsyncly' type combinator can be used to switch to parallel applicative--- zip composition:--------- @--- import "Streamly"--- import qualified "Streamly.Prelude" as S--- import Control.Concurrent--- import System.IO (stdout, hSetBuffering, BufferMode(LineBuffering))------ d n = delay n >> return n--- s1 = 'serially' $ d 1 <> d 2--- s2 = 'serially' $ d 3 <> d 4------ main = do---     hSetBuffering stdout LineBuffering---     (S.'toList' . 'zipAsyncly' $ (,) \<$> s1 \<*> s2) >>= print--- @------ This takes 7 seconds to zip, which is max (1,3) + max (2,4) because 1 and 3--- are produced concurrently, and 2 and 4 are produced concurrently:------ @--- ThreadId 32: Delay 1--- ThreadId 32: Delay 2--- ThreadId 33: Delay 3--- ThreadId 33: Delay 4--- [(1,3),(2,4)]--- @---- $concurrent------ When writing concurrent programs there are two distinct places where the--- programmer can control the concurrency. First, when /composing/ a stream by--- merging multiple streams we can choose an appropriate sum style operators to--- combine them concurrently or serially. Second, when /processing/ a stream in--- a monadic composition we can choose one of the monad composition types to--- choose the desired type of concurrency.------ In the following example the squares of @x@ and @y@ are computed--- concurrently using the 'async' operation and the square roots of their--- sum are computed serially because of the 'streamly' combinator. We can--- choose different combinators for the monadic processing and the stream--- generation, to control the concurrency.  We can also use the 'asyncly'--- combinator instead of explicitly folding with 'async'.------ @--- import "Streamly"--- import qualified "Streamly.Prelude" as S--- import Data.List (sum)------ main = do---     z \<-   S.'toList'---          $ 'serially'     -- Serial monadic processing (sqrt below)---          $ do---              x2 \<- 'forEachWith' 'async' [1..100] $ -- Concurrent @"for"@ loop---                          \\x -> return $ x * x  -- body of the loop---              y2 \<- 'forEachWith' 'async' [1..100] $---                          \\y -> return $ y * y---              return $ sqrt (x2 + y2)---     print $ sum z--- @------ We can see how this directly maps to the imperative style--- <https://en.wikipedia.org/wiki/OpenMP OpenMP> model, we use combinators--- and operators instead of the ugly pragmas.------ For more concurrent programming examples see,--- <examples/ListDir.hs ListDir.hs>,--- <examples/MergeSort.hs MergeSort.hs> and--- <examples/SearchQuery.hs SearchQuery.hs> in the examples directory.---- $reactive------ Reactive programming is nothing but concurrent streaming which is what--- streamly is all about. With streamly we can generate streams of events,--- merge streams that are generated concurrently and process events--- concurrently. We can do all this without any knowledge about the specifics--- of the implementation of concurrency. In the following example you will see--- that the code is just regular Haskell code without much streamly APIs used--- (active hyperlinks are the streamly APIs) and yet it is a reactive--- application.------ This application has two independent and concurrent sources of event--- streams, @acidRain@ and @userAction@. @acidRain@ continuously generates--- events that deteriorate the health of the character in the game.--- @userAction@ can be "potion" or "quit". When the user types "potion" the--- health improves and the game continues.------ @--- {-\# LANGUAGE FlexibleContexts #-}------ import "Streamly"--- import "Streamly.Prelude" as S--- import Control.Monad (void, when)--- import Control.Monad.IO.Class (MonadIO(liftIO))--- import Control.Monad.State (MonadState, get, modify, runStateT, put)------ data Event = Quit | Harm Int | Heal Int deriving (Show)------ userAction :: MonadAsync m => 'SerialT' m Event--- userAction = S.'repeatM' $ liftIO askUser---     where---     askUser = do---         command <- getLine---         case command of---             "potion" -> return (Heal 10)---             "harm"   -> return (Harm 10)---             "quit"   -> return Quit---             _        -> putStrLn "Type potion or harm or quit" >> askUser------ acidRain :: MonadAsync m => 'SerialT' m Event--- acidRain = 'asyncly' $ 'constRate' 1 $ S.'repeatM' $ liftIO $ return $ Harm 1------ data Result = Check | Done------ runEvents :: (MonadAsync m, MonadState Int m) => 'SerialT' m Result--- runEvents = do---     event \<- userAction \`parallel` acidRain---     case event of---         Harm n -> modify (\\h -> h - n) >> return Check---         Heal n -> modify (\\h -> h + n) >> return Check---         Quit -> return Done------ data Status = Alive | GameOver deriving Eq------ getStatus :: (MonadAsync m, MonadState Int m) => Result -> m Status--- getStatus result =---     case result of---         Done  -> liftIO $ putStrLn "You quit!" >> return GameOver---         Check -> do---             h <- get---             liftIO $ if (h <= 0)---                      then putStrLn "You die!" >> return GameOver---                      else putStrLn ("Health = " <> show h) >> return Alive------ main :: IO ()--- main = do---     putStrLn "Your health is deteriorating due to acid rain,\\---              \\ type \\"potion\\" or \\"quit\\""---     let runGame = S.'drainWhile' (== Alive) $ S.'mapM' getStatus runEvents---     void $ runStateT runGame 60--- @------ You can also find the source of this example in the examples directory as--- <examples/AcidRain.hs AcidRain.hs>. It has been adapted from Gabriel's--- <https://hackage.haskell.org/package/pipes-concurrency-2.0.8/docs/Pipes-Concurrent-Tutorial.html pipes-concurrency>--- package.--- This is much simpler compared to the pipes version because of the builtin--- concurrency in streamly. You can also find a SDL based reactive programming--- example adapted from Yampa in--- <examples/CirclingSquare.hs CirclingSquare.hs>.---- $performance------ Streamly is highly optimized for performance, it is designed for serious--- high performing, concurrent and scalable applications. We have created the--- <https://hackage.haskell.org/package/streaming-benchmarks streaming-benchmarks>--- package which is specifically and carefully designed to measure the--- performance of Haskell streaming libraries fairly and squarely in the right--- way. Streamly performs at par or even better than most streaming libraries--- for serial operations even though it needs to deal with the concurrency--- capability.---- $interop------ We can use @unfoldr@ and @uncons@ to convert one streaming type to another.------  Interop with @vector@:------ @--- import Streamly--- import qualified Streamly.Prelude as S--- import qualified Data.Vector.Fusion.Stream.Monadic as V------ -- | vector to streamly--- fromVector :: (IsStream t, Monad m) => V.Stream m a -> t m a--- fromVector = S.unfoldrM unconsV---     where---     unconsV v = do---         r <- V.null v---         if r---         then return Nothing---         else do---             h <- V.head v---             return $ Just (h, V.tail v)------ -- | streamly to vector--- toVector :: Monad m => SerialT m a -> V.Stream m a--- toVector = V.unfoldrM (S.uncons . adapt)------ main = do---     S.toList (fromVector (V.fromList [1..3]))   >>= print---     V.toList (toVector (S.fromFoldable [1..3])) >>= print--- @------  Interop with @pipes@:------ @--- import "Streamly"--- import qualified "Streamly.Prelude" as S--- import qualified Pipes as P--- import qualified Pipes.Prelude as P------ -- | pipes to streamly--- fromPipes :: (IsStream t, Monad m) => P.Producer a m r -> t m a--- fromPipes = S.'unfoldrM' unconsP---     where---     -- Adapt P.next to return a Maybe instead of Either---     unconsP p = P.next p >>= either (\\_ -> return Nothing) (return . Just)------ -- | streamly to pipes--- toPipes :: Monad m => SerialT m a -> P.Producer a m ()--- toPipes = P.unfoldr unconsS---     where---     -- Adapt S.uncons to return an Either instead of Maybe---     unconsS s = S.'uncons' s >>= maybe (return $ Left ()) (return . Right)------ main = do---     S.'toList' (fromPipes (P.each [1..3])) >>= print---     P.toListM (toPipes (S.'fromFoldable' [1..3])) >>= print--- @------ Interop with @streaming@:------ @--- import "Streamly"--- import qualified "Streamly.Prelude" as S--- import qualified Streaming as SG--- import qualified Streaming.Prelude as SG------ -- | streaming to streamly--- fromStreaming :: (IsStream t, MonadAsync m) => SG.Stream (SG.Of a) m r -> t m a--- fromStreaming = S.unfoldrM SG.uncons------ -- | streamly to streaming--- toStreaming :: Monad m => SerialT m a -> SG.Stream (SG.Of a) m ()--- toStreaming = SG.unfoldr unconsS---     where---     -- Adapt S.uncons to return an Either instead of Maybe---     unconsS s = S.'uncons' s >>= maybe (return $ Left ()) (return . Right)------ main = do---     S.toList (fromStreaming (SG.each [1..3])) >>= print---     SG.toList (toStreaming (S.fromFoldable [1..3])) >>= print--- @------ Interop with @conduit@:------ @--- import "Streamly"--- import qualified "Streamly.Prelude" as S--- import qualified Data.Conduit as C--- import qualified Data.Conduit.List as C--- import qualified Data.Conduit.Combinators as C------ -- It seems there is no way out of a conduit as it does not provide an--- -- uncons or a tail function. We can convert streamly to conduit though.------ -- | streamly to conduit--- toConduit :: Monad m => SerialT m a -> C.ConduitT i a m ()--- toConduit s = C.unfoldM S.'uncons' s------ main = do---  C.runConduit (toConduit (S.'fromFoldable' [1..3]) C..| C.sinkList) >>= print--- @---- $comparison------ List transformers and logic programming monads also provide a product style--- composition similar to streamly, however streamly generalizes it with the--- time dimension; allowing streams to be composed in an asynchronous and--- concurrent fashion in many different ways.  It also provides multiple--- alternative ways of composing streams e.g.  serial, interleaved or--- concurrent.------ This seemingly simple addition of asynchronicity and concurrency to product--- style streaming composition unifies a number of disparate abstractions into--- one powerful, concise and elegant abstraction.  A wide variety of--- programming problems can be solved elegantly with this abstraction. In--- particular, it unifies three major programming domains namely--- non-deterministic (logic) programming, concurrent programming and functional--- reactive programming. In other words, you can do everything with this one--- abstraction that you could do with the popular libraries listed under these--- categories in the list below.------ @--- +-----------------+----------------+--- | Non-determinism | <https://hackage.haskell.org/package/pipes pipes>          |--- |                 +----------------+--- |                 | <https://hackage.haskell.org/package/list-t list-t>         |--- |                 +----------------+--- |                 | <https://hackage.haskell.org/package/logict logict>         |--- +-----------------+----------------+--- | Streaming       | <https://hackage.haskell.org/package/vector vector>         |--- |                 +----------------+--- |                 | <https://hackage.haskell.org/package/streaming streaming>      |--- |                 +----------------+--- |                 | <https://hackage.haskell.org/package/pipes pipes>          |--- |                 +----------------+--- |                 | <https://hackage.haskell.org/package/conduit conduit>        |--- +-----------------+----------------+--- | Concurrency     | <https://hackage.haskell.org/package/async async>          |--- |                 +----------------+--- |                 | <https://hackage.haskell.org/package/transient transient>      |--- +-----------------+----------------+--- | FRP             | <https://hackage.haskell.org/package/Yampa Yampa>          |--- |                 +----------------+--- |                 | <https://hackage.haskell.org/package/dunai dunai>          |--- |                 +----------------+--- |                 | <https://hackage.haskell.org/package/reflex reflex>         |--- +-----------------+----------------+--- @------ Streamly is a list-transformer. It provides all the functionality provided--- by any of the list transformer and logic programming packages listed above.--- In addition, Streamly naturally integrates the concurrency dimension to the--- basic list transformer functionality.------ When it comes to streaming, in terms of the streaming API streamly is almost--- identical to the vector package. Streamly, vector and streaming packages all--- represent a stream as data and are therefore similar in the fundamental--- approach to streaming. The fundamental difference is that streamly adds--- concurrency support and the monad instance provides concurrent looping.--- Other streaming libraries like pipes, conduit and machines represent and--- compose stream processors rather than the stream data and therefore fall in--- another class of streaming libraries and have comparatively more complicated--- types.------ When it comes to concurrency, streamly can do everything that the @async@--- package can do and more. async provides applicative concurrency whereas--- streamly provides both applicative and monadic concurrency. The--- 'ZipAsync' type behaves like the applicative instance of async.  In--- comparison to transient streamly has a first class streaming interface and--- is a monad transformer that can be used universally in any Haskell monad--- transformer stack.  Streamly was in fact originally inspired by the--- concurrency implementation in @transient@ though it has no resemblance with--- that and takes a lazy pull approach versus transient's strict push approach.------ The non-determinism, concurrency and streaming combination make streamly a--- strong reactive programming library as well. Reactive programming is--- fundamentally stream of events that can be processed concurrently. The--- example in this tutorial as well as the--- <examples/CirclingSquare.hs CirclingSquare> example from Yampa demonstrate--- the basic reactive capability of streamly. In core concepts streamly is--- strikingly similar to @dunai@.  dunai was designed from a FRP perspective--- and streamly was originally designed from a concurrency perspective.--- However, both have similarity at the core.---- $furtherReading------ * Read the documentation of "Streamly" module--- * Read the documentation of "Streamly.Prelude" module--- * See the examples in the "examples" directory of the package--- * See the tests in the "test" directory of the package
+ src/Streamly/Unicode/Stream.hs view
@@ -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.Foreign.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.Prelude.fromList'.  An @Array+-- Char@ can be 'Streamly.Prelude.unfold'ed into a stream using the array+-- 'Streamly.Data.Array.Foreign.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.Prelude.toList' or using the+-- '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.Prelude.fold' the 'Char'+-- stream as @Array Char@ using the array 'Streamly.Data.Array.Foreign.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+--+-- @SerialT 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.Char".++-- 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'++    -- * 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)
+ src/config.h.in view
@@ -0,0 +1,79 @@+/* 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 declaration of `IN_EXCL_UNLINK', and to 0 if+   you don't. */+#undef HAVE_DECL_IN_EXCL_UNLINK++/* Define to 1 if you have the declaration of `IN_MASK_CREATE', and to 0 if+   you don't. */+#undef HAVE_DECL_IN_MASK_CREATE++/* Define to 1 if you have the declaration of+   `kFSEventStreamCreateFlagFileEvents', and to 0 if you don't. */+#undef HAVE_DECL_KFSEVENTSTREAMCREATEFLAGFILEEVENTS++/* Define to 1 if you have the declaration of+   `kFSEventStreamCreateFlagFullHistory', and to 0 if you don't. */+#undef HAVE_DECL_KFSEVENTSTREAMCREATEFLAGFULLHISTORY++/* Define to 1 if you have the declaration of+   `kFSEventStreamEventFlagItemCloned', and to 0 if you don't. */+#undef HAVE_DECL_KFSEVENTSTREAMEVENTFLAGITEMCLONED++/* Define to 1 if you have the declaration of+   `kFSEventStreamEventFlagItemIsHardlink', and to 0 if you don't. */+#undef HAVE_DECL_KFSEVENTSTREAMEVENTFLAGITEMISHARDLINK++/* Define to 1 if you have the <inttypes.h> header file. */+#undef HAVE_INTTYPES_H++/* Define to 1 if you have the <memory.h> header file. */+#undef HAVE_MEMORY_H++/* Define to 1 if you have the <stdint.h> header file. */+#undef HAVE_STDINT_H++/* Define to 1 if you have the <stdlib.h> header file. */+#undef HAVE_STDLIB_H++/* Define to 1 if you have the <strings.h> header file. */+#undef HAVE_STRINGS_H++/* Define to 1 if you have the <string.h> header file. */+#undef HAVE_STRING_H++/* Define to 1 if you have the <sys/stat.h> header file. */+#undef HAVE_SYS_STAT_H++/* Define to 1 if you have the <sys/types.h> header file. */+#undef HAVE_SYS_TYPES_H++/* Define to 1 if you have the <time.h> header file. */+#undef HAVE_TIME_H++/* Define to 1 if you have the <unistd.h> 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 you have the ANSI C header files. */+#undef STDC_HEADERS
− stack.yaml 
@@ -1,19 +0,0 @@-resolver: lts-14.25-packages:-- '.'-extra-deps:-    - SDL-0.6.6.0-    - Chart-1.9.1-    - Chart-diagrams-1.9.2-    - bench-show-0.2.2-    - inspection-testing-0.4.2.1-    - fusion-plugin-types-0.1.0-    - fusion-plugin-0.2.0--#allow-newer: true-flags: {}-extra-package-dbs: []-rebuild-ghc-options: true-# For mac ports installed SDL library on Mac OS X-extra-include-dirs:-- /opt/local/include
streamly.cabal view
@@ -1,142 +1,146 @@ cabal-version:      2.2 name:               streamly-version:            0.7.3.2-synopsis:           Beautiful Streaming, Concurrent and Reactive Composition+version:            0.8.0+synopsis:           Dataflow programming and declarative concurrency description:-  Streamly is a framework for writing programs in a high level, declarative-  data flow programming paradigm. It provides a simple API, very close to-  standard Haskell lists.  A program is expressed as a composition of data-  processing pipes, generally known as streams.  Streams can be generated,-  merged, chained, mapped, zipped, and consumed concurrently – enabling a high-  level, declarative yet concurrent composition of programs.  Programs can be-  concurrent or non-concurrent without any significant change.  Concurrency is-  auto scaled based on consumption rate.  Programmers do not have to be aware-  of threads, locking or synchronization to write scalable concurrent programs.-  Streamly provides C like performance, orders of magnitude better compared to-  existing streaming libraries.-  .-  Streamly is designed to express the full spectrum of programs with highest-  performance. Do not think that if you are writing a small and simple program-  it may not be for you. It expresses a small "hello world" program with the-  same efficiency, simplicity and elegance as a large scale concurrent-  application. It unifies many different aspects of special purpose libraries-  into a single yet simple framework.-  .-  Streamly covers the functionality provided by Haskell lists as well as the-  functionality provided by streaming libraries like-  <https://hackage.haskell.org/package/streaming streaming>,-  <https://hackage.haskell.org/package/pipes pipes>, and-  <https://hackage.haskell.org/package/conduit conduit> with a simpler API and-  better performance. Streamly provides-  advanced stream composition including various ways of appending, merging,-  zipping, splitting, grouping, distributing, partitioning and unzipping of-  streams with true streaming and with concurrency. Streamly subsumes the-  functionality of list transformer libraries like @pipes@ or-  <https://hackage.haskell.org/package/list-t list-t> and also the logic-  programming library <https://hackage.haskell.org/package/logict logict>.-  The grouping, splitting and windowing combinators in streamly can be compared-  to the window operators in <https://flink.apache.org/ Apache Flink>.-  However, compared to Flink streamly has a pure functional, succinct and-  expressive API.+  Browse the documentation at https://streamly.composewell.com.   .-  The concurrency capabilities of streamly are much more advanced and powerful-  compared to the basic concurrency functionality provided by the-  <https://hackage.haskell.org/package/async async> package.  Streamly is a-  first class reactive programming library.  If you are familiar with-  <http://reactivex.io/ Reactive Extensions> you will find that it is very-  similar.  For most RxJs combinators you can find or write corresponding ones-  in streamly. Streamly can be used as an alternative to-  <https://hackage.haskell.org/package/Yampa Yampa> or-  <https://hackage.haskell.org/package/reflex reflex> as well.+  Streamly is a streaming framework to build reliable and scalable+  software systems from modular building blocks using dataflow+  programming and declarative concurrency.  Stream fusion optimizations+  in streamly result in high-performance, modular combinatorial+  programming.   .-  Streamly focuses on practical engineering with high performance. From well-  written streamly programs one can expect performance competitive to C.  High-  performance streaming eliminates the need for string and text libraries like-  <https://hackage.haskell.org/package/bytestring bytestring>,-  <https://hackage.haskell.org/package/text text> and their lazy and strict-  flavors. The confusion and cognitive overhead arising from different-  string types is eliminated. The two fundamental types in streamly are arrays-  for storage and streams for processing. Strings and text are simply streams-  or arrays of 'Char' as they should be. Arrays in streamly have performance-  at par with the vector library.+  Performance with simplicity:   .-  Where to find more information:+  * Performance on par with C (<https://github.com/composewell/streaming-benchmarks Benchmarks>)+  * API close to standard Haskell lists (<https://github.com/composewell/streamly-examples Examples>)+  * Declarative concurrency with automatic scaling+  * Filesystem, fsnotify, network, and Unicode support included+  * More functionality provided via many ecosystem packages   .-  * /Quick Overview/: <#readme README file> in the package-  * /Building/: <src/docs/Build.md Build guide> for optimal performance-  * /Detailed Tutorial/: "Streamly.Tutorial" module in the haddock documentation-  * /Interoperation/: "Streamly.Tutorial" module for interop with other-    streaming libraries-  * /Reference Documentation/: Haddock documentation for the respective modules-  * /Examples/: <src/examples examples directory> in the package-  * /Guides/: <src/docs docs directory> in the package, for documentation on-    advanced topics, limitations, semantics of the library or on specific use-    cases.-  * <https://github.com/composewell/streaming-benchmarks Streaming Benchmarks>-  * <https://github.com/composewell/concurrency-benchmarks Concurrency Benchmarks>+  Unified and powerful abstractions:   .-+  * Unifies unfolds, arrays, folds, and parsers with streaming+  * Unifies @Data.List@, @list-t@, and @logict@ with streaming+  * Unifies concurrency with standard streaming abstractions+  * Provides time-domain combinators for reactive programming+  * Interworks with bytestring and streaming libraries -homepage:            https://github.com/composewell/streamly+homepage:            https://streamly.composewell.com bug-reports:         https://github.com/composewell/streamly/issues license:             BSD-3-Clause license-file:        LICENSE-tested-with:         GHC==7.10.3-                   , GHC==8.0.2+tested-with:         GHC==8.0.2                    , GHC==8.4.4                    , GHC==8.6.5-                   , GHC==8.8.1-                   , GHC==8.10.1-author:              Harendra Kumar+                   , GHC==8.8.4+                   , GHC==8.10.4+                   , GHC==9.0.1+author:              Composewell Technologies maintainer:          streamly@composewell.com-copyright:           2017 Harendra Kumar-category:            Control, Concurrency, Streaming, Reactivity-stability:           Experimental+copyright:           2017 Composewell Technologies+category:+    Streamly, Concurrency, Streaming, Dataflow, Pipes, Reactivity, List,+    Logic, Non-determinism, Parsing, Array, Time, Unicode, Filesystem,+    Network+stability:           Stable build-type:          Configure  extra-source-files:+    .circleci/config.yml+    .ghci+    .github/workflows/haskell.yml+    .gitignore+    .hlint.ignore+    .hlint.yaml+    CONTRIBUTING.md     Changelog.md+    README.md+    appveyor.yml+    benchmark/*.hs+    benchmark/README.md+    benchmark/bench-report/BenchReport.hs+    benchmark/bench-report/bench-report.cabal+    benchmark/bench-report/cabal.project+    benchmark/bench-report/default.nix+    benchmark/Streamly/Benchmark/Data/*.hs+    benchmark/Streamly/Benchmark/Data/Array/Stream/Foreign.hs+    benchmark/Streamly/Benchmark/Data/Parser/*.hs+    benchmark/Streamly/Benchmark/Data/Stream/*.hs+    benchmark/Streamly/Benchmark/FileSystem/*.hs+    benchmark/Streamly/Benchmark/FileSystem/Handle/*.hs+    benchmark/Streamly/Benchmark/Prelude/*.hs+    benchmark/Streamly/Benchmark/Prelude/Serial/*.hs+    benchmark/Streamly/Benchmark/Unicode/*.hs+    benchmark/lib/Streamly/Benchmark/*.hs+    benchmark/lib/Streamly/Benchmark/Common/*.hs+    benchmark/streamly-benchmarks.cabal+    bin/bench.sh+    bin/bench-exec-one.sh+    bin/build-lib.sh+    bin/ghc.sh+    bin/run-ci.sh+    bin/mk-hscope.sh+    bin/mk-tags.sh+    bin/targets.sh+    bin/test.sh+    configure+    configure.ac     credits/*.md+    credits/Yampa-0.10.6.2.txt     credits/base-4.12.0.0.txt-    credits/primitive-0.7.0.0.txt     credits/bjoern-2008-2009.txt     credits/clock-0.7.2.txt     credits/foldl-1.4.5.txt+    credits/fsnotify-0.3.0.1.txt+    credits/hfsevents-0.1.6.txt     credits/pipes-concurrency-2.0.8.txt+    credits/primitive-0.7.0.0.txt     credits/transient-0.5.5.txt     credits/vector-0.12.0.2.txt-    credits/Yampa-0.10.6.2.txt-    README.md-    docs/streamly-vs-async.md-    docs/streamly-vs-lists.md-    docs/transformers.md-    docs/Build.md-    design/*.md-    design/*.png-    bench.sh-    stack.yaml+    default.nix+    dev/*.md+    dev/*.png+    dev/*.rst+    docs/*.md+    docs/*.hs+    docs/*.svg+    docs/API-changelog.txt+    docs/streamly-docs.cabal+    examples/README.md     src/Streamly/Internal/Data/Stream/Instances.hs+    src/Streamly/Internal/Data/Time/Clock/config-clock.h+    src/Streamly/Internal/Data/Array/PrimInclude.hs+    src/Streamly/Internal/Data/Array/Prim/TypesInclude.hs+    src/Streamly/Internal/Data/Array/Prim/MutTypesInclude.hs+    src/Streamly/Internal/FileSystem/Event/Darwin.h+    src/config.h.in     src/inline.hs-    configure.ac-    configure-    src/Streamly/Internal/Data/Time/config.h.in-    benchmark/streamly-benchmarks.cabal-    benchmark/README.md-    benchmark/*.hs-    benchmark/lib/Streamly/Benchmark/*.hs-    benchmark/Streamly/Benchmark/Memory/*.hs-    benchmark/Streamly/Benchmark/Data/*.hs-    benchmark/Streamly/Benchmark/Data/Prim/*.hs-    benchmark/Streamly/Benchmark/Data/Stream/*.hs-    benchmark/Streamly/Benchmark/FileIO/*.hs-    benchmark/Streamly/Benchmark/Prelude/*.hs-    benchmark/Streamly/Benchmark/Prelude/Serial/*.hs+    test/README.md+    test/Streamly/Test/Common/Array.hs+    test/Streamly/Test/Data/*.hs+    test/Streamly/Test/Data/Array/Prim.hs+    test/Streamly/Test/Data/Array/Prim/Pinned.hs+    test/Streamly/Test/Data/Array/Foreign.hs+    test/Streamly/Test/Data/Parser/ParserD.hs+    test/Streamly/Test/FileSystem/Event.hs+    test/Streamly/Test/FileSystem/Handle.hs+    test/Streamly/Test/Network/Socket.hs+    test/Streamly/Test/Network/Inet/TCP.hs+    test/Streamly/Test/Prelude.hs+    test/Streamly/Test/Prelude/*.hs+    test/Streamly/Test/Unicode/Stream.hs+    test/lib/Streamly/Test/Common.hs+    test/lib/Streamly/Test/Prelude/Common.hs+    test/streamly-tests.cabal+    test/version-bounds.hs  extra-tmp-files:     config.log     config.status     autom4te.cache-    src/Streamly/Internal/Data/Time/config.h+    src/config.h  source-repository head     type: git@@ -177,15 +181,15 @@   manual: True   default: False -flag examples-  description: Build including examples+flag use-c-malloc+  description: Use C malloc instead of GHC malloc   manual: True   default: False -flag examples-sdl-  description: Build including SDL examples+flag opt+  description: off=GHC default, on=-O2   manual: True-  default: False+  default: True  ------------------------------------------------------------------------------- -- Common stanzas@@ -193,6 +197,16 @@  common compile-options     default-language: Haskell2010++    if os(darwin)+      cpp-options:    -DCABAL_OS_DARWIN++    if os(linux)+      cpp-options:    -DCABAL_OS_LINUX++    if os(windows)+      cpp-options:    -DCABAL_OS_WINDOWS+     if flag(streamk)       cpp-options:    -DUSE_STREAMK_ONLY @@ -205,7 +219,18 @@     if flag(inspection)       cpp-options:    -DINSPECTION +    if flag(use-c-malloc)+      cpp-options:    -DUSE_C_MALLOC+     ghc-options:      -Wall+                      -Wcompat+                      -Wunrecognised-warning-flags+                      -Widentities+                      -Wincomplete-record-updates+                      -Wincomplete-uni-patterns+                      -Wredundant-constraints+                      -Wnoncanonical-monad-instances+                      -Rghc-timing      if flag(has-llvm)       ghc-options: -fllvm@@ -217,20 +242,46 @@     if flag(dev) || flag(debug)       ghc-options:    -fno-ignore-asserts -    if impl(ghc >= 8.0)-      ghc-options:    -Wcompat-                      -Wunrecognised-warning-flags-                      -Widentities-                      -Wincomplete-record-updates-                      -Wincomplete-uni-patterns-                      -Wredundant-constraints-                      -Wnoncanonical-monad-instances+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+        TupleSections+        TypeFamilies+        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-  ghc-options: -O2-               -fdicts-strict-               -fspec-constr-recursive=16-               -fmax-worker-args=16+  if flag(opt)+    ghc-options: -O2+                 -fdicts-strict+                 -fspec-constr-recursive=16+                 -fmax-worker-args=16  common threading-options   ghc-options:  -threaded@@ -243,28 +294,7 @@ -- -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---- Compilation for coverage builds on CI machines takes too long without -O0--- XXX we should use coverage flag for that, -O0 may take too long to run tests--- in general.-common test-options-  import: compile-options, threading-options--  ghc-options:  -O0-                -fno-ignore-asserts-  if flag(fusion-plugin) && !impl(ghcjs) && !impl(ghc < 8.6)-    ghc-options: -fplugin Fusion.Plugin-    build-depends:-        fusion-plugin     >= 0.2   && < 0.3---- Used by maxrate test, benchmarks and executables-common exe-options-  import: compile-options, optimization-options, threading-options-  if flag(fusion-plugin) && !impl(ghcjs) && !impl(ghc < 8.6)-    ghc-options: -fplugin Fusion.Plugin-    build-depends:-        fusion-plugin     >= 0.2   && < 0.3+  import: compile-options, optimization-options, default-extensions  ------------------------------------------------------------------------------- -- Library@@ -272,119 +302,206 @@  library     import: lib-options++    if impl(ghc >= 8.1)+      default-extensions: TypeApplications+    if impl(ghc >= 8.6)+      default-extensions: QuantifiedConstraints+     js-sources: jsbits/clock.js-    include-dirs:     src/Streamly/Internal/Data/Time-                    , src+    include-dirs:    src     if os(windows)-      c-sources:     src/Streamly/Internal/Data/Time/Windows.c+      c-sources:     src/Streamly/Internal/Data/Time/Clock/Windows.c+      exposed-modules: Streamly.Internal.FileSystem.Event.Windows+      build-depends: Win32 >= 2.6 && < 2.13+     if os(darwin)-      c-sources:     src/Streamly/Internal/Data/Time/Darwin.c+      frameworks:    Cocoa+      include-dirs:  src/Streamly/Internal+      c-sources:     src/Streamly/Internal/Data/Time/Clock/Darwin.c+                   , src/Streamly/Internal/FileSystem/Event/Darwin.m+      exposed-modules:+                     Streamly.Internal.FileSystem.Event.Darwin++    if os(linux)+      exposed-modules: Streamly.Internal.FileSystem.Event.Linux+     hs-source-dirs:    src     other-modules:                        Streamly.Data.Array-                     , Streamly.Data.SmallArray                      , Streamly.Data.Prim.Array--                    -- Memory storage-                       Streamly.Memory.Malloc-                     , Streamly.Memory.Ring--    if impl(ghc < 9)-      other-modules:-          Streamly.FileSystem.IOVec-        , Streamly.FileSystem.FDIO-        , Streamly.FileSystem.FD+                     , Streamly.Data.SmallArray      exposed-modules:                        Streamly.Prelude-                     , Streamly-                     , Streamly.Data.Fold                      , Streamly.Data.Unfold-                     , Streamly.Data.Unicode.Stream+                     , Streamly.Data.Fold+                     , Streamly.Data.Fold.Tee+                     , Streamly.Data.Array.Foreign -                    -- IO devices-                     , Streamly.Memory.Array+                     -- Text Processing+                     , Streamly.Unicode.Stream++                     -- Filesystem/IO                      , Streamly.FileSystem.Handle+                     , Streamly.Console.Stdio -                     , Streamly.Tutorial+                     -- Network/IO+                     , Streamly.Network.Socket+                     , Streamly.Network.Inet.TCP -                     -- Internal modules+                     -- Deprecated+                     , Streamly+                     , Streamly.Data.Unicode.Stream+                     , Streamly.Memory.Array++                     -- Internal modules, listed roughly in 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.Data.Strict+                     , Streamly.Internal.Control.Concurrent+                     , Streamly.Internal.Data.Cont+                     , Streamly.Internal.Data.Tuple.Strict+                     , Streamly.Internal.Data.Maybe.Strict+                     , Streamly.Internal.Data.Either.Strict+                     , Streamly.Internal.Foreign.Malloc                      , Streamly.Internal.Data.Atomics+                     , Streamly.Internal.Data.IOFinalizer                      , Streamly.Internal.Data.Time+                     , Streamly.Internal.Data.Time.TimeSpec                      , Streamly.Internal.Data.Time.Units+                     , Streamly.Internal.Data.Time.Clock.Type                      , Streamly.Internal.Data.Time.Clock-                     , Streamly.Internal.Data.SVar-                     , Streamly.Internal.Data.Array-                     , Streamly.Internal.Data.Prim.Array.Types-                     , Streamly.Internal.Data.Prim.Array-                     , Streamly.Internal.Data.SmallArray.Types-                     , Streamly.Internal.Data.SmallArray-                     , Streamly.Internal.Memory.Array.Types-                     , Streamly.Internal.Memory.Array-                     , Streamly.Internal.Memory.ArrayStream-                     , Streamly.Internal.Data.Fold.Types-                     , Streamly.Internal.Data.Fold-                     , Streamly.Internal.Data.Parser-                     , Streamly.Internal.Data.Parser.Types-                     , Streamly.Internal.Data.Parser.Tee-                     , Streamly.Internal.Data.Sink.Types-                     , Streamly.Internal.Data.Sink -                     -- Base streams+                     -- streamly-core-stream+                     , Streamly.Internal.Data.SVar                      , Streamly.Internal.Data.Stream.StreamK.Type-                     , Streamly.Internal.Data.Stream.StreamK+                     , Streamly.Internal.Data.Fold.Type+                     , Streamly.Internal.Data.Stream.StreamD.Step                      , Streamly.Internal.Data.Stream.StreamD.Type-                     , Streamly.Internal.Data.Stream.StreamD                      , Streamly.Internal.Data.Stream.StreamDK.Type+                     , Streamly.Internal.Data.Unfold.Type+                     , Streamly.Internal.Data.Producer.Type+                     , Streamly.Internal.Data.Producer+                     , Streamly.Internal.Data.Producer.Source+                     , Streamly.Internal.Data.Sink.Type+                     , Streamly.Internal.Data.Parser.ParserK.Type+                     , Streamly.Internal.Data.Parser.ParserD.Type+                     , Streamly.Internal.Data.Pipe.Type++                    -- Unboxed IORef+                     , Streamly.Internal.Data.IORef.Prim++                     -- streamly-core-array+                     -- May depend on streamly-core-stream+                     , Streamly.Internal.Data.Array.Foreign.Mut.Type+                     , Streamly.Internal.Data.Array.Foreign.Type+                     , Streamly.Internal.Data.Array.Prim.Mut.Type+                     , Streamly.Internal.Data.Array.Prim.Type+                     , Streamly.Internal.Data.Array.Prim.Pinned.Mut.Type+                     , Streamly.Internal.Data.Array.Prim.Pinned.Type+                     , Streamly.Internal.Data.SmallArray.Type++                     -- streamly-base-streams+                     , Streamly.Internal.Data.Stream.StreamK+                     -- StreamD depends on streamly-core-array+                     , 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                      , Streamly.Internal.Data.Stream.StreamDK-                     , Streamly.Internal.Data.Stream.Enumeration                      , Streamly.Internal.Data.Stream.Prelude -                     -- Higher level streams+                     , Streamly.Internal.Data.Parser.ParserD.Tee+                     , Streamly.Internal.Data.Parser.ParserD++                     -- streamly-core+                     , Streamly.Internal.Data.Unfold+                     , Streamly.Internal.Data.Fold.Tee+                     , Streamly.Internal.Data.Fold+                     , Streamly.Internal.Data.Sink+                     , Streamly.Internal.Data.Parser+                     , Streamly.Internal.Data.Pipe+                      , Streamly.Internal.Data.Stream.SVar                      , Streamly.Internal.Data.Stream.Serial                      , Streamly.Internal.Data.Stream.Async                      , Streamly.Internal.Data.Stream.Parallel                      , Streamly.Internal.Data.Stream.Ahead                      , Streamly.Internal.Data.Stream.Zip-                     , Streamly.Internal.Data.Stream.Combinators-                     , Streamly.Internal.Data.Unfold.Types-                     , Streamly.Internal.Data.Unfold-                     , Streamly.Internal.Data.Pipe.Types-                     , Streamly.Internal.Data.Pipe+                     , Streamly.Internal.Data.Stream.IsStream.Combinators+                     , Streamly.Internal.Data.Stream.IsStream.Common+                     , Streamly.Internal.Data.Stream.IsStream.Types+                     , Streamly.Internal.Data.Stream.IsStream.Enumeration+                     , Streamly.Internal.Data.Stream.IsStream.Generate+                     , Streamly.Internal.Data.Stream.IsStream.Eliminate+                     , Streamly.Internal.Data.Stream.IsStream.Transform+                     , Streamly.Internal.Data.Stream.IsStream.Expand+                     , Streamly.Internal.Data.Stream.IsStream.Reduce+                     , Streamly.Internal.Data.Stream.IsStream.Exception+                     , Streamly.Internal.Data.Stream.IsStream.Lift+                     , Streamly.Internal.Data.Stream.IsStream.Top+                     , Streamly.Internal.Data.Stream.IsStream                      , Streamly.Internal.Data.List++                     -- streamly-arrays+                     -- May depend on streamly-core+                     , Streamly.Internal.Data.Array+                     , Streamly.Internal.Data.Array.Foreign+                     , Streamly.Internal.Data.Array.Prim+                     , Streamly.Internal.Data.Array.Prim.Pinned+                     , Streamly.Internal.Data.SmallArray+                     , Streamly.Internal.Data.Array.Stream.Mut.Foreign+                     , Streamly.Internal.Data.Array.Stream.Foreign+                     , Streamly.Internal.Data.Array.Stream.Fold.Foreign++                    -- Memory storage+                     , Streamly.Internal.Ring.Foreign++                     -- streamly-unicode+                     , Streamly.Internal.Unicode.Stream+                     , Streamly.Internal.Unicode.Char+                     , Streamly.Internal.Unicode.Array.Char+                     , Streamly.Internal.Unicode.Array.Prim.Pinned++                     -- streamly-serde+                     , Streamly.Internal.Data.Binary.Decode++                     -- streamly-filesystem                      , Streamly.Internal.FileSystem.Handle                      , Streamly.Internal.FileSystem.Dir                      , Streamly.Internal.FileSystem.File-                     , Streamly.Internal.Data.Unicode.Stream-                     , Streamly.Internal.Data.Unicode.Char-                     , Streamly.Internal.Memory.Unicode.Array-                     , Streamly.Internal.Prelude--                     -- Mutable data-                     , Streamly.Internal.Mutable.Prim.Var+                     , Streamly.Internal.FileSystem.IOVec+                     , Streamly.Internal.FileSystem.FDIO+                     , Streamly.Internal.FileSystem.FD -    if !impl(ghcjs)-       exposed-modules:-                       Streamly.Network.Socket-                     , Streamly.Network.Inet.TCP+                     -- streamly-console+                     , Streamly.Internal.Console.Stdio +                     -- streamly-network                      , Streamly.Internal.Network.Socket                      , Streamly.Internal.Network.Inet.TCP      build-depends:                     -- Core libraries shipped with ghc, the min and max                     -- constraints of these libraries should match with-                    -- the GHC versions we support-                       base              >= 4.8   &&  < 5+                    -- 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.+                       base              >= 4.9   &&  < 5                      , containers        >= 0.5   && < 0.7                      , deepseq           >= 1.4.1 && < 1.5                      , directory         >= 1.2.2 && < 1.4                      , exceptions        >= 0.8   && < 0.11-                     , ghc-prim          >= 0.2   && < 0.10+                     , ghc-prim          >= 0.2   && < 0.8                      , mtl               >= 2.2   && < 3                      , primitive         >= 0.5.4 && < 0.8                      , transformers      >= 0.4   && < 0.6@@ -401,13 +518,10 @@                       , fusion-plugin-types >= 0.1 && < 0.2 -  if !impl(ghcjs)-    build-depends:-                       network           >= 2.6   && < 4-  if impl(ghc < 8.0)-    build-depends:-                       semigroups        >= 0.18   && < 0.19+                    -- Network+                     , network           >= 2.6   && < 4 +   if flag(inspection)     build-depends:     template-haskell   >= 2.14  && < 2.17                      , inspection-testing >= 0.4   && < 0.5@@ -416,435 +530,3 @@   -- tests fail   if flag(dev) && flag(inspection)     build-depends: inspection-and-dev-flags-cannot-be-used-together------------------------------------------------------------------------------------ Test suites----------------------------------------------------------------------------------test-suite test-  import: test-options-  type: exitcode-stdio-1.0-  main-is: Main.hs-  js-sources: jsbits/clock.js-  hs-source-dirs: test-  build-depends:-      streamly-    , base              >= 4.8   && < 5-    , hspec             >= 2.0   && < 3-    , containers        >= 0.5   && < 0.7-    , transformers      >= 0.4   && < 0.6-    , mtl               >= 2.2   && < 3-    , exceptions        >= 0.8   && < 0.11-  default-language: Haskell2010--test-suite internal-prelude-test-  import: test-options-  type: exitcode-stdio-1.0-  main-is: Streamly/Test/Internal/Prelude.hs-  js-sources: jsbits/clock.js-  hs-source-dirs: test-  build-depends:-      streamly-    , base              >= 4.8   && < 5-    , QuickCheck        >= 2.10  && < 2.15-    , hspec             >= 2.0   && < 3-  default-language: Haskell2010--test-suite pure-streams-base-  import: test-options-  type: exitcode-stdio-1.0-  main-is: PureStreams.hs-  hs-source-dirs: test-  build-depends:-      streamly-    , base              >= 4.8   && < 5-    , hspec             >= 2.0   && < 3-  default-language: Haskell2010--test-suite pure-streams-streamly-  import: test-options-  type: exitcode-stdio-1.0-  main-is: PureStreams.hs-  hs-source-dirs: test-  cpp-options:  -DUSE_STREAMLY_LIST-  build-depends:-      streamly-    , base              >= 4.8   && < 5-    , hspec             >= 2.0   && < 3-  default-language: Haskell2010--test-suite properties-  import: test-options-  type: exitcode-stdio-1.0-  main-is: Prop.hs-  js-sources: jsbits/clock.js-  hs-source-dirs: test-  build-depends:-      streamly-    , base              >= 4.8   && < 5-    , QuickCheck        >= 2.10  && < 2.15-    , hspec             >= 2.0   && < 3-  if impl(ghc < 8.0)-    build-depends:-        transformers  >= 0.4 && < 0.6-  default-language: Haskell2010--test-suite array-test-  import: test-options-  type: exitcode-stdio-1.0-  main-is: Streamly/Test/Array.hs-  js-sources: jsbits/clock.js-  hs-source-dirs: test-  cpp-options: -DTEST_ARRAY-  build-depends:-      streamly-    , base              >= 4.8   && < 5-    , QuickCheck        >= 2.10  && < 2.15-    , hspec             >= 2.0   && < 3-  if impl(ghc < 8.0)-    build-depends:-        transformers  >= 0.4 && < 0.6-  default-language: Haskell2010--test-suite internal-data-fold-test-  import: test-options-  type: exitcode-stdio-1.0-  main-is: Streamly/Test/Internal/Data/Fold.hs-  js-sources: jsbits/clock.js-  hs-source-dirs: test-  build-depends:-      streamly-    , base              >= 4.8   && < 5-    , hspec             >= 2.0   && < 3-    , QuickCheck        >= 2.10  && < 2.15-  default-language: Haskell2010--test-suite data-array-test-  import: test-options-  type: exitcode-stdio-1.0-  main-is: Streamly/Test/Array.hs-  js-sources: jsbits/clock.js-  hs-source-dirs: test-  build-depends:-      streamly-    , base              >= 4.8   && < 5-    , QuickCheck        >= 2.10  && < 2.15-    , hspec             >= 2.0   && < 3-  if impl(ghc < 8.0)-    build-depends:-        transformers  >= 0.4 && < 0.6-  default-language: Haskell2010--test-suite smallarray-test-  import: test-options-  type: exitcode-stdio-1.0-  main-is: Streamly/Test/Array.hs-  js-sources: jsbits/clock.js-  hs-source-dirs: test-  cpp-options: -DTEST_SMALL_ARRAY-  build-depends:-      streamly-    , base              >= 4.8   && < 5-    , QuickCheck        >= 2.10  && < 2.15-    , hspec             >= 2.0   && < 3-  if impl(ghc < 8.0)-    build-depends:-        transformers  >= 0.4 && < 0.6-  default-language: Haskell2010--test-suite primarray-test-  import: test-options-  type: exitcode-stdio-1.0-  main-is: Streamly/Test/Array.hs-  js-sources: jsbits/clock.js-  hs-source-dirs: test-  cpp-options: -DTEST_PRIM_ARRAY-  build-depends:-      streamly-    , base              >= 4.8   && < 5-    , QuickCheck        >= 2.10  && < 2.15-    , hspec             >= 2.0   && < 3-  if impl(ghc < 8.0)-    build-depends:-        transformers  >= 0.4 && < 0.6-  default-language: Haskell2010--test-suite string-test-  import: test-options-  type: exitcode-stdio-1.0-  main-is: String.hs-  js-sources: jsbits/clock.js-  hs-source-dirs: test-  build-depends:-      streamly-    , base              >= 4.8   && < 5-    , QuickCheck        >= 2.10  && < 2.15-    , hspec             >= 2.0   && < 3-  if impl(ghc < 8.0)-    build-depends:-        transformers  >= 0.4 && < 0.6-  default-language: Haskell2010--test-suite maxrate-  import: exe-options-  type: exitcode-stdio-1.0-  default-language: Haskell2010-  main-is: MaxRate.hs-  js-sources: jsbits/clock.js-  hs-source-dirs:  test-  if flag(dev)-    buildable: True-    build-Depends:-          streamly-        , base   >= 4.8   && < 5-        , clock  >= 0.7.1 && < 0.9-        , hspec  >= 2.0   && < 3-        , random >= 1.0.0 && < 2-  else-    buildable: False--test-suite loops-  import: test-options-  type: exitcode-stdio-1.0-  default-language: Haskell2010-  main-is: loops.hs-  hs-source-dirs:  test-  build-Depends:-      streamly-    , base >= 4.8   && < 5--test-suite nested-loops-  import: test-options-  type: exitcode-stdio-1.0-  default-language: Haskell2010-  main-is: nested-loops.hs-  hs-source-dirs:  test-  build-Depends:-      streamly-    , base   >= 4.8   && < 5-    , random >= 1.0.0 && < 2--test-suite parallel-loops-  import: test-options-  type: exitcode-stdio-1.0-  default-language: Haskell2010-  main-is: parallel-loops.hs-  hs-source-dirs:  test-  build-Depends:-      streamly-    , base   >= 4.8   && < 5-    , random >= 1.0.0 && < 2--test-suite version-bounds-  import: test-options-  type: exitcode-stdio-1.0-  default-language: Haskell2010-  main-is: version-bounds.hs-  hs-source-dirs:  test-  build-Depends:-      streamly-    , ghc-    , base   >= 4.8   && < 5------------------------------------------------------------------------------------ Examples----------------------------------------------------------------------------------executable SearchQuery-  import: exe-options-  main-is: SearchQuery.hs-  hs-source-dirs:  examples-  if (flag(examples) || flag(examples-sdl)) && !impl(ghcjs)-    buildable: True-    build-depends:-        streamly-      , base          >= 4.8   && < 5-      , http-conduit  >= 2.2.2 && < 2.4-    if impl(ghc < 8.0)-      build-depends:-        unliftio-core < 0.2-  else-    buildable: False--executable ListDir-  import: exe-options-  main-is: ListDir.hs-  hs-source-dirs:  examples-  if flag(examples) || flag(examples-sdl)-    buildable: True-    build-Depends:-        streamly-      , base    >= 4.8   && < 5-    if impl(ghc < 8.0)-      build-depends:-          transformers  >= 0.4    && < 0.6-  else-    buildable: False--executable MergeSort-  import: exe-options-  main-is: MergeSort.hs-  hs-source-dirs:  examples-  if flag(examples) || flag(examples-sdl)-    buildable: True-    build-Depends:-        streamly-      , base   >= 4.8   && < 5-      , random >= 1.0.0 && < 2-  else-    buildable: False--executable AcidRain-  import: exe-options-  main-is: AcidRain.hs-  hs-source-dirs:  examples-  if flag(examples) || flag(examples-sdl)-    buildable: True-    build-Depends:-        streamly-      , base         >= 4.8   && < 5-      , mtl          >= 2.2   && < 3-    if impl(ghc < 8.0)-      build-depends:-          semigroups    >= 0.18   && < 0.19-        , transformers  >= 0.4    && < 0.6-  else-    buildable: False--executable CirclingSquare-  import: exe-options-  main-is: CirclingSquare.hs-  hs-source-dirs:  examples-  if flag(examples-sdl)-    buildable: True-    build-Depends:-        streamly-      , base >= 4.8   && < 5-      , SDL  >= 0.6.5 && < 0.7-  else-    buildable: False--executable ControlFlow-  import: exe-options-  main-is: ControlFlow.hs-  hs-source-dirs:  examples-  if flag(examples) || flag(examples-sdl)-    buildable: True-    build-Depends:-        streamly-      , base              >= 4.8   && < 5-      , exceptions        >= 0.8   && < 0.11-      , transformers      >= 0.4   && < 0.6-      , transformers-base >= 0.4   && < 0.5-    if impl(ghc < 8.0)-      build-depends:-          semigroups    >= 0.18   && < 0.19-  else-    buildable: False--executable HandleIO-  import: exe-options-  main-is: HandleIO.hs-  hs-source-dirs:  examples-  if flag(examples) || flag(examples-sdl)-    buildable: True-    build-Depends:-        streamly-      , base              >= 4.8   && < 5-  else-    buildable: False--executable FileIOExamples-  import: exe-options-  main-is: FileIOExamples.hs-  hs-source-dirs:  examples-  if flag(examples) || flag(examples-sdl)-    buildable: True-    build-Depends:-        streamly-      , base              >= 4.8   && < 5-  else-    buildable: False--executable EchoServer-  import: exe-options-  main-is: EchoServer.hs-  hs-source-dirs:  examples-  if (flag(examples) || flag(examples-sdl)) && !impl(ghcjs)-    buildable: True-    build-Depends:-        streamly-      , base              >= 4.8   && < 5-      , network           >= 2.6   && < 4-    if impl(ghc < 8.0)-      build-depends:-          transformers  >= 0.4 && < 0.6-  else-    buildable: False--executable FileSinkServer-  import: exe-options-  main-is: FileSinkServer.hs-  hs-source-dirs:  examples-  if (flag(examples) || flag(examples-sdl)) && !impl(ghcjs)-    buildable: True-    build-Depends:-        streamly-      , base              >= 4.8   && < 5-      , network           >= 2.6   && < 4-    if impl(ghc < 8.0)-      build-depends:-          transformers  >= 0.4 && < 0.6-  else-    buildable: False--executable FromFileClient-  import: exe-options-  main-is: FromFileClient.hs-  hs-source-dirs:  examples-  if (flag(examples) || flag(examples-sdl)) && !impl(ghcjs)-    buildable: True-    build-Depends:-        streamly-      , base              >= 4.8   && < 5-  else-    buildable: False--executable WordClassifier-  import: exe-options-  main-is: WordClassifier.hs-  hs-source-dirs:  examples-  if (flag(examples) || flag(examples-sdl)) && !impl(ghcjs)-    buildable: True-    build-Depends:-        streamly-      , base                 >= 4.8   && < 5-      , hashable             >= 1.2   && < 1.4-      , unordered-containers >= 0.2   && < 0.3-  else-    buildable: False--executable WordCount-  import: exe-options-  main-is: WordCount.hs-  hs-source-dirs:  examples-  if (flag(examples) || flag(examples-sdl)) && !impl(ghcjs)-    buildable: True-    build-Depends:-        streamly-      , base                 >= 4.8   && < 5-      , vector               >= 0.12  && < 0.13-  else-    buildable: False--executable CamelCase-  import: exe-options-  main-is: CamelCase.hs-  hs-source-dirs:  examples-  if (flag(examples) || flag(examples-sdl)) && !impl(ghcjs)-    buildable: True-    build-Depends:-        streamly-      , base                 >= 4.8   && < 5-  else-    buildable: False
− test/Main.hs 
@@ -1,1172 +0,0 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Main (main) where--import Control.Concurrent (threadDelay)-import Control.Exception (Exception, try, ErrorCall(..), catch)-import Control.Monad (void)-import Control.Monad.Catch (throwM, MonadThrow)-import Control.Monad.Error.Class (throwError, MonadError)-import Control.Monad.IO.Class (MonadIO(liftIO))-import Control.Monad.State (MonadState, get, modify, runStateT, StateT)-import Control.Monad.Trans.Except (runExceptT, ExceptT)-import Data.Foldable (forM_, fold)-import Data.Function ((&))-import Data.List (sort)-import Data.Maybe (fromJust, isJust)-import System.Mem (performMajorGC)--import Data.IORef-import Test.Hspec as H--import Streamly-import Streamly.Prelude ((.:), nil)-import qualified Streamly as S-import qualified Streamly.Prelude as S-import qualified Streamly.Internal.Prelude as IP--singleton :: IsStream t => a -> t m a-singleton a = a .: nil--toListSerial :: SerialT IO a -> IO [a]-toListSerial = S.toList . serially--toListInterleaved :: WSerialT IO a -> IO [a]-toListInterleaved = S.toList . wSerially--toListAsync :: AsyncT IO a -> IO [a]-toListAsync = S.toList . asyncly--toListParallel :: WAsyncT IO a -> IO [a]-toListParallel = S.toList . wAsyncly--main :: IO ()-main = hspec $ do-    parallelTests--    describe "restricts concurrency and cleans up extra tasks" $ do-        it "take 1 asyncly" $ checkCleanup 2 asyncly (S.take 1)-        it "take 1 wAsyncly" $ checkCleanup 2 wAsyncly (S.take 1)-        it "take 1 aheadly" $ checkCleanup 2 aheadly (S.take 1)--        it "takeWhile (< 0) asyncly" $ checkCleanup 2 asyncly (S.takeWhile (< 0))-        it "takeWhile (< 0) wAsyncly" $ checkCleanup 2 wAsyncly (S.takeWhile (< 0))-        it "takeWhile (< 0) aheadly" $ checkCleanup 2 aheadly (S.takeWhile (< 0))--#ifdef DEVBUILD-    let timed :: (IsStream t, Monad (t IO)) => Int -> t IO Int-        timed x = S.yieldM (threadDelay (x * 100000)) >> return x--    -- These are not run parallely because the timing gets affected-    -- unpredictably when other tests are running on the same machine.-    ---    -- Also, they fail intermittently due to scheduling delays, so not run on-    -- CI machines.-    describe "Nested parallel and serial compositions" $ do-        let t = timed-            p = wAsyncly-            s = serially-        {--        -- This is not correct, the result can also be [4,4,8,0,8,0,2,2]-        -- because of parallelism of [8,0] and [8,0].-        it "Nest <|>, <>, <|> (1)" $-            let t = timed-             in toListSerial (-                    ((t 8 <|> t 4) <> (t 2 <|> t 0))-                <|> ((t 8 <|> t 4) <> (t 2 <|> t 0)))-            `shouldReturn` ([4,4,8,8,0,0,2,2])-        -}-        it "Nest <|>, <>, <|> (2)" $-            (S.toList . wAsyncly) (-                   s (p (t 4 <> t 8) <> p (t 1 <> t 2))-                <> s (p (t 4 <> t 8) <> p (t 1 <> t 2)))-            `shouldReturn` ([4,4,8,8,1,1,2,2])-        -- FIXME: These two keep failing intermittently on Mac OS X-        -- Need to examine and fix the tests.-        {--        it "Nest <|>, <=>, <|> (1)" $-            let t = timed-             in toListSerial (-                    ((t 8 <|> t 4) <=> (t 2 <|> t 0))-                <|> ((t 9 <|> t 4) <=> (t 2 <|> t 0)))-            `shouldReturn` ([4,4,0,0,8,2,9,2])-        it "Nest <|>, <=>, <|> (2)" $-            let t = timed-             in toListSerial (-                    ((t 4 <|> t 8) <=> (t 1 <|> t 2))-                <|> ((t 4 <|> t 9) <=> (t 1 <|> t 2)))-            `shouldReturn` ([4,4,1,1,8,2,9,2])-        -}-        it "Nest <|>, <|>, <|>" $-            (S.toList . wAsyncly) (-                    ((t 4 <> t 8) <> (t 0 <> t 2))-                <> ((t 4 <> t 8) <> (t 0 <> t 2)))-            `shouldReturn` ([0,0,2,2,4,4,8,8])--        -- parallely fails on CI machines, may need more difference in times of-        -- the events, but that would make tests even slower.-        it "take 1 parallely" $ checkCleanup 3 parallely (S.take 1)-        it "takeWhile (< 0) parallely" $ checkCleanup 3 parallely (S.takeWhile (< 0))--        testFoldOpsCleanup "head" S.head-        testFoldOpsCleanup "null" S.null-        testFoldOpsCleanup "elem" (S.elem 0)-        testFoldOpsCleanup "notElem" (S.notElem 0)-        testFoldOpsCleanup "elemIndex" (S.elemIndex 0)-        -- S.lookup-        testFoldOpsCleanup "notElem" (S.notElem 0)-        testFoldOpsCleanup "find" (S.find (==0))-        testFoldOpsCleanup "findIndex" (S.findIndex (==0))-        testFoldOpsCleanup "all" (S.all (==1))-        testFoldOpsCleanup "any" (S.any (==0))-        testFoldOpsCleanup "and" (S.and . S.map (==1))-        testFoldOpsCleanup "or" (S.or . S.map (==0))-#endif--    ----------------------------------------------------------------------------    -- Semigroup/Monoidal Composition strict ordering checks-    -----------------------------------------------------------------------------    -- test both (<>) and mappend to make sure we are using correct instance-    -- for Monoid that is using the right version of semigroup. Instance-    -- deriving can cause us to pick wrong instances sometimes.--    describe "WSerial interleaved (<>) ordering check" $ interleaveCheck wSerially (<>)-    describe "WSerial interleaved mappend ordering check" $ interleaveCheck wSerially mappend--    -- describe "WAsync interleaved (<>) ordering check" $ interleaveCheck wAsyncly (<>)-    -- describe "WAsync interleaved mappend ordering check" $ interleaveCheck wAsyncly mappend--    describe "Async (<>) time order check" $ parallelCheck asyncly (<>)-    describe "Async mappend time order check" $ parallelCheck asyncly mappend--    -- XXX this keeps failing intermittently, need to investigate-    -- describe "WAsync (<>) time order check" $ parallelCheck wAsyncly (<>)-    -- describe "WAsync mappend time order check" $ parallelCheck wAsyncly mappend--    describe "Parallel (<>) time order check" $ parallelCheck parallely (<>)-    describe "Parallel mappend time order check" $ parallelCheck parallely mappend-    it "fromCallback" $ testFromCallback `shouldReturn` (50*101)--checkCleanup :: IsStream t-    => Int-    -> (t IO Int -> SerialT IO Int)-    -> (t IO Int -> t IO Int)-    -> IO ()-checkCleanup d t op = do-    r <- newIORef (-1 :: Int)-    S.drain . serially $ do-        _ <- t $ op $ delay r 0 S.|: delay r 1 S.|: delay r 2 S.|: S.nil-        return ()-    performMajorGC-    threadDelay 500000-    res <- readIORef r-    res `shouldBe` 0-    where-    delay ref i = threadDelay (i*d*100000) >> writeIORef ref i >> return i--#ifdef DEVBUILD-checkCleanupFold :: IsStream t-    => (t IO Int -> SerialT IO Int)-    -> (SerialT IO Int -> IO (Maybe Int))-    -> IO ()-checkCleanupFold t op = do-    r <- newIORef (-1 :: Int)-    _ <- op $ t $ delay r 0 S.|: delay r 1 S.|: delay r 2 S.|: S.nil-    performMajorGC-    threadDelay 500000-    res <- readIORef r-    res `shouldBe` 0-    where-    delay ref i = threadDelay (i*200000) >> writeIORef ref i >> return i--testFoldOpsCleanup :: String -> (SerialT IO Int -> IO a) -> Spec-testFoldOpsCleanup name f = do-    let testOp op x = op x >> return Nothing-    it (name <> " asyncly") $ checkCleanupFold asyncly (testOp f)-    it (name <> " wAsyncly") $ checkCleanupFold wAsyncly (testOp f)-    it (name <> " aheadly") $ checkCleanupFold aheadly (testOp f)-    it (name <> " parallely") $ checkCleanupFold parallely (testOp f)-#endif--parallelTests :: SpecWith ()-parallelTests = H.parallel $ do-    describe "Runners" $ do-        -- XXX move these to property tests-        -- XXX use an IORef to store and check the side effects-        it "simple serially" $-            (S.drain . serially) (return (0 :: Int)) `shouldReturn` ()-        it "simple serially with IO" $-            (S.drain . serially) (S.yieldM $ putStrLn "hello") `shouldReturn` ()--    describe "Empty" $ -- do-        it "Monoid - mempty" $-            toListSerial mempty `shouldReturn` ([] :: [Int])-        -- it "Alternative - empty" $-        --     (toListSerial empty) `shouldReturn` ([] :: [Int])-        -- it "MonadPlus - mzero" $-        --     (toListSerial mzero) `shouldReturn` ([] :: [Int])--    ----------------------------------------------------------------------------    -- Functor-    -----------------------------------------------------------------------------    describe "Functor (fmap)" $ do-        -- XXX we should do these through property tests by using a-        -- construction via list fold construction method.-        it "fmap on composed (<>)" $-            toListSerial (fmap (+1) (return 1 <> return 2))-                `shouldReturn` ([2,3] :: [Int])--        it "fmap on composed (<>)" $-            sort <$> toListParallel (fmap (+1) (return 1 <> return 2))-                `shouldReturn` ([2,3] :: [Int])--    ----------------------------------------------------------------------------    -- Applicative-    -----------------------------------------------------------------------------    describe "Applicative" $ do-        -- XXX we should do these through property tests by using a-        -- construction via list fold construction method.-        it "Apply - serial composed first argument" $-            toListSerial ((,) <$> (return 1 <> return 2) <*> return 3)-                `shouldReturn` ([(1,3),(2,3)] :: [(Int, Int)])--        it "Apply - serial composed second argument" $-            toListSerial ((,) <$> return 1 <*> (return 2 <> return 3))-                `shouldReturn` ([(1,2),(1,3)] :: [(Int, Int)])--        it "Apply - parallel composed first argument" $-            sort <$> toListParallel ((,) <$> (return 1 <> return 2) <*> return 3)-                `shouldReturn` ([(1,3),(2,3)] :: [(Int, Int)])--        it "Apply - parallel composed second argument" $-            sort <$> toListParallel ((,) <$> return 1 <*> (return 2 <> return 3))-                `shouldReturn` ([(1,2),(1,3)] :: [(Int, Int)])--    ----------------------------------------------------------------------------    -- Monoidal Compositions, multiset equality checks-    -----------------------------------------------------------------------------    describe "Serial Composition" $ compose serially mempty id-    describe "Ahead Composition" $ compose aheadly mempty id-    describe "WSerial Composition" $ compose wSerially mempty sort-    describe "Async Composition" $ compose asyncly mempty sort-    describe "WAsync Composition" $ compose wAsyncly mempty sort-    describe "Parallel Composition" $ compose parallely mempty sort-    describe "Semigroup Composition for ZipSerial" $ compose zipSerially mempty id-    describe "Semigroup Composition for ZipAsync" $ compose zipAsyncly mempty id-    -- XXX need to check alternative compositions as well--    ----------------------------------------------------------------------------    -- TBD Monoidal composition combinations-    -----------------------------------------------------------------------------    -- TBD need more such combinations to be tested.-    describe "serial <> and serial <>" $-        composeAndComposeSimple serially serially (repeat [1 .. 9])-    describe "ahead <> and ahead <>" $-        composeAndComposeSimple aheadly aheadly (repeat [1 .. 9])-    describe "ahead <> and serial <>" $-        composeAndComposeSimple aheadly serially (repeat [1 .. 9])-    describe "serial <> and ahead <>" $-        composeAndComposeSimple serially aheadly (repeat [1 .. 9])--    describe "<> and <=>" $ composeAndComposeSimple-      serially-      wSerially-      [ [1 .. 9]-       , [1 .. 9]-       , [1, 3, 2, 4, 6, 5, 7, 9, 8]-       , [1, 3, 2, 4, 6, 5, 7, 9, 8]-      ]--    describe "<=> and <=>" $ composeAndComposeSimple-      wSerially-      wSerially-      [ [1, 4, 2, 7, 3, 5, 8, 6, 9]-       , [1, 7, 4, 8, 2, 9, 5, 3, 6]-       , [1, 4, 3, 7, 2, 6, 9, 5, 8]-       , [1, 7, 4, 9, 3, 8, 6, 2, 5]-      ]--    describe "<=> and <>" $ composeAndComposeSimple-      wSerially-      serially-      [ [1, 4, 2, 7, 3, 5, 8, 6, 9]-       , [1, 7, 4, 8, 2, 9, 5, 3, 6]-       , [1, 4, 2, 7, 3, 5, 8, 6, 9]-       , [1, 7, 4, 8, 2, 9, 5, 3, 6]-      ]--    ----------------------------------------------------------------------------    -- Monoidal composition recursion loops-    -----------------------------------------------------------------------------    describe "Serial loops" $ loops serially id reverse-    describe "Ahead loops" $ loops aheadly id reverse-    describe "Async parallel loops" $ loops asyncly sort sort-    describe "WAsync loops" $ loops wAsyncly sort sort-    describe "parallel loops" $ loops parallely sort sort--    ----------------------------------------------------------------------------    -- Bind and monoidal composition combinations-    -----------------------------------------------------------------------------    describe "Bind and compose Stream 1" $ bindAndComposeSimple serially serially-    describe "Bind and compose Stream 2" $ bindAndComposeSimple serially wSerially-    describe "Bind and compose Stream 3" $ bindAndComposeSimple serially asyncly-    describe "Bind and compose Stream 4" $ bindAndComposeSimple serially wAsyncly-    describe "Bind and compose Stream 5" $ bindAndComposeSimple serially parallely-    describe "Bind and compose Stream 6" $ bindAndComposeSimple serially aheadly--    describe "Bind and compose Ahead Stream 0" $ bindAndComposeSimple aheadly aheadly-    describe "Bind and compose Ahead Stream 1" $ bindAndComposeSimple aheadly serially-    describe "Bind and compose Ahead Stream 2" $ bindAndComposeSimple aheadly wSerially-    describe "Bind and compose Ahead Stream 3" $ bindAndComposeSimple aheadly asyncly-    describe "Bind and compose Ahead Stream 4" $ bindAndComposeSimple aheadly wAsyncly-    describe "Bind and compose Ahead Stream 5" $ bindAndComposeSimple aheadly parallely--    describe "Bind and compose Costream 1" $ bindAndComposeSimple wSerially serially-    describe "Bind and compose Costream 2" $ bindAndComposeSimple wSerially wSerially-    describe "Bind and compose Costream 3" $ bindAndComposeSimple wSerially asyncly-    describe "Bind and compose Costream 4" $ bindAndComposeSimple wSerially wAsyncly-    describe "Bind and compose Costream 5" $ bindAndComposeSimple wSerially parallely-    describe "Bind and compose Costream 6" $ bindAndComposeSimple wSerially aheadly--    describe "Bind and compose Async 1" $ bindAndComposeSimple asyncly serially-    describe "Bind and compose Async 2" $ bindAndComposeSimple asyncly wSerially-    describe "Bind and compose Async 3" $ bindAndComposeSimple asyncly asyncly-    describe "Bind and compose Async 4" $ bindAndComposeSimple asyncly wAsyncly-    describe "Bind and compose Async 5" $ bindAndComposeSimple asyncly parallely-    describe "Bind and compose Async 6" $ bindAndComposeSimple asyncly aheadly--    describe "Bind and compose WAsync 1" $ bindAndComposeSimple wAsyncly serially-    describe "Bind and compose WAsync 2" $ bindAndComposeSimple wAsyncly wSerially-    describe "Bind and compose WAsync 3" $ bindAndComposeSimple wAsyncly asyncly-    describe "Bind and compose WAsync 4" $ bindAndComposeSimple wAsyncly wAsyncly-    describe "Bind and compose WAsync 5" $ bindAndComposeSimple wAsyncly parallely-    describe "Bind and compose WAsync 6" $ bindAndComposeSimple wAsyncly aheadly--    describe "Bind and compose Parallel 1" $ bindAndComposeSimple parallely serially-    describe "Bind and compose Parallel 2" $ bindAndComposeSimple parallely wSerially-    describe "Bind and compose Parallel 3" $ bindAndComposeSimple parallely asyncly-    describe "Bind and compose Parallel 4" $ bindAndComposeSimple parallely wAsyncly-    describe "Bind and compose Parallel 5" $ bindAndComposeSimple parallely parallely-    describe "Bind and compose Parallel 6" $ bindAndComposeSimple parallely aheadly--    let fldr, fldl :: (IsStream t, Semigroup (t IO Int)) => [t IO Int] -> t IO Int-        fldr = foldr (<>) nil-        fldl = foldl (<>) nil--    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose" $ bindAndComposeHierarchy serially serially k-    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose" $ bindAndComposeHierarchy serially wSerially k-    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose" $ bindAndComposeHierarchy serially asyncly k-    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose" $ bindAndComposeHierarchy serially wAsyncly k-    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose" $ bindAndComposeHierarchy serially parallely k-    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose serially aheadly" $ bindAndComposeHierarchy serially aheadly k--    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose aheadly serially" $ bindAndComposeHierarchy aheadly serially k-    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose aheadly wSerially" $ bindAndComposeHierarchy aheadly wSerially k-    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose aheadly asyncly" $ bindAndComposeHierarchy aheadly asyncly k-    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose aheadly wAsyncly" $ bindAndComposeHierarchy aheadly wAsyncly k-    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose aheadly parallely" $ bindAndComposeHierarchy aheadly parallely k-    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose serially aheadly" $ bindAndComposeHierarchy aheadly aheadly k--    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose" $ bindAndComposeHierarchy wSerially serially k-    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose" $ bindAndComposeHierarchy wSerially wSerially k-    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose" $ bindAndComposeHierarchy wSerially asyncly k-    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose" $ bindAndComposeHierarchy wSerially wAsyncly k-    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose" $ bindAndComposeHierarchy wSerially parallely k-    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose wserially aheadly" $ bindAndComposeHierarchy wSerially aheadly k--    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose" $ bindAndComposeHierarchy asyncly serially k-    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose" $ bindAndComposeHierarchy asyncly wSerially k-    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose" $ bindAndComposeHierarchy asyncly asyncly k-    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose" $ bindAndComposeHierarchy asyncly wAsyncly k-    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose" $ bindAndComposeHierarchy asyncly parallely k-    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose asyncly aheadly" $ bindAndComposeHierarchy asyncly aheadly k--    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose" $ bindAndComposeHierarchy wAsyncly serially k-    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose" $ bindAndComposeHierarchy wAsyncly wSerially k-    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose" $ bindAndComposeHierarchy wAsyncly asyncly k-    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose" $ bindAndComposeHierarchy wAsyncly wAsyncly k-    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose" $ bindAndComposeHierarchy wAsyncly parallely k-    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose wAsyncly aheadly" $ bindAndComposeHierarchy wAsyncly aheadly k--    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose" $ bindAndComposeHierarchy parallely serially k-    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose" $ bindAndComposeHierarchy parallely wSerially k-    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose" $ bindAndComposeHierarchy parallely asyncly k-    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose" $ bindAndComposeHierarchy parallely wAsyncly k-    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose" $ bindAndComposeHierarchy parallely parallely k-    forM_ [fldr, fldl] $ \k ->-        describe "Bind and compose parallely aheadly" $ bindAndComposeHierarchy parallely aheadly k--    -- Nest two lists using different styles of product compositions-    it "Nests two streams using monadic serial composition" nestTwoSerial-    it "Nests two streams using monadic ahead composition" nestTwoAhead-    it "Nests two streams using monadic interleaved composition" nestTwoInterleaved-    it "Nests two streams using monadic Async composition" nestTwoAsync-    it "Nests two streams using monadic WAsync composition" nestTwoWAsync-    it "Nests two streams using monadic parallel composition" nestTwoParallel--    it "Nests two streams using applicative serial composition" nestTwoSerialApp-    it "Nests two streams using applicative ahead composition" nestTwoAheadApp-    it "Nests two streams using applicative interleaved composition" nestTwoInterleavedApp-    it "Nests two streams using applicative Async composition" nestTwoAsyncApp-    it "Nests two streams using applicative WAsync composition" nestTwoWAsyncApp-    it "Nests two streams using applicative parallel composition" nestTwoParallelApp--    ----------------------------------------------------------------------------    -- TBD Bind and Bind combinations-    -----------------------------------------------------------------------------    -- TBD combine all binds and all compose in one example-    describe "Miscellaneous combined examples" mixedOps-    describe "Miscellaneous combined examples aheadly" mixedOpsAheadly-    describe "Simple MonadError and MonadThrow" simpleMonadError--    {--    describe "Composed MonadError serially" $ composeWithMonadError serially-    describe "Composed MonadError wSerially" $ composeWithMonadError wSerially-    describe "Composed MonadError asyncly" $ composeWithMonadError asyncly-    describe "Composed MonadError wAsyncly" $ composeWithMonadError wAsyncly-    -}--    describe "Composed MonadThrow serially" $ composeWithMonadThrow serially-    describe "Composed MonadThrow wSerially" $ composeWithMonadThrow wSerially-    describe "Composed MonadThrow asyncly" $ composeWithMonadThrow asyncly-    describe "Composed MonadThrow wAsyncly" $ composeWithMonadThrow wAsyncly-    describe "Composed MonadThrow parallely" $ composeWithMonadThrow parallely-    describe "Composed MonadThrow aheadly" $ composeWithMonadThrow aheadly--    describe "take on infinite concurrent stream" $ takeInfinite asyncly-    describe "take on infinite concurrent stream" $ takeInfinite wAsyncly-    describe "take on infinite concurrent stream" $ takeInfinite aheadly--    ----------------------------------------------------------------------------    -- Some ad-hoc tests that failed at times-    -----------------------------------------------------------------------------    it "takes n from stream of streams" (takeCombined 1 aheadly)-    it "takes n from stream of streams" (takeCombined 2 asyncly)-    it "takes n from stream of streams" (takeCombined 3 wAsyncly)--    ----------------------------------------------------------------------------    -- Left folds are strict enough-    -----------------------------------------------------------------------------#ifdef DEVBUILD-    it "foldx is strict enough" checkFoldxStrictness-    it "scanx is strict enough" checkScanxStrictness-    it "foldxM is strict enough" (checkFoldMStrictness foldxMStrictCheck)-#endif-    it "foldl' is strict enough" checkFoldl'Strictness-    it "scanl' is strict enough" checkScanl'Strictness-    it "foldlM' is strict enough" (checkFoldMStrictness foldlM'StrictCheck)-    it "scanlM' is strict enough" (checkScanlMStrictness scanlM'StrictCheck)--    ----------------------------------------------------------------------------    -- Right folds are lazy enough-    -----------------------------------------------------------------------------    it "foldrM is lazy enough" checkFoldrLaziness--    ----------------------------------------------------------------------------    -- Monadic state snapshot in concurrent tasks-    -----------------------------------------------------------------------------    it "asyncly maintains independent states in concurrent tasks"-        (monadicStateSnapshot asyncly)-    it "asyncly limited maintains independent states in concurrent tasks"-        (monadicStateSnapshot (asyncly . S.take 10000))-    it "wAsyncly maintains independent states in concurrent tasks"-        (monadicStateSnapshot wAsyncly)-    it "wAsyncly limited maintains independent states in concurrent tasks"-        (monadicStateSnapshot (wAsyncly . S.take 10000))-    it "aheadly maintains independent states in concurrent tasks"-        (monadicStateSnapshot aheadly)-    it "aheadly limited maintains independent states in concurrent tasks"-        (monadicStateSnapshot (aheadly . S.take 10000))-    it "parallely maintains independent states in concurrent tasks"-        (monadicStateSnapshot parallely)--    it "async maintains independent states in concurrent tasks"-        (monadicStateSnapshotOp async)-    it "ahead maintains independent states in concurrent tasks"-        (monadicStateSnapshotOp ahead)-    it "wAsync maintains independent states in concurrent tasks"-        (monadicStateSnapshotOp wAsync)-    it "parallel maintains independent states in concurrent tasks"-        (monadicStateSnapshotOp Streamly.parallel)--    ----------------------------------------------------------------------------    -- Slower tests are at the end-    -----------------------------------------------------------------------------    ----------------------------------------------------------------------------    -- Thread limits-    -----------------------------------------------------------------------------    it "asyncly crosses thread limit (2000 threads)" $-        S.drain (asyncly $ fold $-                   replicate 2000 $ S.yieldM $ threadDelay 1000000)-        `shouldReturn` ()--    it "aheadly crosses thread limit (4000 threads)" $-        S.drain (aheadly $ fold $-                   replicate 4000 $ S.yieldM $ threadDelay 1000000)-        `shouldReturn` ()---- Each snapshot carries an independent state. Multiple parallel tasks should--- not affect each other's state. This is especially important when we run--- multiple tasks in a single thread.-snapshot :: (IsStream t, MonadAsync m, MonadState Int m) => t m ()-snapshot =-    -- We deliberately use a replicate count 1 here, because a lower count-    -- catches problems that a higher count doesn't.-    S.replicateM 1 $ do-        -- Even though we modify the state here it should not reflect in other-        -- parallel tasks, it is local to each concurrent task.-        modify (+1) >> get >>= liftIO . (`shouldSatisfy` (==1))-        modify (+1) >> get >>= liftIO . (`shouldSatisfy` (==2))--snapshot1 :: (IsStream t, MonadAsync m, MonadState Int m) => t m ()-snapshot1 = S.replicateM 1000 $-    modify (+1) >> get >>= liftIO . (`shouldSatisfy` (==2))--snapshot2 :: (IsStream t, MonadAsync m, MonadState Int m) => t m ()-snapshot2 = S.replicateM 1000 $-    modify (+1) >> get >>= liftIO . (`shouldSatisfy` (==2))--stateComp-    :: ( IsStream t-       , MonadAsync m-       , Semigroup (t m ())-       , MonadIO (t m)-       , MonadState Int m-       , MonadState Int (t m)-       )-    => t m ()-stateComp = do-    -- Each task in a concurrent composition inherits the state and maintains-    -- its own modifications to it, not affecting the parent computation.-    snapshot <> (modify (+1) >> (snapshot1 <> snapshot2))-    -- The above modify statement does not affect our state because that is-    -- used in a parallel composition. In a serial composition it will affect-    -- our state.-    get >>= liftIO . (`shouldSatisfy` (== (0 :: Int)))--monadicStateSnapshot-    :: ( IsStream t-       , Semigroup (t (StateT Int IO) ())-       , MonadIO (t (StateT Int IO))-       , MonadState Int (t (StateT Int IO))-       )-    => (t (StateT Int IO) () -> SerialT (StateT Int IO) ()) -> IO ()-monadicStateSnapshot t = void $ runStateT (S.drain $ t stateComp) 0--stateCompOp-    :: (   AsyncT (StateT Int IO) ()-        -> AsyncT (StateT Int IO) ()-        -> AsyncT (StateT Int IO) ()-       )-    -> SerialT (StateT Int IO) ()-stateCompOp op = do-    -- Each task in a concurrent composition inherits the state and maintains-    -- its own modifications to it, not affecting the parent computation.-    asyncly (snapshot `op` (modify (+1) >> (snapshot1 `op` snapshot2)))-    -- The above modify statement does not affect our state because that is-    -- used in a parallel composition. In a serial composition it will affect-    -- our state.-    get >>= liftIO . (`shouldSatisfy` (== (0 :: Int)))--monadicStateSnapshotOp-    :: (   AsyncT (StateT Int IO) ()-        -> AsyncT (StateT Int IO) ()-        -> AsyncT (StateT Int IO) ()-       )-    -> IO ()-monadicStateSnapshotOp op = void $ runStateT (S.drain $ stateCompOp op) 0--takeCombined :: (Monad m, Semigroup (t m Int), Show a, Eq a, IsStream t)-    => Int -> (t m Int -> SerialT IO a) -> IO ()-takeCombined n t = do-    let constr = S.fromFoldable-    r <- (S.toList . t) $-            S.take n (constr ([] :: [Int]) <> constr ([] :: [Int]))-    r `shouldBe` []--checkFoldrLaziness :: IO ()-checkFoldrLaziness = do-    S.foldrM (\x xs -> if odd x then return True else xs)-             (return False) (S.fromList (2:4:5:undefined :: [Int]))-        `shouldReturn` True--    S.toList (IP.foldrS (\x xs -> if odd x then return True else xs)-                        (return False)-                        $ (S.fromList (2:4:5:undefined) :: SerialT IO Int))-        `shouldReturn` [True]--    S.toList (IP.foldrT (\x xs -> if odd x then return True else xs)-                        (return False)-                        $ (S.fromList (2:4:5:undefined) :: SerialT IO Int))-        `shouldReturn` [True]--#ifdef DEVBUILD-checkFoldxStrictness :: IO ()-checkFoldxStrictness = do-  let s = return (1 :: Int) `S.consM` error "failure"-  catch (S.foldx (\_ a -> if a == 1 then error "success" else "done")-                      "begin" id s)-    (\(ErrorCall err) -> return err)-    `shouldReturn` "success"-#endif--checkFoldl'Strictness :: IO ()-checkFoldl'Strictness = do-  let s = return (1 :: Int) `S.consM` error "failure"-  catch (S.foldl' (\_ a -> if a == 1 then error "success" else "done")-                      "begin" s)-    (\(ErrorCall err) -> return err)-    `shouldReturn` "success"--#ifdef DEVBUILD-checkScanxStrictness :: IO ()-checkScanxStrictness = do-  let s = return (1 :: Int) `S.consM` error "failure"-  catch-    (S.drain (-        S.scanx (\_ a ->-                    if a == 1-                    then error "success"-                    else "done")-                "begin" id s-        )-        >> return "finished"-    )-    (\(ErrorCall err) -> return err)-    `shouldReturn` "success"-#endif--checkScanl'Strictness :: IO ()-checkScanl'Strictness = do-    let s = return (1 :: Int) `S.consM` error "failure"-    catch-        (S.drain-             (S.scanl'-                  (\_ a ->-                       if a == 1-                           then error "success"-                           else "done")-                  "begin"-                  s)-             >> return "finished"-        )-        (\(ErrorCall err) -> return err)-        `shouldReturn` "success"--foldlM'StrictCheck :: IORef Int -> SerialT IO Int -> IO ()-foldlM'StrictCheck ref = S.foldlM' (\_ _ -> writeIORef ref 1) ()--#ifdef DEVBUILD-foldxMStrictCheck :: IORef Int -> SerialT IO Int -> IO ()-foldxMStrictCheck ref = S.foldxM (\_ _ -> writeIORef ref 1) (return ()) return-#endif--checkFoldMStrictness :: (IORef Int -> SerialT IO Int -> IO ()) -> IO ()-checkFoldMStrictness f = do-  ref <- newIORef 0-  let s = return 1 `S.consM` error "x"-  catch (f ref s) (\(_ :: ErrorCall) -> return ())-  readIORef ref `shouldReturn` 1--scanlM'StrictCheck :: IORef Int -> SerialT IO Int -> SerialT IO ()-scanlM'StrictCheck ref = S.scanlM' (\_ _ -> writeIORef ref 1) ()--checkScanlMStrictness :: (IORef Int -> SerialT IO Int -> SerialT IO ()) -> IO ()-checkScanlMStrictness f = do-  ref <- newIORef 0-  let s = return 1 `S.consM` error "x"-  catch (S.drain $ f ref s) (\(_ :: ErrorCall) -> return ())-  readIORef ref `shouldReturn` 1--takeInfinite :: IsStream t => (t IO Int -> SerialT IO Int) -> Spec-takeInfinite t =-    it "take 1" $-        S.drain (t $ S.take 1 $ S.repeatM (print "hello" >> return (1::Int)))-        `shouldReturn` ()---- XXX need to test that we have promptly cleaned up everything after the error--- XXX We can also check the output that we are expected to get before the--- error occurs.--newtype ExampleException = ExampleException String deriving (Eq, Show)--instance Exception ExampleException--simpleMonadError :: Spec-simpleMonadError = do-{--    it "simple runExceptT" $ do-        (runExceptT $ S.drain $ return ())-        `shouldReturn` (Right () :: Either String ())-    it "simple runExceptT with error" $ do-        (runExceptT $ S.drain $ throwError "E") `shouldReturn` Left "E"-        -}-    it "simple try" $-        try (S.drain $ return ())-        `shouldReturn` (Right () :: Either ExampleException ())-    it "simple try with throw error" $-        try (S.drain $ throwM $ ExampleException "E")-        `shouldReturn` (Left (ExampleException "E") :: Either ExampleException ())--composeWithMonadThrow-    :: ( IsStream t-       , Semigroup (t IO Int)-       , MonadThrow (t IO)-       )-    => (t IO Int -> SerialT IO Int) -> Spec-composeWithMonadThrow t = do-    it "Compose throwM, nil" $-        try (tl (throwM (ExampleException "E") <> S.nil))-        `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])-    it "Compose nil, throwM" $-        try (tl (S.nil <> throwM (ExampleException "E")))-        `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])-    oneLevelNestedSum "serially" serially-    oneLevelNestedSum "wSerially" wSerially-    oneLevelNestedSum "asyncly" asyncly-    oneLevelNestedSum "wAsyncly" wAsyncly-    -- XXX add two level nesting--    oneLevelNestedProduct "serially"   serially-    oneLevelNestedProduct "wSerially" wSerially-    oneLevelNestedProduct "asyncly" asyncly-    oneLevelNestedProduct "wAsyncly"  wAsyncly--    where-    tl = S.toList . t-    oneLevelNestedSum desc t1 =-        it ("One level nested sum " <> desc) $ do-            let nested = S.fromFoldable [1..10] <> throwM (ExampleException "E")-                         <> S.fromFoldable [1..10]-            try (tl (S.nil <> t1 nested <> S.fromFoldable [1..10]))-            `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])--    oneLevelNestedProduct desc t1 =-        it ("One level nested product" <> desc) $ do-            let s1 = t $ S.foldMapWith (<>) return [1..4]-                s2 = t1 $ S.foldMapWith (<>) return [5..8]-            try $ tl (do-                x <- adapt s1-                y <- s2-                if x + y > 10-                then throwM (ExampleException "E")-                else return (x + y)-                )-            `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])--_composeWithMonadError-    :: ( IsStream t-       , Semigroup (t (ExceptT String IO) Int)-       , MonadError String (t (ExceptT String IO))-       )-    => (t (ExceptT String IO) Int -> SerialT (ExceptT String IO) Int) -> Spec-_composeWithMonadError t = do-    let tl = S.toList . t-    it "Compose throwError, nil" $-        runExceptT (tl (throwError "E" <> S.nil)) `shouldReturn` Left "E"-    it "Compose nil, error" $-        runExceptT (tl (S.nil <> throwError "E")) `shouldReturn` Left "E"--nestTwoSerial :: Expectation-nestTwoSerial =-    let s1 = S.foldMapWith (<>) return [1..4]-        s2 = S.foldMapWith (<>) return [5..8]-    in toListSerial (do-        x <- s1-        y <- s2-        return (x + y)-        ) `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])--nestTwoAhead :: Expectation-nestTwoAhead =-    let s1 = S.foldMapWith (<>) return [1..4]-        s2 = S.foldMapWith (<>) return [5..8]-    in (S.toList . aheadly) (do-        x <- s1-        y <- s2-        return (x + y)-        ) `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])--nestTwoSerialApp :: Expectation-nestTwoSerialApp =-    let s1 = S.foldMapWith (<>) return [1..4]-        s2 = S.foldMapWith (<>) return [5..8]-    in toListSerial ((+) <$> s1 <*> s2)-        `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])--nestTwoAheadApp :: Expectation-nestTwoAheadApp =-    let s1 = S.foldMapWith (<>) return [1..4]-        s2 = S.foldMapWith (<>) return [5..8]-    in (S.toList . aheadly) ((+) <$> s1 <*> s2)-        `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])--nestTwoInterleaved :: Expectation-nestTwoInterleaved =-    let s1 = S.foldMapWith (<>) return [1..4]-        s2 = S.foldMapWith (<>) return [5..8]-    in toListInterleaved (do-        x <- s1-        y <- s2-        return (x + y)-        ) `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])--nestTwoInterleavedApp :: Expectation-nestTwoInterleavedApp =-    let s1 = S.foldMapWith (<>) return [1..4]-        s2 = S.foldMapWith (<>) return [5..8]-    in toListInterleaved ((+) <$> s1 <*> s2)-        `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])--nestTwoAsync :: Expectation-nestTwoAsync =-    let s1 = S.foldMapWith (<>) return [1..4]-        s2 = S.foldMapWith (<>) return [5..8]-    in sort <$> toListAsync (do-        x <- s1-        y <- s2-        return (x + y))-    `shouldReturn` sort ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])--nestTwoAsyncApp :: Expectation-nestTwoAsyncApp =-    let s1 = S.foldMapWith (<>) return [1..4]-        s2 = S.foldMapWith (<>) return [5..8]-    in sort <$> toListAsync ((+) <$> s1 <*> s2)-        `shouldReturn` sort ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])--nestTwoWAsync :: Expectation-nestTwoWAsync =-    let s1 = S.foldMapWith (<>) return [1..4]-        s2 = S.foldMapWith (<>) return [5..8]-    in sort <$> (S.toList . wAsyncly) (do-        x <- s1-        y <- s2-        return (x + y))-    `shouldReturn` sort ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])--nestTwoParallel :: Expectation-nestTwoParallel =-    let s1 = S.foldMapWith (<>) return [1..4]-        s2 = S.foldMapWith (<>) return [5..8]-    in sort <$> (S.toList . parallely) (do-        x <- s1-        y <- s2-        return (x + y))-    `shouldReturn` sort ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])--nestTwoWAsyncApp :: Expectation-nestTwoWAsyncApp =-    let s1 = S.foldMapWith (<>) return [1..4]-        s2 = S.foldMapWith (<>) return [5..8]-    in sort <$> (S.toList . wAsyncly) ((+) <$> s1 <*> s2)-        `shouldReturn` sort ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])--nestTwoParallelApp :: Expectation-nestTwoParallelApp =-    let s1 = S.foldMapWith (<>) return [1..4]-        s2 = S.foldMapWith (<>) return [5..8]-    in sort <$> (S.toList . parallely) ((+) <$> s1 <*> s2)-        `shouldReturn` sort ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])--interleaveCheck :: IsStream t-    => (t IO Int -> SerialT IO Int)-    -> (t IO Int -> t IO Int -> t IO Int)-    -> Spec-interleaveCheck t f =-    it "Interleave four" $-        (S.toList . t) ((singleton 0 `f` singleton 1) `f` (singleton 100 `f` singleton 101))-            `shouldReturn` [0, 100, 1, 101]--parallelCheck :: (IsStream t, Monad (t IO))-    => (t IO Int -> SerialT IO Int)-    -> (t IO Int -> t IO Int -> t IO Int)-    -> Spec-parallelCheck t f = do-    it "Parallel ordering left associated" $-        (S.toList . t) (((event 4 `f` event 3) `f` event 2) `f` event 1)-            `shouldReturn` [1..4]--    it "Parallel ordering right associated" $-        (S.toList . t) (event 4 `f` (event 3 `f` (event 2 `f` event 1)))-            `shouldReturn` [1..4]--    where event n = S.yieldM (threadDelay (n * 200000)) >> return n--compose :: (IsStream t, Semigroup (t IO Int))-    => (t IO Int -> SerialT IO Int) -> t IO Int -> ([Int] -> [Int]) -> Spec-compose t z srt = do-    -- XXX these should get covered by the property tests-    it "Compose mempty, mempty" $-        tl (z <> z) `shouldReturn` ([] :: [Int])-    it "Compose empty at the beginning" $-        tl (z <> singleton 1) `shouldReturn` [1]-    it "Compose empty at the end" $-        tl (singleton 1 <> z) `shouldReturn` [1]-    it "Compose two" $-        srt <$> tl (singleton 0 <> singleton 1)-            `shouldReturn` [0, 1]-    it "Compose many" $-        srt <$> tl (S.forEachWith (<>) [1..100] singleton)-            `shouldReturn` [1..100]--    -- These are not covered by the property tests-    it "Compose three - empty in the middle" $-        srt <$> tl (singleton 0 <> z <> singleton 1)-            `shouldReturn` [0, 1]-    it "Compose left associated" $-        srt <$> tl (((singleton 0 <> singleton 1) <> singleton 2) <> singleton 3)-            `shouldReturn` [0, 1, 2, 3]-    it "Compose right associated" $-        srt <$> tl (singleton 0 <> (singleton 1 <> (singleton 2 <> singleton 3)))-            `shouldReturn` [0, 1, 2, 3]-    it "Compose hierarchical (multiple levels)" $-        srt <$> tl (((singleton 0 <> singleton 1) <> (singleton 2 <> singleton 3))-                <> ((singleton 4 <> singleton 5) <> (singleton 6 <> singleton 7)))-            `shouldReturn` [0..7]-    where tl = S.toList . t--composeAndComposeSimple-    :: ( IsStream t1, Semigroup (t1 IO Int)-       , IsStream t2, Monoid (t2 IO Int), Monad (t2 IO)-#if __GLASGOW_HASKELL__ < 804-       , Semigroup (t2 IO Int)-#endif-       )-    => (t1 IO Int -> SerialT IO Int)-    -> (t2 IO Int -> t2 IO Int)-    -> [[Int]] -> Spec-composeAndComposeSimple t1 t2 answer = do-    let rfold = adapt . t2 . S.foldMapWith (<>) return-    it "Compose right associated outer expr, right folded inner" $-         (S.toList . t1) (rfold [1,2,3] <> (rfold [4,5,6] <> rfold [7,8,9]))-            `shouldReturn` head answer--    it "Compose left associated outer expr, right folded inner" $-         (S.toList . t1) ((rfold [1,2,3] <> rfold [4,5,6]) <> rfold [7,8,9])-            `shouldReturn` (answer !! 1)--    let lfold xs = adapt $ t2 $ foldl (<>) mempty $ fmap return xs-    it "Compose right associated outer expr, left folded inner" $-         (S.toList . t1) (lfold [1,2,3] <> (lfold [4,5,6] <> lfold [7,8,9]))-            `shouldReturn` (answer !! 2)--    it "Compose left associated outer expr, left folded inner" $-         (S.toList . t1) ((lfold [1,2,3] <> lfold [4,5,6]) <> lfold [7,8,9])-            `shouldReturn` (answer !! 3)--loops-    :: (IsStream t, Semigroup (t IO Int), Monad (t IO))-    => (t IO Int -> t IO Int)-    -> ([Int] -> [Int])-    -> ([Int] -> [Int])-    -> Spec-loops t tsrt hsrt = do-    it "Tail recursive loop" $ (tsrt <$> (S.toList . adapt) (loopTail 0))-            `shouldReturn` [0..3]--    it "Head recursive loop" $ (hsrt <$> (S.toList . adapt) (loopHead 0))-            `shouldReturn` [0..3]--    where-        loopHead x = do-            -- this print line is important for the test (causes a bind)-            S.yieldM $ putStrLn "LoopHead..."-            t $ (if x < 3 then loopHead (x + 1) else nil) <> return x--        loopTail x = do-            -- this print line is important for the test (causes a bind)-            S.yieldM $ putStrLn "LoopTail..."-            t $ return x <> (if x < 3 then loopTail (x + 1) else nil)--bindAndComposeSimple-    :: ( IsStream t1, IsStream t2, Semigroup (t2 IO Int), Monad (t2 IO))-    => (t1 IO Int -> SerialT IO Int)-    -> (t2 IO Int -> t2 IO Int)-    -> Spec-bindAndComposeSimple t1 t2 = do-    -- XXX need a bind in the body of forEachWith instead of a simple return-    it "Compose many (right fold) with bind" $-        (sort <$> (S.toList . t1)-                    (adapt . t2 $ S.forEachWith (<>) [1..10 :: Int] return))-            `shouldReturn` [1..10]--    it "Compose many (left fold) with bind" $-        let forL xs k = foldl (<>) nil $ fmap k xs-         in (sort <$> (S.toList . t1) (adapt . t2 $ forL [1..10 :: Int] return))-            `shouldReturn` [1..10]--bindAndComposeHierarchy-    :: ( IsStream t1, Monad (t1 IO)-       , IsStream t2, Monad (t2 IO))-    => (t1 IO Int -> SerialT IO Int)-    -> (t2 IO Int -> t2 IO Int)-    -> ([t2 IO Int] -> t2 IO Int)-    -> Spec-bindAndComposeHierarchy t1 t2 g =-    it "Bind and compose nested" $-        (sort <$> (S.toList . t1) bindComposeNested)-            `shouldReturn` (sort (-                   [12, 18]-                <> replicate 3 13-                <> replicate 3 17-                <> replicate 6 14-                <> replicate 6 16-                <> replicate 7 15) :: [Int])--    where--    -- bindComposeNested :: WAsyncT IO Int-    bindComposeNested =-        let c1 = tripleCompose (return 1) (return 2) (return 3)-            c2 = tripleCompose (return 4) (return 5) (return 6)-            c3 = tripleCompose (return 7) (return 8) (return 9)-            b = tripleBind c1 c2 c3--- it seems to be causing a huge space leak in hspec so disabling this for now---            c = tripleCompose b b b---            m = tripleBind c c c---         in m-         in b--    tripleCompose a b c = adapt . t2 $ g [a, b, c]-    tripleBind mx my mz =-        mx >>= \x -> my-           >>= \y -> mz-           >>= \z -> return (x + y + z)--mixedOps :: Spec-mixedOps =-    it "Compose many ops" $-        (sort <$> toListSerial composeMixed)-            `shouldReturn` ([8,9,9,9,9,9,10,10,10,10,10,10,10,10,10,10,11,11-                            ,11,11,11,11,11,11,11,11,12,12,12,12,12,13-                            ] :: [Int])-    where--    composeMixed :: SerialT IO Int-    composeMixed = do-        S.yieldM $ return ()-        S.yieldM $ putStr ""-        let x = 1-        let y = 2-        z <- do-                x1 <- wAsyncly $ return 1 <> return 2-                S.yieldM $ return ()-                S.yieldM $ putStr ""-                y1 <- asyncly $ return 1 <> return 2-                z1 <- do-                    x11 <- return 1 <> return 2-                    y11 <- asyncly $ return 1 <> return 2-                    z11 <- wSerially $ return 1 <> return 2-                    S.yieldM $ return ()-                    S.yieldM $ putStr ""-                    return (x11 + y11 + z11)-                return (x1 + y1 + z1)-        return (x + y + z)--mixedOpsAheadly :: Spec-mixedOpsAheadly =-    it "Compose many ops" $-        (sort <$> toListSerial composeMixed)-            `shouldReturn` ([8,9,9,9,9,9,10,10,10,10,10,10,10,10,10,10,11,11-                            ,11,11,11,11,11,11,11,11,12,12,12,12,12,13-                            ] :: [Int])-    where--    composeMixed :: SerialT IO Int-    composeMixed = do-        S.yieldM $ return ()-        S.yieldM $ putStr ""-        let x = 1-        let y = 2-        z <- do-                x1 <- wAsyncly $ return 1 <> return 2-                S.yieldM $ return ()-                S.yieldM $ putStr ""-                y1 <- aheadly $ return 1 <> return 2-                z1 <- do-                    x11 <- return 1 <> return 2-                    y11 <- aheadly $ return 1 <> return 2-                    z11 <- parallely $ return 1 <> return 2-                    S.yieldM $ return ()-                    S.yieldM $ putStr ""-                    return (x11 + y11 + z11)-                return (x1 + y1 + z1)-        return (x + y + z)--testFromCallback :: IO Int-testFromCallback = do-    ref <- newIORef Nothing-    let stream = S.map Just (IP.fromCallback (setCallback ref))-                    `Streamly.parallel` runCallback ref-    S.sum $ S.map fromJust $ S.takeWhile isJust stream--    where--    setCallback ref cb = do-        writeIORef ref (Just cb)--    runCallback ref = S.yieldM $ do-        cb <--              S.repeatM (readIORef ref)-                & IP.delayPost 0.1-                & S.mapMaybe id-                & S.head--        S.fromList [1..100]-            & IP.delayPost 0.001-            & S.mapM_ (fromJust cb)-        threadDelay 100000-        return Nothing
− test/MaxRate.hs 
@@ -1,227 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}--import Streamly-import qualified Streamly.Prelude as S-import Control.Concurrent-import Control.Monad-import System.Clock-import Test.Hspec-import System.Random--durationShouldBe :: (Double, Double) -> IO () -> Expectation-durationShouldBe d@(tMin, tMax) action = do-        t0 <- getTime Monotonic-        action-        t1 <- getTime Monotonic-        let t = fromIntegral (toNanoSecs (t1 - t0)) / 1e9-            -- tMax = fromNanoSecs (round $ d*10^9*1.2)-            -- tMin = fromNanoSecs (round $ d*10^9*0.8)-        putStrLn $ "Expected: " <> show d <> " Took: " <> show t-        (t <= tMax && t >= tMin) `shouldBe` True--toMicroSecs :: Num a => a -> a-toMicroSecs x = x * 10^(6 :: Int)--measureRate' :: IsStream t-    => String-    -> (t IO Int -> SerialT IO Int)-    -> Int -- buffers-    -> Int -- threads-    -> Either Double Int  -- either rate or count of actions-    -> Int-    -> (Double, Double)-    -> (Double, Double)-    -> Spec-measureRate' desc t buffers threads rval consumerDelay producerDelay expectedRange = do--    let threadAction =-            case rval of-                Left r -> S.take (round $ 10 * r) . S.repeatM-                Right n -> S.replicateM n--        rateDesc = case rval of-            Left r ->  " rate: " <> show r-            Right n -> " count: " <> show n--    it (desc <> rateDesc-             <> " buffers: " <> show buffers-             <> " threads: " <> show threads-             <> ", consumer latency: " <> show consumerDelay-             <> ", producer latency: " <> show producerDelay)-        $ durationShouldBe expectedRange $-            runStream-                $ (if consumerDelay > 0-                  then S.mapM $ \x ->-                            threadDelay (toMicroSecs consumerDelay) >> return x-                  else id)-                $ t-                $ maxBuffer  buffers-                $ maxThreads threads-                $ (case rval of {Left r -> avgRate r; Right _ -> rate Nothing})-                $ threadAction $ do-                    let (t1, t2) = producerDelay-                    r <- if t1 == t2-                         then return $ round $ toMicroSecs t1-                         else randomRIO ( round $ toMicroSecs t1-                                        , round $ toMicroSecs t2)-                    when (r > 0) $ -- do-                        -- t1 <- getTime Monotonic-                        threadDelay r-                        -- t2 <- getTime Monotonic-                        -- let delta = fromIntegral (toNanoSecs (t2 - t1)) / 1000000000-                        -- putStrLn $ "delay took: " <> show delta-                        -- when (delta > 2) $ do-                        --     putStrLn $ "delay took high: " <> show delta-                    return 1--measureRateVariable :: IsStream t-    => String-    -> (t IO Int -> SerialT IO Int)-    -> Double-    -> Int-    -> (Double, Double)-    -> (Double, Double)-    -> Spec-measureRateVariable desc t rval consumerDelay producerDelay dur =-    measureRate' desc t (-1) (-1) (Left rval)-                 consumerDelay producerDelay dur--measureRate :: IsStream t-    => String-    -> (t IO Int -> SerialT IO Int)-    -> Double-    -> Int-    -> Int-    -> (Double, Double)-    -> Spec-measureRate desc t rval consumerDelay producerDelay dur =-    let d = fromIntegral producerDelay-    in measureRateVariable desc t rval consumerDelay (d, d) dur--measureThreads :: IsStream t-    => String-    -> (t IO Int -> SerialT IO Int)-    -> Int -- threads-    -> Int -- count of actions-    -> Spec-measureThreads desc t threads count = do-    let expectedTime =-            if threads < 0-            then 1.0-            else fromIntegral count / fromIntegral threads-        duration = (expectedTime * 0.9, expectedTime * 1.1)-    measureRate' desc t (-1) threads (Right count) 0 (1,1) duration--measureBuffers :: IsStream t-    => String-    -> (t IO Int -> SerialT IO Int)-    -> Int -- buffers-    -> Int -- count of actions-    -> Spec-measureBuffers desc t buffers count = do-    let expectedTime =-            if buffers < 0-            then 1.0-            else fromIntegral count / fromIntegral buffers-        duration = (expectedTime * 0.9, expectedTime * 1.1)-    measureRate' desc t buffers (-1) (Right count) 0 (1,1) duration--main :: IO ()-main = hspec $ do--    describe "maxBuffers" $ do-        measureBuffers "asyncly" asyncly (-1) 5-        -- XXX this test fails due to a known issue-        -- measureBuffers "maxBuffers" asyncly 1 5-        measureBuffers "asyncly" asyncly 5 5--    describe "maxThreads" $ do-        measureThreads "asyncly" asyncly (-1) 5-        measureThreads "asyncly" asyncly 1 5-        measureThreads "asyncly" asyncly 5 5--        measureThreads "aheadly" aheadly (-1) 5-        measureThreads "aheadly" aheadly 1 5-        measureThreads "aheadly" aheadly 5 5--    let range = (8,12)--    -- Note that because after the last yield we don't wait, the last period-    -- will be effectively shorter. This becomes significant when the rates are-    -- lower (1 or lower). For rate 1 we lose 1 second in the end and for rate-    -- 10 0.1 second.-    let rates = [1, 10, 100, 1000, 10000-#ifndef __GHCJS__-                , 100000, 1000000-#endif-                ]-     in describe "asyncly no consumer delay no producer delay" $-            forM_ rates (\r -> measureRate "asyncly" asyncly r 0 0 range)--    -- XXX try staggering the dispatches to achieve higher rates-    let rates = [1, 10, 100, 1000-#ifndef __GHCJS__-                , 10000, 25000-#endif-                ]-     in describe "asyncly no consumer delay and 1 sec producer delay" $-            forM_ rates (\r -> measureRate "asyncly" asyncly r 0 1 range)--    -- At lower rates (1/10) this is likely to vary quite a bit depending on-    -- the spread of random producer latencies generated.-    let rates = [1, 10, 100, 1000-#ifndef __GHCJS__-                , 10000, 25000-#endif-                ]-     in describe "asyncly no consumer delay and variable producer delay" $-            forM_ rates $ \r ->-                measureRateVariable "asyncly" asyncly r 0 (0.1, 3) range--    let rates = [1, 10, 100, 1000, 10000-#ifndef __GHCJS__-                , 100000, 1000000-#endif-                ]-     in describe "wAsyncly no consumer delay no producer delay" $-            forM_ rates (\r -> measureRate "wAsyncly" wAsyncly r 0 0 range)--    let rates = [1, 10, 100, 1000-#ifndef __GHCJS__-                , 10000, 25000-#endif-                ]-     in describe "wAsyncly no consumer delay and 1 sec producer delay" $-            forM_ rates (\r -> measureRate "wAsyncly" wAsyncly r 0 1 range)--    let rates = [1, 10, 100, 1000, 10000-#ifndef __GHCJS__-                , 100000, 1000000-#endif-                ]-     in describe "aheadly no consumer delay no producer delay" $-            forM_ rates (\r -> measureRate "aheadly" aheadly r 0 0 range)--    -- XXX after the change to stop workers when the heap is clearing-    -- thi does not work well at a 25000 ops per second, need to fix.-    let rates = [1, 10, 100, 1000-#ifndef __GHCJS__-                , 10000, 12500-#endif-                ]-     in describe "aheadly no consumer delay and 1 sec producer delay" $-            forM_ rates (\r -> measureRate "aheadly" aheadly r 0 1 range)--    describe "asyncly with 1 sec producer delay and some consumer delay" $ do-        -- ideally it should take 10 x 1 + 1 seconds-        forM_ [1] (\r -> measureRate "asyncly" asyncly r 1 1 (11, 16))-        -- ideally it should take 10 x 2 + 1 seconds-        forM_ [1] (\r -> measureRate "asyncly" asyncly r 2 1 (21, 23))-        -- ideally it should take 10 x 3 + 1 seconds-        forM_ [1] (\r -> measureRate "asyncly" asyncly r 3 1 (31, 33))--    describe "aheadly with 1 sec producer delay and some consumer delay" $ do-        forM_ [1] (\r -> measureRate "aheadly" aheadly r 1 1 (11, 16))-        forM_ [1] (\r -> measureRate "aheadly" aheadly r 2 1 (21, 23))-        forM_ [1] (\r -> measureRate "aheadly" aheadly r 3 1 (31, 33))
− test/Prop.hs 
@@ -1,1328 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE TypeFamilies #-}--module Main (main) where--import Control.Applicative (ZipList(..))-import Control.Concurrent (MVar, takeMVar, putMVar, newEmptyMVar)-import Control.Exception-       (BlockedIndefinitelyOnMVar(..), catches,-        BlockedIndefinitelyOnSTM(..), Handler(..))-import Control.Monad (when, forM_, replicateM, replicateM_)-import Control.Monad.IO.Class (MonadIO(..))-import Data.Function ((&))-import Data.IORef (readIORef, modifyIORef, newIORef, modifyIORef', IORef)-import Data.List-       (sort, foldl', scanl', findIndices, findIndex, elemIndices,-        elemIndex, find, insertBy, intersperse, foldl1', (\\),-        maximumBy, minimumBy, deleteBy, isPrefixOf, isSubsequenceOf,-        stripPrefix, intercalate)-import Data.Maybe (mapMaybe)-import GHC.Word (Word8)--import Test.Hspec.QuickCheck-import Test.QuickCheck-       (counterexample, Property, withMaxSuccess, forAll, choose, Gen,-       arbitrary, elements, frequency, listOf) --, listOf1, vectorOf, suchThat)-import Test.QuickCheck.Monadic (run, monadicIO, monitor, assert, PropertyM)--import Test.Hspec as H--import Streamly-import Streamly.Prelude ((.:), nil)-import Streamly as S-import qualified Streamly.Prelude as S-import qualified Streamly.Data.Fold as FL-import qualified Streamly.Internal.Data.Fold as FL---- Coverage build takes too long with default number of tests-maxTestCount :: Int-#ifdef DEVBUILD-maxTestCount = 100-#else-maxTestCount = 10-#endif--singleton :: IsStream t => a -> t m a-singleton a = a .: nil--sortEq :: Ord a => [a] -> [a] -> Bool-sortEq a b = sort a == sort b--equals-    :: (Show a, Monad m)-    => (a -> a -> Bool) -> a -> a -> PropertyM m ()-equals eq stream list = do-    when (not $ stream `eq` list) $-        monitor-            (counterexample $-             "stream " <> show stream-             <> "\nlist   " <> show list-            )-    assert (stream `eq` list)--listEquals-    :: (Show a, Eq a, MonadIO m)-    => ([a] -> [a] -> Bool) -> [a] -> [a] -> PropertyM m ()-listEquals eq stream list = do-    when (not $ stream `eq` list) $ liftIO $ putStrLn $-                  "stream " <> show stream-             <> "\nlist   " <> show list-             <> "\nstream \\\\ list " <> show (stream \\ list)-             <> "\nlist \\\\ stream " <> show (list \\ stream)-    when (not $ stream `eq` list) $-        monitor-            (counterexample $-                  "stream " <> show stream-             <> "\nlist   " <> show list-             <> "\nstream \\\\ list " <> show (stream \\ list)-             <> "\nlist \\\\ stream " <> show (list \\ stream)-             )-    assert (stream `eq` list)------------------------------------------------------------------------------------ Construction operations----------------------------------------------------------------------------------constructWithLen-    :: (Show a, Eq a)-    => (Int -> t IO a)-    -> (Int -> [a])-    -> (t IO a -> SerialT IO a)-    -> Word8-    -> Property-constructWithLen mkStream mkList op len = withMaxSuccess maxTestCount $-    monadicIO $ do-        stream <- run $ (S.toList . op) (mkStream (fromIntegral len))-        let list = mkList (fromIntegral len)-        listEquals (==) stream list--constructWithLenM-    :: (Int -> t IO Int)-    -> (Int -> IO [Int])-    -> (t IO Int -> SerialT IO Int)-    -> Word8-    -> Property-constructWithLenM mkStream mkList op len = withMaxSuccess maxTestCount $-    monadicIO $ do-        stream <- run $ (S.toList . op) (mkStream (fromIntegral len))-        list <- run $ mkList (fromIntegral len)-        listEquals (==) stream list--constructWithReplicate, constructWithReplicateM, constructWithIntFromThenTo-    :: IsStream t-    => (t IO Int -> SerialT IO Int)-    -> Word8-    -> Property--constructWithReplicateM = constructWithLenM stream list-    where list = flip replicateM (return 1 :: IO Int)-          stream = flip S.replicateM (return 1 :: IO Int)--constructWithReplicate = constructWithLen stream list-    where list = flip replicate (1 :: Int)-          stream = flip S.replicate (1 :: Int)--constructWithIntFromThenTo op l =-    forAll (choose (minBound, maxBound)) $ \from ->-    forAll (choose (minBound, maxBound)) $ \next ->-    forAll (choose (minBound, maxBound)) $ \to ->-        let list len = take len [from,next..to]-            stream len = S.take len $ S.enumerateFromThenTo from next to-        in constructWithLen stream list op l--#if __GLASGOW_HASKELL__ >= 806--- XXX try very small steps close to 0-constructWithDoubleFromThenTo-    :: IsStream t-    => (t IO Double -> SerialT IO Double)-    -> Word8-    -> Property-constructWithDoubleFromThenTo op l =-    forAll (choose (-9007199254740999,9007199254740999)) $ \from ->-    forAll (choose (-9007199254740999,9007199254740999)) $ \next ->-    forAll (choose (-9007199254740999,9007199254740999)) $ \to ->-        let list len = take len [from,next..to]-            stream len = S.take len $ S.enumerateFromThenTo from next to-        in constructWithLen stream list op l-#endif--constructWithIterate ::-       IsStream t => (t IO Int -> SerialT IO Int) -> Word8 -> Property-constructWithIterate op len =-    withMaxSuccess maxTestCount $-    monadicIO $ do-        stream <--            run $-            (S.toList . op . S.take (fromIntegral len))-                (S.iterate (+ 1) (0 :: Int))-        let list = take (fromIntegral len) (iterate (+ 1) 0)-        listEquals (==) stream list--constructWithIterateM ::-       IsStream t => (t IO Int -> SerialT IO Int) -> Word8 -> Property-constructWithIterateM op len =-    withMaxSuccess maxTestCount $-    monadicIO $ do-        mvl <- run (newIORef [] :: IO (IORef [Int]))-        let addM mv x y = modifyIORef' mv (++ [y + x]) >> return (y + x)-            list = take (fromIntegral len) (iterate (+ 1) 0)-        run $-            S.drain . op $-            S.take (fromIntegral len) $-            S.iterateM (addM mvl 1) (addM mvl 0 0 :: IO Int)-        streamEffect <- run $ readIORef mvl-        listEquals (==) streamEffect list--constructWithFromIndices ::-       IsStream t => (t IO Int -> SerialT IO Int) -> Word8 -> Property-constructWithFromIndices op len =-    withMaxSuccess maxTestCount $-    monadicIO $ do-        stream <--            run $ (S.toList . op . S.take (fromIntegral len)) (S.fromIndices id)-        let list = take (fromIntegral len) (iterate (+ 1) 0)-        listEquals (==) stream list--constructWithFromIndicesM ::-       IsStream t => (t IO Int -> SerialT IO Int) -> Word8 -> Property-constructWithFromIndicesM op len =-    withMaxSuccess maxTestCount $-    monadicIO $ do-        mvl <- run (newIORef [] :: IO (IORef [Int]))-        let addIndex mv i = modifyIORef' mv (++ [i]) >> return i-            list = take (fromIntegral len) (iterate (+ 1) 0)-        run $-            S.drain . op $-            S.take (fromIntegral len) $ S.fromIndicesM (addIndex mvl)-        streamEffect <- run $ readIORef mvl-        listEquals (==) streamEffect list------------------------------------------------------------------------------------ Concurrent generation----------------------------------------------------------------------------------mvarExcHandler :: String -> BlockedIndefinitelyOnMVar -> IO ()-mvarExcHandler label BlockedIndefinitelyOnMVar =-    error $ label <> " " <> "BlockedIndefinitelyOnMVar\n"--stmExcHandler :: String -> BlockedIndefinitelyOnSTM -> IO ()-stmExcHandler label BlockedIndefinitelyOnSTM =-    error $ label <> " " <> "BlockedIndefinitelyOnSTM\n"--dbgMVar :: String -> IO () -> IO ()-dbgMVar label action =-    action `catches` [ Handler (mvarExcHandler label)-                     , Handler (stmExcHandler label)-                     ]---- | first n actions takeMVar and the last action performs putMVar n times-mvarSequenceOp :: MVar () -> Word8 -> Word8 -> IO Word8-mvarSequenceOp mv n x = do-    let msg = show x <> "/" <> show n-    if x < n-    then dbgMVar ("take mvarSequenceOp " <> msg) (takeMVar mv) >>  return x-    else dbgMVar ("put mvarSequenceOp" <> msg)-            (replicateM_ (fromIntegral n) (putMVar mv ())) >> return x--concurrentMapM-    :: ([Word8] -> t IO Word8)-    -> ([Word8] -> [Word8] -> Bool)-    -> (Word8 -> MVar () -> t IO Word8 -> SerialT IO Word8)-    -> Word8-    -> Property-concurrentMapM constr eq op n =-    monadicIO $ do-        let list = [0..n]-        stream <- run $ do-            mv <- newEmptyMVar :: IO (MVar ())-            (S.toList . op n mv) (constr list)-        listEquals eq stream list--concurrentFromFoldable-    :: IsStream t-    => ([Word8] -> [Word8] -> Bool)-    -> (t IO Word8 -> SerialT IO Word8)-    -> Word8-    -> Property-concurrentFromFoldable eq op n =-    monadicIO $ do-        let list = [0..n]-        stream <- run $ do-            mv <- newEmptyMVar :: IO (MVar ())-            (S.toList . op) (S.fromFoldableM (fmap (mvarSequenceOp mv n) list))-        listEquals eq stream list--sourceUnfoldrM :: IsStream t => MVar () -> Word8 -> t IO Word8-sourceUnfoldrM mv n = S.unfoldrM step 0-    where-    -- argument must be integer to avoid overflow of word8 at 255-    step :: Int -> IO (Maybe (Word8, Int))-    step cnt = do-        let msg = show cnt <> "/" <> show n-        if cnt > fromIntegral n-        then return Nothing-        else do-            dbgMVar ("put sourceUnfoldrM " <> msg) (putMVar mv ())-            return (Just (fromIntegral cnt, cnt + 1))---- Note that this test is not guaranteed to succeed, because there is no--- guarantee of parallelism in case of Async/Ahead streams.-concurrentUnfoldrM-    :: IsStream t-    => ([Word8] -> [Word8] -> Bool)-    -> (t IO Word8 -> SerialT IO Word8)-    -> Word8-    -> Property-concurrentUnfoldrM eq op n =-    monadicIO $ do-        -- XXX we should test empty list case as well-        let list = [0..n]-        stream <- run $ do-            -- putStrLn $ "concurrentUnfoldrM: " <> show n-            mv <- newEmptyMVar :: IO (MVar ())-            cnt <- newIORef 0-            -- since unfoldr happens in parallel with the stream processing we-            -- can do two takeMVar in one iteration. If it is not parallel then-            -- this will not work and the test will fail.-            S.toList $ do-                x <- op (sourceUnfoldrM mv n)-                -- results may not be yielded in order, in case of-                -- Async/WAsync/Parallel. So we use an increasing count-                -- instead.-                i <- S.yieldM $ readIORef cnt-                S.yieldM $ modifyIORef cnt (+1)-                let msg = show i <> "/" <> show n-                S.yieldM $-                    when (even i) $ do-                        dbgMVar ("first take concurrentUnfoldrM " <> msg)-                                (takeMVar mv)-                        when (n > i) $-                            dbgMVar ("second take concurrentUnfoldrM " <> msg)-                                     (takeMVar mv)-                return x-        listEquals eq stream list--concurrentOps-    :: IsStream t-    => ([Word8] -> t IO Word8)-    -> String-    -> ([Word8] -> [Word8] -> Bool)-    -> (t IO Word8 -> SerialT IO Word8)-    -> Spec-concurrentOps constr desc eq t = do-    let prop1 d p = prop d $ withMaxSuccess maxTestCount p--    prop1 (desc <> " fromFoldableM") $ concurrentFromFoldable eq t-    prop1 (desc <> " unfoldrM") $ concurrentUnfoldrM eq t-    -- we pass it the length of the stream n and an mvar mv.-    -- The stream is [0..n]. The threads communicate in such a way that the-    -- actions coming first in the stream are dependent on the last action. So-    -- if the stream is not processed concurrently it will block forever.-    -- Note that if the size of the stream is bigger than the thread limit-    -- then it will block even if it is concurrent.-    prop1 (desc <> " mapM") $-        concurrentMapM constr eq $ \n mv stream ->-            t $ S.mapM (mvarSequenceOp mv n) stream------------------------------------------------------------------------------------ Concurrent Application----------------------------------------------------------------------------------concurrentApplication :: IsStream t-    => ([Word8] -> [Word8] -> Bool)-    -> (t IO Word8 -> SerialT IO Word8)-    -> Word8-    -> Property-concurrentApplication eq t n = withMaxSuccess maxTestCount $-    monadicIO $ do-        -- XXX we should test empty list case as well-        let list = [0..n]-        stream <- run $ do-            -- putStrLn $ "concurrentApplication: " <> show n-            mv <- newEmptyMVar :: IO (MVar ())-            -- since unfoldr happens in parallel with the stream processing we-            -- can do two takeMVar in one iteration. If it is not parallel then-            -- this will not work and the test will fail.-            (S.toList . t) $-                sourceUnfoldrM mv n |&-                    S.mapM (\x -> do-                        let msg = show x <> "/" <> show n-                        when (even x) $ do-                            dbgMVar ("first take concurrentApp " <> msg)-                                    (takeMVar mv)-                            when (n > x) $-                                dbgMVar ("second take concurrentApp " <> msg)-                                         (takeMVar mv)-                        return x)-        listEquals eq stream list--sourceUnfoldrM1 :: IsStream t => Word8 -> t IO Word8-sourceUnfoldrM1 n = S.unfoldrM step 0-    where-    -- argument must be integer to avoid overflow of word8 at 255-    step :: Int -> IO (Maybe (Word8, Int))-    step cnt =-        if cnt > fromIntegral n-        then return Nothing-        else return (Just (fromIntegral cnt, cnt + 1))--concurrentFoldlApplication :: Word8 -> Property-concurrentFoldlApplication n =-    monadicIO $ do-        -- XXX we should test empty list case as well-        let list = [0..n]-        stream <- run $-            sourceUnfoldrM1 n |&. S.foldlM' (\xs x -> return (x : xs)) []-        listEquals (==) (reverse stream) list--concurrentFoldrApplication :: Word8 -> Property-concurrentFoldrApplication n =-    monadicIO $ do-        -- XXX we should test empty list case as well-        let list = [0..n]-        stream <- run $-            sourceUnfoldrM1 n |&. S.foldrM (\x xs -> xs >>= return . (x :))-                                           (return [])-        listEquals (==) stream list------------------------------------------------------------------------------------ Transformation operations----------------------------------------------------------------------------------transformCombineFromList-    :: Semigroup (t IO Int)-    => ([Int] -> t IO Int)-    -> ([Int] -> [Int] -> Bool)-    -> ([Int] -> [Int])-    -> (t IO Int -> SerialT IO Int)-    -> (t IO Int -> t IO Int)-    -> [Int]-    -> [Int]-    -> [Int]-    -> Property-transformCombineFromList constr eq listOp t op a b c =-    withMaxSuccess maxTestCount $-        monadicIO $ do-            stream <- run ((S.toList . t) $-                constr a <> op (constr b <> constr c))-            let list = a <> listOp (b <> c)-            listEquals eq stream list---- XXX add tests for MonadReader and MonadError etc. In case an SVar is--- accidentally passed through them.------ This tests transform ops along with detecting illegal sharing of SVar across--- conurrent streams. These tests work for all stream types whereas--- transformCombineOpsOrdered work only for ordered stream types i.e. excluding--- the Async type.-transformCombineOpsCommon-    :: (IsStream t, Semigroup (t IO Int))-    => ([Int] -> t IO Int)-    -> String-    -> ([Int] -> [Int] -> Bool)-    -> (t IO Int -> SerialT IO Int)-    -> Spec-transformCombineOpsCommon constr desc eq t = do-    let transform = transformCombineFromList constr eq--    -- Filtering-    prop (desc <> " filter False") $-        transform (filter (const False)) t (S.filter (const False))-    prop (desc <> " filter True") $-        transform (filter (const True)) t (S.filter (const True))-    prop (desc <> " filter even") $-        transform (filter even) t (S.filter even)--    prop (desc <> " filterM False") $-        transform (filter (const False)) t (S.filterM (const $ return False))-    prop (desc <> " filterM True") $-        transform (filter (const True)) t (S.filterM (const $ return True))-    prop (desc <> " filterM even") $-        transform (filter even) t (S.filterM (return . even))--    prop (desc <> " take maxBound") $-        transform (take maxBound) t (S.take maxBound)-    prop (desc <> " take 0") $ transform (take 0) t (S.take 0)--    prop (desc <> " takeWhile True") $-        transform (takeWhile (const True)) t (S.takeWhile (const True))-    prop (desc <> " takeWhile False") $-        transform (takeWhile (const False)) t (S.takeWhile (const False))--    prop (desc <> " takeWhileM True") $-        transform (takeWhile (const True)) t (S.takeWhileM (const $ return True))-    prop (desc <> " takeWhileM False") $-        transform (takeWhile (const False)) t (S.takeWhileM (const $ return False))--    prop (desc <> " drop maxBound") $-        transform (drop maxBound) t (S.drop maxBound)-    prop (desc <> " drop 0") $ transform (drop 0) t (S.drop 0)--    prop (desc <> " dropWhile True") $-        transform (dropWhile (const True)) t (S.dropWhile (const True))-    prop (desc <> " dropWhile False") $-        transform (dropWhile (const False)) t (S.dropWhile (const False))--    prop (desc <> " dropWhileM True") $-        transform (dropWhile (const True)) t (S.dropWhileM (const $ return True))-    prop (desc <> " dropWhileM False") $-        transform (dropWhile (const False)) t (S.dropWhileM (const $ return False))--    prop (desc <> " deleteBy (<=) maxBound") $-        transform (deleteBy (<=) maxBound) t (S.deleteBy (<=) maxBound)-    prop (desc <> " deleteBy (==) 4") $-        transform (deleteBy (==) 4) t (S.deleteBy (==) 4)--    -- transformation-    prop (desc <> " mapM (+1)") $-        transform (fmap (+1)) t (S.mapM (\x -> return (x + 1)))--    prop (desc <> " scanl'") $ transform (scanl' (flip const) 0) t-                                       (S.scanl' (flip const) 0)-    prop (desc <> " scanlM'") $ transform (scanl' (flip const) 0) t-                                       (S.scanlM' (\_ a -> return a) 0)-    prop (desc <> " scanl") $ transform (scanl' (flip const) 0) t-                                       (S.scanl' (flip const) 0)-    prop (desc <> " scanl1'") $ transform (scanl1 (flip const)) t-                                         (S.scanl1' (flip const))-    prop (desc <> " scanl1M'") $ transform (scanl1 (flip const)) t-                                          (S.scanl1M' (\_ a -> return a))--    let f x = if odd x then Just (x + 100) else Nothing-    prop (desc <> " mapMaybe") $ transform (mapMaybe f) t (S.mapMaybe f)--    -- tap-    prop (desc <> " tap FL.sum . map (+1)") $ \a b ->-        withMaxSuccess maxTestCount $-        monadicIO $ do-            cref <- run $ newIORef 0-            let sumfoldinref = FL.Fold (\_ e -> modifyIORef' cref (e+))-                                       (return ())-                                       (const $ return ())-                op = S.tap sumfoldinref . S.mapM (\x -> return (x+1))-                listOp = fmap (+1)-            stream <- run ((S.toList . t) $ op (constr a <> constr b))-            let list = listOp (a <> b)-            ssum <- run $ readIORef cref-            assert (sum list == ssum)-            listEquals eq stream list--    -- reordering-    prop (desc <> " reverse") $ transform reverse t S.reverse-    -- prop (desc <> " reverse'") $ transform reverse t S.reverse'--    -- inserting-    prop (desc <> " intersperseM") $-        forAll (choose (minBound, maxBound)) $ \n ->-            transform (intersperse n) t (S.intersperseM $ return n)-    prop (desc <> " insertBy 0") $-        forAll (choose (minBound, maxBound)) $ \n ->-            transform (insertBy compare n) t (S.insertBy compare n)--    -- multi-stream-    prop (desc <> " concatMap") $-        forAll (choose (0, 100)) $ \n ->-            transform (concatMap (const [1..n]))-                t (S.concatMap (const (S.fromList [1..n])))--toListFL :: Monad m => FL.Fold m a [a]-toListFL = FL.toList--groupSplitOps :: String -> Spec-groupSplitOps desc = do-    -- splitting-    -- XXX add tests with multichar separators too--{--    prop (desc <> " intercalate . splitOnSeq == id (nil separator)") $-        forAll listWithZeroes $ \xs -> do-            withMaxSuccess maxTestCount $-                monadicIO $ do-                    ys <- S.toList $ FL.splitOnSeq [] toListFL (S.fromList xs)-                    listEquals (==) (intercalate [] ys) xs--    prop (desc <> " intercalate . splitOnSeq == id (single element separator)") $-        forAll listWithZeroes $ \xs -> do-            withMaxSuccess maxTestCount $-                monadicIO $ do-                    ys <- S.toList $ FL.splitOnSeq [0] toListFL (S.fromList xs)-                    listEquals (==) (intercalate [0] ys) xs--    prop (desc <> " concat . splitOnSeq . intercalate == concat (nil separator/possibly empty list)") $-        forAll listsWithoutZeroes $ \xss -> do-            withMaxSuccess maxTestCount $-                monadicIO $ do-                    let xs = intercalate [] xss-                    ys <- S.toList $ FL.splitOnSeq [0] toListFL (S.fromList xs)-                    listEquals (==) (concat ys) (concat xss)--    prop (desc <> " concat . splitOnSeq . intercalate == concat (non-nil separator/possibly empty list)") $-        forAll listsWithoutZeroes $ \xss -> do-            withMaxSuccess maxTestCount $-                monadicIO $ do-                    let xs = intercalate [0] xss-                    ys <- S.toList $ FL.splitOnSeq [0] toListFL (S.fromList xs)-                    listEquals (==) (concat ys) (concat xss)--    prop (desc <> " splitOnSeq . intercalate == id (exclusive separator/non-empty list)") $-        forAll listsWithoutZeroes1 $ \xss -> do-            withMaxSuccess maxTestCount $-                monadicIO $ do-                    let xs = intercalate [0] xss-                    ys <- S.toList $ FL.splitOnSeq [0] toListFL (S.fromList xs)-                    listEquals (==) ys xss--}--    prop (desc <> " intercalate [x] . splitOn (== x) == id") $-        forAll listWithZeroes $ \xs -> do-            withMaxSuccess maxTestCount $-                monadicIO $ do-                    ys <- S.toList $ S.splitOn (== 0) toListFL (S.fromList xs)-                    listEquals (==) (intercalate [0] ys) xs--    where--    listWithZeroes :: Gen [Int]-    listWithZeroes = listOf $ frequency [(3, arbitrary), (1, elements [0])]--{--    listWithoutZeroes = vectorOf 4 $ suchThat arbitrary (/= 0)--    listsWithoutZeroes :: Gen [[Int]]-    listsWithoutZeroes = listOf listWithoutZeroes--    listsWithoutZeroes1 :: Gen [[Int]]-    listsWithoutZeroes1 = listOf1 listWithoutZeroes--}---- transformation tests that can only work reliably for ordered streams i.e.--- Serial, Ahead and Zip. For example if we use "take 1" on an async stream, it--- might yield a different result every time.-transformCombineOpsOrdered-    :: (IsStream t, Semigroup (t IO Int))-    => ([Int] -> t IO Int)-    -> String-    -> ([Int] -> [Int] -> Bool)-    -> (t IO Int -> SerialT IO Int)-    -> Spec-transformCombineOpsOrdered constr desc eq t = do-    let transform = transformCombineFromList constr eq--    -- Filtering-    prop (desc <> " take 1") $ transform (take 1) t (S.take 1)-#ifdef DEVBUILD-    prop (desc <> " take 2") $ transform (take 2) t (S.take 2)-    prop (desc <> " take 3") $ transform (take 3) t (S.take 3)-    prop (desc <> " take 4") $ transform (take 4) t (S.take 4)-    prop (desc <> " take 5") $ transform (take 5) t (S.take 5)-#endif-    prop (desc <> " take 10") $ transform (take 10) t (S.take 10)--    prop (desc <> " takeWhile > 0") $-        transform (takeWhile (> 0)) t (S.takeWhile (> 0))--    prop (desc <> " drop 1") $ transform (drop 1) t (S.drop 1)-    prop (desc <> " drop 10") $ transform (drop 10) t (S.drop 10)--    prop (desc <> " dropWhile > 0") $-        transform (dropWhile (> 0)) t (S.dropWhile (> 0))-    prop (desc <> " scan") $ transform (scanl' (+) 0) t (S.scanl' (+) 0)--    prop (desc <> " uniq") $ transform referenceUniq t S.uniq--    prop (desc <> " deleteBy (<=) 0") $-        transform (deleteBy (<=) 0) t (S.deleteBy (<=) 0)--    prop (desc <> " findIndices") $-        transform (findIndices odd) t (S.findIndices odd)-    prop (desc <> " findIndices . filter") $-        transform (findIndices odd . filter odd)-                  t-                  (S.findIndices odd . S.filter odd)-    prop (desc <> " elemIndices") $-        transform (elemIndices 0) t (S.elemIndices 0)--    -- XXX this does not fail when the SVar is shared, need to fix.-    prop (desc <> " concurrent application") $-        transform (& fmap (+1)) t (|& S.map (+1))------------------------------------------------------------------------------------ Elimination operations----------------------------------------------------------------------------------eliminateOp-    :: (Show a, Eq a)-    => ([s] -> t IO s)-    -> ([s] -> a)-    -> (t IO s -> IO a)-    -> [s]-    -> Property-eliminateOp constr listOp op a =-    monadicIO $ do-        stream <- run $ op (constr a)-        let list = listOp a-        equals (==) stream list--wrapMaybe :: ([a1] -> a2) -> [a1] -> Maybe a2-wrapMaybe f x = if null x then Nothing else Just (f x)--wrapOutOfBounds :: ([a1] -> Int -> a2) -> Int -> [a1] -> Maybe a2-wrapOutOfBounds f i x | null x = Nothing-                      | i >= length x = Nothing-                      | otherwise = Just (f x i)--wrapThe :: Eq a => [a] -> Maybe a-wrapThe (x:xs)-    | all (x ==) xs = Just x-    | otherwise = Nothing-wrapThe [] = Nothing---- This is the reference uniq implementation to compare uniq against,--- we can use uniq from vector package, but for now this should--- suffice.-referenceUniq :: Eq a => [a] -> [a]-referenceUniq = go-  where-    go [] = []-    go (x:[]) = [x]-    go (x:y:xs)-        | x == y = go (x : xs)-        | otherwise = x : go (y : xs)--eliminationOps-    :: ([Int] -> t IO Int)-    -> String-    -> (t IO Int -> SerialT IO Int)-    -> Spec-eliminationOps constr desc t = do-    -- Elimination-    prop (desc <> " null") $ eliminateOp constr null $ S.null . t-    prop (desc <> " foldl'") $-        eliminateOp constr (foldl' (+) 0) $ S.foldl' (+) 0 . t-    prop (desc <> " foldl1'") $-        eliminateOp constr (wrapMaybe $ foldl1' (+)) $ S.foldl1' (+) . t-#ifdef DEVBUILD-    prop (desc <> " foldr1") $-        eliminateOp constr (wrapMaybe $ foldr1 (+)) $ S.foldr1 (+) . t-#endif-    prop (desc <> " all") $ eliminateOp constr (all even) $ S.all even . t-    prop (desc <> " any") $ eliminateOp constr (any even) $ S.any even . t-    prop (desc <> " and") $ eliminateOp constr (and . fmap (> 0)) $-        (S.and . S.map (> 0)) . t-    prop (desc <> " or") $ eliminateOp constr (or . fmap (> 0)) $-        (S.or . S.map (> 0)) . t-    prop (desc <> " length") $ eliminateOp constr length $ S.length . t-    prop (desc <> " sum") $ eliminateOp constr sum $ S.sum . t-    prop (desc <> " product") $ eliminateOp constr product $ S.product . t--    prop (desc <> " maximum") $-        eliminateOp constr (wrapMaybe maximum) $ S.maximum . t-    prop (desc <> " minimum") $-        eliminateOp constr (wrapMaybe minimum) $ S.minimum . t--    prop (desc <> " maximumBy compare") $-        eliminateOp constr (wrapMaybe $ maximumBy compare) $-        S.maximumBy compare . t-    prop (desc <> " maximumBy flip compare") $-        eliminateOp constr (wrapMaybe $ maximumBy $ flip compare) $-        S.maximumBy (flip compare) . t-    prop (desc <> " minimumBy compare") $-        eliminateOp constr (wrapMaybe $ minimumBy compare) $-        S.minimumBy compare . t-    prop (desc <> " minimumBy flip compare") $-        eliminateOp constr (wrapMaybe $ minimumBy $ flip compare) $-        S.minimumBy (flip compare) . t--    prop (desc <> " findIndex") $-        eliminateOp constr (findIndex odd) $ S.findIndex odd . t-    prop (desc <> " elemIndex") $-        eliminateOp constr (elemIndex 3) $ S.elemIndex 3 . t--    prop (desc <> " !! 5") $-        eliminateOp constr (wrapOutOfBounds (!!) 5) $ (S.!! 5) . t-    prop (desc <> " !! 4") $-        eliminateOp constr (wrapOutOfBounds (!!) 0) $ (S.!! 0) . t--    prop (desc <> " find") $ eliminateOp constr (find even) $ S.find even . t-    prop (desc <> " lookup") $-        eliminateOp constr (lookup 3 . flip zip [1..]) $-            S.lookup 3 . S.zipWith (\a b -> (b, a)) (S.fromList [(1::Int)..]) . t-    prop (desc <> " the") $ eliminateOp constr wrapThe $ S.the . t--    -- Multi-stream eliminations-    -- Add eqBy, cmpBy-    -- XXX Write better tests for substreams.-    prop (desc <> " isPrefixOf 10") $ eliminateOp constr (isPrefixOf [1..10]) $-        S.isPrefixOf (S.fromList [(1::Int)..10]) . t-    prop (desc <> " isSubsequenceOf 10") $-        eliminateOp constr (isSubsequenceOf $ filter even [1..10]) $-        S.isSubsequenceOf (S.fromList $ filter even [(1::Int)..10]) . t-    prop (desc <> " stripPrefix 10") $ eliminateOp constr (stripPrefix [1..10]) $-        (\s -> s >>= maybe (return Nothing) (fmap Just . S.toList)) .-        S.stripPrefix (S.fromList [(1::Int)..10]) . t---- head/tail/last may depend on the order in case of parallel streams--- so we test these only for serial streams.-eliminationOpsOrdered-    :: ([Int] -> t IO Int)-    -> String-    -> (t IO Int -> SerialT IO Int)-    -> Spec-eliminationOpsOrdered constr desc t = do-    prop (desc <> " head") $ eliminateOp constr (wrapMaybe head) $ S.head . t-    prop (desc <> " tail") $ eliminateOp constr (wrapMaybe tail) $ \x -> do-        r <- S.tail (t x)-        case r of-            Nothing -> return Nothing-            Just s -> Just <$> S.toList s-    prop (desc <> " last") $ eliminateOp constr (wrapMaybe last) $ S.last . t-    prop (desc <> " init") $ eliminateOp constr (wrapMaybe init) $ \x -> do-        r <- S.init (t x)-        case r of-            Nothing -> return Nothing-            Just s -> Just <$> S.toList s--elemOp-    :: ([Word8] -> t IO Word8)-    -> (t IO Word8 -> SerialT IO Word8)-    -> (Word8 -> SerialT IO Word8 -> IO Bool)-    -> (Word8 -> [Word8] -> Bool)-    -> (Word8, [Word8])-    -> Property-elemOp constr op streamOp listOp (x, xs) =-    monadicIO $ do-        stream <- run $ (streamOp x . op) (constr xs)-        let list = listOp x xs-        equals (==) stream list--eliminationOpsWord8-    :: ([Word8] -> t IO Word8)-    -> String-    -> (t IO Word8 -> SerialT IO Word8)-    -> Spec-eliminationOpsWord8 constr desc t = do-    prop (desc <> " elem") $ elemOp constr t S.elem elem-    prop (desc <> " notElem") $ elemOp constr t S.notElem notElem------------------------------------------------------------------------------------ Semigroup operations----------------------------------------------------------------------------------transformFromList-    :: (Eq b, Show b) =>-       ([a] -> t IO a)-    -> ([b] -> [b] -> Bool)-    -> ([a] -> [b])-    -> (t IO a -> SerialT IO b)-    -> [a]-    -> Property-transformFromList constr eq listOp op a =-    monadicIO $ do-        stream <- run ((S.toList . op) (constr a))-        let list = listOp a-        listEquals eq stream list--foldFromList-    :: ([Int] -> t IO Int)-    -> (t IO Int -> SerialT IO Int)-    -> ([Int] -> [Int] -> Bool)-    -> [Int]-    -> Property-foldFromList constr op eq = transformFromList constr eq id op---- XXX concatenate streams of multiple elements rather than single elements-semigroupOps-    :: (IsStream t--#if __GLASGOW_HASKELL__ < 804-       , Semigroup (t IO Int)-#endif-       , Monoid (t IO Int))-    => String-    -> ([Int] -> [Int] -> Bool)-    -> (t IO Int -> SerialT IO Int)-    -> Spec-semigroupOps desc eq t = do-    prop (desc <> " <>") $ foldFromList (S.foldMapWith (<>) singleton) t eq-    prop (desc <> " mappend") $ foldFromList (S.foldMapWith mappend singleton) t eq------------------------------------------------------------------------------------ Functor operations----------------------------------------------------------------------------------functorOps-    :: Functor (t IO)-    => ([Int] -> t IO Int)-    -> String-    -> ([Int] -> [Int] -> Bool)-    -> (t IO Int -> SerialT IO Int)-    -> Spec-functorOps constr desc eq t = do-    prop (desc <> " id") $ transformFromList constr eq id t-    prop (desc <> " fmap (+1)") $ transformFromList constr eq (fmap (+1)) $ t . fmap (+1)------------------------------------------------------------------------------------ Applicative operations----------------------------------------------------------------------------------applicativeOps-    :: Applicative (t IO)-    => ([Int] -> t IO Int)-    -> ([(Int, Int)] -> [(Int, Int)] -> Bool)-    -> (t IO (Int, Int) -> SerialT IO (Int, Int))-    -> ([Int], [Int])-    -> Property-applicativeOps constr eq t (a, b) = withMaxSuccess maxTestCount $-    monadicIO $ do-        stream <- run ((S.toList . t) ((,) <$> constr a <*> constr b))-        let list = (,) <$> a <*> b-        listEquals eq stream list------------------------------------------------------------------------------------ Zip operations----------------------------------------------------------------------------------zipApplicative-    :: (IsStream t, Applicative (t IO))-    => ([Int] -> t IO Int)-    -> ([(Int, Int)] -> [(Int, Int)] -> Bool)-    -> (t IO (Int, Int) -> SerialT IO (Int, Int))-    -> ([Int], [Int])-    -> Property-zipApplicative constr eq t (a, b) = withMaxSuccess maxTestCount $-    monadicIO $ do-        stream1 <- run ((S.toList . t) ((,) <$> constr a <*> constr b))-        stream2 <- run ((S.toList . t) (pure (,) <*> constr a <*> constr b))-        stream3 <- run ((S.toList . t) (S.zipWith (,) (constr a) (constr b)))-        let list = getZipList $ (,) <$> ZipList a <*> ZipList b-        listEquals eq stream1 list-        listEquals eq stream2 list-        listEquals eq stream3 list--zipMonadic-    :: IsStream t-    => ([Int] -> t IO Int)-    -> ([(Int, Int)] -> [(Int, Int)] -> Bool)-    -> (t IO (Int, Int) -> SerialT IO (Int, Int))-    -> ([Int], [Int])-    -> Property-zipMonadic constr eq t (a, b) = withMaxSuccess maxTestCount $-    monadicIO $ do-        stream1 <--            run-                ((S.toList . t)-                     (S.zipWithM (curry return) (constr a) (constr b)))-        let list = getZipList $ (,) <$> ZipList a <*> ZipList b-        listEquals eq stream1 list--zipAsyncMonadic-    :: IsStream t-    => ([Int] -> t IO Int)-    -> ([(Int, Int)] -> [(Int, Int)] -> Bool)-    -> (t IO (Int, Int) -> SerialT IO (Int, Int))-    -> ([Int], [Int])-    -> Property-zipAsyncMonadic constr eq t (a, b) = withMaxSuccess maxTestCount $-    monadicIO $ do-        stream1 <--            run-                ((S.toList . t)-                     (S.zipWithM (curry return) (constr a) (constr b)))-        stream2 <--            run-                ((S.toList . t)-                     (S.zipAsyncWithM (curry return) (constr a) (constr b)))-        let list = getZipList $ (,) <$> ZipList a <*> ZipList b-        listEquals eq stream1 list-        listEquals eq stream2 list------------------------------------------------------------------------------------ Monad operations----------------------------------------------------------------------------------monadThen-    :: Monad (t IO)-    => ([Int] -> t IO Int)-    -> ([Int] -> [Int] -> Bool)-    -> (t IO Int -> SerialT IO Int)-    -> ([Int], [Int])-    -> Property-monadThen constr eq t (a, b) = withMaxSuccess maxTestCount $ monadicIO $ do-    stream <- run ((S.toList . t) (constr a >> constr b))-    let list = a >> b-    listEquals eq stream list--monadBind-    :: Monad (t IO)-    => ([Int] -> t IO Int)-    -> ([Int] -> [Int] -> Bool)-    -> (t IO Int -> SerialT IO Int)-    -> ([Int], [Int])-    -> Property-monadBind constr eq t (a, b) = withMaxSuccess maxTestCount $-    monadicIO $ do-        stream <--            run-                ((S.toList . t)-                     (constr a >>= \x -> (+ x) <$> constr b))-        let list = a >>= \x -> (+ x) <$> b-        listEquals eq stream list--main :: IO ()-main = hspec-    $ H.parallel-#ifdef COVERAGE_BUILD-    $ modifyMaxSuccess (const 10)-#endif-    $ do-    let folded :: IsStream t => [a] -> t IO a-        folded = serially . (\xs ->-            case xs of-                [x] -> return x -- singleton stream case-                _ -> S.foldMapWith (<>) return xs-            )--    let makeCommonOps :: IsStream t => (t m a -> c) -> [(String, t m a -> c)]-        makeCommonOps t =-            [ ("default", t)-#ifndef COVERAGE_BUILD-            , ("rate AvgRate 10000", t . avgRate 10000)-            , ("rate Nothing", t . rate Nothing)-            , ("maxBuffer 0", t . maxBuffer 0)-            , ("maxThreads 0", t . maxThreads 0)-            , ("maxThreads 1", t . maxThreads 1)-            , ("maxThreads -1", t . maxThreads (-1))-#endif-            ]--    let makeOps :: IsStream t => (t m a -> c) -> [(String, t m a -> c)]-        makeOps t = makeCommonOps t ++-            [-#ifndef COVERAGE_BUILD-              ("maxBuffer 1", t . maxBuffer 1)-#endif-            ]--    -- For concurrent application test we need a buffer of at least size 2 to-    -- allow two threads to run.-    let makeConcurrentAppOps :: IsStream t-            => (t m a -> c) -> [(String, t m a -> c)]-        makeConcurrentAppOps t = makeCommonOps t ++-            [-#ifndef COVERAGE_BUILD-              ("maxBuffer 2", t . maxBuffer 2)-#endif-            ]--    let mapOps spec = mapM_ (\(desc, f) -> describe desc $ spec f)-    let serialOps :: IsStream t => ((SerialT IO a -> t IO a) -> Spec) -> Spec-        serialOps spec = mapOps spec $ makeOps serially-#ifndef COVERAGE_BUILD-            <> [("rate AvgRate 0.00000001", serially . avgRate 0.00000001)]-            <> [("maxBuffer -1", serially . maxBuffer (-1))]-#endif-    let wSerialOps :: IsStream t => ((WSerialT IO a -> t IO a) -> Spec) -> Spec-        wSerialOps spec = mapOps spec $ makeOps wSerially-#ifndef COVERAGE_BUILD-            <> [("rate AvgRate 0.00000001", wSerially . avgRate 0.00000001)]-            <> [("maxBuffer (-1)", wSerially . maxBuffer (-1))]-#endif-    let asyncOps :: IsStream t => ((AsyncT IO a -> t IO a) -> Spec) -> Spec-        asyncOps spec = mapOps spec $ makeOps asyncly-#ifndef COVERAGE_BUILD-            <> [("maxBuffer (-1)", asyncly . maxBuffer (-1))]-#endif-    let wAsyncOps :: IsStream t => ((WAsyncT IO a -> t IO a) -> Spec) -> Spec-        wAsyncOps spec = mapOps spec $ makeOps wAsyncly-#ifndef COVERAGE_BUILD-            <> [("maxBuffer (-1)", wAsyncly . maxBuffer (-1))]-#endif-    let aheadOps :: IsStream t => ((AheadT IO a -> t IO a) -> Spec) -> Spec-        aheadOps spec = mapOps spec $ makeOps aheadly-#ifndef COVERAGE_BUILD-              <> [("maxBuffer (-1)", aheadly . maxBuffer (-1))]-#endif-    let parallelCommonOps :: IsStream t => [(String, ParallelT m a -> t m a)]-        parallelCommonOps = []-#ifndef COVERAGE_BUILD-            <> [("rate AvgRate 0.00000001", parallely . avgRate 0.00000001)]-            <> [("maxBuffer (-1)", parallely . maxBuffer (-1))]-#endif-    let parallelOps :: IsStream t-            => ((ParallelT IO a -> t IO a) -> Spec) -> Spec-        parallelOps spec = mapOps spec $ makeOps parallely <> parallelCommonOps--    let parallelConcurrentAppOps :: IsStream t-            => ((ParallelT IO a -> t IO a) -> Spec) -> Spec-        parallelConcurrentAppOps spec =-            mapOps spec $ makeConcurrentAppOps parallely <> parallelCommonOps--    let zipSerialOps :: IsStream t-            => ((ZipSerialM IO a -> t IO a) -> Spec) -> Spec-        zipSerialOps spec = mapOps spec $ makeOps zipSerially-#ifndef COVERAGE_BUILD-            <> [("rate AvgRate 0.00000001", zipSerially . avgRate 0.00000001)]-            <> [("maxBuffer (-1)", zipSerially . maxBuffer (-1))]-#endif-    -- Note, the "pure" of applicative Zip streams generates and infinite-    -- stream and therefore maxBuffer (-1) must not be used for that case.-    let zipAsyncOps :: IsStream t => ((ZipAsyncM IO a -> t IO a) -> Spec) -> Spec-        zipAsyncOps spec = mapOps spec $ makeOps zipAsyncly--    describe "Construction" $ do-        serialOps   $ prop "serially replicate" . constructWithReplicate--        serialOps   $ prop "serially replicateM" . constructWithReplicateM-        wSerialOps  $ prop "wSerially replicateM" . constructWithReplicateM-        aheadOps    $ prop "aheadly replicateM" . constructWithReplicateM-        asyncOps    $ prop "asyncly replicateM" . constructWithReplicateM-        wAsyncOps   $ prop "wAsyncly replicateM" . constructWithReplicateM-        parallelOps $ prop "parallely replicateM" .  constructWithReplicateM--        serialOps   $ prop "serially intFromThenTo" .-                            constructWithIntFromThenTo-#if __GLASGOW_HASKELL__ >= 806-        serialOps   $ prop "serially DoubleFromThenTo" .-                            constructWithDoubleFromThenTo-#endif--        serialOps   $ prop "serially iterate" . constructWithIterate--        -- XXX test for all types of streams-        serialOps   $ prop "serially iterateM" . constructWithIterateM-        -- take doesn't work well on concurrent streams. Even though it-        -- seems like take only has a problem when used with parallely.-        -- wSerialOps $ prop "wSerially iterateM" wSerially . constructWithIterate-        -- aheadOps $ prop "aheadly iterateM" aheadly . onstructWithIterate-        -- asyncOps $ prop "asyncly iterateM" asyncly . constructWithIterate-        -- wAsyncOps $ prop "wAsyncly iterateM" wAsyncly . onstructWithIterate-        -- parallelOps $ prop "parallely iterateM" parallely . onstructWithIterate-        -- XXX add tests for fromIndices--        serialOps $ prop "serially fromIndices" . constructWithFromIndices--        serialOps $ prop "serially fromIndicesM" . constructWithFromIndicesM--    describe "Functor operations" $ do-        serialOps    $ functorOps S.fromFoldable "serially" (==)-        serialOps    $ functorOps folded "serially folded" (==)-        wSerialOps   $ functorOps S.fromFoldable "wSerially" (==)-        wSerialOps   $ functorOps folded "wSerially folded" (==)-        aheadOps     $ functorOps S.fromFoldable "aheadly" (==)-        aheadOps     $ functorOps folded "aheadly folded" (==)-        asyncOps     $ functorOps S.fromFoldable "asyncly" sortEq-        asyncOps     $ functorOps folded "asyncly folded" sortEq-        wAsyncOps    $ functorOps S.fromFoldable "wAsyncly" sortEq-        wAsyncOps    $ functorOps folded "wAsyncly folded" sortEq-        parallelOps  $ functorOps S.fromFoldable "parallely" sortEq-        parallelOps  $ functorOps folded "parallely folded" sortEq-        zipSerialOps $ functorOps S.fromFoldable "zipSerially" (==)-        zipSerialOps $ functorOps folded "zipSerially folded" (==)-        zipAsyncOps  $ functorOps S.fromFoldable "zipAsyncly" (==)-        zipAsyncOps  $ functorOps folded "zipAsyncly folded" (==)--    describe "Semigroup operations" $ do-        serialOps    $ semigroupOps "serially" (==)-        wSerialOps   $ semigroupOps "wSerially" (==)-        aheadOps     $ semigroupOps "aheadly" (==)-        asyncOps     $ semigroupOps "asyncly" sortEq-        wAsyncOps    $ semigroupOps "wAsyncly" sortEq-        parallelOps  $ semigroupOps "parallely" sortEq-        zipSerialOps $ semigroupOps "zipSerially" (==)-        zipAsyncOps  $ semigroupOps "zipAsyncly" (==)--    describe "Applicative operations" $ do-        -- The tests using sorted equality are weaker tests-        -- We need to have stronger unit tests for all those-        -- XXX applicative with three arguments-        serialOps   $ prop "serially applicative" . applicativeOps S.fromFoldable (==)-        serialOps   $ prop "serially applicative folded" . applicativeOps folded (==)-        wSerialOps  $ prop "wSerially applicative" . applicativeOps S.fromFoldable sortEq-        wSerialOps  $ prop "wSerially applicative folded" . applicativeOps folded sortEq-        aheadOps    $ prop "aheadly applicative" . applicativeOps S.fromFoldable (==)-        aheadOps    $ prop "aheadly applicative folded" . applicativeOps folded (==)-        asyncOps    $ prop "asyncly applicative" . applicativeOps S.fromFoldable sortEq-        asyncOps    $ prop "asyncly applicative folded" . applicativeOps folded sortEq-        wAsyncOps   $ prop "wAsyncly applicative" . applicativeOps S.fromFoldable sortEq-        wAsyncOps   $ prop "wAsyncly applicative folded" . applicativeOps folded sortEq-        parallelOps $ prop "parallely applicative folded" . applicativeOps folded sortEq--    -- XXX add tests for indexed/indexedR-    describe "Zip operations" $ do-        zipSerialOps $ prop "zipSerially applicative" . zipApplicative S.fromFoldable (==)-        zipSerialOps $ prop "zipSerially applicative folded" . zipApplicative folded (==)-        zipAsyncOps  $ prop "zipAsyncly applicative" . zipApplicative S.fromFoldable (==)-        zipAsyncOps  $ prop "zipAsyncly applicative folded" . zipApplicative folded (==)--        -- We test only the serial zip with serial streams and the parallel-        -- stream, because the rate setting in these streams can slow down-        -- zipAsync.-        serialOps   $ prop "zip monadic serially" . zipMonadic S.fromFoldable (==)-        serialOps   $ prop "zip monadic serially folded" . zipMonadic folded (==)-        wSerialOps  $ prop "zip monadic wSerially" . zipMonadic S.fromFoldable (==)-        wSerialOps  $ prop "zip monadic wSerially folded" . zipMonadic folded (==)-        aheadOps    $ prop "zip monadic aheadly" . zipAsyncMonadic S.fromFoldable (==)-        aheadOps    $ prop "zip monadic aheadly folded" . zipAsyncMonadic folded (==)-        asyncOps    $ prop "zip monadic asyncly" . zipAsyncMonadic S.fromFoldable (==)-        asyncOps    $ prop "zip monadic asyncly folded" . zipAsyncMonadic folded (==)-        wAsyncOps   $ prop "zip monadic wAsyncly" . zipAsyncMonadic S.fromFoldable (==)-        wAsyncOps   $ prop "zip monadic wAsyncly folded" . zipAsyncMonadic folded (==)-        parallelOps $ prop "zip monadic parallely" . zipMonadic S.fromFoldable (==)-        parallelOps $ prop "zip monadic parallely folded" . zipMonadic folded (==)--    -- XXX add merge tests like zip tests-    -- for mergeBy, we can split a list randomly into two lists and-    -- then merge them, it should result in original list-    -- describe "Merge operations" $ do--    describe "Monad operations" $ do-        serialOps   $ prop "serially monad then" . monadThen S.fromFoldable (==)-        wSerialOps  $ prop "wSerially monad then" . monadThen S.fromFoldable sortEq-        aheadOps    $ prop "aheadly monad then" . monadThen S.fromFoldable (==)-        asyncOps    $ prop "asyncly monad then" . monadThen S.fromFoldable sortEq-        wAsyncOps   $ prop "wAsyncly monad then" . monadThen S.fromFoldable sortEq-        parallelOps $ prop "parallely monad then" . monadThen S.fromFoldable sortEq--        serialOps   $ prop "serially monad then folded" . monadThen folded (==)-        wSerialOps  $ prop "wSerially monad then folded" . monadThen folded sortEq-        aheadOps    $ prop "aheadly monad then folded" . monadThen folded (==)-        asyncOps    $ prop "asyncly monad then folded" . monadThen folded sortEq-        wAsyncOps   $ prop "wAsyncly monad then folded" . monadThen folded sortEq-        parallelOps $ prop "parallely monad then folded" . monadThen folded sortEq--        serialOps   $ prop "serially monad bind" . monadBind S.fromFoldable (==)-        wSerialOps  $ prop "wSerially monad bind" . monadBind S.fromFoldable sortEq-        aheadOps    $ prop "aheadly monad bind" . monadBind S.fromFoldable (==)-        asyncOps    $ prop "asyncly monad bind" . monadBind S.fromFoldable sortEq-        wAsyncOps   $ prop "wAsyncly monad bind" . monadBind S.fromFoldable sortEq-        parallelOps $ prop "parallely monad bind" . monadBind S.fromFoldable sortEq--        serialOps   $ prop "serially monad bind folded"  . monadBind folded (==)-        wSerialOps  $ prop "wSerially monad bind folded" . monadBind folded sortEq-        aheadOps    $ prop "aheadly monad bind folded"   . monadBind folded (==)-        asyncOps    $ prop "asyncly monad bind folded"   . monadBind folded sortEq-        wAsyncOps   $ prop "wAsyncly monad bind folded"  . monadBind folded sortEq-        parallelOps $ prop "parallely monad bind folded" . monadBind folded sortEq--    -- These tests won't work with maxBuffer or maxThreads set to 1, so we-    -- exclude those cases from these.-    let mkOps :: IsStream t => (t m a -> c) -> [(String, t m a -> c)]-        mkOps t =-            [ ("default", t)-#ifndef COVERAGE_BUILD-            , ("rate Nothing", t . rate Nothing)-            , ("maxBuffer 0", t . maxBuffer 0)-            , ("maxThreads 0", t . maxThreads 0)-            , ("maxThreads 0", t . maxThreads (-1))-#endif-            ]--    let forOps ops spec = forM_ ops (\(desc, f) -> describe desc $ spec f)-    describe "Stream concurrent operations" $ do-        forOps (mkOps aheadly)   $ concurrentOps S.fromFoldable "aheadly" (==)-        forOps (mkOps asyncly)   $ concurrentOps S.fromFoldable "asyncly" sortEq-        forOps (mkOps wAsyncly)  $ concurrentOps S.fromFoldable "wAsyncly" sortEq-        forOps (mkOps parallely) $ concurrentOps S.fromFoldable "parallely" sortEq--        forOps (mkOps aheadly)   $ concurrentOps folded "aheadly folded" (==)-        forOps (mkOps asyncly)   $ concurrentOps folded "asyncly folded" sortEq-        forOps (mkOps wAsyncly)  $ concurrentOps folded "wAsyncly folded" sortEq-        forOps (mkOps parallely) $ concurrentOps folded "parallely folded" sortEq--    describe "Concurrent application" $ do-        serialOps $ prop "serial" . concurrentApplication (==)-        asyncOps $ prop "async" . concurrentApplication sortEq-        aheadOps $ prop "ahead" . concurrentApplication (==)-        parallelConcurrentAppOps $-            prop "parallel" . concurrentApplication sortEq--        prop "concurrent foldr application" $ withMaxSuccess maxTestCount-            concurrentFoldrApplication-        prop "concurrent foldl application" $ withMaxSuccess maxTestCount-            concurrentFoldlApplication--    describe "Stream transform and combine operations" $ do-        serialOps    $ transformCombineOpsCommon S.fromFoldable "serially" (==)-        wSerialOps   $ transformCombineOpsCommon S.fromFoldable "wSerially" sortEq-        aheadOps     $ transformCombineOpsCommon S.fromFoldable "aheadly" (==)-        asyncOps     $ transformCombineOpsCommon S.fromFoldable "asyncly" sortEq-        wAsyncOps    $ transformCombineOpsCommon S.fromFoldable "wAsyncly" sortEq-        parallelOps  $ transformCombineOpsCommon S.fromFoldable "parallely" sortEq-        zipSerialOps $ transformCombineOpsCommon S.fromFoldable "zipSerially" (==)-        zipAsyncOps  $ transformCombineOpsCommon S.fromFoldable "zipAsyncly" (==)--        serialOps    $ transformCombineOpsCommon folded "serially" (==)-        wSerialOps   $ transformCombineOpsCommon folded "wSerially" sortEq-        aheadOps     $ transformCombineOpsCommon folded "aheadly" (==)-        asyncOps     $ transformCombineOpsCommon folded "asyncly" sortEq-        wAsyncOps    $ transformCombineOpsCommon folded "wAsyncly" sortEq-        parallelOps  $ transformCombineOpsCommon folded "parallely" sortEq-        zipSerialOps $ transformCombineOpsCommon folded "zipSerially" (==)-        zipAsyncOps  $ transformCombineOpsCommon folded "zipAsyncly" (==)--        serialOps    $ transformCombineOpsOrdered S.fromFoldable "serially" (==)-        aheadOps     $ transformCombineOpsOrdered S.fromFoldable "aheadly" (==)-        zipSerialOps $ transformCombineOpsOrdered S.fromFoldable "zipSerially" (==)-        zipAsyncOps  $ transformCombineOpsOrdered S.fromFoldable "zipAsyncly" (==)--        serialOps    $ transformCombineOpsOrdered folded "serially" (==)-        aheadOps     $ transformCombineOpsOrdered folded "aheadly" (==)-        zipSerialOps $ transformCombineOpsOrdered folded "zipSerially" (==)-        zipAsyncOps  $ transformCombineOpsOrdered folded "zipAsyncly" (==)--    describe "Stream group and split operations" $ do-        groupSplitOps "serially"--    describe "Stream elimination operations" $ do-        serialOps    $ eliminationOps S.fromFoldable "serially"-        wSerialOps   $ eliminationOps S.fromFoldable "wSerially"-        aheadOps     $ eliminationOps S.fromFoldable "aheadly"-        asyncOps     $ eliminationOps S.fromFoldable "asyncly"-        wAsyncOps    $ eliminationOps S.fromFoldable "wAsyncly"-        parallelOps  $ eliminationOps S.fromFoldable "parallely"-        zipSerialOps $ eliminationOps S.fromFoldable "zipSerially"-        zipAsyncOps  $ eliminationOps S.fromFoldable "zipAsyncly"--        serialOps    $ eliminationOps folded "serially folded"-        wSerialOps   $ eliminationOps folded "wSerially folded"-        aheadOps     $ eliminationOps folded "aheadly folded"-        asyncOps     $ eliminationOps folded "asyncly folded"-        wAsyncOps    $ eliminationOps folded "wAsyncly folded"-        parallelOps  $ eliminationOps folded "parallely folded"-        zipSerialOps $ eliminationOps folded "zipSerially folded"-        zipAsyncOps  $ eliminationOps folded "zipAsyncly folded"--        serialOps    $ eliminationOpsWord8 S.fromFoldable "serially"-        wSerialOps   $ eliminationOpsWord8 S.fromFoldable "wSerially"-        aheadOps     $ eliminationOpsWord8 S.fromFoldable "aheadly"-        asyncOps     $ eliminationOpsWord8 S.fromFoldable "asyncly"-        wAsyncOps    $ eliminationOpsWord8 S.fromFoldable "wAsyncly"-        parallelOps  $ eliminationOpsWord8 S.fromFoldable "parallely"-        zipSerialOps $ eliminationOpsWord8 S.fromFoldable "zipSerially"-        zipAsyncOps  $ eliminationOpsWord8 S.fromFoldable "zipAsyncly"--        serialOps    $ eliminationOpsWord8 folded "serially folded"-        wSerialOps   $ eliminationOpsWord8 folded "wSerially folded"-        aheadOps     $ eliminationOpsWord8 folded "aheadly folded"-        asyncOps     $ eliminationOpsWord8 folded "asyncly folded"-        wAsyncOps    $ eliminationOpsWord8 folded "wAsyncly folded"-        parallelOps  $ eliminationOpsWord8 folded "parallely folded"-        zipSerialOps $ eliminationOpsWord8 folded "zipSerially folded"-        zipAsyncOps  $ eliminationOpsWord8 folded "zipAsyncly folded"--    -- XXX Add a test where we chain all transformation APIs and make sure that-    -- the state is being passed through all of them.-    describe "Stream serial elimination operations" $ do-        serialOps    $ eliminationOpsOrdered S.fromFoldable "serially"-        wSerialOps   $ eliminationOpsOrdered S.fromFoldable "wSerially"-        aheadOps     $ eliminationOpsOrdered S.fromFoldable "aheadly"-        zipSerialOps $ eliminationOpsOrdered S.fromFoldable "zipSerially"-        zipAsyncOps  $ eliminationOpsOrdered S.fromFoldable "zipAsyncly"--        serialOps    $ eliminationOpsOrdered folded "serially folded"-        wSerialOps   $ eliminationOpsOrdered folded "wSerially folded"-        aheadOps     $ eliminationOpsOrdered folded "aheadly folded"-        zipSerialOps $ eliminationOpsOrdered folded "zipSerially folded"-        zipAsyncOps  $ eliminationOpsOrdered folded "zipAsyncly folded"
− test/PureStreams.hs 
@@ -1,223 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MonadComprehensions #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Main (main) where--import Test.Hspec-import qualified GHC.Exts as GHC--import Streamly--#ifdef USE_STREAMLY_LIST-import Data.Functor.Identity-import Streamly.Internal.Data.List (List(..), pattern Cons, pattern Nil, ZipList(..),-                     fromZipList, toZipList)-import qualified Streamly.Prelude as S-#else-import Prelude -- to suppress compiler warning--type List = []--pattern Nil :: [a]-pattern Nil <- [] where Nil = []--pattern Cons :: a -> [a] -> [a]-pattern Cons x xs = x : xs-infixr 5 `Cons`--{-# COMPLETE Nil, Cons #-}-#endif--main :: IO ()-main = hspec $ do-#ifdef USE_STREAMLY_LIST-    describe "OverloadedLists for 'SerialT Identity' type" $ do-        it "Overloaded lists" $ do-            ([1..3] :: SerialT Identity Int) `shouldBe` S.fromList [1..3]-            GHC.toList ([1..3] :: SerialT Identity Int) `shouldBe` [1..3]--        it "Show instance" $ do-            show (S.fromList [1..3] :: SerialT Identity Int)-                `shouldBe` "fromList [1,2,3]"-        it "Read instance" $ do-            (read "fromList [1,2,3]" :: SerialT Identity Int) `shouldBe` [1..3]--        it "Eq instance" $ do-            ([1,2,3] :: SerialT Identity Int) == [1,2,3] `shouldBe` True--        it "Ord instance" $ do-            ([1,2,3] :: SerialT Identity Int) > [1,2,1] `shouldBe` True--        it "Monad comprehension" $ do-            [(x,y) | x <- [1..2], y <- [1..2]] `shouldBe`-                ([(1,1), (1,2), (2,1), (2,2)] :: SerialT Identity (Int, Int))--        it "Foldable (sum)" $ sum ([1..3] :: SerialT Identity Int)-            `shouldBe` 6--        it "Traversable (mapM)" $-            mapM return ([1..10] :: SerialT Identity Int)-                `shouldReturn` [1..10]--    describe "OverloadedStrings for 'SerialT Identity' type" $ do-        it "overloaded strings" $ do-            ("hello" :: SerialT Identity Char) `shouldBe` S.fromList "hello"-#endif--    describe "OverloadedLists for List type" $ do-        it "overloaded lists" $ do-            ([1..3] :: List Int) `shouldBe` GHC.fromList [1..3]-            GHC.toList ([1..3] :: List Int) `shouldBe` [1..3]--        it "Construct empty list" $ (Nil :: List Int) `shouldBe` []--        it "Construct a list" $ do-            (Nil :: List Int) `shouldBe` []-            ('x' `Cons` Nil) `shouldBe` ['x']-            (1 `Cons` [2 :: Int]) `shouldBe` [1,2]-            (1 `Cons` 2 `Cons` 3 `Cons` Nil :: List Int) `shouldBe` [1,2,3]--        it "pattern matches" $ do-            case [] of-                Nil -> return ()-                _ -> expectationFailure "not reached"--            case ['x'] of-                Cons 'x' Nil -> return ()-                _ -> expectationFailure "not reached"--            case [1..10 :: Int] of-                Cons x xs -> do-                    x `shouldBe` 1-                    xs `shouldBe` [2..10]-                _ -> expectationFailure "not reached"--            case [1..10 :: Int] of-                x `Cons` y `Cons` xs -> do-                    x `shouldBe` 1-                    y `shouldBe` 2-                    xs `shouldBe` [3..10]-                _ -> expectationFailure "not reached"--        it "Show instance" $ do-            show ([1..3] :: List Int) `shouldBe`-#ifdef USE_STREAMLY_LIST-                "List {toSerial = fromList [1,2,3]}"-#else-                "[1,2,3]"-#endif--        it "Read instance" $ do-            (read-#ifdef USE_STREAMLY_LIST-                "List {toSerial = fromList [1,2,3]}"-#else-                "[1,2,3]"-#endif-                :: List Int) `shouldBe` [1..3]--        it "Eq instance" $ do-            ([1,2,3] :: List Int) == [1,2,3] `shouldBe` True--        it "Ord instance" $ do-            ([1,2,3] :: List Int) > [1,2,1] `shouldBe` True--        it "Monad comprehension" $ do-            [(x,y) | x <- [1..2], y <- [1..2]] `shouldBe`-                ([(1,1), (1,2), (2,1), (2,2)] :: List (Int, Int))--        it "Foldable (sum)" $ sum ([1..3] :: List Int) `shouldBe` 6--        it "Traversable (mapM)" $-            mapM return ([1..10] :: List Int)-                `shouldReturn` [1..10]--    describe "OverloadedStrings for List type" $ do-        it "overloaded strings" $ do-            ("hello" :: List Char) `shouldBe` GHC.fromList "hello"--        it "pattern matches" $ do-#if __GLASGOW_HASKELL__ >= 802-            case "" of-#else-            case "" :: List Char of-#endif-                Nil -> return ()-                _ -> expectationFailure "not reached"--            case "a" of-                Cons x Nil -> x `shouldBe` 'a'-                _ -> expectationFailure "not reached"--            case "hello" <> "world" of-                Cons x1 (Cons x2 xs) -> do-                    x1 `shouldBe` 'h'-                    x2 `shouldBe` 'e'-                    xs `shouldBe` "lloworld"-                _ -> expectationFailure "not reached"--#ifdef USE_STREAMLY_LIST-    describe "OverloadedLists for ZipList type" $ do-        it "overloaded lists" $ do-            ([1..3] :: ZipList Int) `shouldBe` GHC.fromList [1..3]-            GHC.toList ([1..3] :: ZipList Int) `shouldBe` [1..3]--        it "toZipList" $ do-            toZipList (Nil :: List Int) `shouldBe` []-            toZipList ('x' `Cons` Nil) `shouldBe` ['x']-            toZipList (1 `Cons` [2 :: Int]) `shouldBe` [1,2]-            toZipList (1 `Cons` 2 `Cons` 3 `Cons` Nil :: List Int) `shouldBe` [1,2,3]--        it "fromZipList" $ do-            case fromZipList [] of-                Nil -> return ()-                _ -> expectationFailure "not reached"--            case fromZipList ['x'] of-                Cons 'x' Nil -> return ()-                _ -> expectationFailure "not reached"--            case fromZipList [1..10 :: Int] of-                Cons x xs -> do-                    x `shouldBe` 1-                    xs `shouldBe` [2..10]-                _ -> expectationFailure "not reached"--            case fromZipList [1..10 :: Int] of-                x `Cons` y `Cons` xs -> do-                    x `shouldBe` 1-                    y `shouldBe` 2-                    xs `shouldBe` [3..10]-                _ -> expectationFailure "not reached"--        it "Show instance" $ do-            show ([1..3] :: ZipList Int) `shouldBe`-                "ZipList {toZipSerial = fromList [1,2,3]}"--        it "Read instance" $ do-            (read "ZipList {toZipSerial = fromList [1,2,3]}" :: ZipList Int)-                `shouldBe` [1..3]--        it "Eq instance" $ do-            ([1,2,3] :: ZipList Int) == [1,2,3] `shouldBe` True--        it "Ord instance" $ do-            ([1,2,3] :: ZipList Int) > [1,2,1] `shouldBe` True--        it "Foldable (sum)" $ sum ([1..3] :: ZipList Int) `shouldBe` 6--        it "Traversable (mapM)" $-            mapM return ([1..10] :: ZipList Int)-                `shouldReturn` [1..10]--        it "Applicative Zip" $ do-            (,) <$> "abc" <*> [1..3] `shouldBe`-                ([('a',1),('b',2),('c',3)] :: ZipList (Char, Int))-#endif
+ test/README.md view
@@ -0,0 +1,158 @@+# Streamly Tests++## Running tests using bin/test.sh++`bin/test.sh` (path relative to the top level repo dir) can run selected+test groups, generate coverage report, pass GHC RTS options when+running tests. `test.sh` runs the tests with restricted memory, see+`bin/test.sh` source for details on the amount of memory used or to change it.++To generate coverage report:++```+$ bin/test.sh --coverage+```++To view coverage report, open `./hpc_index.html` in browser.++See `bin/test.sh --help` for more info.++## Building and Running Tests using cabal++### Build a single test++```+$ cabal build test:Prelude.Serial+```++or:++```+$ cd test; cabal build Prelude.Serial+```++Build with optimizations:++```+$ cabal build --flag opt ...+```++### Build all tests++```+$ cabal build --enable-tests all+```++or:++```+$ cd test; cabal build --enable-tests+```++Or this, note this command does not work as expected when in the "test" dir:++```+$ cabal build --enable-tests streamly-tests+```++### Build and run++Running all test suites, use any of the following:++```+$ cabal test all+```++or:++```+$ cd test; cabal test+```++Or this, note this command does not work as expected when in the "test" dir:++```+$ cabal test streamly-tests+```++### Build and Run a single test suite++To run `Prelude.Serial` test-suite:++```+$ cabal run test:Prelude.Serial+```++or:++```+$ cd test; cabal run Prelude.Serial+```++Note you could use `cabal test Prelude.Serial` but that unfortunately builds+all the test suites before running `Prelude.Serial`.++## Writing doctests++* The test named `doctest` runs all the code snippets in a source module+  that are written using the `>>>` markup in haddock. See `doctest.hs`.+* Make sure you do not enclose your snippets in the `@ .. @` markup otherwise+  they will show up verbatim in the docs and not as ghci styled snippets.+* We use `--fast` mode of doctest, which means snippets are run as if you are+  typing those examples from top to bottom in that order in GHCi. Previous+  snippet's state is available to the next one.+* A haddock section named `$setup` contains a snippet that is always run before+  any other. When `--fast` mode is not used it is run before every snippet.++An example setup section:++```+-- $setup+-- >>> :m+-- >>> import Control.Monad.IO.Class (MonadIO(..))+-- >>> import Data.Function ((&))+```++Some tests that may take long can be written as follows.  Just assigning+the code to a function makes it compile but not run.++```+>>> :{+main = do+ Stream.drain $ Stream.fromAsync $ foldMap delay [1..10]+ Stream.drain $ Stream.concatFoldableWith Stream.async (map delay [1..10])+ Stream.drain $ Stream.concatMapFoldableWith Stream.async delay [1..10]+ Stream.drain $ Stream.concatForFoldableWith Stream.async [1..10] delay+:}+```++## Running doctests++Run tests for all modules:++```+$ cabal run doctests --flag doctests+```++Use verbose mode to debug:++```+$ cabal run doctests --flag doctests -- --verbose+```++Run tests only for selected modules:++```+$ cabal run doctests --flag doctests -- --modules Streamly.Prelude+```++If it fails with a message that a particular modules is not loaded specify that+module as well on the command line.++## Naming of test modules++Tests are organized by source modules. For example, for the source+module `Streamly.Data.Array` and `Streamly.Internal.Data.Array` we have+a test module `Data.Array`. For some modules tests for a source module+are broken into multiple modules. For example, for `Streamly.Prelude` we have+`Streamly.Prelude.Serial`, `Streamly.Prelude.Async` etc.
− test/Streamly/Test/Array.hs 
@@ -1,190 +0,0 @@-{-# LANGUAGE CPP #-}---- |--- Module      : Main--- Copyright   : (c) 2019 Composewell Technologies------ License     : BSD-3-Clause--- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC----module Main (main) where--import Foreign.Storable (Storable(..))--import Test.Hspec.QuickCheck-import Test.QuickCheck (Property, forAll, Gen, vectorOf, arbitrary, choose)-import Test.QuickCheck.Monadic (monadicIO, assert, run)--import Test.Hspec as H--import Streamly (SerialT)--import qualified Streamly.Prelude as S--#ifdef TEST_SMALL_ARRAY-import qualified Streamly.Internal.Data.SmallArray as A-type Array = A.SmallArray-#elif defined(TEST_ARRAY)-import qualified Streamly.Memory.Array as A-import qualified Streamly.Internal.Memory.Array as A-import qualified Streamly.Internal.Prelude as IP-type Array = A.Array-#elif defined(TEST_PRIM_ARRAY)-import qualified Streamly.Internal.Data.Prim.Array as A-type Array = A.PrimArray-#else-import qualified Streamly.Internal.Data.Array as A-type Array = A.Array-#endif---- Coverage build takes too long with default number of tests-maxTestCount :: Int-#ifdef DEVBUILD-maxTestCount = 100-#else-maxTestCount = 10-#endif--allocOverhead :: Int-allocOverhead = 2 * sizeOf (undefined :: Int)---- XXX this should be in sync with the defaultChunkSize in Array code, or we--- should expose that and use that. For fast testing we could reduce the--- defaultChunkSize under CPP conditionals.----defaultChunkSize :: Int-defaultChunkSize = 32 * k - allocOverhead-   where k = 1024--maxArrLen :: Int-maxArrLen = defaultChunkSize * 8--genericTestFrom ::-       (Int -> SerialT IO Int -> IO (Array Int))-    -> Property-genericTestFrom arrFold =-    forAll (choose (0, maxArrLen)) $ \len ->-        forAll (vectorOf len (arbitrary :: Gen Int)) $ \list ->-            monadicIO $ do-                arr <- run $ arrFold len $ S.fromList list-                assert (A.length arr == len)--testLength :: Property-testLength = genericTestFrom (\n -> S.fold (A.writeN n))--testLengthFromStreamN :: Property-testLengthFromStreamN = genericTestFrom A.fromStreamN--#ifndef TEST_SMALL_ARRAY-testLengthFromStream :: Property-testLengthFromStream = genericTestFrom (const A.fromStream)-#endif--genericTestFromTo ::-       (Int -> SerialT IO Int -> IO (Array Int))-    -> (Array Int -> SerialT IO Int)-    -> ([Int] -> [Int] -> Bool)-    -> Property-genericTestFromTo arrFold arrUnfold listEq =-    forAll (choose (0, maxArrLen)) $ \len ->-        forAll (vectorOf len (arbitrary :: Gen Int)) $ \list ->-            monadicIO $ do-                arr <- run $ arrFold len $ S.fromList list-                xs <- run $ S.toList $ arrUnfold arr-                assert (listEq xs list)--testFoldNUnfold :: Property-testFoldNUnfold =-    genericTestFromTo (\n -> S.fold (A.writeN n)) (S.unfold A.read) (==)--testFoldNToStream :: Property-testFoldNToStream =-    genericTestFromTo (\n -> S.fold (A.writeN n)) A.toStream (==)--testFoldNToStreamRev :: Property-testFoldNToStreamRev =-    genericTestFromTo-        (\n -> S.fold (A.writeN n))-        A.toStreamRev-        (\xs list -> xs == reverse list)--testFromStreamNUnfold :: Property-testFromStreamNUnfold = genericTestFromTo A.fromStreamN (S.unfold A.read) (==)--testFromStreamNToStream :: Property-testFromStreamNToStream = genericTestFromTo A.fromStreamN A.toStream (==)--#ifndef TEST_SMALL_ARRAY-testFromStreamToStream :: Property-testFromStreamToStream = genericTestFromTo (const A.fromStream) A.toStream (==)--testFoldUnfold :: Property-testFoldUnfold = genericTestFromTo (const (S.fold A.write)) (S.unfold A.read) (==)-#endif--#ifdef TEST_ARRAY-testArraysOf :: Property-testArraysOf =-    forAll (choose (0, maxArrLen)) $ \len ->-        forAll (vectorOf len (arbitrary :: Gen Int)) $ \list ->-            monadicIO $ do-                xs <- S.toList-                    $ S.concatUnfold A.read-                    $ IP.arraysOf 240-                    $ S.fromList list-                assert (xs == list)--lastN :: Int -> [a] -> [a]-lastN n l = drop (length l - n) l--testLastN :: Property-testLastN =-    forAll (choose (0, maxArrLen)) $ \len ->-        forAll (choose (0, len)) $ \n ->-            forAll (vectorOf len (arbitrary :: Gen Int)) $ \list ->-                monadicIO $ do-                    xs <- fmap A.toList-                        $ S.fold (A.lastN n)-                        $ S.fromList list-                    assert (xs == lastN n list)--testLastN_LN :: Int -> Int -> IO Bool-testLastN_LN len n = do-    let list = [1..len]-    l1 <- fmap A.toList $ S.fold (A.lastN n) $ S.fromList list-    let l2 = lastN n list-    return $ l1 == l2-#endif--main :: IO ()-main =-    hspec $-    H.parallel $-    modifyMaxSuccess (const maxTestCount) $ do-        describe "Construction" $ do-            prop "length . writeN n === n" testLength-            prop "length . fromStreamN n === n" testLengthFromStreamN-            prop "read . writeN === id " testFoldNUnfold-            prop "toStream . writeN === id" testFoldNToStream-            prop "toStreamRev . writeN === reverse" testFoldNToStreamRev-            prop "read . fromStreamN === id" testFromStreamNUnfold-            prop "toStream . fromStreamN === id" testFromStreamNToStream-#ifndef TEST_SMALL_ARRAY-            prop "length . fromStream === n" testLengthFromStream-            prop "toStream . fromStream === id" testFromStreamToStream-            prop "read . write === id" testFoldUnfold-#endif-#ifdef TEST_ARRAY-            prop "arraysOf concats to original" testArraysOf-#endif-#ifdef TEST_ARRAY-        describe "Fold" $ do-            prop "lastN : 0 <= n <= len" $ testLastN-            describe "lastN boundary conditions" $ do-                it "lastN -1" (testLastN_LN 10 (-1) `shouldReturn` True)-                it "lastN 0" (testLastN_LN 10 0 `shouldReturn` True)-                it "lastN length" (testLastN_LN 10 10 `shouldReturn` True)-                it "lastN (length + 1)" (testLastN_LN 10 11 `shouldReturn` True)-#endif
+ test/Streamly/Test/Common/Array.hs view
@@ -0,0 +1,284 @@+-- |+-- Module      : Main+-- Copyright   : (c) 2019 Composewell Technologies+--+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--++-- This is a common array test module that gets included in different+-- Array test modules with the corresponding macro defined.++import Foreign.Storable (Storable(..))++import Test.Hspec.QuickCheck+import Test.QuickCheck (Property, forAll, Gen, vectorOf, arbitrary, choose)+import Test.QuickCheck.Monadic (monadicIO, assert, run)+import Test.Hspec as H++import Streamly.Prelude (SerialT)+import Streamly.Test.Common (listEquals)++import qualified Streamly.Prelude as S+#ifdef TEST_SMALL_ARRAY+import qualified Streamly.Internal.Data.SmallArray as A+type Array = A.SmallArray+#elif defined(TEST_ARRAY)+import Data.Word(Word8)++import qualified Streamly.Internal.Data.Array.Foreign as A+import qualified Streamly.Internal.Data.Array.Foreign.Type as A+import qualified Streamly.Internal.Data.Array.Foreign.Mut.Type as MA+import qualified Streamly.Internal.Data.Stream.IsStream as IP+import qualified Streamly.Internal.Data.Array.Stream.Foreign as AS+type Array = A.Array+#elif defined(DATA_ARRAY_PRIM_PINNED)+import qualified Streamly.Internal.Data.Array.Prim.Pinned as A+import qualified Streamly.Internal.Data.Array.Prim.Pinned.Type as A+import qualified Streamly.Internal.Data.Stream.IsStream as IP+type Array = A.Array+#elif defined(DATA_ARRAY_PRIM)+import qualified Streamly.Internal.Data.Array.Prim as A+import qualified Streamly.Internal.Data.Array.Prim.Type as A+import qualified Streamly.Internal.Data.Stream.IsStream as IP+type Array = A.Array+#else+import qualified Streamly.Internal.Data.Array as A+type Array = A.Array+#endif++moduleName :: String+#ifdef TEST_SMALL_ARRAY+moduleName = "Data.SmallArray"+#elif defined(TEST_ARRAY)+moduleName = "Data.Array.Foreign"+#elif defined(DATA_ARRAY_PRIM_PINNED)+moduleName = "Data.Array.Prim.Pinned"+#elif defined(DATA_ARRAY_PRIM)+moduleName = "Data.Array.Prim"+#else+moduleName = "Data.Array"+#endif++-- Coverage build takes too long with default number of tests+maxTestCount :: Int+#ifdef DEVBUILD+maxTestCount = 100+#else+maxTestCount = 10+#endif++allocOverhead :: Int+allocOverhead = 2 * sizeOf (undefined :: Int)++-- XXX this should be in sync with the defaultChunkSize in Array code, or we+-- should expose that and use that. For fast testing we could reduce the+-- defaultChunkSize under CPP conditionals.+--+defaultChunkSize :: Int+defaultChunkSize = 32 * k - allocOverhead+   where k = 1024++maxArrLen :: Int+maxArrLen = defaultChunkSize * 8++genericTestFrom ::+       (Int -> SerialT IO Int -> IO (Array Int))+    -> Property+genericTestFrom arrFold =+    forAll (choose (0, maxArrLen)) $ \len ->+        forAll (vectorOf len (arbitrary :: Gen Int)) $ \list ->+            monadicIO $ do+                arr <- run $ arrFold len $ S.fromList list+                assert (A.length arr == len)++testLength :: Property+testLength = genericTestFrom (\n -> S.fold (A.writeN n))++testLengthFromStreamN :: Property+testLengthFromStreamN = genericTestFrom A.fromStreamN++#ifndef TEST_SMALL_ARRAY+testLengthFromStream :: Property+testLengthFromStream = genericTestFrom (const A.fromStream)+#endif++genericTestFromTo ::+       (Int -> SerialT IO Int -> IO (Array Int))+    -> (Array Int -> SerialT IO Int)+    -> ([Int] -> [Int] -> Bool)+    -> Property+genericTestFromTo arrFold arrUnfold listEq =+    forAll (choose (0, maxArrLen)) $ \len ->+        forAll (vectorOf len (arbitrary :: Gen Int)) $ \list ->+            monadicIO $ do+                arr <- run $ arrFold len $ S.fromList list+                xs <- run $ S.toList $ arrUnfold arr+                assert (listEq xs list)++testFoldNUnfold :: Property+testFoldNUnfold =+    genericTestFromTo (\n -> S.fold (A.writeN n)) (S.unfold A.read) (==)++testFoldNToStream :: Property+testFoldNToStream =+    genericTestFromTo (\n -> S.fold (A.writeN n)) A.toStream (==)++testFoldNToStreamRev :: Property+testFoldNToStreamRev =+    genericTestFromTo+        (\n -> S.fold (A.writeN n))+        A.toStreamRev+        (\xs list -> xs == reverse list)++testFromStreamNUnfold :: Property+testFromStreamNUnfold = genericTestFromTo A.fromStreamN (S.unfold A.read) (==)++testFromStreamNToStream :: Property+testFromStreamNToStream = genericTestFromTo A.fromStreamN A.toStream (==)++testFromListN :: Property+testFromListN =+    forAll (choose (0, maxArrLen)) $ \len ->+        forAll (choose (0, len)) $ \n ->+            forAll (vectorOf len (arbitrary :: Gen Int)) $ \list ->+                monadicIO $ do+                    let arr = A.fromListN n list+                    xs <- run $ S.toList $ (S.unfold A.read) arr+                    listEquals (==) xs (take n list)++#ifndef TEST_SMALL_ARRAY+testFromStreamToStream :: Property+testFromStreamToStream = genericTestFromTo (const A.fromStream) A.toStream (==)++testFoldUnfold :: Property+testFoldUnfold = genericTestFromTo (const (S.fold A.write)) (S.unfold A.read) (==)++testFromList :: Property+testFromList =+    forAll (choose (0, maxArrLen)) $ \len ->+            forAll (vectorOf len (arbitrary :: Gen Int)) $ \list ->+                monadicIO $ do+                    let arr = A.fromList list+                    xs <- run $ S.toList $ (S.unfold A.read) arr+                    assert (xs == list)+#endif++#if defined(TEST_ARRAY) ||\+    defined(DATA_ARRAY_PRIM) ||\+    defined(DATA_ARRAY_PRIM_PINNED)++testArraysOf :: Property+testArraysOf =+    forAll (choose (0, maxArrLen)) $ \len ->+        forAll (vectorOf len (arbitrary :: Gen Int)) $ \list ->+            monadicIO $ do+                xs <- run+                    $ S.toList+                    $ S.unfoldMany A.read+                    $ arraysOf 240+                    $ S.fromList list+                assert (xs == list)+  where+    arraysOf n = IP.chunksOf n (A.writeNUnsafe n)++#endif++#ifdef TEST_ARRAY++unsafeWriteIndex :: [Int] -> Int -> Int -> IO Bool+unsafeWriteIndex xs i x = do+    let arr = MA.fromList xs+    arr1 <- MA.unsafeWriteIndex arr i x+    x1 <- MA.unsafeIndexIO arr1 i+    return $ x1 == x++lastN :: Int -> [a] -> [a]+lastN n l = drop (length l - n) l++testLastN :: Property+testLastN =+    forAll (choose (0, maxArrLen)) $ \len ->+        forAll (choose (0, len)) $ \n ->+            forAll (vectorOf len (arbitrary :: Gen Int)) $ \list ->+                monadicIO $ do+                    xs <- run+                        $ fmap A.toList+                        $ S.fold (A.writeLastN n)+                        $ S.fromList list+                    assert (xs == lastN n list)++testLastN_LN :: Int -> Int -> IO Bool+testLastN_LN len n = do+    let list = [1..len]+    l1 <- fmap A.toList $ S.fold (A.writeLastN n) $ S.fromList list+    let l2 = lastN n list+    return $ l1 == l2++-- Instead of hard coding 10000 here we can have maxStreamLength for operations+-- that use stream of arrays.+concatArrayW8 :: Property+concatArrayW8 =+    forAll (vectorOf 10000 (arbitrary :: Gen Word8))+        $ \w8List -> do+              let w8ArrList = A.fromList . (: []) <$> w8List+              f2 <- S.toList $ AS.concat $ S.fromList w8ArrList+              w8List `shouldBe` f2++unsafeSlice :: Int -> Int -> [Int] -> Bool+unsafeSlice i n list =+    let lst = take n $ drop i $ list+        arr = A.toList $ A.unsafeSlice i n $ A.fromList list+     in arr == lst++#endif++main :: IO ()+main =+    hspec $+    H.parallel $+    modifyMaxSuccess (const maxTestCount) $ do+      describe moduleName $ do+        describe "Construction" $ do+            prop "length . writeN n === n" testLength+            prop "length . fromStreamN n === n" testLengthFromStreamN+            prop "read . writeN === id " testFoldNUnfold+            prop "toStream . writeN === id" testFoldNToStream+            prop "toStreamRev . writeN === reverse" testFoldNToStreamRev+            prop "read . fromStreamN === id" testFromStreamNUnfold+            prop "toStream . fromStreamN === id" testFromStreamNToStream+            prop "fromListN" testFromListN++#ifndef TEST_SMALL_ARRAY+            prop "length . fromStream === n" testLengthFromStream+            prop "toStream . fromStream === id" testFromStreamToStream+            prop "read . write === id" testFoldUnfold+            prop "fromList" testFromList+#endif++#if defined(TEST_ARRAY) ||\+    defined(DATA_ARRAY_PRIM) ||\+    defined(DATA_ARRAY_PRIM_PINNED)+            prop "arraysOf concats to original" testArraysOf+#endif++#ifdef TEST_ARRAY+            prop "AS.concat . (A.fromList . (:[]) <$>) === id" $ concatArrayW8+        describe "unsafeSlice" $ do+            it "partial" $ unsafeSlice 2 4 [1..10]+            it "none" $ unsafeSlice 10 0 [1..10]+            it "full" $ unsafeSlice 0 10 [1..10]+        describe "Mut.unsafeWriteIndex" $ do+            it "first" (unsafeWriteIndex [1..10] 0 0 `shouldReturn` True)+            it "middle" (unsafeWriteIndex [1..10] 5 0 `shouldReturn` True)+            it "last" (unsafeWriteIndex [1..10] 9 0 `shouldReturn` True)+        describe "Fold" $ do+            prop "writeLastN : 0 <= n <= len" $ testLastN+            describe "writeLastN boundary conditions" $ do+                it "writeLastN -1" (testLastN_LN 10 (-1) `shouldReturn` True)+                it "writeLastN 0" (testLastN_LN 10 0 `shouldReturn` True)+                it "writeLastN length" (testLastN_LN 10 10 `shouldReturn` True)+                it "writeLastN (length + 1)" (testLastN_LN 10 11 `shouldReturn` True)+#endif
+ test/Streamly/Test/Data/Array.hs view
@@ -0,0 +1,11 @@+-- |+-- Module      : Streamly.Test.Data.Array+-- Copyright   : (c) 2019 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Test.Data.Array where++#include "Streamly/Test/Common/Array.hs"
+ test/Streamly/Test/Data/Array/Foreign.hs view
@@ -0,0 +1,12 @@+-- |+-- Module      : Streamly.Test.Data.Array.Foreign+-- Copyright   : (c) 2019 Composewell technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Test.Data.Array.Foreign (main) where++#define TEST_ARRAY+#include "Streamly/Test/Common/Array.hs"
+ test/Streamly/Test/Data/Array/Prim.hs view
@@ -0,0 +1,12 @@+-- |+-- Module      : Streamly.Test.Data.Array.Prim+-- Copyright   : (c) 2020 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Test.Data.Array.Prim where++#define DATA_ARRAY_PRIM+#include "Streamly/Test/Common/Array.hs"
+ test/Streamly/Test/Data/Array/Prim/Pinned.hs view
@@ -0,0 +1,12 @@+-- |+-- Module      : Streamly.Test.Data.Array.Prim.Pinned+-- Copyright   : (c) 2020 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Test.Data.Array.Prim.Pinned where++#define DATA_ARRAY_PRIM_PINNED+#include "Streamly/Test/Common/Array.hs"
+ test/Streamly/Test/Data/Fold.hs view
@@ -0,0 +1,530 @@+module Main (main) where++import Data.Semigroup (Sum(..), getSum)+import Streamly.Test.Common (checkListEqual, listEquals)+import Test.QuickCheck+    ( Gen+    , Property+    , arbitrary+    , choose+    , forAll+    , listOf+    , listOf1+    , property+    , vectorOf+    , withMaxSuccess+    )+import Test.QuickCheck.Monadic (monadicIO, assert, run)++import qualified Prelude+import qualified Streamly.Internal.Data.Fold as F+import qualified Streamly.Prelude as S+import qualified Streamly.Internal.Data.Stream.IsStream as Stream+import qualified Streamly.Data.Fold as FL++import Prelude hiding+    (maximum, minimum, elem, notElem, null, product, sum, head, last, take)+import Test.Hspec as H+import Test.Hspec.QuickCheck++maxStreamLen :: Int+maxStreamLen = 1000++intMin :: Int+intMin = minBound++intMax :: Int+intMax = maxBound++min_value :: Int+min_value = 0++max_value :: Int+max_value = 10000++chooseInt :: (Int, Int) -> Gen Int+chooseInt = choose++{-# INLINE maxStreamLen #-}+{-# INLINE intMin #-}+{-# INLINE intMax #-}++rollingHashFirstN :: Property+rollingHashFirstN =+    forAll (choose (0, maxStreamLen)) $ \len ->+        forAll (choose (0, len)) $ \n ->+            forAll (vectorOf len (arbitrary :: Gen Int)) $ \vec -> monadicIO $ do+                a <- run $ S.fold F.rollingHash $ S.take n $ S.fromList vec+                b <- run $ S.fold (F.rollingHashFirstN n) $ S.fromList vec+                assert $ a == b++head :: [Int] -> Expectation+head ls = S.fold FL.head (S.fromList ls) `shouldReturn` headl ls++headl :: [a] -> Maybe a+headl [] = Nothing+headl (x:_) = Just x++length :: [Int] -> Expectation+length ls = S.fold FL.length (S.fromList ls) `shouldReturn` Prelude.length ls++sum :: [Int] -> Expectation+sum ls = S.fold FL.sum (S.fromList ls) `shouldReturn` Prelude.sum ls++product :: [Int] -> Expectation+product ls =+    S.fold FL.product (S.fromList ls) `shouldReturn` Prelude.product ls++lesser :: (a -> a -> Ordering) -> a -> a -> a+lesser f x y = if f x y == LT then x else y++greater :: (a -> a -> Ordering) -> a -> a -> a+greater f x y = if f x y == GT then x else y++foldMaybe :: (b -> a -> b) -> b -> [a] -> Maybe b+foldMaybe f acc ls =+    case ls of+        [] -> Nothing+        _ -> Just (foldl f acc ls)++maximumBy :: (Ord a, Show a) => a -> (a -> a -> Ordering) -> [a] -> Expectation+maximumBy genmin f ls =+    S.fold (FL.maximumBy f) (S.fromList ls)+        `shouldReturn` foldMaybe (greater f) genmin ls++maximum :: (Show a, Ord a) => a -> [a] -> Expectation+maximum genmin ls =+    S.fold FL.maximum (S.fromList ls)+        `shouldReturn` foldMaybe (greater compare) genmin ls++minimumBy :: (Ord a, Show a) => a -> (a -> a -> Ordering) -> [a] -> Expectation+minimumBy genmax f ls =+    S.fold (FL.minimumBy f) (S.fromList ls)+        `shouldReturn` foldMaybe (lesser f) genmax ls++minimum :: (Show a, Ord a) => a -> [a] -> Expectation+minimum genmax ls =+    S.fold FL.minimum (S.fromList ls)+        `shouldReturn` foldMaybe (lesser compare) genmax ls++toList :: [Int] -> Expectation+toList ls = S.fold FL.toList (S.fromList ls) `shouldReturn` ls++safeLast :: [a] -> Maybe a+safeLast [] = Nothing+safeLast (x:[]) = Just x+safeLast (_:xs) = safeLast xs++last :: [String] -> Expectation+last ls = S.fold FL.last (S.fromList ls) `shouldReturn` safeLast ls++mapMaybe :: [Int] -> Expectation+mapMaybe ls =+    let maybeEven x =+            if even x+            then Just x+            else Nothing+        f = F.mapMaybe maybeEven FL.toList+    in S.fold f (S.fromList ls) `shouldReturn` filter even ls++nth :: Int -> [a] -> Maybe a+nth idx (x : xs)+    | idx == 0 = Just x+    | idx < 0 = Nothing+    | otherwise = nth (idx - 1) xs+nth _ [] = Nothing++index :: Int -> [String] -> Expectation+index idx ls =+    let x = S.fold (FL.index idx) (S.fromList ls)+    in x `shouldReturn` nth idx ls++find :: (Show a, Eq a) => (a -> Bool) -> [a] -> Expectation+find f ls = do+    y <- S.fold (FL.findIndex f) (S.fromList ls)+    case y of+        Nothing ->+            let fld = S.fold (FL.find f) (S.fromList ls)+            in fld `shouldReturn` Nothing+        Just idx ->+            let fld = S.fold (FL.any f) (S.fromList $ Prelude.take idx ls)+            in fld `shouldReturn` False++neg :: (a -> Bool) -> a -> Bool+neg f x = not (f x)++findIndex :: (a -> Bool) -> [a] -> Expectation+findIndex f ls = do+    y <- S.fold (FL.findIndex f) (S.fromList ls)+    case y of+        Nothing  ->+            let fld = S.fold (FL.all $ neg f) (S.fromList ls)+            in fld `shouldReturn` True+        Just idx ->+            if idx == 0+            then+                S.fold (FL.all f) (S.fromList []) `shouldReturn` True+            else+                S.fold (FL.all f) (S.fromList $ Prelude.take idx ls)+                    `shouldReturn` False++predicate :: Int -> Bool+predicate x = x * x < 100++elemIndex :: Int -> [Int] -> Expectation+elemIndex elm ls = do+    y <- S.fold (FL.elemIndex elm) (S.fromList ls)+    case y of+        Nothing ->+            let fld = S.fold (FL.any (== elm)) (S.fromList ls)+            in fld `shouldReturn` False+        Just idx ->+            let fld = S.fold (FL.any (== elm)) (S.fromList $ Prelude.take idx ls)+            in fld `shouldReturn` False++null :: [Int] -> Expectation+null ls =+    S.fold FL.null (S.fromList ls)+        `shouldReturn`+            case ls of+                [] -> True+                _ -> False++elem :: Int -> [Int] -> Expectation+elem elm ls = do+    y <- S.fold (FL.elem elm) (S.fromList ls)+    let fld = S.fold (FL.any (== elm)) (S.fromList ls)+    fld `shouldReturn` y++notElem :: Int -> [Int] -> Expectation+notElem elm ls = do+    y <- S.fold (FL.notElem elm) (S.fromList ls)+    let fld = S.fold (FL.any (== elm)) (S.fromList ls)+    fld `shouldReturn` not y++all :: (a -> Bool) -> [a] -> Expectation+all f ls =+    S.fold (FL.all f) (S.fromList ls) `shouldReturn` Prelude.all f ls++any :: (a -> Bool) -> [a] -> Expectation+any f ls = S.fold (FL.any f) (S.fromList ls) `shouldReturn` Prelude.any f ls++and :: [Bool] -> Expectation+and ls = S.fold FL.and (S.fromList ls) `shouldReturn` Prelude.and ls++or :: [Bool] -> Expectation+or ls = S.fold FL.or (S.fromList ls) `shouldReturn` Prelude.or ls++take :: [Int] -> Property+take ls =+    forAll (chooseInt (-1, Prelude.length ls + 2)) $ \n ->+            S.fold (F.take n FL.toList) (S.fromList ls)+                `shouldReturn` Prelude.take n ls++takeEndBy_ :: Property+takeEndBy_ =+    forAll (listOf (chooseInt (0, 1))) $ \ls ->+        let p = (== 1)+            f = F.takeEndBy_ p FL.toList+            ys = Prelude.takeWhile (not . p) ls+         in case S.fold f (S.fromList ls) of+            Right xs -> checkListEqual xs ys+            Left _ -> property False++takeEndByOrMax :: Property+takeEndByOrMax =+    forAll (chooseInt (min_value, max_value)) $ \n ->+        forAll (listOf (chooseInt (0, 1))) $ \ls ->+            let p = (== 1)+                f = F.takeEndBy_ p (F.take n FL.toList)+                ys = Prelude.take n (Prelude.takeWhile (not . p) ls)+             in case S.fold f (S.fromList ls) of+                    Right xs -> checkListEqual xs ys+                    Left _ -> property False++chooseFloat :: (Float, Float) -> Gen Float+chooseFloat = choose++drain :: [Int] -> Expectation+drain ls = S.fold FL.drain (S.fromList ls) `shouldReturn` ()++drainBy :: [Int] -> Expectation+drainBy ls = S.fold (FL.drainBy return) (S.fromList ls) `shouldReturn` ()++mean :: Property+mean =+    forAll (listOf1 (chooseFloat (-100.0, 100.0)))+        $ \ls0 -> withMaxSuccess 1000 $ monadicIO $ action ls0++    where++    action ls = do+        v1 <- run $ S.fold FL.mean (S.fromList ls)+        let v2 = Prelude.sum ls / fromIntegral (Prelude.length ls)+        assert (abs (v1 - v2) < 0.0001)++stdDev :: Property+stdDev =+    forAll (listOf1 (chooseFloat (-100.0, 100.0)))+        $ \ls0 -> withMaxSuccess 1000 $ monadicIO $ action ls0++    where++    action ls = do+        v1 <- run $ S.fold FL.stdDev (S.fromList ls)+        let avg = Prelude.sum ls / fromIntegral (Prelude.length ls)+            se = Prelude.sum (fmap (\x -> (x - avg) * (x - avg)) ls)+            sd = sqrt $ se / fromIntegral (Prelude.length ls)+        assert (abs (v1 - sd) < 0.0001 )++variance :: Property+variance =+    forAll (listOf1 (chooseFloat (-100.0, 100.0)))+        $ \ls0 -> withMaxSuccess 1000 $ monadicIO $ action ls0++    where++    action ls = do+        v1 <- run $ S.fold FL.variance (S.fromList ls)+        let avg = Prelude.sum ls / fromIntegral (Prelude.length ls)+            se = Prelude.sum (fmap (\x -> (x - avg) * (x - avg)) ls)+            vr = se / fromIntegral (Prelude.length ls)+        assert (abs (v1 - vr) < 0.01 )++mconcat :: Property+mconcat =+    forAll (listOf1 (chooseInt (intMin, intMax)))+        $ \ls0 -> monadicIO $ action ls0++    where++    action ls = do+        v1 <- run $ S.fold FL.mconcat (S.map Sum $ S.fromList ls)+        let v2 = Prelude.sum ls+        assert (getSum v1 == v2)++foldMap :: Property+foldMap =+    forAll (listOf1 (chooseInt (intMin, intMax)))+        $ \ls0 -> monadicIO $ action ls0++    where++    action ls = do+        v1 <- run $ S.fold (FL.foldMap Sum) $ S.fromList ls+        let v2 = Prelude.sum ls+        assert (getSum v1 == v2)++foldMapM :: Property+foldMapM =+    forAll (listOf1 (chooseInt (intMin, intMax)))+        $ \ls0 -> monadicIO $ action ls0++    where++    action ls = do+        v1 <- run $ S.fold (FL.foldMapM (return . Sum)) $ S.fromList ls+        let v2 = Prelude.sum ls+        assert (getSum v1 == v2)++lookup :: Property+lookup =+    forAll (chooseInt (1, 15))+        $ \key0 ->monadicIO $ action key0++    where++    action key = do+        let ls = [(1, "first"), (2, "second"), (3, "third"), (4, "fourth")+                , (5, "fifth"), (6, "fifth+first"), (7, "fifth+second")+                , (8, "fifth+third"), (9, "fifth+fourth")+                , (10, "fifth+fifth")]+        v1 <- run $ S.fold (FL.lookup key) $ S.fromList ls+        let v2 = Prelude.lookup key ls+        assert (v1 == v2)++rmapM :: Property+rmapM =+    forAll (listOf1 (chooseInt (intMin, intMax)))+        $ \ls0 -> monadicIO $ action ls0++    where++    action ls = do+        let addLen x = return $ x + Prelude.length ls+            fld = FL.rmapM addLen FL.sum+            v2 = foldl (+) (Prelude.length ls) ls+        v1 <- run $ S.fold fld $ S.fromList ls+        assert (v1 == v2)++teeWithLength :: Property+teeWithLength =+    forAll (listOf1 (chooseInt (intMin, intMax)))+        $ \ls0 -> monadicIO $ action ls0++    where++    action ls = do+        v1 <- run $ S.fold (FL.tee FL.sum FL.length) $ S.fromList ls+        let v2 = Prelude.sum ls+            v3 = Prelude.length ls+        assert (v1 == (v2, v3))++teeWithMax :: Property+teeWithMax =+    forAll (listOf1 (chooseInt (intMin, intMax)))+       $ \ls0 -> monadicIO $ action ls0++    where++    action ls = do+        v1 <- run $ S.fold (FL.tee FL.sum FL.maximum) $ S.fromList ls+        let v2 = Prelude.sum ls+            v3 = foldMaybe (greater compare) intMin ls+        assert (v1 == (v2, v3))++distribute :: Property+distribute =+    forAll (listOf1 (chooseInt (intMin, intMax)))+        $ \ls0 -> monadicIO $ action ls0++    where++    action ls = do+        v1 <- run $ S.fold (FL.distribute [FL.sum, FL.length]) $ S.fromList ls+        let v2 = Prelude.sum ls+            v3 = Prelude.length ls+        assert (v1 == [v2, v3])++partition :: Property+partition =+    monadicIO $ do+        v1 :: (Int, [String]) <-+            run+                $ S.fold (FL.partition FL.sum FL.toList)+                $ S.fromList+                    [Left 1, Right "abc", Left 3, Right "xy", Right "pp2"]+        let v2 = (4,["abc","xy","pp2"])+        assert (v1 == v2)++unzip :: Property+unzip =+    monadicIO $ do+    v1 :: (Int, [String]) <-+        run+            $ S.fold (FL.unzip FL.sum FL.toList)+            $ S.fromList [(1, "aa"), (2, "bb"), (3, "cc")]+    let v2 = (6, ["aa", "bb", "cc"])+    assert (v1 == v2)++many :: Property+many =+    forAll (listOf (chooseInt (0, 100))) $ \lst ->+    forAll (chooseInt (1, 100)) $ \i ->+        monadicIO $ do+            let strm = S.fromList lst+            r1 <- S.fold (F.many (split i) F.toList) strm+            r2 <- S.toList $ Stream.foldMany (split i) strm+            assert $ r1 == r2++    where++    split i = F.take i F.toList++headAndRest :: [Int] -> Property+headAndRest ls = monadicIO $ do+    (mbh, rest) <- run $ Stream.fold_ FL.head (S.fromList ls)+    rests <- run $ S.toList rest+    assert (mbh == headl ls)+    listEquals (==) rests (taill ls)++    where++    taill :: [a] -> [a]+    taill [] = []+    taill (_:xs) = xs++moduleName :: String+moduleName = "Data.Fold"++main :: IO ()+main = hspec $ do+    describe moduleName $ do+        -- Folds+        -- Accumulators+        prop "mconcat" Main.mconcat+        prop "foldMap" Main.foldMap+        prop "foldMapM" Main.foldMapM++        prop "drain" Main.drain+        prop "drainBy" Main.drainBy+        prop "last" last+        prop "length" Main.length+        prop "sum" sum+        prop "product" product+        prop "maximumBy" $ maximumBy intMin compare+        prop "maximum" $ maximum intMin+        prop "minimumBy" $ minimumBy intMax compare+        prop "minimum" $ minimum intMax+        prop "mean" Main.mean+        prop "stdDev" Main.stdDev+        prop "variance" Main.variance+        prop "rollingHashFirstN" rollingHashFirstN++        prop "toList" toList++        -- Terminating folds+        prop "index" index+        prop "head" head+        prop "find" $ find predicate+        prop "lookup" Main.lookup+        prop "findIndex" $ findIndex predicate+        prop "elemIndex" $ elemIndex 10+        prop "null" null+        prop "elem" $ elem 10+        prop "notElem" $ notElem 10+        prop "all" $ Main.all predicate+        prop "any" $ Main.any predicate+        prop "and" Main.and+        prop "or" Main.or++        -- Combinators++        -- Transformation+        -- rsequence+        -- Functor instance+        prop "rmapM" Main.rmapM+        -- lmap/lmapM++        -- Filtering+        -- filter/filterM+        -- catMaybes+        prop "mapMaybe" mapMaybe++        -- Trimming+        prop "take" take+        -- takeEndBy+        prop "takeEndBy_" takeEndBy_+        prop "takeEndByOrMax" takeEndByOrMax++        -- Appending+        -- serialWith++        -- Distributing+        -- tee+        prop "teeWithLength" Main.teeWithLength+        prop "teeWithMax" Main.teeWithMax+        prop "distribute" Main.distribute++        -- Partitioning+        prop "partition" Main.partition++        -- Unzipping+        prop "unzip" Main.unzip++        -- Nesting+        prop "many" Main.many+        -- concatMap+        -- chunksOf++        prop "head from fold_" headAndRest
+ test/Streamly/Test/Data/List.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-}++module Main (main) where++#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup ((<>))+#endif+import Test.Hspec+import qualified GHC.Exts as GHC++#ifdef USE_STREAMLY_LIST+import Data.Functor.Identity+import Streamly.Internal.Data.List (List(..), pattern Cons, pattern Nil, ZipList(..),+                     fromZipList, toZipList)+import Streamly.Prelude (SerialT)+import qualified Streamly.Prelude as S+#else+import Prelude -- to suppress compiler warning++type List = []++pattern Nil :: [a]+pattern Nil <- [] where Nil = []++pattern Cons :: a -> [a] -> [a]+pattern Cons x xs = x : xs+infixr 5 `Cons`++{-# COMPLETE Nil, Cons #-}+#endif++moduleName :: String+#ifdef USE_STREAMLY_LIST+moduleName = "Data.List+Data.List.Base"+#else+moduleName = "Data.List.Base"+#endif++main :: IO ()+main = hspec $+  describe moduleName $ do+#ifdef USE_STREAMLY_LIST+    describe "OverloadedLists for 'SerialT Identity' type" $ do+        it "Overloaded lists" $ do+            ([1..3] :: SerialT Identity Int) `shouldBe` S.fromList [1..3]+            GHC.toList ([1..3] :: SerialT Identity Int) `shouldBe` [1..3]++        it "Show instance" $ do+            show (S.fromList [1..3] :: SerialT Identity Int)+                `shouldBe` "fromList [1,2,3]"+        it "Read instance" $ do+            (read "fromList [1,2,3]" :: SerialT Identity Int) `shouldBe` [1..3]++        it "Eq instance" $ do+            ([1,2,3] :: SerialT Identity Int) == [1,2,3] `shouldBe` True++        it "Ord instance" $ do+            ([1,2,3] :: SerialT Identity Int) > [1,2,1] `shouldBe` True++        it "Monad comprehension" $ do+            [(x,y) | x <- [1..2], y <- [1..2]] `shouldBe`+                ([(1,1), (1,2), (2,1), (2,2)] :: SerialT Identity (Int, Int))++        it "Foldable (sum)" $ sum ([1..3] :: SerialT Identity Int)+            `shouldBe` 6++        it "Traversable (mapM)" $+            mapM return ([1..10] :: SerialT Identity Int)+                `shouldReturn` [1..10]++    describe "OverloadedStrings for 'SerialT Identity' type" $ do+        it "overloaded strings" $ do+            ("hello" :: SerialT Identity Char) `shouldBe` S.fromList "hello"+#endif++    describe "OverloadedLists for List type" $ do+        it "overloaded lists" $ do+            ([1..3] :: List Int) `shouldBe` GHC.fromList [1..3]+            GHC.toList ([1..3] :: List Int) `shouldBe` [1..3]++        it "Construct empty list" $ (Nil :: List Int) `shouldBe` []++        it "Construct a list" $ do+            (Nil :: List Int) `shouldBe` []+            ('x' `Cons` Nil) `shouldBe` ['x']+            (1 `Cons` [2 :: Int]) `shouldBe` [1,2]+            (1 `Cons` 2 `Cons` 3 `Cons` Nil :: List Int) `shouldBe` [1,2,3]++        it "pattern matches" $ do+            case [] of+                Nil -> return ()+                _ -> expectationFailure "not reached"++            case ['x'] of+                Cons 'x' Nil -> return ()+                _ -> expectationFailure "not reached"++            case [1..10 :: Int] of+                Cons x xs -> do+                    x `shouldBe` 1+                    xs `shouldBe` [2..10]+                _ -> expectationFailure "not reached"++            case [1..10 :: Int] of+                x `Cons` y `Cons` xs -> do+                    x `shouldBe` 1+                    y `shouldBe` 2+                    xs `shouldBe` [3..10]+                _ -> expectationFailure "not reached"++        it "Show instance" $ do+            show ([1..3] :: List Int) `shouldBe`+#ifdef USE_STREAMLY_LIST+                "List {toSerial = fromList [1,2,3]}"+#else+                "[1,2,3]"+#endif++        it "Read instance" $ do+            (read+#ifdef USE_STREAMLY_LIST+                "List {toSerial = fromList [1,2,3]}"+#else+                "[1,2,3]"+#endif+                :: List Int) `shouldBe` [1..3]++        it "Eq instance" $ do+            ([1,2,3] :: List Int) == [1,2,3] `shouldBe` True++        it "Ord instance" $ do+            ([1,2,3] :: List Int) > [1,2,1] `shouldBe` True++        it "Monad comprehension" $ do+            [(x,y) | x <- [1..2], y <- [1..2]] `shouldBe`+                ([(1,1), (1,2), (2,1), (2,2)] :: List (Int, Int))++        it "Foldable (sum)" $ sum ([1..3] :: List Int) `shouldBe` 6++        it "Traversable (mapM)" $+            mapM return ([1..10] :: List Int)+                `shouldReturn` [1..10]++    describe "OverloadedStrings for List type" $ do+        it "overloaded strings" $ do+            ("hello" :: List Char) `shouldBe` GHC.fromList "hello"++        it "pattern matches" $ do+#if __GLASGOW_HASKELL__ >= 802+            case "" of+#else+            case "" :: List Char of+#endif+                Nil -> return ()+                _ -> expectationFailure "not reached"++            case "a" of+                Cons x Nil -> x `shouldBe` 'a'+                _ -> expectationFailure "not reached"++            case "hello" <> "world" of+                Cons x1 (Cons x2 xs) -> do+                    x1 `shouldBe` 'h'+                    x2 `shouldBe` 'e'+                    xs `shouldBe` "lloworld"+                _ -> expectationFailure "not reached"++#ifdef USE_STREAMLY_LIST+    describe "OverloadedLists for ZipList type" $ do+        it "overloaded lists" $ do+            ([1..3] :: ZipList Int) `shouldBe` GHC.fromList [1..3]+            GHC.toList ([1..3] :: ZipList Int) `shouldBe` [1..3]++        it "toZipList" $ do+            toZipList (Nil :: List Int) `shouldBe` []+            toZipList ('x' `Cons` Nil) `shouldBe` ['x']+            toZipList (1 `Cons` [2 :: Int]) `shouldBe` [1,2]+            toZipList (1 `Cons` 2 `Cons` 3 `Cons` Nil :: List Int) `shouldBe` [1,2,3]++        it "fromZipList" $ do+            case fromZipList [] of+                Nil -> return ()+                _ -> expectationFailure "not reached"++            case fromZipList ['x'] of+                Cons 'x' Nil -> return ()+                _ -> expectationFailure "not reached"++            case fromZipList [1..10 :: Int] of+                Cons x xs -> do+                    x `shouldBe` 1+                    xs `shouldBe` [2..10]+                _ -> expectationFailure "not reached"++            case fromZipList [1..10 :: Int] of+                x `Cons` y `Cons` xs -> do+                    x `shouldBe` 1+                    y `shouldBe` 2+                    xs `shouldBe` [3..10]+                _ -> expectationFailure "not reached"++        it "Show instance" $ do+            show ([1..3] :: ZipList Int) `shouldBe`+                "ZipList {toZipSerial = fromList [1,2,3]}"++        it "Read instance" $ do+            (read "ZipList {toZipSerial = fromList [1,2,3]}" :: ZipList Int)+                `shouldBe` [1..3]++        it "Eq instance" $ do+            ([1,2,3] :: ZipList Int) == [1,2,3] `shouldBe` True++        it "Ord instance" $ do+            ([1,2,3] :: ZipList Int) > [1,2,1] `shouldBe` True++        it "Foldable (sum)" $ sum ([1..3] :: ZipList Int) `shouldBe` 6++        it "Traversable (mapM)" $+            mapM return ([1..10] :: ZipList Int)+                `shouldReturn` [1..10]++        it "Applicative Zip" $ do+            (,) <$> "abc" <*> [1..3] `shouldBe`+                ([('a',1),('b',2),('c',3)] :: ZipList (Char, Int))+#endif
+ test/Streamly/Test/Data/Parser.hs view
@@ -0,0 +1,764 @@+module Main (main) where++import Control.Exception (SomeException(..), displayException)+import Data.Word (Word8, Word32, Word64)+import Streamly.Test.Common (listEquals, checkListEqual, chooseInt)+import Test.Hspec (Spec, hspec, describe)+import Test.Hspec.QuickCheck+import Test.QuickCheck+       (arbitrary, forAll, elements, Property, property, listOf,+        vectorOf, Gen)+import Test.QuickCheck.Monadic (monadicIO, assert, run)++import Prelude hiding (sequence)++import qualified Data.List as List+import qualified Prelude+import qualified Streamly.Internal.Data.Array.Foreign as A+import qualified Streamly.Internal.Data.Fold as FL+import qualified Streamly.Internal.Data.Parser as P+import qualified Streamly.Internal.Data.Stream.IsStream as S+import qualified Test.Hspec as H++#if MIN_VERSION_QuickCheck(2,14,0)++import Test.QuickCheck (chooseAny)++#else++import System.Random (Random(random))+import Test.QuickCheck.Gen (Gen(MkGen))++-- | Generates a random element over the natural range of `a`.+chooseAny :: Random a => Gen a+chooseAny = MkGen (\r _ -> let (x,_) = random r in x)++#endif+++maxTestCount :: Int+maxTestCount = 100++min_value :: Int+min_value = 0++mid_value :: Int+mid_value = 5000++max_value :: Int+max_value = 10000++max_length :: Int+max_length = 1000++-- Accumulator Tests++fromFold :: Property+fromFold =+    forAll (listOf $ chooseInt (min_value, max_value)) $ \ls ->+        case (==) <$> S.parse (P.fromFold FL.sum) (S.fromList ls)+                  <*> S.fold FL.sum (S.fromList ls) of+            Right is_equal -> is_equal+            Left _ -> False++fromPure :: Property+fromPure =+    forAll (chooseInt (min_value, max_value)) $ \x ->+        case S.parse (P.fromPure x) (S.fromList [1 :: Int]) of+            Right r -> r == x+            Left _ -> False++fromEffect :: Property+fromEffect =+    forAll (chooseInt (min_value, max_value)) $ \x ->+        case S.parse (P.fromEffect $ return x) (S.fromList [1 :: Int]) of+            Right r -> r == x+            Left _ -> False++die :: Property+die =+    property $+    case S.parse (P.die "die test") (S.fromList [0 :: Int]) of+        Right _ -> False+        Left _ -> True++dieM :: Property+dieM =+    property $+    case S.parse (P.dieM (Right "die test")) (S.fromList [0 :: Int]) of+        Right _ -> False+        Left _ -> True++parserFail :: Property+parserFail =+    property $+    case S.parse (fail err) (S.fromList [0 :: Int]) of+        Right _ -> False+        Left (SomeException e) -> err == displayException e+  where+    err = "Testing MonadFail.fail."++-- Element Parser Tests++peekPass :: Property+peekPass =+    forAll (chooseInt (1, max_length)) $ \list_length ->+        forAll (vectorOf list_length (chooseInt (min_value, max_value))) $ \ls ->+            case S.parse P.peek (S.fromList ls) of+                Right head_value -> case ls of+                    head_ls : _ -> head_value == head_ls+                    _ -> False+                Left _ -> False++peekFail :: Property+peekFail =+    property (case S.parse P.peek (S.fromList []) of+        Right _ -> False+        Left _ -> True)++eofPass :: Property+eofPass =+    property (case S.parse P.eof (S.fromList []) of+        Right _ -> True+        Left _ -> False)++eofFail :: Property+eofFail =+    forAll (chooseInt (1, max_length)) $ \list_length ->+        forAll (vectorOf list_length (chooseInt (min_value, max_value))) $ \ls ->+            case S.parse P.eof (S.fromList ls) of+                Right _ -> False+                Left _ -> True++satisfyPass :: Property+satisfyPass =+    forAll (chooseInt (mid_value, max_value)) $ \first_element ->+        forAll (listOf (chooseInt (min_value, max_value))) $ \ls_tail ->+            let+                ls = first_element : ls_tail+                predicate = (>= mid_value)+            in+                case S.parse (P.satisfy predicate) (S.fromList ls) of+                    Right r -> r == first_element+                    Left _ -> False++satisfy :: Property+satisfy =+    forAll (listOf (chooseInt (min_value, max_value))) $ \ls ->+        case S.parse (P.satisfy predicate) (S.fromList ls) of+            Right r -> case ls of+                [] -> False+                (x : _) -> predicate x && (r == x)+            Left _ -> case ls of+                [] -> True+                (x : _) -> not $ predicate x+        where+            predicate = (>= mid_value)++-- Sequence Parsers Tests+takeBetweenPass :: Property+takeBetweenPass =+    forAll (chooseInt (min_value, max_value)) $ \m ->+        forAll (chooseInt (m, max_value)) $ \n ->+            forAll (chooseInt (m, max_value)) $ \list_length ->+                forAll (vectorOf list_length (chooseInt (min_value, max_value)))+                    $ \ls ->+                        case S.parse (P.takeBetween m n FL.toList)+                                (S.fromList ls) of+                            Right parsed_list ->+                                let lpl = Prelude.length parsed_list+                                in checkListEqual parsed_list+                                    $ Prelude.take lpl ls+                            Left _ -> property False++takeBetween :: Property+takeBetween =+    forAll (chooseInt (min_value, max_value)) $ \m ->+        forAll (chooseInt (min_value, max_value)) $ \n ->+                forAll (listOf (chooseInt (min_value, max_value))) $ \ls ->+                let+                    list_length = Prelude.length ls+                in+                    case S.parse (P.takeBetween m n FL.toList)+                            (S.fromList ls) of+                        Right parsed_list ->+                            if m <= list_length && n >= list_length+                            then+                                let lpl = Prelude.length parsed_list+                                in checkListEqual parsed_list+                                    $ Prelude.take lpl ls+                            else property False+                        Left _ -> property (m > n || list_length < m)+++takeEQPass :: Property+takeEQPass =+    forAll (chooseInt (min_value, max_value)) $ \n ->+        forAll (chooseInt (n, max_value)) $ \list_length ->+            forAll (vectorOf list_length+                        (chooseInt (min_value, max_value))) $ \ls ->+                case S.parse (P.takeEQ n FL.toList) (S.fromList ls) of+                    Right parsed_list ->+                        checkListEqual parsed_list (Prelude.take n ls)+                    Left _ -> property False++takeEQ :: Property+takeEQ =+    forAll (chooseInt (min_value, max_value)) $ \n ->+        forAll (listOf (chooseInt (min_value, max_value))) $ \ls ->+            let+                list_length = Prelude.length ls+            in+                case S.parse (P.takeEQ n FL.toList) (S.fromList ls) of+                    Right parsed_list ->+                        if n <= list_length+                        then checkListEqual parsed_list (Prelude.take n ls)+                        else property False+                    Left _ -> property (n > list_length)++takeGEPass :: Property+takeGEPass =+    forAll (chooseInt (min_value, max_value)) $ \n ->+        forAll (chooseInt (n, max_value)) $ \list_length ->+            forAll (vectorOf list_length (chooseInt (min_value, max_value)))+                $ \ls ->+                    case S.parse (P.takeGE n FL.toList) (S.fromList ls) of+                        Right parsed_list -> checkListEqual parsed_list ls+                        Left _ -> property False++takeGE :: Property+takeGE =+    forAll (chooseInt (min_value, max_value)) $ \n ->+        forAll (listOf (chooseInt (min_value, max_value))) $ \ls ->+            let+                list_length = Prelude.length ls+            in+                case S.parse (P.takeGE n FL.toList) (S.fromList ls) of+                    Right parsed_list ->+                        if n <= list_length+                        then checkListEqual parsed_list ls+                        else property False+                    Left _ -> property (n > list_length)++nLessThanEqual0 ::+       (  Int+       -> FL.Fold (Either SomeException) Int [Int]+       -> P.Parser (Either SomeException) Int [Int]+       )+    -> (Int -> [Int] -> [Int])+    -> Property+nLessThanEqual0 tk ltk =+    forAll (elements [0, (-1)]) $ \n ->+        forAll (listOf arbitrary) $ \ls ->+            case S.parse (tk n FL.toList) (S.fromList ls) of+                Right parsed_list -> checkListEqual parsed_list (ltk n ls)+                Left _ -> property False++takeProperties :: Spec+takeProperties =+    describe "take combinators when n <= 0/" $ do+        prop "takeEQ n FL.toList = []" $+            nLessThanEqual0 P.takeEQ (\_ -> const [])+        prop "takeGE n FL.toList xs = xs" $+            nLessThanEqual0 P.takeGE (\_ -> id)++-- lookAheadPass :: Property+-- lookAheadPass =+--     forAll (chooseInt (min_value + 1, max_value)) $ \n ->+--         let+--             takeWithoutConsume = P.lookAhead $ P.take n FL.toList+--             parseTwice = do+--                 parsed_list_1 <- takeWithoutConsume+--                 parsed_list_2 <- takeWithoutConsume+--                 return (parsed_list_1, parsed_list_2)+--         in+--             forAll (chooseInt (n, max_value)) $ \list_length ->+--                 forAll (vectorOf list_length (chooseInt (min_value, max_value))) $ \ls ->+--                     case S.parse parseTwice (S.fromList ls) of+--                         Right (ls_1, ls_2) -> checkListEqual ls_1 ls_2 .&&. checkListEqual ls_1 (Prelude.take n ls)+--                         Left _ -> property $ False++-- lookAheadFail :: Property+-- lookAheadFail =+--     forAll (chooseInt (min_value + 1, max_value)) $ \n ->+--         let+--             takeWithoutConsume = P.lookAhead $ P.take n FL.toList+--             parseTwice = do+--                 parsed_list_1 <- takeWithoutConsume+--                 parsed_list_2 <- takeWithoutConsume+--                 return (parsed_list_1, parsed_list_2)+--         in+--             forAll (chooseInt (min_value, n - 1)) $ \list_length ->+--                 forAll (vectorOf list_length (chooseInt (min_value, max_value))) $ \ls ->+--                     case S.parse parseTwice (S.fromList ls) of+--                         Right _ -> False+--                         Left _ -> True++-- lookAhead :: Property+-- lookAhead =+--     forAll (chooseInt (min_value, max_value)) $ \n ->+--         let+--             takeWithoutConsume = P.lookAhead $ P.take n FL.toList+--             parseTwice = do+--                 parsed_list_1 <- takeWithoutConsume+--                 parsed_list_2 <- takeWithoutConsume+--                 return (parsed_list_1, parsed_list_2)+--         in+--             forAll (listOf (chooseInt (min_value, max_value))) $ \ls ->+--                 case S.parse parseTwice (S.fromList ls) of+--                     Right (ls_1, ls_2) -> checkListEqual ls_1 ls_2 .&&. checkListEqual ls_1 (Prelude.take n ls)+--                     Left _ -> property ((list_length < n) || (list_length == n && n == 0))+--                         where+--                             list_length = Prelude.length ls++sliceSepByP :: Property+sliceSepByP =+    forAll (listOf (chooseInt (min_value, max_value )))  $ \ls ->+        case S.parse (P.sliceSepByP predicate prsr) (S.fromList ls) of+            Right parsed_list ->+                checkListEqual parsed_list (tkwhl ls)+            Left _ -> property False+        where+            predicate = (>= 100)+            prsr = P.many (P.satisfy (const True)) FL.toList+            tkwhl ls = Prelude.takeWhile (not . predicate) ls++sliceBeginWith :: Property+sliceBeginWith =+    forAll (listOf (chooseInt (min_value, max_value))) $ \ls ->+        let ls1 = 1:ls+        in+            case S.parse parser (S.fromList ls1) of+                Right parsed_list ->+                  if not $ Prelude.null ls1+                  then+                    let tls = Prelude.takeWhile (not . predicate) (tail ls1)+                    in checkListEqual parsed_list $+                      if predicate (head ls1)+                      then head ls1 : tls+                      else Prelude.takeWhile (not . predicate) ls1+                  else property $ Prelude.null parsed_list+                Left _ -> property False+            where+                predicate = odd+                parser = P.sliceBeginWith predicate FL.toList++takeWhile :: Property+takeWhile =+    forAll (listOf (chooseInt (0, 1))) $ \ ls ->+        case S.parse (P.takeWhile predicate FL.toList) (S.fromList ls) of+            Right parsed_list ->+                checkListEqual parsed_list (Prelude.takeWhile predicate ls)+            Left _ -> property False+        where+            predicate = (== 0)++takeWhile1 :: Property+takeWhile1 =+    forAll (listOf (chooseInt (0, 1))) $ \ ls ->+        case S.parse (P.takeWhile1 predicate  FL.toList) (S.fromList ls) of+            Right parsed_list -> case ls of+                [] -> property False+                (x : _) ->+                    if predicate x+                    then+                        checkListEqual parsed_list+                           $ Prelude.takeWhile predicate ls+                    else+                        property False+            Left _ -> case ls of+                [] -> property True+                (x : _) -> property (not $ predicate x)+        where+            predicate = (== 0)++groupBy :: Property+groupBy =+    forAll (listOf (chooseInt (0, 1)))+        $ \ls ->+              case S.parse parser (S.fromList ls) of+                  Right parsed -> checkListEqual parsed (groupByLF ls)+                  Left _ -> property False++    where++    cmp = (==)+    parser = P.groupBy cmp FL.toList+    groupByLF lst+        | null lst = []+        | otherwise = head $ List.groupBy cmp lst+++wordBy :: Property+wordBy =+    forAll (listOf (elements [' ', 's']))+        $ \ls ->+              case S.parse parser (S.fromList ls) of+                  Right parsed -> checkListEqual parsed (words' ls)+                  Left _ -> property False++    where++    predicate = (== ' ')+    parser = P.many (P.wordBy predicate FL.toList) FL.toList+    words' lst =+        let wrds = words lst+         in if wrds == [] && length lst > 0 then [""] else wrds++-- splitWithPass :: Property+-- splitWithPass =+--     forAll (listOf (chooseInt (0, 1))) $ \ls ->+--         case S.parse (P.serialWith (,) (P.satisfy (== 0)) (P.satisfy (== 1))) (S.fromList ls) of+--             Right (result_first, result_second) -> case ls of+--                 0 : 1 : _ -> (result_first == 0) && (result_second == 1)+--                 _ -> False+--             Left _ -> case ls of+--                 0 : 1 : _ -> False+--                 _ -> True++-- splitWithFailLeft :: Property+-- splitWithFailLeft =+--     property (case S.parse (P.serialWith (,) (P.die "die") (P.fromPure (1 :: Int))) (S.fromList [1 :: Int]) of+--         Right _ -> False+--         Left _ -> True)++-- splitWithFailRight :: Property+-- splitWithFailRight =+--     property (case S.parse (P.serialWith (,) (P.fromPure (1 :: Int)) (P.die "die")) (S.fromList [1 :: Int]) of+--         Right _ -> False+--         Left _ -> True)++-- splitWithFailBoth :: Property+-- splitWithFailBoth =+--     property (case S.parse (P.serialWith (,) (P.die "die") (P.die "die")) (S.fromList [1 :: Int]) of+--         Right _ -> False+--         Left _ -> True)++-- teeWithPass :: Property+-- teeWithPass =+--     forAll (chooseInt (0, 10000)) $ \n ->+--         forAll (listOf (chooseInt (0, 1))) $ \ls ->+--             let+--                 prsr = P.take n FL.toList+--             in+--                 case S.parse (P.teeWith (,) prsr prsr) (S.fromList ls) of+--                     Right (ls_1, ls_2) -> checkListEqual (Prelude.take n ls) ls_1 .&&. checkListEqual ls_1 ls_2+--                     Left _ -> property False++-- teeWithFailLeft :: Property+-- teeWithFailLeft =+--     property (case S.parse (P.teeWith (,) (P.die "die") (P.fromPure (1 :: Int))) (S.fromList [1 :: Int]) of+--         Right _ -> False+--         Left _ -> True)++-- teeWithFailRight :: Property+-- teeWithFailRight =+--     property (case S.parse (P.teeWith (,) (P.fromPure (1 :: Int)) (P.die "die")) (S.fromList [1 :: Int]) of+--         Right _ -> False+--         Left _ -> True)++-- teeWithFailBoth :: Property+-- teeWithFailBoth =+--     property (case S.parse (P.teeWith (,) (P.die "die") (P.die "die")) (S.fromList [1 :: Int]) of+--         Right _ -> False+--         Left _ -> True)++-- deintercalate :: Property+-- deintercalate =+--     forAll (listOf (chooseInt (0, 1))) $ \ls ->+--         case S.parse (P.deintercalate concatFold prsr_1 concatFold prsr_2) (S.fromList ls) of+--             Right parsed_list_tuple -> parsed_list_tuple == (partition (== 0) ls)+--             Left _ -> False++--         where+--             prsr_1 = (P.takeWhile (== 0) FL.toList)+--             prsr_2 = (P.takeWhile (== 1) FL.toList)+--             concatFold = FL.Fold (\concatList curr_list -> return $ concatList ++ curr_list) (return []) return++-- shortestPass :: Property+-- shortestPass =+--     forAll (listOf (chooseInt(min_value, max_value))) $ \ls ->+--         let+--             prsr_1 = P.takeWhile (<= (mid_value `Prelude.div` 2)) FL.toList+--             prsr_2 = P.takeWhile (<= mid_value) FL.toList+--             prsr_shortest = P.shortest prsr_1 prsr_2+--         in+--             case S.parse prsr_shortest (S.fromList ls) of+--                 Right short_list -> checkListEqual short_list (Prelude.takeWhile (<= 2500) ls)+--                 Left _ -> property False++-- shortestFailLeft :: Property+-- shortestFailLeft =+--     property (case S.parse (P.shortest (P.die "die") (P.fromPure (1 :: Int))) (S.fromList [1 :: Int]) of+--         Right r -> r == 1+--         Left _ -> False)++-- shortestFailRight :: Property+-- shortestFailRight =+--     property (case S.parse (P.shortest (P.fromPure (1 :: Int)) (P.die "die")) (S.fromList [1 :: Int]) of+--         Right r -> r == 1+--         Left _ -> False)++-- shortestFailBoth :: Property+-- shortestFailBoth =+--     property (case S.parse (P.shortest (P.die "die") (P.die "die")) (S.fromList [1 :: Int]) of+--         Right _ -> False+--         Left _ -> True)++many :: Property+many =+    forAll (listOf (chooseInt (0, 1))) $ \ls ->+        let fldstp conL currL = return $ FL.Partial $ conL ++ currL+            concatFold = FL.Fold fldstp (return (FL.Partial [])) return+            prsr =+                flip P.many concatFold $ P.fromFold $ FL.takeEndBy_ (== 1) FL.toList+        in+            case S.parse prsr (S.fromList ls) of+                Right res_list -> checkListEqual res_list+                                    $ Prelude.filter (== 0) ls+                Left _ -> property False++-- many_empty :: Property+-- many_empty =+--     property (case S.parse (P.many FL.toList (P.die "die")) (S.fromList [1 :: Int]) of+--         Right res_list -> checkListEqual res_list ([] :: [Int])+--         Left _ -> property False)++some :: Property+some =+    forAll (listOf (chooseInt (0, 1))) $ \genLs ->+        let+            ls = 0 : genLs+            fldstp conL currL = return $ FL.Partial $ conL ++ currL+            concatFold = FL.Fold fldstp (return (FL.Partial [])) return+            prsr =+                flip P.some concatFold $ P.fromFold $ FL.takeEndBy_ (== 1) FL.toList+        in+            case S.parse prsr (S.fromList ls) of+                Right res_list -> res_list == Prelude.filter (== 0) ls+                Left _ -> False++-- someFail :: Property+-- someFail =+--     property (case S.parse (P.some FL.toList (P.die "die")) (S.fromList [1 :: Int]) of+--         Right _ -> False+--         Left _ -> True)++-------------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------------++applicative :: Property+applicative =+    forAll (listOf (chooseAny :: Gen Int)) $ \ list1 ->+        forAll (listOf (chooseAny :: Gen Int)) $ \ list2 ->+            let parser =+                    (,)+                        <$> P.fromFold (FL.take (length list1) FL.toList)+                        <*> P.fromFold (FL.take (length list2) FL.toList)+             in monadicIO $ do+                    (olist1, olist2) <-+                        run $ S.parse parser (S.fromList $ list1 ++ list2)+                    listEquals (==) olist1 list1+                    listEquals (==) olist2 list2++sequence :: Property+sequence =+    forAll (vectorOf 11 (listOf (chooseAny :: Gen Int))) $ \ ins ->+        let p xs = P.fromFold (FL.take (length xs) FL.toList)+         in monadicIO $ do+                outs <- run $+                        S.parse+                            (Prelude.sequence $ fmap p ins)+                            (S.fromList $ concat ins)+                listEquals (==) outs ins++monad :: Property+monad =+    forAll (listOf (chooseAny :: Gen Int)) $ \ list1 ->+        forAll (listOf (chooseAny :: Gen Int)) $ \ list2 ->+            let parser = do+                    olist1 <- P.fromFold (FL.take (length list1) FL.toList)+                    olist2 <- P.fromFold (FL.take (length list2) FL.toList)+                    return (olist1, olist2)+             in monadicIO $ do+                    (olist1, olist2) <-+                        run $ S.parse parser (S.fromList $ list1 ++ list2)+                    listEquals (==) olist1 list1+                    listEquals (==) olist2 list2++-------------------------------------------------------------------------------+-- Stream parsing+-------------------------------------------------------------------------------++parseMany :: Property+parseMany =+    forAll (chooseInt (1,100)) $ \len ->+        forAll (listOf (vectorOf len (chooseAny :: Gen Int))) $ \ ins ->+            monadicIO $ do+                outs <- do+                    let p = P.fromFold $ FL.take len FL.toList+                    run+                        $ S.toList+                        $ S.parseMany p (S.fromList $ concat ins)+                listEquals (==) outs ins++-------------------------------------------------------------------------------+-- Test for a particular case hit during fs events testing+-------------------------------------------------------------------------------++evId :: [Word8]+evId = [96,238,17,9,0,0,0,0]++evFlags :: [Word8]+evFlags = [0,4,1,0,0,0,0,0]++evPathLen :: [Word8]+evPathLen = [71,0,0,0,0,0,0,0]++evPath :: [Word8]+evPath =+    [47,85,115,101,114,115,47,118,111,108,47,118,101,109,98,97,47,99,111,109+    ,112,111,115,101,119,101 ,108,108,45,116,101,99,104,47,69,110,103,47,112+    ,114,111,106,101,99,116,115,47,115,116,114,101,97,109,108,121,47,115,116+    ,114,101,97,109,108,121,47,116,109,112,47,122,122+    ]++event :: [Word8]+event = evId ++ evFlags ++ evPathLen ++ evPath++data Event = Event+   { eventId :: Word64+   , eventFlags :: Word32+   , eventAbsPath :: A.Array Word8+   } deriving (Show, Ord, Eq)++readOneEvent :: P.Parser IO Word8 Event+readOneEvent = do+    arr <- P.takeEQ 24 (A.writeN 24)+    let arr1 = A.unsafeCast arr :: A.Array Word64+        eid = A.unsafeIndex arr1 0+        eflags = A.unsafeIndex arr1 1+        pathLen = fromIntegral $ A.unsafeIndex arr1 2+    -- XXX handle if pathLen is 0+    path <- P.takeEQ pathLen (A.writeN pathLen)+    return $ Event+        { eventId = eid+        , eventFlags = fromIntegral eflags+        , eventAbsPath = path+        }++parseMany2Events :: Property+parseMany2Events =+    monadicIO $ do+        xs <-+            ( run+            $ S.toList+            $ S.parseMany readOneEvent+            $ S.fromList (concat (replicate 2 event))+            )+        assert (length xs == 2)+        -- XXX assuming little endian machine+        let ev = Event+                { eventId = 152170080+                , eventFlags = 66560+                , eventAbsPath = A.fromList evPath+                }+         in listEquals (==) xs (replicate 2 ev)++manyEqParseMany :: Property+manyEqParseMany =+    forAll (listOf (chooseInt (0, 100))) $ \lst ->+    forAll (chooseInt (1, 100)) $ \i ->+        monadicIO $ do+            let strm = S.fromList lst+            r1 <- run $ S.parse (P.many (split i) FL.toList) strm+            r2 <- run $ S.toList $ S.parseMany (split i) strm+            assert $ r1 == r2++    where++    split i = P.fromFold (FL.take i FL.toList)++-------------------------------------------------------------------------------+-- Main+-------------------------------------------------------------------------------++moduleName :: String+moduleName = "Data.Parser"++main :: IO ()+main =+  hspec $+  H.parallel $+  modifyMaxSuccess (const maxTestCount) $ do+  describe moduleName $ do++    describe "Instances" $ do+        prop "applicative" applicative+        prop "monad" monad+        prop "sequence" sequence++    describe "Stream parsing" $ do+        prop "parseMany" parseMany+        prop "parseMany2Events" parseMany2Events++    describe "test for accumulator" $ do+        prop "P.fromFold FL.sum = FL.sum" fromFold+        prop "fromPure value provided" fromPure+        prop "fromPure monadic value provided" fromEffect+        prop "fail err = Left (SomeException (ParseError err))" parserFail+        prop "always fail" die+        prop "always fail but monadic" dieM++    describe "test for element parser" $ do+        prop "peek = head with list length > 0" peekPass+        prop "peek fail on []" peekFail+        prop "eof pass on []" eofPass+        prop "eof fail on non-empty list" eofFail+        prop "first element exists and >= mid_value" satisfyPass+        prop "check first element exists and satisfies predicate" satisfy++    describe "test for sequence parser" $ do+        prop "P.takeBetween = Prelude.take when len >= m and len <= n"+            takeBetweenPass+        prop ("P.takeBetween = Prelude.take when len >= m and len <= n and fail"+              ++ "otherwise fail") Main.takeBetween++        prop "P.takeEQ = Prelude.take when len >= n" takeEQPass+        prop "P.takeEQ = Prelude.take when len >= n and fail otherwise"+            Main.takeEQ+        prop "P.takeGE n ls = ls when len >= n" takeGEPass+        prop "P.takeGE n ls = ls when len >= n and fail otherwise" Main.takeGE+        -- prop "lookAhead . take n >> lookAhead . take n = lookAhead . take n" lookAheadPass+        -- prop "Fail when stream length exceeded" lookAheadFail+        -- prop "lookAhead . take n >> lookAhead . take n = lookAhead . take n, else fail" lookAhead+        prop "P.sliceSepByP test" Main.sliceSepByP+        prop ("P.sliceBeginWith pred = head : Prelude.takeWhile (not . pred)"+                ++ " tail") sliceBeginWith+        prop "P.takeWhile = Prelude.takeWhile" Main.takeWhile+        prop ("P.takeWhile1 = Prelude.takeWhile if taken something,"+                ++ " else check why failed") takeWhile1+        prop "P.groupBy = Prelude.head . Prelude.groupBy" groupBy+        prop "many (P.wordBy ' ') = words'" wordBy+        -- prop "" splitWithPass+        -- prop "" splitWithFailLeft+        -- prop "" splitWithFailRight+        -- prop "" splitWithFailBoth+        -- prop "" teeWithPass+        -- prop "" teeWithFailLeft+        -- prop "" teeWithFailRight+        -- prop "" teeWithFailBoth+        -- prop "" deintercalate+        -- prop "" shortestPass+        -- prop "" shortestFailLeft+        -- prop "" shortestFailRight+        -- prop "" shortestFailBoth+        prop ("P.many concatFold $ P.takeEndBy_ (== 1) FL.toList ="+                ++ "Prelude.filter (== 0)") many+        -- prop "[] due to parser being die" many_empty+        prop ("P.some concatFold $ P.takeEndBy_ (== 1) FL.toList ="+                ++ "Prelude.filter (== 0)") some+        -- prop "fail due to parser being die" someFail+        prop "P.many == S.parseMany" manyEqParseMany+    takeProperties
+ test/Streamly/Test/Data/Parser/ParserD.hs view
@@ -0,0 +1,777 @@+module Main (main) where++import Control.Exception (SomeException(..))+import Data.Word (Word8, Word32, Word64)+import Streamly.Test.Common (listEquals, checkListEqual, chooseInt)+import Test.Hspec (Spec, hspec, describe)+import Test.Hspec.QuickCheck+import Test.QuickCheck+       (arbitrary, forAll, elements, Property,+        property, listOf, vectorOf, (.&&.), Gen)+import Test.QuickCheck.Monadic (monadicIO, assert, run)++import qualified Data.List as List+import qualified Prelude+import qualified Streamly.Internal.Data.Array.Foreign as A+import qualified Streamly.Internal.Data.Fold as FL+import qualified Streamly.Internal.Data.Parser.ParserD as P+import qualified Streamly.Internal.Data.Producer.Source as Source+import qualified Streamly.Internal.Data.Producer as Producer+import qualified Streamly.Internal.Data.Stream.IsStream as S+import qualified Streamly.Internal.Data.Unfold as Unfold+import qualified Test.Hspec as H++import Prelude hiding (sequence)++#if MIN_VERSION_QuickCheck(2,14,0)++import Test.QuickCheck (chooseAny)++#else++import System.Random (Random(random))+import Test.QuickCheck.Gen (Gen(MkGen))++-- | Generates a random element over the natural range of `a`.+chooseAny :: Random a => Gen a+chooseAny = MkGen (\r _ -> let (x,_) = random r in x)++#endif++maxTestCount :: Int+maxTestCount = 100++min_value :: Int+min_value = 0++mid_value :: Int+mid_value = 5000++max_value :: Int+max_value = 10000++max_length :: Int+max_length = 1000++-- Accumulator Tests++fromFold :: Property+fromFold =+    forAll (listOf $ chooseInt (min_value, max_value))+      $ \ls ->+            case (==) <$> (S.parseD (P.fromFold FL.sum) (S.fromList ls))+                   <*> (S.fold FL.sum (S.fromList ls)) of+                Right is_equal -> is_equal+                Left _ -> False++fromPure :: Property+fromPure =+    forAll (chooseInt (min_value, max_value)) $ \x ->+        case S.parseD (P.fromPure x) (S.fromList [1 :: Int]) of+            Right r -> r == x+            Left _ -> False++fromEffect :: Property+fromEffect =+    forAll (chooseInt (min_value, max_value)) $ \x ->+        case S.parseD (P.fromEffect $ return x) (S.fromList [1 :: Int]) of+            Right r -> r == x+            Left _ -> False++die :: Property+die =+    property $+    case S.parseD (P.die "die test") (S.fromList [0 :: Int]) of+        Right _ -> False+        Left _ -> True++dieM :: Property+dieM =+    property $+    case S.parseD (P.dieM (Right "die test")) (S.fromList [0 :: Int]) of+        Right _ -> False+        Left _ -> True++-- Element Parser Tests++peekPass :: Property+peekPass =+    forAll (chooseInt (1, max_length)) $ \list_length ->+        forAll (vectorOf list_length (chooseInt (min_value, max_value))) $ \ls ->+            case S.parseD P.peek (S.fromList ls) of+                Right head_value -> case ls of+                    head_ls : _ -> head_value == head_ls+                    _ -> False+                Left _ -> False++peekFail :: Property+peekFail =+    property (case S.parseD P.peek (S.fromList []) of+        Right _ -> False+        Left _ -> True)++eofPass :: Property+eofPass =+    property (case S.parseD P.eof (S.fromList []) of+        Right _ -> True+        Left _ -> False)++eofFail :: Property+eofFail =+    forAll (chooseInt (1, max_length)) $ \list_length ->+        forAll (vectorOf list_length (chooseInt (min_value, max_value))) $ \ls ->+            case S.parseD P.eof (S.fromList ls) of+                Right _ -> False+                Left _ -> True++satisfyPass :: Property+satisfyPass =+    forAll (chooseInt (mid_value, max_value)) $ \first_element ->+        forAll (listOf (chooseInt (min_value, max_value))) $ \ls_tail ->+            let+                ls = first_element : ls_tail+                predicate = (>= mid_value)+            in+                case S.parseD (P.satisfy predicate) (S.fromList ls) of+                    Right r -> r == first_element+                    Left _ -> False++satisfy :: Property+satisfy =+    forAll (listOf (chooseInt (min_value, max_value))) $ \ls ->+        case S.parseD (P.satisfy predicate) (S.fromList ls) of+            Right r -> case ls of+                [] -> False+                (x : _) -> predicate x && (r == x)+            Left _ -> case ls of+                [] -> True+                (x : _) -> not $ predicate x+        where+            predicate = (>= mid_value)++-- Sequence Parsers Tests+takeBetweenPass :: Property+takeBetweenPass =+    forAll (chooseInt (min_value, max_value)) $ \m ->+        forAll (chooseInt (m, max_value)) $ \n ->+            forAll (chooseInt (m, max_value)) $ \list_length ->+                forAll (vectorOf list_length (chooseInt (min_value, max_value))) $ \ls ->+                    case S.parseD (P.takeBetween m n FL.toList) (S.fromList ls) of+                        Right parsed_list ->+                            let lpl = Prelude.length parsed_list+                            in checkListEqual parsed_list (Prelude.take lpl ls)+                        Left _ -> property False+++takeBetween :: Property+takeBetween =+    forAll (chooseInt (min_value, max_value)) $ \m ->+        forAll (chooseInt (min_value, max_value)) $ \n ->+            forAll (listOf (chooseInt (min_value, max_value))) $ \ls ->+                let+                    list_length = Prelude.length ls+                in+                    case S.parseD (P.takeBetween m n FL.toList) (S.fromList ls) of+                        Right parsed_list ->+                            if m <= list_length && n >= list_length+                            then+                                let lpl = Prelude.length parsed_list+                                in checkListEqual parsed_list (Prelude.take+                                    lpl ls)+                            else property False+                        Left _ -> property (m > n || list_length < m)++take :: Property+take =+    forAll (chooseInt (min_value, max_value)) $ \n ->+        forAll (listOf (chooseInt (min_value, max_value))) $ \ls ->+            case S.parseD (P.fromFold $ FL.take n FL.toList) (S.fromList ls) of+                Right parsed_list -> checkListEqual parsed_list (Prelude.take n ls)+                Left _ -> property False++takeEQPass :: Property+takeEQPass =+    forAll (chooseInt (min_value, max_value)) $ \n ->+        forAll (chooseInt (n, max_value)) $ \list_length ->+            forAll (vectorOf list_length (chooseInt (min_value, max_value))) $ \ls ->+                case S.parseD (P.takeEQ n FL.toList) (S.fromList ls) of+                    Right parsed_list -> checkListEqual parsed_list (Prelude.take n ls)+                    Left _ -> property False++takeEQ :: Property+takeEQ =+    forAll (chooseInt (min_value, max_value)) $ \n ->+        forAll (listOf (chooseInt (min_value, max_value))) $ \ls ->+            let+                list_length = Prelude.length ls+            in+                case S.parseD (P.takeEQ n FL.toList) (S.fromList ls) of+                    Right parsed_list ->+                        if (n <= list_length) then+                            checkListEqual parsed_list (Prelude.take n ls)+                        else+                            property False+                    Left _ -> property (n > list_length)++takeGEPass :: Property+takeGEPass =+    forAll (chooseInt (min_value, max_value)) $ \n ->+        forAll (chooseInt (n, max_value)) $ \list_length ->+            forAll (vectorOf list_length (chooseInt (min_value, max_value))) $ \ls ->+                case S.parseD (P.takeGE n FL.toList) (S.fromList ls) of+                    Right parsed_list -> checkListEqual parsed_list ls+                    Left _ -> property False++takeGE :: Property+takeGE =+    forAll (chooseInt (min_value, max_value)) $ \n ->+        forAll (listOf (chooseInt (min_value, max_value))) $ \ls ->+            let+                list_length = Prelude.length ls+            in+                case S.parseD (P.takeGE n FL.toList) (S.fromList ls) of+                    Right parsed_list ->+                        if (n <= list_length) then+                            checkListEqual parsed_list ls+                        else+                            property False+                    Left _ -> property (n > list_length)++nLessThanEqual0 ::+       (  Int+       -> FL.Fold (Either SomeException) Int [Int]+       -> P.Parser (Either SomeException) Int [Int]+       )+    -> (Int -> [Int] -> [Int])+    -> Property+nLessThanEqual0 tk ltk =+    forAll (elements [0, (-1)]) $ \n ->+        forAll (listOf arbitrary) $ \ls ->+            case S.parseD (tk n FL.toList) (S.fromList ls) of+                Right parsed_list -> checkListEqual parsed_list (ltk n ls)+                Left _ -> property False++takeProperties :: Spec+takeProperties =+    describe "take combinators when n <= 0/" $ do+        prop "takeEQ n FL.toList = []" $+            nLessThanEqual0 P.takeEQ (\_ -> const [])+        prop "takeGE n FL.toList xs = xs" $+            nLessThanEqual0 P.takeGE (\_ -> id)+++-- XXX lookAhead can't deal with EOF which in this case means when+-- n==list_length, this test will fail. So excluding that case for now.+lookAheadPass :: Property+lookAheadPass =+    forAll (chooseInt (min_value, max_value)) $ \n ->+        let+            takeWithoutConsume = P.lookAhead $ P.fromFold $ FL.take n FL.toList+            parseTwice = do+                parsed_list_1 <- takeWithoutConsume+                parsed_list_2 <- takeWithoutConsume+                return (parsed_list_1, parsed_list_2)+        in+            forAll (chooseInt (n+1, max_value)) $ \list_length ->+                forAll (vectorOf list_length (chooseInt (min_value, max_value))) $ \ls ->+                    case S.parseD parseTwice (S.fromList ls) of+                        Right (ls_1, ls_2) -> checkListEqual ls_1 ls_2 .&&. checkListEqual ls_1 (Prelude.take n ls)+                        Left _ -> property $ False++lookAhead :: Property+lookAhead =+    forAll (chooseInt (min_value, max_value)) $ \n ->+        let+            takeWithoutConsume = P.lookAhead $ P.fromFold $ FL.take n FL.toList+            parseTwice = do+                parsed_list_1 <- takeWithoutConsume+                parsed_list_2 <- takeWithoutConsume+                return (parsed_list_1, parsed_list_2)+        in+            forAll (listOf (chooseInt (min_value, max_value))) $ \ls ->+                case S.parseD parseTwice (S.fromList ls) of+                    Right (ls_1, ls_2) -> checkListEqual ls_1 ls_2 .&&. checkListEqual ls_1 (Prelude.take n ls)+                    Left _ -> property ((list_length < n) || (list_length == n && n == 0))+                        where+                            list_length = Prelude.length ls++takeWhile :: Property+takeWhile =+    forAll (listOf (chooseInt (0, 1))) $ \ ls ->+        case S.parseD (P.takeWhile predicate FL.toList) (S.fromList ls) of+            Right parsed_list -> checkListEqual parsed_list (Prelude.takeWhile predicate ls)+            Left _ -> property False+        where+            predicate = (== 0)++takeWhile1 :: Property+takeWhile1 =+    forAll (listOf (chooseInt (0, 1))) $ \ ls ->+        case S.parseD (P.takeWhile1 predicate  FL.toList) (S.fromList ls) of+            Right parsed_list -> case ls of+                [] -> property False+                (x : _) ->+                    if predicate x then+                        checkListEqual parsed_list (Prelude.takeWhile predicate ls)+                    else+                        property False+            Left _ -> case ls of+                [] -> property True+                (x : _) -> property (not $ predicate x)+        where+            predicate = (== 0)++groupBy :: Property+groupBy =+    forAll (listOf (chooseInt (0, 1)))+        $ \ls ->+              case S.parseD parser (S.fromList ls) of+                  Right parsed -> checkListEqual parsed (groupByLF ls)+                  Left _ -> property False++    where++    cmp = (==)+    parser = P.groupBy cmp FL.toList+    groupByLF lst+        | null lst = []+        | otherwise = head $ List.groupBy cmp lst++groupByRolling :: Property+groupByRolling =+    forAll (listOf (chooseInt (0, 1)))+        $ \ls ->+              case S.parseD parser (S.fromList ls) of+                  Right parsed -> checkListEqual parsed (groupByLF Nothing ls)+                  Left _ -> property False++    where++    cmp = (==)+    parser = P.groupBy cmp FL.toList+    groupByLF _ [] = []+    groupByLF Nothing (x:xs) = x : groupByLF (Just x) xs+    groupByLF (Just y) (x:xs) =+        if cmp y x+        then x : groupByLF (Just x) xs+        else []++takeEndByOrMax :: Property+takeEndByOrMax =+    forAll (chooseInt (min_value, max_value)) $ \n ->+        forAll (listOf (chooseInt (0, 1))) $ \ls ->+            case S.parseD (P.fromFold $ FL.takeEndBy_ predicate (FL.take n FL.toList)) (S.fromList ls) of+                Right parsed_list -> checkListEqual parsed_list (Prelude.take n (Prelude.takeWhile (not . predicate) ls))+                Left _ -> property False+            where+                predicate = (== 1)++wordBy :: Property+wordBy =+    forAll (listOf (elements [' ', 's']))+        $ \ls ->+              case S.parseD parser (S.fromList ls) of+                  Right parsed -> checkListEqual parsed (words' ls)+                  Left _ -> property False++    where++    predicate = (== ' ')+    parser = P.many (P.wordBy predicate FL.toList) FL.toList+    words' lst =+        let wrds = words lst+         in if wrds == [] && length lst > 0 then [""] else wrds+++serialWith :: Property+serialWith =+    forAll (listOf (chooseInt (0, 1))) $ \ls ->+        case S.parseD (P.serialWith (,) (P.satisfy (== 0)) (P.satisfy (== 1))) (S.fromList ls) of+            Right (result_first, result_second) -> case ls of+                0 : 1 : _ -> (result_first == 0) && (result_second == 1)+                _ -> False+            Left _ -> case ls of+                0 : 1 : _ -> False+                _ -> True++splitWithFailLeft :: Property+splitWithFailLeft =+    property (case S.parseD (P.serialWith (,) (P.die "die") (P.fromPure (1 :: Int))) (S.fromList [1 :: Int]) of+        Right _ -> False+        Left _ -> True)++splitWithFailRight :: Property+splitWithFailRight =+    property (case S.parseD (P.serialWith (,) (P.fromPure (1 :: Int)) (P.die "die")) (S.fromList [1 :: Int]) of+        Right _ -> False+        Left _ -> True)++splitWithFailBoth :: Property+splitWithFailBoth =+    property (case S.parseD (P.serialWith (,) (P.die "die") (P.die "die")) (S.fromList [1 :: Int]) of+        Right _ -> False+        Left _ -> True)++teeWithPass :: Property+teeWithPass =+    forAll (chooseInt (min_value, max_value)) $ \n ->+        forAll (listOf (chooseInt (0, 1))) $ \ls ->+            let+                prsr = P.fromFold $ FL.take n FL.toList+            in+                case S.parseD (P.teeWith (,) prsr prsr) (S.fromList ls) of+                    Right (ls_1, ls_2) -> checkListEqual (Prelude.take n ls) ls_1 .&&. checkListEqual ls_1 ls_2+                    Left _ -> property False++teeWithFailLeft :: Property+teeWithFailLeft =+    property (case S.parseD (P.teeWith (,) (P.die "die") (P.fromPure (1 :: Int))) (S.fromList [1 :: Int]) of+        Right _ -> False+        Left _ -> True)++teeWithFailRight :: Property+teeWithFailRight =+    property (case S.parseD (P.teeWith (,) (P.fromPure (1 :: Int)) (P.die "die")) (S.fromList [1 :: Int]) of+        Right _ -> False+        Left _ -> True)++teeWithFailBoth :: Property+teeWithFailBoth =+    property (case S.parseD (P.teeWith (,) (P.die "die") (P.die "die")) (S.fromList [1 :: Int]) of+        Right _ -> False+        Left _ -> True)++shortestPass :: Property+shortestPass =+    forAll (listOf (chooseInt(min_value, max_value))) $ \ls ->+        let+            half_mid_value = mid_value `Prelude.div` 2+            prsr_1 = P.takeWhile (<= half_mid_value) FL.toList+            prsr_2 = P.takeWhile (<= mid_value) FL.toList+            prsr_shortest = P.shortest prsr_1 prsr_2+        in+            case S.parseD prsr_shortest (S.fromList ls) of+                Right short_list -> checkListEqual short_list (Prelude.takeWhile (<= half_mid_value) ls)+                Left _ -> property False++shortestPassLeft :: Property+shortestPassLeft =+    property (case S.parseD (P.shortest (P.die "die") (P.fromPure (1 :: Int))) (S.fromList [1 :: Int]) of+        Right r -> r == 1+        Left _ -> False)++shortestPassRight :: Property+shortestPassRight =+    property (case S.parseD (P.shortest (P.fromPure (1 :: Int)) (P.die "die")) (S.fromList [1 :: Int]) of+        Right r -> r == 1+        Left _ -> False)++shortestFailBoth :: Property+shortestFailBoth =+    property+        (case S.parseD+                  (P.shortest (P.die "die") (P.die "die"))+                  (S.fromList [1 :: Int]) of+             Right _ -> False+             Left _ -> True)++longestPass :: Property+longestPass =+    forAll (listOf (chooseInt(min_value, max_value))) $ \ls ->+        let+            half_mid_value = mid_value `Prelude.div` 2+            prsr_1 = P.takeWhile (<= half_mid_value) FL.toList+            prsr_2 = P.takeWhile (<= mid_value) FL.toList+            prsr_longest = P.longest prsr_1 prsr_2+        in+            case S.parseD prsr_longest (S.fromList ls) of+                Right long_list -> long_list == Prelude.takeWhile (<= mid_value) ls+                Left _ -> False++longestPassLeft :: Property+longestPassLeft =+    property (case S.parseD (P.shortest (P.die "die") (P.fromPure (1 :: Int))) (S.fromList [1 :: Int]) of+        Right r -> r == 1+        Left _ -> False)++longestPassRight :: Property+longestPassRight =+    property (case S.parseD (P.shortest (P.fromPure (1 :: Int)) (P.die "die")) (S.fromList [1 :: Int]) of+        Right r -> r == 1+        Left _ -> False)++longestFailBoth :: Property+longestFailBoth =+    property+        (case S.parseD (P.shortest (P.die "die") (P.die "die")) (S.fromList [1 :: Int]) of+        Right _ -> False+        Left _ -> True)++many :: Property+many =+    forAll (listOf (chooseInt (0, 1)))+      $ \ls ->+            let fldstp conL currL = return $ FL.Partial (conL ++ currL)+                concatFold =+                    FL.Fold fldstp (return (FL.Partial [])) return+                prsr =+                    flip P.many concatFold+                        $ P.fromFold $ FL.takeEndBy_ (== 1) FL.toList+             in case S.parseD prsr (S.fromList ls) of+                    Right res_list ->+                        checkListEqual res_list (Prelude.filter (== 0) ls)+                    Left _ -> property False++many_empty :: Property+many_empty =+    property (case S.parseD (flip P.many FL.toList (P.die "die")) (S.fromList [1 :: Int]) of+        Right res_list -> checkListEqual res_list ([] :: [Int])+        Left _ -> property False)++some :: Property+some =+    forAll (listOf (chooseInt (0, 1)))+      $ \ls ->+            let fldstp conL currL = return $ FL.Partial $ conL ++ currL+                concatFold = FL.Fold fldstp (return (FL.Partial [])) return+                prsr =+                    flip P.some concatFold+                        $ P.fromFold $ FL.takeEndBy_ (== 1) FL.toList+             in case S.parseD prsr (S.fromList ls) of+                    Right res_list -> res_list == Prelude.filter (== 0) ls+                    Left _ -> False++someFail :: Property+someFail =+    property (case S.parseD (P.some (P.die "die") FL.toList) (S.fromList [1 :: Int]) of+        Right _ -> False+        Left _ -> True)++-------------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------------++applicative :: Property+applicative =+    forAll (listOf (chooseAny :: Gen Int)) $ \ list1 ->+        forAll (listOf (chooseAny :: Gen Int)) $ \ list2 ->+            let parser =+                        (,)+                            <$> P.fromFold (FL.take (length list1) FL.toList)+                            <*> P.fromFold (FL.take (length list2) FL.toList)+             in monadicIO $ do+                    (olist1, olist2) <-+                        run $ S.parseD parser (S.fromList $ list1 ++ list2)+                    listEquals (==) olist1 list1+                    listEquals (==) olist2 list2++sequence :: Property+sequence =+    forAll (vectorOf 11 (listOf (chooseAny :: Gen Int))) $ \ ins ->+        let parsers = fmap (\xs -> P.fromFold $ FL.take (length xs) FL.toList) ins+         in monadicIO $ do+                outs <- run $+                        S.parseD+                            (Prelude.sequence parsers)+                            (S.fromList $ concat ins)+                listEquals (==) outs ins++monad :: Property+monad =+    forAll (listOf (chooseAny :: Gen Int)) $ \ list1 ->+        forAll (listOf (chooseAny :: Gen Int)) $ \ list2 ->+            let parser = do+                            olist1 <- P.fromFold (FL.take (length list1) FL.toList)+                            olist2 <- P.fromFold (FL.take (length list2) FL.toList)+                            return (olist1, olist2)+             in monadicIO $ do+                    (olist1, olist2) <-+                        run $ S.parseD parser (S.fromList $ list1 ++ list2)+                    listEquals (==) olist1 list1+                    listEquals (==) olist2 list2++-------------------------------------------------------------------------------+-- Stream parsing+-------------------------------------------------------------------------------++parseMany :: Property+parseMany =+    forAll (chooseInt (1,100)) $ \len ->+        forAll (listOf (vectorOf len (chooseAny :: Gen Int))) $ \ ins ->+            monadicIO $ do+                outs <-+                    ( run+                    $ S.toList+                    $ S.parseManyD+                        (P.fromFold $ FL.take len FL.toList) (S.fromList $ concat ins)+                    )+                listEquals (==) outs ins++-- basic sanity test for parsing from arrays+parseUnfold :: Property+parseUnfold = do+    let len = 200+    -- ls = input list (stream)+    -- clen = chunk size+    -- tlen = parser take size+    forAll+        ((,,)+            <$> vectorOf len (chooseAny :: Gen Int)+            <*> chooseInt (1, len)+            <*> chooseInt (1, len)) $ \(ls, clen, tlen) ->+        monadicIO $ do+            arrays <- S.toList $ S.arraysOf clen (S.fromList ls)+            let src = Source.source (Just (Producer.OuterLoop arrays))+            let parser = P.fromFold (FL.take tlen FL.toList)+            let readSrc =+                    Source.producer+                        $ Producer.concat Producer.fromList A.producer+            let streamParser =+                    Producer.simplify (Source.parseManyD parser readSrc)+            xs <- run+                $ S.toList+                $ S.unfoldMany Unfold.fromList+                $ S.unfold streamParser src++            listEquals (==) xs ls++-------------------------------------------------------------------------------+-- Test for a particular case hit during fs events testing+-------------------------------------------------------------------------------++evId :: [Word8]+evId = [96,238,17,9,0,0,0,0]++evFlags :: [Word8]+evFlags = [0,4,1,0,0,0,0,0]++evPathLen :: [Word8]+evPathLen = [71,0,0,0,0,0,0,0]++evPath :: [Word8]+evPath =+    [47,85,115,101,114,115,47,118,111,108,47,118,101,109,98,97,47,99,111,109+    ,112,111,115,101,119,101 ,108,108,45,116,101,99,104,47,69,110,103,47,112+    ,114,111,106,101,99,116,115,47,115,116,114,101,97,109,108,121,47,115,116+    ,114,101,97,109,108,121,47,116,109,112,47,122,122+    ]++event :: [Word8]+event = evId ++ evFlags ++ evPathLen ++ evPath++data Event = Event+   { eventId :: Word64+   , eventFlags :: Word32+   , eventAbsPath :: A.Array Word8+   } deriving (Show, Ord, Eq)++readOneEvent :: P.Parser IO Word8 Event+readOneEvent = do+    arr <- P.takeEQ 24 (A.writeN 24)+    let arr1 = A.unsafeCast arr :: A.Array Word64+        eid = A.unsafeIndex arr1 0+        eflags = A.unsafeIndex arr1 1+        pathLen = fromIntegral $ A.unsafeIndex arr1 2+    path <- P.takeEQ pathLen (A.writeN pathLen)+    return $ Event+        { eventId = eid+        , eventFlags = fromIntegral eflags+        , eventAbsPath = path+        }++parseMany2Events :: Property+parseMany2Events =+    monadicIO $ do+        xs <-+            ( run+            $ S.toList+            $ S.parseManyD readOneEvent+            $ S.fromList (concat (replicate 2 event))+            )+        assert (length xs == 2)+        -- XXX assuming little endian machine+        let ev = Event+                { eventId = 152170080+                , eventFlags = 66560+                , eventAbsPath = A.fromList evPath+                }+         in listEquals (==) xs (replicate 2 ev)++-------------------------------------------------------------------------------+-- Main+-------------------------------------------------------------------------------++moduleName :: String+moduleName = "Data.Parser.ParserD"++main :: IO ()+main =+  hspec $+  H.parallel $+  modifyMaxSuccess (const maxTestCount) $ do+  describe moduleName $ do++    describe "Instances" $ do+        prop "applicative" applicative+        prop "monad" monad+        prop "sequence" sequence++    describe "Stream parsing" $ do+        prop "parseMany" parseMany+        prop "parseMany2Events" parseMany2Events+        prop "parseUnfold" parseUnfold++    describe "test for accumulator" $ do+        prop "P.fromFold FL.sum = FL.sum" fromFold+        prop "fromPure value provided" fromPure+        prop "fromPure monadic value provided" fromEffect+        prop "always fail" die+        prop "always fail but monadic" dieM++    describe "test for element parser" $ do+        prop "peek = head with list length > 0" peekPass+        prop "peek fail on []" peekFail+        prop "eof pass on []" eofPass+        prop "eof fail on non-empty list" eofFail+        prop "first element exists and >= mid_value" satisfyPass+        prop "check first element exists and satisfies predicate" satisfy++    describe "test for sequence parser" $ do+        prop "P.takeBetween m n = Prelude.take when len >= m and len <= n"+                takeBetweenPass+        prop "P.takeBetween m n = Prelude.take when len >= m and len <= n and\+                \fail otherwise" takeBetween+        prop "P.take = Prelude.take" Main.take+        prop "P.takeEQ = Prelude.take when len >= n" takeEQPass+        prop "P.takeEQ = Prelude.take when len >= n and fail otherwise" Main.takeEQ+        prop "P.takeGE n ls = ls when len >= n" takeGEPass+        prop "P.takeGE n ls = ls when len >= n and fail otherwise" Main.takeGE+        prop "lookAhead . take n >> lookAhead . take n = lookAhead . take n" lookAheadPass+        prop "lookAhead . take n >> lookAhead . take n = lookAhead . take n, else fail" lookAhead+        prop "P.takeWhile = Prelude.takeWhile" Main.takeWhile+        prop "P.takeWhile1 = Prelude.takeWhile if taken something, else check why failed" takeWhile1+        prop "P.groupBy = Prelude.head . Prelude.groupBy" groupBy+        prop "groupByRolling" groupByRolling+        prop "P.takeEndByOrMax = Prelude.take n (Prelude.takeWhile (not . predicate)" takeEndByOrMax+        prop "many (P.wordBy ' ') = words'" wordBy+        prop "parse 0, then 1, else fail" serialWith+        prop "fail due to die as left parser" splitWithFailLeft+        prop "fail due to die as right parser" splitWithFailRight+        prop "fail due to die as both parsers" splitWithFailBoth+        prop "parsed two lists should be equal" teeWithPass+        prop "fail due to die as left parser" teeWithFailLeft+        prop "fail due to die as right parser" teeWithFailRight+        prop "fail due to die as both parsers" teeWithFailBoth+        prop "P.takeWhile (<= half_mid_value) = Prelude.takeWhile half_mid_value" shortestPass+        prop "pass even if die is left parser" shortestPassLeft+        prop "pass even if die is right parser" shortestPassRight+        prop "fail due to die as both parsers" shortestFailBoth+        prop "P.takeWhile (<= mid_value) = Prelude.takeWhile (<= mid_value)" longestPass+        prop "pass even if die is left parser" longestPassLeft+        prop "pass even if die is right parser" longestPassRight+        prop "fail due to die as both parsers" longestFailBoth+        prop "P.many concatFold $ P.takeEndBy_ (== 1) FL.toList = Prelude.filter (== 0)" many+        prop "[] due to parser being die" many_empty+        prop "P.some concatFold $ P.takeEndBy_ (== 1) FL.toList = Prelude.filter (== 0)" some+        prop "fail due to parser being die" someFail+    takeProperties
+ test/Streamly/Test/Data/SmallArray.hs view
@@ -0,0 +1,12 @@+-- |+-- Module      : Streamly.Test.Data.SmallArray+-- Copyright   : (c) 2020 Composewell technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Test.Data.SmallArray where++#define TEST_SMALL_ARRAY+#include "Streamly/Test/Common/Array.hs"
+ test/Streamly/Test/Data/Unfold.hs view
@@ -0,0 +1,448 @@+-- |+-- Module      : Main+-- Copyright   : (c) 2020 Composewell Technologies+--+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+module Main (main) where++import Streamly.Internal.Data.Unfold (Unfold)++import qualified Data.List as List+import qualified Prelude+import qualified Streamly.Internal.Data.Unfold as UF+import qualified Streamly.Internal.Data.Stream.IsStream as S+import qualified Streamly.Internal.Data.Stream.StreamD as D+import qualified Streamly.Internal.Data.Stream.StreamK as K++import Control.Monad.Trans.State.Strict+import Data.Functor.Identity+import Prelude hiding (const, take, drop, concat, mapM)+import Streamly.Prelude (SerialT)+import Test.Hspec as H+import Test.Hspec.QuickCheck+import Test.QuickCheck+import Test.QuickCheck.Function++-------------------------------------------------------------------------------+-- Helper functions+-------------------------------------------------------------------------------++-- | @testUnfoldM unf seed initial final xs@, runs an unfold under state monad+-- using @initial@ as the initial state. @final@ is the expected state after+-- running it and @xs@ is the list of elements the stream must produce.+testUnfoldM ::+       (Eq s, Eq b) => Unfold (State s) a b -> a -> s -> s -> [b] -> Bool+testUnfoldM unf seed si sf lst = evalState action si++    where++    action = do+        x <- S.toList $ S.unfold unf seed+        y <- get+        return $ x == lst && y == sf++testUnfoldMD :: Unfold (State Int) a Int -> a -> Int -> Int -> [Int] -> Bool+testUnfoldMD = testUnfoldM++-- | This is similar to 'testUnfoldM' but without the state monad.+testUnfold :: Eq b => Unfold Identity a b -> a -> [b] -> Bool+testUnfold unf seed lst = runIdentity action++    where++    action = do+        x <- S.toList $ S.unfold unf seed+        return $ x == lst++testUnfoldD :: Unfold Identity a Int -> a -> [Int] -> Bool+testUnfoldD = testUnfold++-------------------------------------------------------------------------------+-- Operations on input+-------------------------------------------------------------------------------++lmapM :: Bool+lmapM =+    let unf = UF.lmapM (\x -> modify (+ 1) >> return x) (UF.function id)+     in testUnfoldMD unf 1 0 1 [1]++supply :: Bool+supply =+    let unf = UF.supply 1 (UF.function id)+     in testUnfold unf undefined ([1] :: [Int])++supplyFirst :: Bool+supplyFirst =+    let unf = UF.supplyFirst 1 (UF.function id)+     in testUnfold unf 2 ([(1, 2)] :: [(Int, Int)])++supplySecond :: Bool+supplySecond =+    let unf = UF.supplySecond 1 (UF.function id)+     in testUnfold unf 2 ([(2, 1)] :: [(Int, Int)])++discardFirst :: Bool+discardFirst =+    let unf = UF.discardFirst (UF.function id)+     in testUnfold unf ((1, 2) :: (Int, Int)) [2]++discardSecond :: Bool+discardSecond =+    let unf = UF.discardSecond (UF.function id)+     in testUnfold unf ((1, 2) :: (Int, Int)) [1]++swap :: Bool+swap =+    let unf = UF.swap (UF.function id)+     in testUnfold unf ((1, 2) :: (Int, Int)) [(2, 1)]++-------------------------------------------------------------------------------+-- Stream generation+-------------------------------------------------------------------------------++fromStream :: Property+fromStream =+    property+        $ \list ->+              testUnfoldD+                  UF.fromStream+                  (S.fromList list :: SerialT Identity Int)+                  list++fromStreamD :: Property+fromStreamD =+    property+        $ \list -> testUnfoldD UF.fromStreamD (D.fromList list) (list :: [Int])++fromStreamK :: Property+fromStreamK =+    property+        $ \list -> testUnfoldD UF.fromStreamK (K.fromList list) (list :: [Int])++nilM :: Bool+nilM =+    let unf = UF.nilM put+     in testUnfoldMD unf 1 0 1 []++consM :: Bool+consM =+    let cns = UF.consM (\a -> modify (+ a) >> get)+        unf = cns $ cns $ UF.nilM $ \a -> modify (+ a)+     in testUnfoldMD unf 1 0 3 [1, 2]++functionM :: Bool+functionM =+    let unf = UF.functionM (\a -> modify (+ a) >> get)+     in testUnfoldMD unf 1 0 1 [1]++const :: Bool+const =+    let unf = UF.fromEffect (modify (+ 1) >> get)+     in testUnfoldMD unf (0 :: Int) 0 1 [1]++unfoldrM :: Property+unfoldrM =+    property+        $ \gen ->+              let genA = apply gen :: Int -> Maybe (Int, Int)+                  genM x = modify (+ 1) >> return (genA x)+                  list = Prelude.take 100 $ List.unfoldr genA 1+                  unf = UF.take 100 $ UF.unfoldrM genM+                  ll = length list+                  fs = if ll < 100 then ll + 1 else 100+               in testUnfoldMD unf 1 0 fs list++fromListM :: Property+fromListM =+    property+        $ \list ->+              let listM = Prelude.map (\x -> modify (+ 1) >> return x) list+               in testUnfoldMD UF.fromListM listM 0 (length list) list++replicateM :: Property+replicateM =+    property+        $ \i ->+              let ns = max 0 i+                  seed = modify (+ 1) >> get+               in testUnfoldMD (UF.replicateM i) seed 0 ns [1 .. i]++repeatM :: Bool+repeatM =+    testUnfoldMD (UF.take 10 UF.repeatM) (modify (+ 1) >> get) 0 10 [1 .. 10]++iterateM :: Property+iterateM =+    property+        $ \next ->+              let nextA = apply next :: Int -> Int+                  nextM x = modify (+ 1) >> return (nextA x)+                  list = Prelude.take 100 $ List.iterate nextA 1+                  unf = UF.take 100 $ UF.iterateM nextM+               in testUnfoldMD unf (modify (+ 10) >> return 1) 0 110 list++fromIndicesM :: Property+fromIndicesM =+    property+        $ \indF ->+              let indFA = apply indF :: Int -> Int+                  indFM x = modify (+ 1) >> return (indFA x)+                  list = Prelude.take 100 $ Prelude.map indFA [1 ..]+                  unf = UF.take 100 $ UF.fromIndicesM indFM+               in testUnfoldMD unf 1 0 (length list) list++enumerateFromStepNum :: Property+enumerateFromStepNum =+    property+        $ \f s ->+              let unf = UF.take 10 $ UF.enumerateFromStepNum s+                  lst = Prelude.take 10 $ List.unfoldr (\x -> Just (x, x + s)) f+               in testUnfoldD unf f lst++#if MIN_VERSION_base(4,12,0)+enumerateFromToFractional :: Property+enumerateFromToFractional =+    property+        $ \f t ->+              let unf = UF.enumerateFromToFractional (t :: Double)+               in testUnfold unf (f :: Double) [f..(t :: Double)]+#endif++enumerateFromStepIntegral :: Property+enumerateFromStepIntegral =+    property+        $ \f s ->+              let unf = UF.take 10 UF.enumerateFromStepIntegral+                  lst = Prelude.take 10 $ List.unfoldr (\x -> Just (x, x + s)) f+               in testUnfoldD unf (f, s) lst++enumerateFromToIntegral :: Property+enumerateFromToIntegral =+    property+        $ \f t ->+              let unf = UF.enumerateFromToIntegral t+               in testUnfoldD unf f [f .. t]++-------------------------------------------------------------------------------+-- Stream transformation+-------------------------------------------------------------------------------++mapM :: Property+mapM =+    property+        $ \f list ->+              let fA = apply f :: Int -> Int+                  fM x = modify (+ 1) >> return (fA x)+                  unf = UF.mapM fM UF.fromList+                  mList = Prelude.map fA list+               in testUnfoldMD unf list 0 (length list) mList++mapMWithInput :: Property+mapMWithInput =+    property+        $ \f list ->+              let fA = applyFun2 f :: [Int] -> Int -> Int+                  fM x y = modify (+ 1) >> return (fA x y)+                  unf = UF.mapMWithInput fM UF.fromList+                  mList = Prelude.map (fA list) list+               in testUnfoldMD unf list 0 (length list) mList++take :: Property+take =+    property+        $ \i ->+              testUnfoldD+                  (UF.take i UF.repeatM)+                  (return 1)+                  (Prelude.take i (Prelude.repeat 1))++takeWhileM :: Property+takeWhileM =+    property+        $ \f list ->+              let fM x =+                      if apply f x+                      then modify (+ 1) >> return True+                      else return False+                  unf = UF.takeWhileM fM UF.fromList+                  fL = Prelude.takeWhile (apply f) list+                  fS = Prelude.length fL+               in testUnfoldMD unf list 0 fS fL++filterM :: Property+filterM =+    property+        $ \f list ->+              let fM x =+                      if apply f x+                      then modify (+ 1) >> return True+                      else return False+                  unf = UF.filterM fM UF.fromList+                  fL = Prelude.filter (apply f) list+                  fS = Prelude.length fL+               in testUnfoldMD unf list 0 fS fL++drop :: Property+drop =+    property+        $ \i list ->+              let unf = UF.drop i UF.fromList+                  fL = Prelude.drop i list+               in testUnfoldD unf list fL++dropWhileM :: Property+dropWhileM =+    property+        $ \f list ->+              let fM x =+                      if apply f x+                      then modify (+ 1) >> return True+                      else return False+                  unf = UF.dropWhileM fM UF.fromList+                  fL = Prelude.dropWhile (apply f) list+                  fS = Prelude.length list - Prelude.length fL+               in testUnfoldMD unf list 0 fS fL++-------------------------------------------------------------------------------+-- Stream combination+-------------------------------------------------------------------------------++zipWithM :: Property+zipWithM =+    property+        $ \f ->+              let unf1 = UF.enumerateFromToIntegral 10+                  unf2 = UF.enumerateFromToIntegral 20+                  fA = applyFun2 f :: Int -> Int -> Int+                  fM a b = modify (+ 1) >> return (fA a b)+                  unf = UF.zipWithM fM (UF.lmap fst unf1) (UF.lmap snd unf2)+                  lst = Prelude.zipWith fA [1 .. 10] [1 .. 20]+               in testUnfoldMD unf (1, 1) 0 10 lst++concat :: Bool+concat =+    let unfIn = UF.replicateM 10+        unfOut = UF.map return $ UF.enumerateFromToIntegral 10+        unf = UF.many unfOut unfIn+        lst = Prelude.concat $ Prelude.map (Prelude.replicate 10) [1 .. 10]+     in testUnfoldD unf 1 lst++outerProduct :: Bool+outerProduct =+    let unf1 = UF.enumerateFromToIntegral 10+        unf2 = UF.enumerateFromToIntegral 20+        unf = crossProduct unf1 unf2+        lst = [(a, b) :: (Int, Int) | a <- [0 .. 10], b <- [0 .. 20]]+     in testUnfold unf ((0, 0) :: (Int, Int)) lst++    where++    crossProduct u1 u2 = UF.cross (UF.lmap fst u1) (UF.lmap snd u2)++concatMapM :: Bool+concatMapM =+    let inner b =+          let u = UF.lmap (\_ -> modify (+ 1) >> return b) (UF.replicateM 10)+           in modify (+ 1) >> return u+        unf = UF.concatMapM inner (UF.enumerateFromToIntegral 10)+        list = List.concatMap (replicate 10) [1 .. 10]+     in testUnfoldMD unf 1 0 110 list++-------------------------------------------------------------------------------+-- Test groups+-------------------------------------------------------------------------------++testInputOps :: Spec+testInputOps =+    describe "Input"+        $ do+            -- prop "lmap" lmap+            prop "lmapM" lmapM+            prop "supply" supply+            prop "supplyFirst" supplyFirst+            prop "supplySecond" supplySecond+            prop "discardFirst" discardFirst+            prop "discardSecond" discardSecond+            prop "swap" swap++testGeneration :: Spec+testGeneration =+    describe "Generation"+        $ do+            prop "fromStream" fromStream+            prop "fromStreamK" fromStreamK+            prop "fromStreamD" fromStreamD+            prop "nilM" nilM+            prop "consM" consM+            prop "functionM" functionM+            -- prop "function" function+            -- prop "identity" identity+            prop "const" const+            prop "unfoldrM" unfoldrM+            -- prop "fromList" fromList+            prop "fromListM" fromListM+            -- prop "fromSVar" fromSVar+            -- prop "fromProducer" fromProducer+            prop "replicateM" replicateM+            prop "repeatM" repeatM+            prop "iterateM" iterateM+            prop "fromIndicesM" fromIndicesM+            prop "enumerateFromStepIntegral" enumerateFromStepIntegral+            prop "enumerateFromToIntegral" enumerateFromToIntegral+            -- prop "enumerateFromIntegral" enumerateFromIntegral+            prop "enumerateFromStepNum" enumerateFromStepNum+            -- prop "numFrom" numFrom+#if MIN_VERSION_base(4,12,0)+            prop "enumerateFromToFractional" enumerateFromToFractional+#endif++testTransformation :: Spec+testTransformation =+    describe "Transformation"+        $ do+            -- prop "map" map+            prop "mapM" mapM+            prop "mapMWithInput" mapMWithInput+            prop "takeWhileM" takeWhileM+            -- prop "takeWhile" takeWhile+            prop "take" take+            -- prop "filter" filter+            prop "filterM" filterM+            prop "drop" drop+            -- prop "dropWhile" dropWhile+            prop "dropWhileM" dropWhileM++testCombination :: Spec+testCombination =+    describe "Transformation"+        $ do+            prop "zipWithM" zipWithM+            -- prop "zipWith" zipWith+            -- prop "teeZipWith" teeZipWith+            prop "concat" concat+            prop "concatMapM" concatMapM+            prop "outerProduct" outerProduct+            -- prop "ap" ap+            -- prop "apDiscardFst" apDiscardFst+            -- prop "apDiscardSnd" apDiscardSnd++-------------------------------------------------------------------------------+-- Main+-------------------------------------------------------------------------------++moduleName :: String+moduleName = "Data.Unfold"++main :: IO ()+main =+    hspec+        $ describe moduleName+        $ do+            testInputOps+            testGeneration+            testTransformation+            testCombination
+ test/Streamly/Test/FileSystem/Event.hs view
@@ -0,0 +1,402 @@+-- |+-- Module      : Streamly.Test.FileSystem.Event+-- Copyright   : (c) 2020 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+module Main (main) where++import Control.Concurrent (MVar, newEmptyMVar, putMVar, takeMVar, threadDelay)+import Control.Monad.IO.Class (MonadIO)+#if !defined(CABAL_OS_WINDOWS)+import Data.Char (ord)+#endif+import Data.Maybe (fromJust)+import Data.Word (Word8)+import System.Directory+    ( createDirectoryIfMissing+    , removeFile+    , removeDirectory+    , removePathForcibly+    , renameDirectory+    , renamePath+    )+import System.FilePath ((</>))+import System.IO (BufferMode(..), hSetBuffering, stdout)+import System.IO.Temp (withSystemTempDirectory)+#if !defined(CABAL_OS_WINDOWS)+import System.IO.Unsafe (unsafePerformIO)+#endif+import Streamly.Internal.Data.Array.Foreign (Array)++import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Set as Set+import qualified Streamly.Unicode.Stream as Unicode+import qualified Streamly.Internal.Data.Array.Foreign as Array+import qualified Streamly.Internal.Data.Fold as FL+import qualified Streamly.Internal.Data.Parser as PR+import qualified Streamly.Internal.Data.Stream.IsStream as S+#if defined(CABAL_OS_DARWIN)+import qualified Streamly.Internal.FileSystem.Event.Darwin as Event+#elif defined(CABAL_OS_LINUX)+import qualified Streamly.Internal.FileSystem.Event.Linux as Event+#elif defined(CABAL_OS_WINDOWS)+import qualified Streamly.Internal.FileSystem.Event.Windows as Event+#else+#error "FS Events not supported on this platform+#endif++#if !defined(CABAL_OS_WINDOWS)+import Data.Functor.Identity (runIdentity)+import qualified Streamly.Internal.Unicode.Stream as U+#endif++import Test.Hspec++-------------------------------------------------------------------------------+-- Utilities+-------------------------------------------------------------------------------++toUtf8 :: MonadIO m => String -> m (Array Word8)+toUtf8 = Array.fromStream . Unicode.encodeUtf8' . S.fromList++#if !defined(CABAL_OS_WINDOWS)+utf8ToString :: Array Word8 -> String+utf8ToString = runIdentity . S.toList . U.decodeUtf8' . Array.toStream+#endif++timeout :: IO String+timeout = threadDelay 5000000 >> return "Timeout"++fseventDir :: String+fseventDir = "fsevent_dir"++-- XXX Make the getRelPath type same on windows and other platforms+eventPredicate :: Event.Event -> Bool+eventPredicate ev =+#if defined(CABAL_OS_WINDOWS)+    if (Event.getRelPath ev) == "EOTask"+#else+    if (utf8ToString $ Event.getRelPath ev) == "EOTask"+#endif+    then False+    else True++-------------------------------------------------------------------------------+-- Event matching utilities+-------------------------------------------------------------------------------+#if defined(CABAL_OS_LINUX)+removeTrailingSlash :: Array Word8 -> Array Word8+removeTrailingSlash path =+    if Array.length path == 0+    then path+    else+        let mx = Array.getIndex path (Array.length path - 1)+         in case mx of+            Nothing -> error "removeTrailingSlash: Bug: Invalid index"+            Just x ->+                if x == fromIntegral (ord '/')+                -- XXX need array slicing+                then unsafePerformIO+                        $ Array.fromStreamN (Array.length path - 1)+                        $ Array.toStream path+                else path+#endif++-- XXX Return a tuple (path, flags) instead of appending flags to path. And+-- then check the flags using an event mask.++showEventShort :: Event.Event -> String+#if defined(CABAL_OS_WINDOWS)+-- | Convert an 'Event' record to a short representation for unit test.+showEventShort ev@Event.Event{..} =+    Event.getRelPath ev ++ "_" ++ show eventFlags+#elif defined(CABAL_OS_LINUX)+showEventShort ev@Event.Event{..} =+    (utf8ToString $ removeTrailingSlash $ Event.getRelPath ev)+        ++ "_" ++ show eventFlags+        ++ showev Event.isDir "Dir"++    where showev f str = if f ev then "_" ++ str else ""+#else+#error "Unsupported OS+#endif++-------------------------------------------------------------------------------+-- Event Watcher+-------------------------------------------------------------------------------++checkEvents :: FilePath -> MVar () -> [String] -> IO String+checkEvents rootPath m matchList = do+    let args = [rootPath]+    paths <- mapM toUtf8 args+    putStrLn ("Watch started !!!! on Path " ++ rootPath)+    events <- S.parse (PR.takeWhile eventPredicate FL.toList)+        $ S.before (putMVar m ())+        $ Event.watchTrees (NonEmpty.fromList paths)+    let eventStr =  map showEventShort events+    let baseSet = Set.fromList matchList+        resultSet = Set.fromList eventStr+    if (baseSet `Set.isSubsetOf` resultSet)+    then+        return "PASS"+    else do+        putStrLn $ "baseSet " ++ show matchList+        putStrLn $ "resultSet " ++ show eventStr+        return "Mismatch"++-------------------------------------------------------------------------------+-- FS Event Generators+-------------------------------------------------------------------------------++checker :: S.IsStream t =>+                FilePath -> MVar () -> [String] -> t IO String+checker rootPath synch matchList =+    S.fromEffect (checkEvents rootPath synch matchList)+    `S.parallelFst`+    S.fromEffect timeout++-------------------------------------------------------------------------------+-- Test Drivers+-------------------------------------------------------------------------------++driver ::+       ( String+       , FilePath -> IO ()+       , FilePath -> IO ()+       , [String]+       )+    -> SpecWith ()+driver (desc, pre, ops, events) = it desc $ runTest `shouldReturn` "PASS"++    where++    runTest = do+        sync <- newEmptyMVar+        withSystemTempDirectory fseventDir $ \fp -> do+            pre fp+            let eventStream = checker fp sync events+                fsOps = S.fromEffect $ runFSOps fp sync+            fmap fromJust $ S.head $ eventStream `S.parallelFst` fsOps++    runFSOps fp sync = do+        _ <- takeMVar sync+        threadDelay 200000+        ops fp+        threadDelay 200000 -- Why this delay?+        createDirectoryIfMissing True (fp </> "EOTask")+        threadDelay 10000000+        error "fs ops timed out"++-------------------------------------------------------------------------------+-- Main+-------------------------------------------------------------------------------++testDesc ::+    [ ( String                       -- test description+      , FilePath -> IO ()            -- pre test operation+      , FilePath -> IO ()            -- file system actions+      , [String])                    -- expected events+    ]+testDesc =+    [+      ( "Create a single directory"+      , const (return ())+      , \fp -> createDirectoryIfMissing True (fp </> "dir1Single")+#if defined(CABAL_OS_WINDOWS)+      , [ "dir1Single_1" ]+#elif defined(CABAL_OS_LINUX)+      , [ "dir1Single_1073742080_Dir"+        , "dir1Single_1073741856_Dir"+        , "dir1Single_1073741825_Dir"+        , "dir1Single_1073741840_Dir"+        ]+#endif+      )+    , ( "Remove a single directory"+      , \fp -> createDirectoryIfMissing True (fp </> "dir1Single")+      , \fp -> removeDirectory (fp </> "dir1Single")+#if defined(CABAL_OS_WINDOWS)+      , [ "dir1Single_2" ]+#elif defined(CABAL_OS_LINUX)+      , [ "dir1Single_1024"+        , "dir1Single_32768"+        ]+#endif+      )+    , ( "Rename a single directory"+      , \fp -> createDirectoryIfMissing True (fp </> "dir1Single")+      , \fp ->+            let spath = fp </> "dir1Single"+                tpath = fp </> "dir1SingleRenamed"+            in renameDirectory spath tpath+#if defined(CABAL_OS_WINDOWS)+      , [ "dir1Single_4"+        , "dir1SingleRenamed_5"+        ]+#elif defined(CABAL_OS_LINUX)+      , [ "dir1Single_1073741888_Dir"+        , "dir1SingleRenamed_1073741952_Dir"+        ]+#endif+      )+    , ( "Create a nested directory"+      , const (return ())+      , \fp ->+            createDirectoryIfMissing True (fp </> "dir1" </> "dir2" </> "dir3")+#if defined(CABAL_OS_WINDOWS)+      , [ "dir1_1"+        , "dir1\\dir2_1"+        , "dir1\\dir2\\dir3_1"+        ]+#elif defined(CABAL_OS_LINUX)+      , [ "dir1_1073742080_Dir"+        , "dir1_1073741856_Dir"+        , "dir1_1073741825_Dir"+        , "dir1_1073741840_Dir"+        ]+#endif+      )+    , ( "Remove a nested directory"+      , \fp ->+            createDirectoryIfMissing True (fp </> "dir1" </> "dir2" </> "dir3")+      , \fp -> removePathForcibly (fp </> "dir1")+#if defined(CABAL_OS_WINDOWS)+      , [ "dir1_3"+        , "dir1\\dir2_3"+        , "dir1\\dir2\\dir3_2"+        , "dir1\\dir2_2","dir1_2"+        ]+#elif defined(CABAL_OS_LINUX)+      , [ "dir1/dir2/dir3_1073742336_Dir"+        , "dir1/dir2_1073742336_Dir"+        , "dir1_1073742336_Dir"+        ]+#endif+      )+    , ( "Rename a nested directory"+      , \fp -> createDirectoryIfMissing True+                (fp </> "dir1" </> "dir2" </> "dir3")+      , \fp ->+            let spath = fp </> "dir1" </> "dir2" </> "dir3"+                tpath = fp </> "dir1" </> "dir2" </> "dir3Renamed"+            in renameDirectory spath tpath+#if defined(CABAL_OS_WINDOWS)+      , [ "dir1\\dir2_3"+        , "dir1\\dir2\\dir3_4"+        , "dir1\\dir2\\dir3Renamed_5"+        , "dir1\\dir2_3"+        ]+#elif defined(CABAL_OS_LINUX)+      , [ "dir1/dir2/dir3_1073741888_Dir"+        , "dir1/dir2/dir3Renamed_1073741952_Dir"+        ]+#endif+      )+    , ( "Create a file in root Dir"+      , const (return ())+      , \fp -> writeFile (fp </> "FileCreated.txt") "Test Data"+#if defined(CABAL_OS_WINDOWS)+      , [ "FileCreated.txt_1"+        , "FileCreated.txt_3"+        , "FileCreated.txt_3"+        ]+#elif defined(CABAL_OS_LINUX)+      , [ "FileCreated.txt_256"+        , "FileCreated.txt_32"+        , "FileCreated.txt_2"+        ]+#endif+      )+    , ( "Remove a file in root Dir"+      , \fp -> writeFile (fp </> "FileCreated.txt") "Test Data"+      , \fp -> removeFile (fp </> "FileCreated.txt")+#if defined(CABAL_OS_WINDOWS)+      , [ "FileCreated.txt_2" ]+#elif defined(CABAL_OS_LINUX)+      , [ "FileCreated.txt_512" ]+#endif+      )+    , ( "Rename a file in root Dir"+      , \fp -> writeFile (fp </> "FileCreated.txt") "Test Data"+      , \fp ->+            let spath = (fp </> "FileCreated.txt")+                tpath = (fp </> "FileRenamed.txt")+            in renamePath spath tpath+#if defined(CABAL_OS_WINDOWS)+      , [ "FileCreated.txt_4"+        , "FileRenamed.txt_5"+        ]+#elif defined(CABAL_OS_LINUX)+      , [ "FileCreated.txt_64"+        , "FileRenamed.txt_128"+        ]+#endif+      )+    , ( "Create a file in a nested Dir"+      , \fp ->+            createDirectoryIfMissing True (fp </> "dir1" </> "dir2" </> "dir3")+      , \fp ->+            let p = fp </> "dir1" </> "dir2" </> "dir3" </> "FileCreated.txt"+            in writeFile p "Test Data"+#if defined(CABAL_OS_WINDOWS)+      , [ "dir1\\dir2\\dir3\\FileCreated.txt_1"+        , "dir1\\dir2\\dir3\\FileCreated.txt_3"+        ]+#elif defined(CABAL_OS_LINUX)+      , [ "dir1/dir2/dir3/FileCreated.txt_256"+        , "dir1/dir2/dir3/FileCreated.txt_32"+        , "dir1/dir2/dir3/FileCreated.txt_2"+        , "dir1/dir2/dir3/FileCreated.txt_8"+        ]+#endif+      )+    , ( "Remove a file in a nested Dir"+      , \fp ->+            let nestedDir = fp </> "dir1" </> "dir2" </> "dir3"+                fpath = nestedDir </> "FileCreated.txt"+            in do+                createDirectoryIfMissing True nestedDir+                writeFile fpath "Test Data"+      , \fp ->+            let p = fp </> "dir1" </> "dir2" </> "dir3" </> "FileCreated.txt"+            in removeFile p+#if defined(CABAL_OS_WINDOWS)+      , ["dir1\\dir2\\dir3\\FileCreated.txt_2"]+#elif defined(CABAL_OS_LINUX)+      , ["dir1/dir2/dir3/FileCreated.txt_512"]+#endif+      )+    , ( "Rename a file in a nested Dir"+      , \fp ->+            let nestedDir = fp </> "dir1" </> "dir2" </> "dir3"+                fpath = nestedDir </> "FileCreated.txt"+            in do+                createDirectoryIfMissing True nestedDir+                writeFile fpath "Test Data"+      , \fp ->+            let s = (fp </> "dir1" </> "dir2" </> "dir3" </> "FileCreated.txt")+                t = (fp </> "dir1" </> "dir2" </> "dir3" </> "FileRenamed.txt")+            in renamePath s t+#if defined(CABAL_OS_WINDOWS)+      , [ "dir1\\dir2\\dir3_3"+        , "dir1\\dir2\\dir3\\FileCreated.txt_4"+        , "dir1\\dir2\\dir3\\FileRenamed.txt_5"+        ]+#elif defined(CABAL_OS_LINUX)+      , [ "dir1/dir2/dir3/FileCreated.txt_64"+        , "dir1/dir2/dir3/FileRenamed.txt_128"+        ]+#endif+      )+    ]++moduleName :: String+moduleName = "FileSystem.Event"++main :: IO ()+main = do+    hSetBuffering stdout NoBuffering+    hspec $ describe moduleName $ sequence_ $ map driver testDesc
+ test/Streamly/Test/FileSystem/Handle.hs view
@@ -0,0 +1,173 @@+-- |+-- Module      : Streamly.Test.FileSystem.Handle+-- Copyright   : (c) 2020 Composewell technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Test.FileSystem.Handle (main) where++import Data.Functor.Identity (runIdentity)+import Data.Word (Word8)+import Foreign.Storable (Storable(..))+import Streamly.Internal.Data.Stream.IsStream (IsStream, SerialT)+import System.FilePath ((</>))+import System.IO+    ( Handle+    , IOMode(..)+    , SeekMode(..)+    , hClose+    , hFlush+    , hSeek+    , openFile+    )+import System.IO.Temp (withSystemTempDirectory)+import Test.QuickCheck (Property, forAll, Gen, vectorOf, choose)+import Test.QuickCheck.Monadic (monadicIO, assert, run)++import qualified Streamly.Data.Fold as Fold+import qualified Streamly.FileSystem.Handle as Handle+import qualified Streamly.Internal.Data.Stream.IsStream as Stream+import qualified Streamly.Internal.Data.Array.Foreign as Array+import qualified Streamly.Internal.Unicode.Stream as Unicode++import Test.Hspec as H+import Test.Hspec.QuickCheck++allocOverhead :: Int+allocOverhead = 2 * sizeOf (undefined :: Int)++defaultChunkSize :: Int+defaultChunkSize = 32 * k - allocOverhead+   where k = 1024++maxArrLen :: Int+maxArrLen = defaultChunkSize * 8++maxTestCount :: Int+maxTestCount = 10++chooseWord8 :: (Word8, Word8) -> Gen Word8+chooseWord8 = choose++utf8ToString :: Array.Array Word8 -> String+utf8ToString =+    runIdentity . Stream.toList . Unicode.decodeUtf8' . Array.toStream++testData :: String+testData = "This is the test data for FileSystem.Handle ??`!@#$%^&*~~))`]"++testDataLarge :: String+testDataLarge = concat $ replicate 6000 testData++executor :: (Handle -> SerialT IO Char) -> IO (SerialT IO Char)+executor f =+    withSystemTempDirectory "fs_handle" $ \fp -> do+        let fpath = fp </> "tmp_read.txt"+        writeFile fpath testDataLarge+        h <- openFile fpath ReadMode+        return $ f h++readFromHandle :: IO (SerialT IO Char)+readFromHandle =+    let f = Unicode.decodeUtf8 . Stream.unfold Handle.read+    in executor f++readWithBufferFromHandle :: IO (SerialT IO Char)+readWithBufferFromHandle =+    let f1 = (\h -> (1024, h))+        f2 = Unicode.decodeUtf8 . Stream.unfold Handle.readWithBufferOf . f1+    in executor f2++readChunksFromHandle :: IO (SerialT IO Char)+readChunksFromHandle =+    let f =   Unicode.decodeUtf8+            . Stream.concatMap Array.toStream+            . Stream.unfold Handle.readChunks+    in executor f++readChunksWithBuffer :: IO (SerialT IO Char)+readChunksWithBuffer =+    let f1 = (\h -> (1024, h))+        f2 =+              Unicode.decodeUtf8+            . Stream.concatMap Array.toStream+            . Stream.unfold Handle.readChunksWithBufferOf+            . f1+    in executor f2++testRead :: (IsStream t) => IO (t IO Char) -> Property+testRead fn = monadicIO $ do+    let v2 = Stream.fromList testDataLarge+    v1 <- run fn+    res <- run $ Stream.eqBy (==) v1 v2+    assert res++testWrite :: (Handle -> Fold.Fold IO Word8 ()) -> Property+testWrite hfold =+    forAll (choose (0, maxArrLen)) $ \len ->+        forAll (vectorOf len $ chooseWord8 (0, 255)) $ \list0 ->+            monadicIO $ do+                res <- run $ go list0+                assert res++                where++                go list =+                    withSystemTempDirectory "fs_handle" $ \fp -> do+                        let fpathWrite = fp </> "tmp_write.txt"+                        writeFile fpathWrite ""+                        h <- openFile fpathWrite ReadWriteMode+                        hSeek h AbsoluteSeek 0+                        _ <- Stream.fold (hfold h) $ Stream.fromList list+                        hFlush h+                        hSeek h AbsoluteSeek 0+                        ls <- Stream.toList $ Stream.unfold Handle.read h+                        hClose h+                        return (ls == list)++testWriteWithChunk :: Property+testWriteWithChunk =+    monadicIO $ do+        res <- run go+        assert res++        where++        go =+            withSystemTempDirectory "fs_handle" $ \fp -> do+                let fpathRead = fp </> "tmp_read.txt"+                    fpathWrite = fp </> "tmp_write.txt"+                writeFile fpathRead testDataLarge+                writeFile fpathWrite ""+                hr <- openFile fpathRead ReadMode+                hw <- openFile fpathWrite ReadWriteMode+                hSeek hw AbsoluteSeek 0+                _ <- Stream.fold (Handle.writeChunks hw)+                    $ Stream.unfold Handle.readChunksWithBufferOf (1024, hr)+                hFlush hw+                hSeek hw AbsoluteSeek 0+                ls <- Stream.toList $ Stream.unfold Handle.read hw+                let arr = Array.fromList ls+                return (testDataLarge == utf8ToString arr)++moduleName :: String+moduleName = "FileSystem.Handle"++main :: IO ()+main =+    hspec $+    H.parallel $+    modifyMaxSuccess (const maxTestCount) $ do+      describe moduleName $ do+        describe "Read From Handle" $ do+            prop "read" $ testRead readFromHandle+            prop "readWithBufferOf" $ testRead readWithBufferFromHandle+            prop "readChunks" $ testRead readChunksFromHandle+            prop "readChunksWithBufferOf" $ testRead readChunksWithBuffer+        describe "Write To Handle" $ do+            prop "write" $ testWrite Handle.write+            prop "writeWithBufferOf" $ testWrite $ Handle.writeWithBufferOf 1024+            -- XXX This test needs a lot of stack when built with -O0+            prop "writeChunks" testWriteWithChunk
− test/Streamly/Test/Internal/Data/Fold.hs 
@@ -1,27 +0,0 @@-module Main (main) where--import qualified Streamly.Prelude as S-import Streamly.Internal.Data.Fold--import Test.Hspec.QuickCheck-import Test.QuickCheck (Property, forAll, Gen, vectorOf, arbitrary, choose)-import Test.QuickCheck.Monadic (monadicIO, assert, run)--import Test.Hspec as H--maxStreamLen :: Int-maxStreamLen = 1000--testRollingHashFirstN :: Property-testRollingHashFirstN = -    forAll (choose (0, maxStreamLen)) $ \len ->-        forAll (choose (0, len)) $ \n ->-            forAll (vectorOf len (arbitrary :: Gen Int)) $ \vec -> monadicIO $ do-                a <- run $ S.fold rollingHash $ S.take n $ S.fromList vec-                b <- run $ S.fold (rollingHashFirstN n) $ S.fromList vec-                assert $ a == b--main :: IO ()-main = hspec $-    describe "Rolling Hash Folds" $-        prop "testRollingHashFirstN" testRollingHashFirstN
− test/Streamly/Test/Internal/Prelude.hs 
@@ -1,78 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}---- |--- Module      : Main--- Copyright   : (c) 2019 Composewell Technologies------ License     : BSD-3-Clause--- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC----module Main (main) where--import Control.Concurrent (threadDelay)-import Control.Monad (when)--import Test.Hspec as H--import qualified Streamly.Prelude as S-import qualified Streamly.Internal.Data.Fold as FL-import qualified Streamly.Internal.Prelude as SI--import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime)-import Streamly.Internal.Data.Time.Units-       (AbsTime, NanoSecond64(..), toRelTime64, diffAbsTime64)-import Data.Int (Int64)--tenPow8 :: Int64-tenPow8 = 10^(8 :: Int)--tenPow7 :: Int64-tenPow7 = 10^(7 :: Int)--takeDropTime :: NanoSecond64-takeDropTime = NanoSecond64 $ 5 * tenPow8--checkTakeDropTime :: (Maybe AbsTime, Maybe AbsTime) -> IO Bool-checkTakeDropTime (mt0, mt1) = do-    let graceTime = NanoSecond64 $ 8 * tenPow7-    case mt0 of-        Nothing -> return True-        Just t0 ->-            case mt1 of-                Nothing -> return True-                Just t1 -> do-                    let tMax = toRelTime64 (takeDropTime + graceTime)-                    let tMin = toRelTime64 (takeDropTime - graceTime)-                    let t = diffAbsTime64 t1 t0-                    let r = t >= tMin && t <= tMax-                    when (not r) $ putStrLn $-                        "t = " ++ show t ++-                        " tMin = " ++ show tMin ++-                        " tMax = " ++ show tMax-                    return r--testTakeByTime :: IO Bool-testTakeByTime = do-    r <--          S.fold ((,) <$> FL.head <*> FL.last)-        $ SI.takeByTime takeDropTime-        $ S.repeatM (threadDelay 1000 >> getTime Monotonic)-    checkTakeDropTime r--testDropByTime :: IO Bool-testDropByTime = do-    t0 <- getTime Monotonic-    mt1 <--          S.head-        $ SI.dropByTime takeDropTime-        $ S.repeatM (threadDelay 1000 >> getTime Monotonic)-    checkTakeDropTime (Just t0, mt1)--main :: IO ()-main =-    hspec $-    describe "Filtering" $ do-        it "takeByTime" (testTakeByTime `shouldReturn` True)-        it "dropByTime" (testDropByTime `shouldReturn` True)
+ test/Streamly/Test/Network/Inet/TCP.hs view
@@ -0,0 +1,137 @@+-- |+-- Module      : Streamly.Test.Network.Socket+-- Copyright   : (c) 2020 Composewell technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Main (main) where++import Control.Concurrent (threadDelay, killThread, forkIO)+import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, putMVar)+import Control.Monad.IO.Class (liftIO)+import Data.Function ((&))+import Data.Word (Word8)+import Network.Socket (Socket, PortNumber)+import Streamly.Internal.Control.Monad (discard)+import Streamly.Prelude (SerialT)+import Test.QuickCheck (Property)+import Test.QuickCheck.Monadic (monadicIO, assert, run)++import qualified Streamly.Internal.Data.Array.Foreign.Type as Array+import qualified Streamly.Internal.Data.Unfold as Unfold+import qualified Streamly.Internal.Network.Inet.TCP as TCP+import qualified Streamly.Internal.Network.Socket as Socket+import qualified Streamly.Internal.Unicode.Stream as Unicode+import qualified Streamly.Prelude as Stream++import Test.Hspec+import Test.Hspec.QuickCheck++------------------------------------------------------------------------------+-- Command Handlers+------------------------------------------------------------------------------+testData :: String+testData = "Test data 1234567891012131415!@#$%^&*()`~ABCD"++testDataSource :: String+testDataSource = concat $ replicate 1000 testData++------------------------------------------------------------------------------+-- Read and Write data on a socket+------------------------------------------------------------------------------+handlerRW :: Socket -> IO ()+handlerRW sk =+          Stream.unfold Socket.read sk+        & Stream.fold (Socket.write sk)+        & discard++------------------------------------------------------------------------------+-- Accept connections and handle connected sockets+------------------------------------------------------------------------------++-- Ideally we should choose an available port automatically.  However, to test+-- the APIs that do not allow choosing a port automatically we still need to+-- use a hardcoded port or search an available port on the system.+--+-- This is unreliable and the test may fail on systems where this port is not+-- available. We choose a higher port number so that the likelihood of it being+-- available is more.+--+-- Also, we cannot run the test after running it once until the timeout.+basePort :: PortNumber+basePort = 64100++server+    :: Unfold.Unfold IO PortNumber Socket+    -> PortNumber+    -> MVar ()+    -> (Socket -> IO ())+    -> IO ()+server listener port sem handler = do+    putMVar sem ()+    Stream.fromSerial (Stream.unfold listener port)+        & (Stream.fromAsync . Stream.mapM (Socket.forSocketM handler))+        & Stream.drain++remoteAddr :: (Word8,Word8,Word8,Word8)+remoteAddr = (127, 0, 0, 1)++sender :: PortNumber -> MVar () -> SerialT IO Char+sender port sem = do+    _ <- liftIO $ takeMVar sem+    liftIO $ threadDelay 1000000                       -- wait for server+    Stream.replicate 1000 testData                     -- SerialT IO String+        & Stream.concatMap Stream.fromList             -- SerialT IO Char+        & Unicode.encodeLatin1                         -- SerialT IO Word8+        & TCP.processBytes remoteAddr port             -- SerialT IO Word8+        & Unicode.decodeLatin1                         -- SerialT IO Char++execute+    :: Unfold.Unfold IO PortNumber Socket+    -> PortNumber+    -> Int+    -> (Socket -> IO ())+    -> IO (SerialT IO Char)+execute listener port size handler = do+    sem <- newEmptyMVar+    tid <- forkIO $ server listener port sem handler+    let lst = sender port sem+                & Stream.take size+                & Stream.finally (killThread tid)+    return lst++validateOnPort :: Property+validateOnPort = monadicIO $ do+    res <- run $ do+        ls2 <-+            execute TCP.acceptOnPort basePort Array.defaultChunkSize handlerRW+        let dataChunk = take Array.defaultChunkSize testDataSource+        Stream.eqBy (==) (Stream.fromList dataChunk) ls2+    assert res++validateOnPortLocal :: Property+validateOnPortLocal = monadicIO $ do+    res <- run $ do+        ls2 <-+            execute+                TCP.acceptOnPortLocal+                (basePort + 1)+                Array.defaultChunkSize+                handlerRW+        let dataChunk = take Array.defaultChunkSize testDataSource+        Stream.eqBy (==) (Stream.fromList dataChunk) ls2+    assert res++moduleName :: String+moduleName = "Network.Inet.TCP"++main :: IO ()+main = hspec $ do+    modifyMaxSuccess (const 1) $ do+      describe moduleName $ do+        describe "Accept Connections" $ do+            prop "acceptOnPort" validateOnPort+            prop "acceptOnPortLocal" validateOnPortLocal+        --  prop "acceptOnAddr/connect" Tested as part of above test cases
+ test/Streamly/Test/Network/Socket.hs view
@@ -0,0 +1,151 @@+-- |+-- Module      : Streamly.Test.Network.Socket+-- Copyright   : (c) 2020 Composewell technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Main (main) where++import Control.Concurrent (threadDelay, killThread, forkIO)+import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, putMVar)+import Control.Monad.IO.Class (liftIO)+import Data.Function ((&))+import Data.Word (Word8)+import Network.Socket (Socket, PortNumber)+import Streamly.Internal.Control.Monad (discard)+import Streamly.Prelude (SerialT)+import Test.QuickCheck (Property)+import Test.QuickCheck.Monadic (monadicIO, assert, run)++import qualified Streamly.Internal.Data.Array.Foreign.Type as Array+import qualified Streamly.Internal.Network.Inet.TCP as TCP+import qualified Streamly.Internal.Network.Socket as Socket+import qualified Streamly.Internal.Unicode.Stream as Unicode+import qualified Streamly.Prelude as Stream++import Test.Hspec+import Test.Hspec.QuickCheck++------------------------------------------------------------------------------+-- Command Handlers+------------------------------------------------------------------------------+testData :: String+testData = "Test data 1234567891012131415!@#$%^&*()`~ABCD"++testDataSource :: String+testDataSource = concat $ replicate 1000 testData++------------------------------------------------------------------------------+-- Parse and handle commands on a socket+------------------------------------------------------------------------------+handlerChunksWithBuffer :: Socket -> IO ()+handlerChunksWithBuffer sk =+          Stream.unfold Socket.readChunksWithBufferOf (100, sk)+        & Stream.fold (Socket.writeChunks sk)+        & discard++handlerChunks :: Socket -> IO ()+handlerChunks sk =+          Stream.unfold Socket.readChunks sk+        & Stream.fold (Socket.writeChunks sk)+        & discard++handlerwithbuffer :: Socket -> IO ()+handlerwithbuffer sk =+          Stream.unfold Socket.readWithBufferOf (100, sk)+        & Stream.fold (Socket.writeWithBufferOf 100 sk)+        & discard++handlerRW :: Socket -> IO ()+handlerRW sk =+          Stream.unfold Socket.read sk+        & Stream.fold (Socket.write sk)+        & discard+------------------------------------------------------------------------------+-- Accept connections and handle connected sockets+------------------------------------------------------------------------------++-- Ideally we should choose an available port automatically.  However, to test+-- the APIs that do not allow choosing a port automatically we still need to+-- use a hardcoded port or search an available port on the system.+--+-- This is unreliable and the test may fail on systems where this port is not+-- available. We choose a higher port number so that the likelihood of it being+-- available is more.+--+-- Also, we cannot run the test after running it once until the timeout.+basePort :: PortNumber+basePort = 64000++server :: PortNumber -> MVar () -> (Socket -> IO ()) -> IO ()+server port sem handler = do+    putMVar sem ()+    Stream.fromSerial (Stream.unfold TCP.acceptOnPort port)+        & Stream.fromAsync . Stream.mapM (Socket.forSocketM handler)+        & Stream.drain++remoteAddr :: (Word8,Word8,Word8,Word8)+remoteAddr = (127, 0, 0, 1)++sender :: PortNumber -> MVar () -> SerialT IO Char+sender port sem = do+    _ <- liftIO $ takeMVar sem+    liftIO $ threadDelay 1000000                       -- wait for server+    Stream.replicate 1000 testData                     -- SerialT IO String+        & Stream.concatMap Stream.fromList             -- SerialT IO Char+        & Unicode.encodeLatin1                         -- SerialT IO Word8+        & TCP.processBytes remoteAddr port             -- SerialT IO Word8+        & Unicode.decodeLatin1                         -- SerialT IO Char++execute :: PortNumber -> Int -> (Socket -> IO ()) -> IO (SerialT IO Char)+execute port size handler = do+    sem <- newEmptyMVar+    tid <- forkIO $ server port sem handler+    let lst = sender port sem+                & Stream.take size+                & Stream.finally (killThread tid)+    return lst++validateWithBufferOf :: Property+validateWithBufferOf = monadicIO $ do+    res <- run $ do+        ls2 <- execute basePort 45000 handlerwithbuffer+        Stream.eqBy (==) (Stream.fromList testDataSource) ls2+    assert res++validateRW :: Property+validateRW = monadicIO $ do+    res <- run $ do+        ls2 <- execute (basePort + 1) Array.defaultChunkSize handlerRW+        let dataChunk = take Array.defaultChunkSize testDataSource+        Stream.eqBy (==) (Stream.fromList dataChunk) ls2+    assert res++validateChunks :: Property+validateChunks = monadicIO $ do+    res <- run $ do+        ls2 <- execute (basePort + 2) 45000 handlerChunks+        Stream.eqBy (==) (Stream.fromList testDataSource) ls2+    assert res++validateChunksWithBufferOf :: Property+validateChunksWithBufferOf = monadicIO $ do+    res <- run $ do+        ls2 <- execute (basePort + 3) 45000 handlerChunksWithBuffer+        Stream.eqBy (==) (Stream.fromList testDataSource) ls2+    assert res++moduleName :: String+moduleName = "Network.Socket"++main :: IO ()+main = hspec $ do+    modifyMaxSuccess (const 1) $ do+      describe moduleName $ do+        describe "Read/Write" $ do+            prop "read/write" validateRW+            prop "readWithBufferOf/writeWithBufferOf" validateWithBufferOf+            prop "readChunks/writeChunks" validateChunks+            prop "readChunksWithBufferOf" validateChunksWithBufferOf
+ test/Streamly/Test/Prelude.hs view
@@ -0,0 +1,189 @@+-- |+-- Module      : Streamly.Test.Prelude+-- Copyright   : (c) 2020 Composewell Technologies+--+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Test.Prelude (main) where++import Control.Concurrent (myThreadId, threadDelay)+import Control.Exception (Exception, try)+import Control.Monad.Catch (throwM)+import Control.Monad.Error.Class (throwError, MonadError)+import Control.Monad.Trans.Except (runExceptT, ExceptT)+import Data.List (sort)+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup (Semigroup(..))+#endif+import System.IO (stdout, hSetBuffering, BufferMode(LineBuffering))+import System.Random (randomIO)+import Test.Hspec as H++import Streamly.Prelude (SerialT, IsStream)++import qualified Streamly.Prelude as S++toListSerial :: SerialT IO a -> IO [a]+toListSerial = S.toList . S.fromSerial++-- XXX need to test that we have promptly cleaned up everything after the error+-- XXX We can also check the output that we are expected to get before the+-- error occurs.++newtype ExampleException = ExampleException String deriving (Eq, Show)++instance Exception ExampleException++simpleMonadError :: Spec+simpleMonadError = do+{-+    it "simple runExceptT" $ do+        (runExceptT $ S.drain $ return ())+        `shouldReturn` (Right () :: Either String ())+    it "simple runExceptT with error" $ do+        (runExceptT $ S.drain $ throwError "E") `shouldReturn` Left "E"+        -}+    it "simple try" $+        try (S.drain $ return ())+        `shouldReturn` (Right () :: Either ExampleException ())+    it "simple try with throw error" $+        try (S.drain $ throwM $ ExampleException "E")+        `shouldReturn` (Left (ExampleException "E") :: Either ExampleException ())++_composeWithMonadError+    :: ( IsStream t+       , Semigroup (t (ExceptT String IO) Int)+       , MonadError String (t (ExceptT String IO))+       )+    => (t (ExceptT String IO) Int -> SerialT (ExceptT String IO) Int) -> Spec+_composeWithMonadError t = do+    let tl = S.toList . t+    it "Compose throwError, nil" $+        runExceptT (tl (throwError "E" <> S.nil)) `shouldReturn` Left "E"+    it "Compose nil, error" $+        runExceptT (tl (S.nil <> throwError "E")) `shouldReturn` Left "E"++mixedOps :: Spec+mixedOps =+    it "Compose many ops" $+        (sort <$> toListSerial composeMixed)+            `shouldReturn` ([8,9,9,9,9,9,10,10,10,10,10,10,10,10,10,10,11,11+                            ,11,11,11,11,11,11,11,11,12,12,12,12,12,13+                            ] :: [Int])+    where++    composeMixed :: SerialT IO Int+    composeMixed = do+        S.fromEffect $ return ()+        S.fromEffect $ putStr ""+        let x = 1+        let y = 2+        z <- do+                x1 <- S.fromWAsync $ return 1 <> return 2+                S.fromEffect $ return ()+                S.fromEffect $ putStr ""+                y1 <- S.fromAsync $ return 1 <> return 2+                z1 <- do+                    x11 <- return 1 <> return 2+                    y11 <- S.fromAsync $ return 1 <> return 2+                    z11 <- S.fromWSerial $ return 1 <> return 2+                    S.fromEffect $ return ()+                    S.fromEffect $ putStr ""+                    return (x11 + y11 + z11)+                return (x1 + y1 + z1)+        return (x + y + z)++mixedOpsAheadly :: Spec+mixedOpsAheadly =+    it "Compose many ops" $+        (sort <$> toListSerial composeMixed)+            `shouldReturn` ([8,9,9,9,9,9,10,10,10,10,10,10,10,10,10,10,11,11+                            ,11,11,11,11,11,11,11,11,12,12,12,12,12,13+                            ] :: [Int])+    where++    composeMixed :: SerialT IO Int+    composeMixed = do+        S.fromEffect $ return ()+        S.fromEffect $ putStr ""+        let x = 1+        let y = 2+        z <- do+                x1 <- S.fromWAsync $ return 1 <> return 2+                S.fromEffect $ return ()+                S.fromEffect $ putStr ""+                y1 <- S.fromAhead $ return 1 <> return 2+                z1 <- do+                    x11 <- return 1 <> return 2+                    y11 <- S.fromAhead $ return 1 <> return 2+                    z11 <- S.fromParallel $ return 1 <> return 2+                    S.fromEffect $ return ()+                    S.fromEffect $ putStr ""+                    return (x11 + y11 + z11)+                return (x1 + y1 + z1)+        return (x + y + z)++-- XXX Merge both the loops.+nestedLoops :: IO ()+nestedLoops = S.drain $ do+    S.fromEffect $ hSetBuffering stdout LineBuffering+    x <- loop "A " 2+    y <- loop "B " 2+    S.fromEffect $ myThreadId >>= putStr . show+             >> putStr " "+             >> print (x, y)++    where++    -- we can just use+    -- fromParallel $ mconcat $ replicate n $ fromEffect (...)+    loop :: String -> Int -> SerialT IO String+    loop name n = do+        rnd <- S.fromEffect (randomIO :: IO Int)+        let result = name <> show rnd+            repeatIt = if n > 1 then loop name (n - 1) else S.nil+         in return result `S.wAsync` repeatIt++parallelLoops :: IO ()+parallelLoops = do+    hSetBuffering stdout LineBuffering+    S.drain $ do+        x <- S.take 10 $ loop "A" `S.parallel` loop "B"+        S.fromEffect $ myThreadId >>= putStr . show+               >> putStr " got "+               >> print x++    where++    -- we can just use+    -- fromParallel $ cycle1 $ fromEffect (...)+    loop :: String -> SerialT IO (String, Int)+    loop name = do+        S.fromEffect $ threadDelay 1000000+        rnd <- S.fromEffect (randomIO :: IO Int)+        S.fromEffect $ myThreadId >>= putStr . show+               >> putStr " yielding "+               >> print rnd+        return (name, rnd) `S.parallel` loop name++moduleName :: String+moduleName = "Prelude"++main :: IO ()+main = hspec $ H.parallel $ do+  describe moduleName $ do+    describe "Miscellaneous combined examples" mixedOps+    describe "Miscellaneous combined examples fromAhead" mixedOpsAheadly+    describe "Simple MonadError and MonadThrow" simpleMonadError++    it "Nested loops" nestedLoops+    it "Parallel loops" parallelLoops+    {-+    describe "Composed MonadError fromSerial" $ composeWithMonadError fromSerial+    describe "Composed MonadError fromWSerial" $ composeWithMonadError fromWSerial+    describe "Composed MonadError fromAsync" $ composeWithMonadError fromAsync+    describe "Composed MonadError fromWAsync" $ composeWithMonadError fromWAsync+    -}
+ test/Streamly/Test/Prelude/Ahead.hs view
@@ -0,0 +1,138 @@+-- |+-- Module      : Streamly.Test.Prelude.Ahead+-- Copyright   : (c) 2020 Composewell Technologies+--+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Test.Prelude.Ahead where++#if __GLASGOW_HASKELL__ < 808+import Data.Semigroup ((<>))+#endif+import Test.QuickCheck (Property)+import Test.Hspec.QuickCheck+import Test.QuickCheck.Monadic (monadicIO, run)+import Test.Hspec as H++import Streamly.Prelude (IsStream, SerialT, AheadT)+import qualified Streamly.Prelude as S++import Streamly.Test.Common+import Streamly.Test.Prelude.Common++associativityCheck+    :: String+    -> (AheadT IO Int -> SerialT IO Int)+    -> Spec+associativityCheck desc t = prop desc assocCheckProp+  where+    assocCheckProp :: [Int] -> [Int] -> [Int] -> Property+    assocCheckProp xs ys zs =+        monadicIO $ do+            let xStream = S.fromList xs+                yStream = S.fromList ys+                zStream = S.fromList zs+            infixAssocstream <-+                run $ S.toList $ t $ xStream `S.ahead` yStream `S.ahead` zStream+            assocStream <- run $ S.toList $ t $ xStream <> yStream <> zStream+            listEquals (==) infixAssocstream assocStream++moduleName :: String+moduleName = "Prelude.Ahead"++main :: IO ()+main = hspec+  $ H.parallel+#ifdef COVERAGE_BUILD+  $ modifyMaxSuccess (const 10)+#endif+  $ describe moduleName $ do+    let aheadOps :: IsStream t => ((AheadT IO a -> t IO a) -> Spec) -> Spec+        aheadOps spec = mapOps spec $ makeOps S.fromAhead+#ifndef COVERAGE_BUILD+              <> [("maxBuffer (-1)", S.fromAhead . S.maxBuffer (-1))]+#endif++    describe "Construction" $ do+        aheadOps    $ prop "aheadly replicateM" . constructWithReplicateM+        aheadOps $ prop "aheadly cons" . constructWithCons S.cons+        aheadOps $ prop "aheadly consM" . constructWithConsM S.consM id+        aheadOps $ prop "aheadly (.:)" . constructWithCons (S..:)+        aheadOps $ prop "aheadly (|:)" . constructWithConsM (S.|:) id++    describe "Functor operations" $ do+        aheadOps     $ functorOps S.fromFoldable "aheadly" (==)+        aheadOps     $ functorOps folded "aheadly folded" (==)++    describe "Monoid operations" $ do+        aheadOps     $ monoidOps "aheadly" mempty (==)++    describe "Ahead loops" $ loops S.fromAhead id reverse++    describe "Bind and Monoidal composition combinations" $ do+        aheadOps $ bindAndComposeSimpleOps "Ahead" sortEq+        aheadOps $ bindAndComposeHierarchyOps "Ahead"+        aheadOps $ nestTwoStreams "Ahead" id id+        aheadOps $ nestTwoStreamsApp "Ahead" id id+        composeAndComposeSimpleSerially "Ahead <> " (repeat [1..9]) S.fromAhead+        composeAndComposeSimpleAheadly "Ahead <> " (repeat [1 .. 9]) S.fromAhead+        composeAndComposeSimpleWSerially+            "Ahead <> "+            [[1..9], [1..9], [1,3,2,4,6,5,7,9,8], [1,3,2,4,6,5,7,9,8]]+            S.fromAhead++    describe "Semigroup operations" $ do+        aheadOps $ semigroupOps "aheadly" (==)+        aheadOps $ associativityCheck "ahead == <>"++    describe "Applicative operations" $ do+        aheadOps $ applicativeOps S.fromFoldable "aheadly applicative" (==)+        aheadOps $ applicativeOps folded "aheadly applicative folded" (==)++    -- XXX add tests for indexed/indexedR+    describe "Zip operations" $ do+        -- We test only the serial zip with serial streams and the parallel+        -- stream, because the rate setting in these streams can slow down+        -- zipAsync.+        aheadOps    $ prop "zip applicative aheadly" . zipAsyncApplicative S.fromFoldable (==)+        aheadOps    $ prop "zip applicative aheadly folded" . zipAsyncApplicative folded (==)+        aheadOps    $ prop "zip monadic aheadly" . zipAsyncMonadic S.fromFoldable (==)+        aheadOps    $ prop "zip monadic aheadly folded" . zipAsyncMonadic folded (==)++    -- XXX add merge tests like zip tests+    -- for mergeBy, we can split a list randomly into two lists and+    -- then merge them, it should result in original list+    -- describe "Merge operations" $ do++    describe "Monad operations" $ do+        aheadOps    $ prop "aheadly monad then" . monadThen S.fromFoldable (==)+        aheadOps    $ prop "aheadly monad then folded" . monadThen folded (==)+        aheadOps    $ prop "aheadly monad bind" . monadBind S.fromFoldable (==)+        aheadOps    $ prop "aheadly monad bind folded"   . monadBind folded (==)++    describe "Stream transform and combine operations" $ do+        aheadOps     $ transformCombineOpsCommon S.fromFoldable "aheadly" (==)+        aheadOps     $ transformCombineOpsCommon folded "aheadly" (==)+        aheadOps     $ transformCombineOpsOrdered S.fromFoldable "aheadly" (==)+        aheadOps     $ transformCombineOpsOrdered folded "aheadly" (==)++    describe "Stream elimination operations" $ do+        aheadOps     $ eliminationOps S.fromFoldable "aheadly"+        aheadOps     $ eliminationOps folded "aheadly folded"+        aheadOps     $ eliminationOpsWord8 S.fromFoldable "aheadly"+        aheadOps     $ eliminationOpsWord8 folded "aheadly folded"++    -- XXX Add a test where we chain all transformation APIs and make sure that+    -- the state is being passed through all of them.+    describe "Stream serial elimination operations" $ do+        aheadOps     $ eliminationOpsOrdered S.fromFoldable "aheadly"+        aheadOps     $ eliminationOpsOrdered folded "aheadly folded"++    describe "Tests for exceptions" $ aheadOps $ exceptionOps "aheadly"+    describe "Composed MonadThrow aheadly" $ composeWithMonadThrow S.fromAhead++    -- Ad-hoc tests+    it "takes n from stream of streams" $ takeCombined 1 S.fromAhead
+ test/Streamly/Test/Prelude/Async.hs view
@@ -0,0 +1,113 @@+-- |+-- Module      : Streamly.Test.Prelude.Async+-- Copyright   : (c) 2020 Composewell Technologies+--+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Test.Prelude.Async where++import Data.List (sort)+#if __GLASGOW_HASKELL__ < 808+import Data.Semigroup ((<>))+#endif+import Test.Hspec.QuickCheck+import Test.Hspec as H++import Streamly.Prelude+import qualified Streamly.Prelude as S++import Streamly.Test.Prelude.Common++moduleName :: String+moduleName = "Prelude.Ahead"++main :: IO ()+main = hspec+  $ H.parallel+#ifdef COVERAGE_BUILD+  $ modifyMaxSuccess (const 10)+#endif+  $ describe moduleName $ do+    let asyncOps :: IsStream t => ((AsyncT IO a -> t IO a) -> Spec) -> Spec+        asyncOps spec = mapOps spec $ makeOps fromAsync+#ifndef COVERAGE_BUILD+            <> [("maxBuffer (-1)", fromAsync . maxBuffer (-1))]+#endif++    describe "Construction" $ do+        asyncOps    $ prop "asyncly replicateM" . constructWithReplicateM+        asyncOps $ prop "asyncly cons" . constructWithCons S.cons+        asyncOps $ prop "asyncly consM" . constructWithConsM S.consM sort+        asyncOps $ prop "asyncly (.:)" . constructWithCons (S..:)+        asyncOps $ prop "asyncly (|:)" . constructWithConsM (S.|:) sort++    describe "Functor operations" $ do+        asyncOps     $ functorOps S.fromFoldable "asyncly" sortEq+        asyncOps     $ functorOps folded "asyncly folded" sortEq++    describe "Monoid operations" $ do+        asyncOps     $ monoidOps "asyncly" mempty sortEq++    describe "Async loops" $ loops fromAsync sort sort++    describe "Bind and Monoidal composition combinations" $ do+        asyncOps $ bindAndComposeSimpleOps "Async" sortEq+        asyncOps $ bindAndComposeHierarchyOps "Async"+        asyncOps $ nestTwoStreams "Async" sort sort+        asyncOps $ nestTwoStreamsApp "Async" sort sort++    describe "Semigroup operations" $ do+        asyncOps     $ semigroupOps "asyncly" sortEq++    describe "Applicative operations" $ do+        asyncOps $ applicativeOps S.fromFoldable "asyncly applicative" sortEq+        asyncOps $ applicativeOps folded "asyncly applicative folded" sortEq++    -- XXX add tests for indexed/indexedR+    describe "Zip operations" $ do+        -- We test only the serial zip with serial streams and the parallel+        -- stream, because the rate setting in these streams can slow down+        -- zipAsync.+        asyncOps    $ prop "zip applicative asyncly" . zipAsyncApplicative S.fromFoldable (==)+        asyncOps    $ prop "zip applicative asyncly folded" . zipAsyncApplicative folded (==)+        asyncOps    $ prop "zip monadic asyncly" . zipAsyncMonadic S.fromFoldable (==)+        asyncOps    $ prop "zip monadic asyncly folded" . zipAsyncMonadic folded (==)++    -- XXX add merge tests like zip tests+    -- for mergeBy, we can split a list randomly into two lists and+    -- then merge them, it should result in original list+    -- describe "Merge operations" $ do++    describe "Monad operations" $ do+        asyncOps    $ prop "asyncly monad then" . monadThen S.fromFoldable sortEq+        asyncOps    $ prop "asyncly monad then folded" . monadThen folded sortEq+        asyncOps    $ prop "asyncly monad bind" . monadBind S.fromFoldable sortEq+        asyncOps    $ prop "asyncly monad bind folded"   . monadBind folded sortEq++    describe "Stream transform and combine operations" $ do+        asyncOps     $ transformCombineOpsCommon S.fromFoldable "asyncly" sortEq+        asyncOps     $ transformCombineOpsCommon folded "asyncly" sortEq++    describe "Stream elimination operations" $ do+        asyncOps     $ eliminationOps S.fromFoldable "asyncly"+        asyncOps     $ eliminationOps folded "asyncly folded"+        asyncOps     $ eliminationOpsWord8 S.fromFoldable "asyncly"+        asyncOps     $ eliminationOpsWord8 folded "asyncly folded"++    -- test both (<>) and mappend to make sure we are using correct instance+    -- for Monoid that is using the right version of semigroup. Instance+    -- deriving can cause us to pick wrong instances sometimes.++#ifdef DEVBUILD+    describe "Async (<>) time order check" $ parallelCheck fromAsync (<>)+    describe "Async mappend time order check" $ parallelCheck fromAsync mappend+#endif++    describe "Tests for exceptions" $ asyncOps $ exceptionOps "asyncly"+    describe "Composed MonadThrow asyncly" $ composeWithMonadThrow fromAsync++    -- Ad-hoc tests+    it "takes n from stream of streams" $ takeCombined 2 fromAsync
+ test/Streamly/Test/Prelude/Concurrent.hs view
@@ -0,0 +1,504 @@+-- |+-- Module      : Streamly.Test.Prelude.Concurrent+-- Copyright   : (c) 2020 Composewell Technologies+--+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++{-# LANGUAGE OverloadedLists #-}++module Streamly.Test.Prelude.Concurrent where++import Control.Concurrent (MVar, takeMVar, threadDelay, putMVar, newEmptyMVar)+import Control.Exception+       (BlockedIndefinitelyOnMVar(..), catches,+        BlockedIndefinitelyOnSTM(..), Handler(..))+import Control.Monad (void, when, forM_, replicateM_)+import Control.Monad.IO.Class (MonadIO(liftIO))+import Control.Monad.State (MonadState, get, modify, runStateT+                           , StateT(..), evalStateT)+import Data.Foldable (fold)+import Data.IORef (readIORef, modifyIORef, newIORef)+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup (Semigroup, (<>))+#endif+import GHC.Word (Word8)+import Test.Hspec.QuickCheck+import Test.Hspec as H+import Test.QuickCheck+       (Property, withMaxSuccess)+import Test.QuickCheck.Monadic (monadicIO, run)++import Streamly.Prelude hiding (fold, replicate, replicateM, reverse, runStateT)+import qualified Streamly.Prelude as S++import Streamly.Test.Common+import Streamly.Test.Prelude.Common++-------------------------------------------------------------------------------+-- Concurrent generation+-------------------------------------------------------------------------------++mvarExcHandler :: String -> BlockedIndefinitelyOnMVar -> IO ()+mvarExcHandler label BlockedIndefinitelyOnMVar =+    error $ label <> " " <> "BlockedIndefinitelyOnMVar\n"++stmExcHandler :: String -> BlockedIndefinitelyOnSTM -> IO ()+stmExcHandler label BlockedIndefinitelyOnSTM =+    error $ label <> " " <> "BlockedIndefinitelyOnSTM\n"++dbgMVar :: String -> IO () -> IO ()+dbgMVar label action =+    action `catches` [ Handler (mvarExcHandler label)+                     , Handler (stmExcHandler label)+                     ]++-- | first n actions takeMVar and the last action performs putMVar n times+mvarSequenceOp :: MVar () -> Word8 -> Word8 -> IO Word8+mvarSequenceOp mv n x = do+    let msg = show x <> "/" <> show n+    if x < n+    then dbgMVar ("take mvarSequenceOp " <> msg) (takeMVar mv) >>  return x+    else dbgMVar ("put mvarSequenceOp" <> msg)+            (replicateM_ (fromIntegral n) (putMVar mv ())) >> return x++concurrentMapM+    :: ([Word8] -> t IO Word8)+    -> ([Word8] -> [Word8] -> Bool)+    -> (Word8 -> MVar () -> t IO Word8 -> SerialT IO Word8)+    -> Word8+    -> Property+concurrentMapM constr eq op n =+    monadicIO $ do+        let list = [0..n]+        stream <- run $ do+            mv <- newEmptyMVar :: IO (MVar ())+            (S.toList . op n mv) (constr list)+        listEquals eq stream list++concurrentFromFoldable+    :: IsStream t+    => ([Word8] -> [Word8] -> Bool)+    -> (t IO Word8 -> SerialT IO Word8)+    -> Word8+    -> Property+concurrentFromFoldable eq op n =+    monadicIO $ do+        let list = [0..n]+        stream <- run $ do+            mv <- newEmptyMVar :: IO (MVar ())+            (S.toList . op) (S.fromFoldableM (fmap (mvarSequenceOp mv n) list))+        listEquals eq stream list++sourceUnfoldrM :: IsStream t => MVar () -> Word8 -> t IO Word8+sourceUnfoldrM mv n = S.unfoldrM step 0+    where+    -- argument must be integer to avoid overflow of word8 at 255+    step :: Int -> IO (Maybe (Word8, Int))+    step cnt = do+        let msg = show cnt <> "/" <> show n+        if cnt > fromIntegral n+        then return Nothing+        else do+            dbgMVar ("put sourceUnfoldrM " <> msg) (putMVar mv ())+            return (Just (fromIntegral cnt, cnt + 1))++-- Note that this test is not guaranteed to succeed, because there is no+-- guarantee of parallelism in case of Async/Ahead streams.+concurrentUnfoldrM+    :: IsStream t+    => ([Word8] -> [Word8] -> Bool)+    -> (t IO Word8 -> SerialT IO Word8)+    -> Word8+    -> Property+concurrentUnfoldrM eq op n =+    monadicIO $ do+        -- XXX we should test empty list case as well+        let list = [0..n]+        stream <- run $ do+            -- putStrLn $ "concurrentUnfoldrM: " <> show n+            mv <- newEmptyMVar :: IO (MVar ())+            cnt <- newIORef 0+            -- since unfoldr happens in parallel with the stream processing we+            -- can do two takeMVar in one iteration. If it is not parallel then+            -- this will not work and the test will fail.+            S.toList $ do+                x <- op (sourceUnfoldrM mv n)+                -- results may not be yielded in order, in case of+                -- Async/WAsync/Parallel. So we use an increasing count+                -- instead.+                i <- S.fromEffect $ readIORef cnt+                S.fromEffect $ modifyIORef cnt (+1)+                let msg = show i <> "/" <> show n+                S.fromEffect $+                    when (even i) $ do+                        dbgMVar ("first take concurrentUnfoldrM " <> msg)+                                (takeMVar mv)+                        when (n > i) $+                            dbgMVar ("second take concurrentUnfoldrM " <> msg)+                                     (takeMVar mv)+                return x+        listEquals eq stream list++concurrentOps+    :: IsStream t+    => ([Word8] -> t IO Word8)+    -> String+    -> ([Word8] -> [Word8] -> Bool)+    -> (t IO Word8 -> SerialT IO Word8)+    -> Spec+concurrentOps constr desc eq t = do+    let prop1 d p = prop d $ withMaxSuccess maxTestCount p++    prop1 (desc <> " fromFoldableM") $ concurrentFromFoldable eq t+    prop1 (desc <> " unfoldrM") $ concurrentUnfoldrM eq t+    -- we pass it the length of the stream n and an mvar mv.+    -- The stream is [0..n]. The threads communicate in such a way that the+    -- actions coming first in the stream are dependent on the last action. So+    -- if the stream is not processed concurrently it will block forever.+    -- Note that if the size of the stream is bigger than the thread limit+    -- then it will block even if it is concurrent.+    prop1 (desc <> " mapM") $+        concurrentMapM constr eq $ \n mv stream ->+            t $ S.mapM (mvarSequenceOp mv n) stream++-------------------------------------------------------------------------------+-- Concurrent Application+-------------------------------------------------------------------------------++concurrentApplication :: IsStream t+    => ([Word8] -> [Word8] -> Bool)+    -> (t IO Word8 -> SerialT IO Word8)+    -> Word8+    -> Property+concurrentApplication eq t n = withMaxSuccess maxTestCount $+    monadicIO $ do+        -- XXX we should test empty list case as well+        let list = [0..n]+        stream <- run $ do+            -- putStrLn $ "concurrentApplication: " <> show n+            mv <- newEmptyMVar :: IO (MVar ())+            -- since unfoldr happens in parallel with the stream processing we+            -- can do two takeMVar in one iteration. If it is not parallel then+            -- this will not work and the test will fail.+            (S.toList . t) $+                sourceUnfoldrM mv n |&+                    S.mapM (\x -> do+                        let msg = show x <> "/" <> show n+                        when (even x) $ do+                            dbgMVar ("first take concurrentApp " <> msg)+                                    (takeMVar mv)+                            when (n > x) $+                                dbgMVar ("second take concurrentApp " <> msg)+                                         (takeMVar mv)+                        return x)+        listEquals eq stream list++sourceUnfoldrM1 :: IsStream t => Word8 -> t IO Word8+sourceUnfoldrM1 n = S.unfoldrM step 0+    where+    -- argument must be integer to avoid overflow of word8 at 255+    step :: Int -> IO (Maybe (Word8, Int))+    step cnt =+        if cnt > fromIntegral n+        then return Nothing+        else return (Just (fromIntegral cnt, cnt + 1))++concurrentFoldlApplication :: Word8 -> Property+concurrentFoldlApplication n =+    monadicIO $ do+        -- XXX we should test empty list case as well+        let list = [0..n]+        stream <- run $+            sourceUnfoldrM1 n |&. S.foldlM' (\xs x -> return (x : xs)) (return [])+        listEquals (==) (reverse stream) list++concurrentFoldrApplication :: Word8 -> Property+concurrentFoldrApplication n =+    monadicIO $ do+        -- XXX we should test empty list case as well+        let list = [0..n]+        stream <- run $+            sourceUnfoldrM1 n |&. S.foldrM (\x xs -> xs >>= return . (x :))+                                           (return [])+        listEquals (==) stream list++-- Each snapshot carries an independent state. Multiple parallel tasks should+-- not affect each other's state. This is especially important when we run+-- multiple tasks in a single thread.+snapshot :: (IsStream t, MonadAsync m, MonadState Int m) => t m ()+snapshot =+    -- We deliberately use a replicate count 1 here, because a lower count+    -- catches problems that a higher count doesn't.+    S.replicateM 1 $ do+        -- Even though we modify the state here it should not reflect in other+        -- parallel tasks, it is local to each concurrent task.+        modify (+1) >> get >>= liftIO . (`shouldSatisfy` (==1))+        modify (+1) >> get >>= liftIO . (`shouldSatisfy` (==2))++snapshot1 :: (IsStream t, MonadAsync m, MonadState Int m) => t m ()+snapshot1 = S.replicateM 1000 $+    modify (+1) >> get >>= liftIO . (`shouldSatisfy` (==2))++snapshot2 :: (IsStream t, MonadAsync m, MonadState Int m) => t m ()+snapshot2 = S.replicateM 1000 $+    modify (+1) >> get >>= liftIO . (`shouldSatisfy` (==2))++stateComp+    :: ( IsStream t+       , MonadAsync m+       , Semigroup (t m ())+       , MonadIO (t m)+       , MonadState Int m+       , MonadState Int (t m)+       )+    => t m ()+stateComp = do+    -- Each task in a concurrent composition inherits the state and maintains+    -- its own modifications to it, not affecting the parent computation.+    snapshot <> (modify (+1) >> (snapshot1 <> snapshot2))+    -- The above modify statement does not affect our state because that is+    -- used in a parallel composition. In a serial composition it will affect+    -- our state.+    get >>= liftIO . (`shouldSatisfy` (== (0 :: Int)))++monadicStateSnapshot+    :: ( IsStream t+       , Semigroup (t (StateT Int IO) ())+       , MonadIO (t (StateT Int IO))+       , MonadState Int (t (StateT Int IO))+       )+    => (t (StateT Int IO) () -> SerialT (StateT Int IO) ()) -> IO ()+monadicStateSnapshot t = void $ runStateT (S.drain $ t stateComp) 0++stateCompOp+    :: (   AsyncT (StateT Int IO) ()+        -> AsyncT (StateT Int IO) ()+        -> AsyncT (StateT Int IO) ()+       )+    -> SerialT (StateT Int IO) ()+stateCompOp op = do+    -- Each task in a concurrent composition inherits the state and maintains+    -- its own modifications to it, not affecting the parent computation.+    fromAsync (snapshot `op` (modify (+1) >> (snapshot1 `op` snapshot2)))+    -- The above modify statement does not affect our state because that is+    -- used in a parallel composition. In a serial composition it will affect+    -- our state.+    get >>= liftIO . (`shouldSatisfy` (== (0 :: Int)))++checkMonadicStateTransfer+    :: (IsStream t1, IsStream t2)+    => (    t1 (StateT Int IO) ()+        ->  t2 (StateT Int IO) ()+        ->  SerialT (StateT Int IO) a3 )+    -> IO ()+checkMonadicStateTransfer op = evalStateT str (0 :: Int)+  where+    str =+        S.drain $+        maxBuffer 1 $+        (fromSerial $ S.mapM snapshoti $ S.fromList [1..10]) `op`+        (fromSerial $ S.mapM snapshoti $ S.fromList [1..10])+    snapshoti y = do+        modify (+ 1)+        x <- get+        lift1 $ x `shouldBe` y+    lift1 m = StateT $ \s -> do+        a <- m+        return (a, s)++monadicStateSnapshotOp+    :: (   AsyncT (StateT Int IO) ()+        -> AsyncT (StateT Int IO) ()+        -> AsyncT (StateT Int IO) ()+       )+    -> IO ()+monadicStateSnapshotOp op = void $ runStateT (S.drain $ stateCompOp op) 0++takeInfinite :: IsStream t => (t IO Int -> SerialT IO Int) -> Spec+takeInfinite t =+    it "take 1" $+        S.drain (t $ S.take 1 $ S.repeatM (print "hello" >> return (1::Int)))+        `shouldReturn` ()++moduleName :: String+moduleName = "Prelude.Concurrent"++main :: IO ()+main = hspec+  $ H.parallel+#ifdef COVERAGE_BUILD+  $ modifyMaxSuccess (const 10)+#endif+  $ describe moduleName $ do+    -- We can have these in Test.Prelude, but I think it's unnecessary.+    let serialOps :: IsStream t => ((SerialT IO a -> t IO a) -> Spec) -> Spec+        serialOps spec = mapOps spec $ makeOps fromSerial+#ifndef COVERAGE_BUILD+            <> [("rate AvgRate 0.00000001", fromSerial . avgRate 0.00000001)]+            <> [("maxBuffer -1", fromSerial . maxBuffer (-1))]+#endif++    let aheadOps :: IsStream t => ((AheadT IO a -> t IO a) -> Spec) -> Spec+        aheadOps spec = mapOps spec $ makeOps fromAhead+#ifndef COVERAGE_BUILD+              <> [("maxBuffer (-1)", fromAhead . maxBuffer (-1))]+#endif++    let asyncOps :: IsStream t => ((AsyncT IO a -> t IO a) -> Spec) -> Spec+        asyncOps spec = mapOps spec $ makeOps fromAsync+#ifndef COVERAGE_BUILD+            <> [("maxBuffer (-1)", fromAsync . maxBuffer (-1))]+#endif++    -- For concurrent application test we need a buffer of at least size 2 to+    -- allow two threads to run.+#ifndef COVERAGE_BUILD+    let makeConcurrentAppOps :: IsStream t+            => (t m a -> c) -> [(String, t m a -> c)]+#endif+        makeConcurrentAppOps t = makeCommonOps t +++            [+#ifndef COVERAGE_BUILD+              ("maxBuffer 2", t . maxBuffer 2)+#endif+            ]++#ifndef COVERAGE_BUILD+    let parallelCommonOps :: IsStream t => [(String, ParallelT m a -> t m a)]+#else+    let parallelCommonOps :: [(String, ParallelT m a -> t m a)]+#endif+        parallelCommonOps = []+#ifndef COVERAGE_BUILD+            <> [("rate AvgRate 0.00000001", fromParallel . avgRate 0.00000001)]+            <> [("maxBuffer (-1)", fromParallel . maxBuffer (-1))]+#endif++    let parallelConcurrentAppOps :: IsStream t+            => ((ParallelT IO a -> t IO a) -> Spec) -> Spec+        parallelConcurrentAppOps spec =+            mapOps spec $ makeConcurrentAppOps fromParallel <> parallelCommonOps++    -- These tests won't work with maxBuffer or maxThreads set to 1, so we+    -- exclude those cases from these.+#ifndef COVERAGE_BUILD+    let mkOps :: IsStream t => (t m a -> c) -> [(String, t m a -> c)]+#else+    let mkOps :: t -> [(String, t)]+    -- let mkOps :: (t m a -> c) -> [(String, t m a -> c)]+#endif+        mkOps t =+            [ ("default", t)+#ifndef COVERAGE_BUILD+            , ("rate Nothing", t . rate Nothing)+            , ("maxBuffer 0", t . maxBuffer 0)+            , ("maxThreads 0", t . maxThreads 0)+            , ("maxThreads 0", t . maxThreads (-1))+#endif+            ]++    let forOps ops spec = forM_ ops (\(desc, f) -> describe desc $ spec f)+    describe "Stream concurrent operations" $ do+        forOps (mkOps fromAhead)   $ concurrentOps S.fromFoldable "aheadly" (==)+        forOps (mkOps fromAsync)   $ concurrentOps S.fromFoldable "asyncly" sortEq+        forOps (mkOps fromWAsync)  $ concurrentOps S.fromFoldable "wAsyncly" sortEq+        forOps (mkOps fromParallel) $ concurrentOps S.fromFoldable "parallely" sortEq++        forOps (mkOps fromAhead)   $ concurrentOps folded "aheadly folded" (==)+        forOps (mkOps fromAsync)   $ concurrentOps folded "asyncly folded" sortEq+        forOps (mkOps fromWAsync)  $ concurrentOps folded "wAsyncly folded" sortEq+        forOps (mkOps fromParallel) $ concurrentOps folded "parallely folded" sortEq++    describe "Concurrent application" $ do+        serialOps $ prop "serial" . concurrentApplication (==)+        asyncOps  $ prop "async" . concurrentApplication sortEq+        aheadOps  $ prop "ahead" . concurrentApplication (==)++        parallelConcurrentAppOps $+            prop "parallel" . concurrentApplication sortEq++        prop "concurrent foldr application" $ withMaxSuccess maxTestCount+            concurrentFoldrApplication+        prop "concurrent foldl application" $ withMaxSuccess maxTestCount+            concurrentFoldlApplication++    describe "take on infinite concurrent stream" $ takeInfinite fromAsync+    describe "take on infinite concurrent stream" $ takeInfinite fromWAsync+    describe "take on infinite concurrent stream" $ takeInfinite fromAhead++    ---------------------------------------------------------------------------+    -- Monadic state transfer in concurrent tasks+    ---------------------------------------------------------------------------++    describe "Monadic state transfer in concurrent tasks" $ do+        -- XXX Can we write better test cases to hit every case?+        it "async: state is saved and used if the work is partially enqueued"+            (checkMonadicStateTransfer async)+        it "wAsync: state is saved and used if the work is partially enqueued"+            (checkMonadicStateTransfer wAsync)+        it "ahead: state is saved and used if the work is partially enqueued"+            (checkMonadicStateTransfer ahead)++    ---------------------------------------------------------------------------+    -- Monadic state snapshot in concurrent tasks+    ---------------------------------------------------------------------------++    describe "Monadic state snapshot in concurrent tasks" $ do+        it "asyncly maintains independent states in concurrent tasks"+            (monadicStateSnapshot fromAsync)+        it "asyncly limited maintains independent states in concurrent tasks"+            (monadicStateSnapshot (fromAsync . S.take 10000))++        it "wAsyncly maintains independent states in concurrent tasks"+            (monadicStateSnapshot fromWAsync)+        it "wAsyncly limited maintains independent states in concurrent tasks"+            (monadicStateSnapshot (fromWAsync . S.take 10000))++        it "aheadly maintains independent states in concurrent tasks"+            (monadicStateSnapshot fromAhead)+        it "aheadly limited maintains independent states in concurrent tasks"+            (monadicStateSnapshot (fromAhead . S.take 10000))+        it "parallely maintains independent states in concurrent tasks"+            (monadicStateSnapshot fromParallel)+++        it "async maintains independent states in concurrent tasks"+            (monadicStateSnapshotOp async)+        it "ahead maintains independent states in concurrent tasks"+            (monadicStateSnapshotOp ahead)+        it "wAsync maintains independent states in concurrent tasks"+            (monadicStateSnapshotOp wAsync)+        it "parallel maintains independent states in concurrent tasks"+            (monadicStateSnapshotOp S.parallel)++    ---------------------------------------------------------------------------+    -- Slower tests are at the end+    ---------------------------------------------------------------------------++    ---------------------------------------------------------------------------+    -- Thread limits+    ---------------------------------------------------------------------------++    it "asyncly crosses thread limit (2000 threads)" $+        S.drain (fromAsync $ fold $+                   replicate 2000 $ S.fromEffect $ threadDelay 1000000)+        `shouldReturn` ()++    it "aheadly crosses thread limit (4000 threads)" $+        S.drain (fromAhead $ fold $+                   replicate 4000 $ S.fromEffect $ threadDelay 1000000)+        `shouldReturn` ()++#ifdef DEVBUILD+    describe "restricts concurrency and cleans up extra tasks" $ do+        it "take 1 asyncly" $ checkCleanup 2 fromAsync (S.take 1)+        it "take 1 wAsyncly" $ checkCleanup 2 fromWAsync (S.take 1)+        it "take 1 aheadly" $ checkCleanup 2 fromAhead (S.take 1)++        it "takeWhile (< 0) asyncly" $ checkCleanup 2 fromAsync (S.takeWhile (< 0))+        it "takeWhile (< 0) wAsyncly" $ checkCleanup 2 fromWAsync (S.takeWhile (< 0))+        it "takeWhile (< 0) aheadly" $ checkCleanup 2 fromAhead (S.takeWhile (< 0))+#endif
+ test/Streamly/Test/Prelude/Fold.hs view
@@ -0,0 +1,190 @@+-- |+-- Module      : Streamly.Test.Prelude.Fold+-- Copyright   : (c) 2020 Composewell Technologies+--+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Test.Prelude.Fold where++#ifdef DEVBUILD+import Control.Concurrent (threadDelay)+#endif+import Control.Exception (ErrorCall(..), catch)+import Data.IORef ( newIORef, readIORef, writeIORef, IORef )+#ifdef COVERAGE_BUILD+import Test.Hspec.QuickCheck (modifyMaxSuccess)+#endif+import Test.Hspec as H+#ifdef DEVBUILD+import System.Mem (performMajorGC)+#endif++import qualified Streamly.Internal.Data.Stream.IsStream as IS+import qualified Streamly.Prelude as S++import Streamly.Prelude (SerialT)+#ifdef DEVBUILD+import Streamly.Prelude (IsStream)+#endif++#ifdef DEVBUILD+checkFoldxStrictness :: IO ()+checkFoldxStrictness = do+  let s = return (1 :: Int) `S.consM` error "failure"+  catch (S.foldx (\_ a -> if a == 1 then error "success" else "done")+                      "begin" id s)+    (\(ErrorCall err) -> return err)+    `shouldReturn` "success"++checkScanxStrictness :: IO ()+checkScanxStrictness = do+  let s = return (1 :: Int) `S.consM` error "failure"+  catch+    (S.drain (+        S.scanx (\_ a ->+                    if a == 1+                    then error "success"+                    else "done")+                "begin" id s+        )+        >> return "finished"+    )+    (\(ErrorCall err) -> return err)+    `shouldReturn` "success"++foldxMStrictCheck :: IORef Int -> SerialT IO Int -> IO ()+foldxMStrictCheck ref = S.foldxM (\_ _ -> writeIORef ref 1) (return ()) return++checkCleanupFold :: IsStream t+    => (t IO Int -> SerialT IO Int)+    -> (SerialT IO Int -> IO (Maybe Int))+    -> IO ()+checkCleanupFold t op = do+    r <- newIORef (-1 :: Int)+    _ <- op $ t $ delay r 0 S.|: delay r 2 S.|: delay r 3 S.|: S.nil+    performMajorGC+    threadDelay 700000+    res <- readIORef r+    res `shouldBe` 0+    where+    delay ref i = threadDelay (i*200000) >> writeIORef ref i >> return i++testFoldOpsCleanup :: String -> (SerialT IO Int -> IO a) -> Spec+testFoldOpsCleanup name f = do+    let testOp op x = op x >> return Nothing+    it (name <> " asyncly") $ checkCleanupFold S.fromAsync (testOp f)+    it (name <> " wAsyncly") $ checkCleanupFold S.fromWAsync (testOp f)+    it (name <> " aheadly") $ checkCleanupFold S.fromAhead (testOp f)+    it (name <> " parallely") $ checkCleanupFold S.fromParallel (testOp f)+#endif++checkFoldMStrictness :: (IORef Int -> SerialT IO Int -> IO ()) -> IO ()+checkFoldMStrictness f = do+  ref <- newIORef 0+  let s = return 1 `S.consM` error "x"+  catch (f ref s) (\(_ :: ErrorCall) -> return ())+  readIORef ref `shouldReturn` 1++checkFoldl'Strictness :: IO ()+checkFoldl'Strictness = do+  let s = return (1 :: Int) `S.consM` error "failure"+  catch (S.foldl' (\_ a -> if a == 1 then error "success" else "done")+                      "begin" s)+    (\(ErrorCall err) -> return err)+    `shouldReturn` "success"++checkScanl'Strictness :: IO ()+checkScanl'Strictness = do+    let s = return (1 :: Int) `S.consM` error "failure"+    catch+        (S.drain+             (S.scanl'+                  (\_ a ->+                       if a == 1+                           then error "success"+                           else "done")+                  "begin"+                  s)+             >> return "finished"+        )+        (\(ErrorCall err) -> return err)+        `shouldReturn` "success"++foldlM'StrictCheck :: IORef Int -> SerialT IO Int -> IO ()+foldlM'StrictCheck ref = S.foldlM' (\_ _ -> writeIORef ref 1) (return ())++scanlM'StrictCheck :: IORef Int -> SerialT IO Int -> SerialT IO ()+scanlM'StrictCheck ref = S.scanlM' (\_ _ -> writeIORef ref 1) (return ())++checkScanlMStrictness :: (IORef Int -> SerialT IO Int -> SerialT IO ()) -> IO ()+checkScanlMStrictness f = do+  ref <- newIORef 0+  let s = return 1 `S.consM` error "x"+  catch (S.drain $ f ref s) (\(_ :: ErrorCall) -> return ())+  readIORef ref `shouldReturn` 1++checkFoldrLaziness :: IO ()+checkFoldrLaziness = do+    S.foldrM (\x xs -> if odd x then return True else xs)+             (return False) (S.fromList (2:4:5:undefined :: [Int]))+        `shouldReturn` True++    S.toList (IS.foldrS (\x xs -> if odd x then return True else xs)+                        (return False)+                        $ (S.fromList (2:4:5:undefined) :: SerialT IO Int))+        `shouldReturn` [True]++    S.toList (IS.foldrT (\x xs -> if odd x then return True else xs)+                        (return False)+                        $ (S.fromList (2:4:5:undefined) :: SerialT IO Int))+        `shouldReturn` [True]++moduleName :: String+moduleName = "Prelude.Fold"++main :: IO ()+main = hspec+  $ H.parallel+#ifdef COVERAGE_BUILD+  $ modifyMaxSuccess (const 10)+#endif+  $ describe moduleName $ do++    ---------------------------------------------------------------------------+    -- Left folds are strict enough+    ---------------------------------------------------------------------------++#ifdef DEVBUILD+    it "foldx is strict enough" checkFoldxStrictness+    it "scanx is strict enough" checkScanxStrictness+    it "foldxM is strict enough" (checkFoldMStrictness foldxMStrictCheck)+#endif+    it "foldl' is strict enough" checkFoldl'Strictness+    it "scanl' is strict enough" checkScanl'Strictness+    it "foldlM' is strict enough" (checkFoldMStrictness foldlM'StrictCheck)+    it "scanlM' is strict enough" (checkScanlMStrictness scanlM'StrictCheck)++    ---------------------------------------------------------------------------+    -- Right folds are lazy enough+    ---------------------------------------------------------------------------++    it "foldrM is lazy enough" checkFoldrLaziness++#ifdef DEVBUILD+    testFoldOpsCleanup "head" S.head+    testFoldOpsCleanup "null" S.null+    testFoldOpsCleanup "elem" (S.elem 0)+    testFoldOpsCleanup "notElem" (S.notElem 0)+    testFoldOpsCleanup "elemIndex" (S.elemIndex 0)+    -- S.lookup+    testFoldOpsCleanup "notElem" (S.notElem 0)+    testFoldOpsCleanup "find" (S.find (==0))+    testFoldOpsCleanup "findIndex" (S.findIndex (==0))+    testFoldOpsCleanup "all" (S.all (==1))+    testFoldOpsCleanup "any" (S.any (==0))+    testFoldOpsCleanup "and" (S.and . S.map (==1))+    testFoldOpsCleanup "or" (S.or . S.map (==0))+#endif
+ test/Streamly/Test/Prelude/Parallel.hs view
@@ -0,0 +1,122 @@+-- |+-- Module      : Streamly.Test.Prelude.Parallel+-- Copyright   : (c) 2020 Composewell Technologies+--+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Test.Prelude.Parallel where++import Data.List (sort)+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup ((<>))+#endif+import Test.Hspec.QuickCheck+import Test.Hspec as H++import Streamly.Prelude+import qualified Streamly.Prelude as S++import Streamly.Test.Prelude.Common++moduleName :: String+moduleName = "Prelude.Parallel"++main :: IO ()+main = hspec+  $ H.parallel+#ifdef COVERAGE_BUILD+  $ modifyMaxSuccess (const 10)+#endif+  $ describe moduleName $ do+    let+#ifndef COVERAGE_BUILD+        parallelCommonOps :: IsStream t => [(String, ParallelT m a -> t m a)]+#endif+        parallelCommonOps = []+#ifndef COVERAGE_BUILD+            <> [("rate AvgRate 0.00000001", fromParallel . avgRate 0.00000001)]+            <> [("maxBuffer (-1)", fromParallel . maxBuffer (-1))]+#endif+    let parallelOps :: IsStream t+            => ((ParallelT IO a -> t IO a) -> Spec) -> Spec+        parallelOps spec = mapOps spec $ makeOps fromParallel <> parallelCommonOps++    describe "Construction" $ do+        parallelOps $ prop "parallely replicateM" . constructWithReplicateM+        parallelOps $ prop "parallely cons" . constructWithCons S.cons+--      parallelOps $ prop "parallely consM" . constructWithConsM S.consM sort+        parallelOps $ prop "parallely (.:)" . constructWithCons (S..:)+--      parallelOps $ prop "parallely (|:)" . constructWithConsM (S.|:) sort++    describe "Functor operations" $ do+        parallelOps $ functorOps S.fromFoldable "parallely" sortEq+        parallelOps $ functorOps folded "parallely folded" sortEq++    describe "Monoid operations" $ do+        parallelOps $ monoidOps "parallely" mempty sortEq++    describe "Parallel loops" $ loops fromParallel sort sort++    describe "Bind and Monoidal composition combinations" $ do+        -- XXX Taking a long time when parallelOps is used.+        bindAndComposeSimpleOps "Parallel" sortEq fromParallel+        bindAndComposeHierarchyOps "Parallel" fromParallel+        parallelOps $ nestTwoStreams "Parallel" sort sort+        parallelOps $ nestTwoStreamsApp "Parallel" sort sort++    describe "Semigroup operations" $ do+        parallelOps $ semigroupOps "parallely" sortEq++    describe "Applicative operations" $ do+        parallelOps $ applicativeOps folded "parallely applicative folded" sortEq++    -- XXX add tests for indexed/indexedR+    describe "Zip operations" $ do+        -- We test only the serial zip with serial streams and the parallel+        -- stream, because the rate setting in these streams can slow down+        -- zipAsync.+        parallelOps $ prop "zip monadic parallely" . zipMonadic S.fromFoldable (==)+        parallelOps $ prop "zip monadic parallely folded" . zipMonadic folded (==)++    -- XXX add merge tests like zip tests+    -- for mergeBy, we can split a list randomly into two lists and+    -- then merge them, it should result in original list+    -- describe "Merge operations" $ do++    describe "Monad operations" $ do+        parallelOps $ prop "parallely monad then" . monadThen S.fromFoldable sortEq+        parallelOps $ prop "parallely monad then folded" . monadThen folded sortEq+        parallelOps $ prop "parallely monad bind" . monadBind S.fromFoldable sortEq+        parallelOps $ prop "parallely monad bind folded" . monadBind folded sortEq++    describe "Stream transform and combine operations" $ do+        parallelOps $ transformCombineOpsCommon S.fromFoldable "parallely" sortEq+        parallelOps $ transformCombineOpsCommon folded "parallely" sortEq++    describe "Stream elimination operations" $ do+        parallelOps $ eliminationOps S.fromFoldable "parallely"+        parallelOps $ eliminationOps folded "parallely folded"+        parallelOps $ eliminationOpsWord8 S.fromFoldable "parallely"+        parallelOps $ eliminationOpsWord8 folded "parallely folded"++    -- test both (<>) and mappend to make sure we are using correct instance+    -- for Monoid that is using the right version of semigroup. Instance+    -- deriving can cause us to pick wrong instances sometimes.++#ifdef DEVBUILD+    describe "Parallel (<>) time order check" $ parallelCheck fromParallel (<>)+    describe "Parallel mappend time order check" $ parallelCheck fromParallel mappend+#endif++    describe "Tests for exceptions" $ parallelOps $ exceptionOps "parallely"+    describe "Composed MonadThrow parallely" $ composeWithMonadThrow fromParallel++#ifdef DEVBUILD+    -- fromParallel fails on CI machines, may need more difference in times of+    -- the events, but that would make tests even slower.+    it "take 1 parallely" $ checkCleanup 3 fromParallel (S.take 1)+    it "takeWhile (< 0) parallely" $ checkCleanup 3 fromParallel (S.takeWhile (< 0))+#endif
+ test/Streamly/Test/Prelude/Rate.hs view
@@ -0,0 +1,244 @@+-- |+-- Module      : Streamly.Test.Prelude.MaxRate+-- Copyright   : (c) 2018 Composewell Technologies+--+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Test.Prelude.Rate where++import qualified Streamly.Prelude as S++import Streamly.Prelude+    ( fromAhead, fromAsync, fromWAsync, avgRate, maxBuffer, maxThreads, rate,+      SerialT, IsStream )+import Streamly.Internal.Data.Time.Clock (getTime, Clock(..))+import Streamly.Internal.Data.Time.Units+    (NanoSecond64, diffAbsTime64, fromRelTime64)++import Control.Concurrent+import Control.Monad+import System.Random+import Test.Hspec++durationShouldBe :: (Double, Double) -> IO () -> Expectation+durationShouldBe d@(tMin, tMax) action = do+        t0 <- getTime Monotonic+        action+        t1 <- getTime Monotonic+        let diff = fromRelTime64 (diffAbsTime64 t1 t0) :: NanoSecond64+        let t = fromIntegral diff / 1e9+        putStrLn $ "Expected: " <> show d <> " Took: " <> show t+        (t <= tMax && t >= tMin) `shouldBe` True++toMicroSecs :: Num a => a -> a+toMicroSecs x = x * 10^(6 :: Int)++measureRate' :: IsStream t+    => String+    -> (t IO Int -> SerialT IO Int)+    -> Int -- buffers+    -> Int -- threads+    -> Either Double Int  -- either rate or count of actions+    -> Int+    -> (Double, Double)+    -> (Double, Double)+    -> Spec+measureRate' desc t buffers threads rval consumerDelay producerDelay expectedRange = do++    let threadAction =+            case rval of+                Left r -> S.take (round $ 10 * r) . S.repeatM+                Right n -> S.replicateM n++        rateDesc = case rval of+            Left r ->  " rate: " <> show r+            Right n -> " count: " <> show n++    it (desc <> rateDesc+             <> " buffers: " <> show buffers+             <> " threads: " <> show threads+             <> ", consumer latency: " <> show consumerDelay+             <> ", producer latency: " <> show producerDelay)+        $ durationShouldBe expectedRange $+            S.drain+                $ (if consumerDelay > 0+                  then S.mapM $ \x ->+                            threadDelay (toMicroSecs consumerDelay) >> return x+                  else id)+                $ t+                $ maxBuffer  buffers+                $ maxThreads threads+                $ (case rval of {Left r -> avgRate r; Right _ -> rate Nothing})+                $ threadAction $ do+                    let (t1, t2) = producerDelay+                    r <- if t1 == t2+                         then return $ round $ toMicroSecs t1+                         else randomRIO ( round $ toMicroSecs t1+                                        , round $ toMicroSecs t2)+                    when (r > 0) $ -- do+                        -- t1 <- getTime Monotonic+                        threadDelay r+                        -- t2 <- getTime Monotonic+                        -- let delta = fromIntegral (toNanoSecs (t2 - t1)) / 1000000000+                        -- putStrLn $ "delay took: " <> show delta+                        -- when (delta > 2) $ do+                        --     putStrLn $ "delay took high: " <> show delta+                    return 1++measureRateVariable :: IsStream t+    => String+    -> (t IO Int -> SerialT IO Int)+    -> Double+    -> Int+    -> (Double, Double)+    -> (Double, Double)+    -> Spec+measureRateVariable desc t rval consumerDelay producerDelay dur =+    measureRate' desc t (-1) (-1) (Left rval)+                 consumerDelay producerDelay dur++measureRate :: IsStream t+    => String+    -> (t IO Int -> SerialT IO Int)+    -> Double+    -> Int+    -> Int+    -> (Double, Double)+    -> Spec+measureRate desc t rval consumerDelay producerDelay dur =+    let d = fromIntegral producerDelay+    in measureRateVariable desc t rval consumerDelay (d, d) dur++measureThreads :: IsStream t+    => String+    -> (t IO Int -> SerialT IO Int)+    -> Int -- threads+    -> Int -- count of actions+    -> Spec+measureThreads desc t threads count = do+    let expectedTime =+            if threads < 0+            then 1.0+            else fromIntegral count / fromIntegral threads+        duration = (expectedTime * 0.9, expectedTime * 1.1)+    measureRate' desc t (-1) threads (Right count) 0 (1,1) duration++measureBuffers :: IsStream t+    => String+    -> (t IO Int -> SerialT IO Int)+    -> Int -- buffers+    -> Int -- count of actions+    -> Spec+measureBuffers desc t buffers count = do+    let expectedTime =+            if buffers < 0+            then 1.0+            else fromIntegral count / fromIntegral buffers+        duration = (expectedTime * 0.9, expectedTime * 1.1)+    measureRate' desc t buffers (-1) (Right count) 0 (1,1) duration++moduleName :: String+moduleName = "Prelude.Rate"++main :: IO ()+main = hspec $ do+  describe moduleName $ do++    describe "maxBuffers" $ do+        measureBuffers "asyncly" fromAsync (-1) 5+        -- XXX this test fails due to a known issue+        -- measureBuffers "maxBuffers" fromAsync 1 5+        measureBuffers "asyncly" fromAsync 5 5++    describe "maxThreads" $ do+        measureThreads "asyncly" fromAsync (-1) 5+        measureThreads "asyncly" fromAsync 1 5+        measureThreads "asyncly" fromAsync 5 5++        measureThreads "aheadly" fromAhead (-1) 5+        measureThreads "aheadly" fromAhead 1 5+        measureThreads "aheadly" fromAhead 5 5++    let range = (8,12)++    -- Note that because after the last yield we don't wait, the last period+    -- will be effectively shorter. This becomes significant when the rates are+    -- lower (1 or lower). For rate 1 we lose 1 second in the end and for rate+    -- 10 0.1 second.+    let rates = [1, 10, 100, 1000, 10000+#ifndef __GHCJS__+                , 100000, 1000000+#endif+                ]+     in describe "asyncly no consumer delay no producer delay" $+            forM_ rates (\r -> measureRate "asyncly" fromAsync r 0 0 range)++    -- XXX try staggering the dispatches to achieve higher rates+    let rates = [1, 10, 100, 1000+#ifndef __GHCJS__+                , 10000, 25000+#endif+                ]+     in describe "asyncly no consumer delay and 1 sec producer delay" $+            forM_ rates (\r -> measureRate "asyncly" fromAsync r 0 1 range)++    -- At lower rates (1/10) this is likely to vary quite a bit depending on+    -- the spread of random producer latencies generated.+    let rates = [1, 10, 100, 1000+#ifndef __GHCJS__+                , 10000, 25000+#endif+                ]+     in describe "asyncly no consumer delay and variable producer delay" $+            forM_ rates $ \r ->+                measureRateVariable "asyncly" fromAsync r 0 (0.1, 3) range++    let rates = [1, 10, 100, 1000, 10000+#ifndef __GHCJS__+                , 100000, 1000000+#endif+                ]+     in describe "fromWAsync no consumer delay no producer delay" $+            forM_ rates (\r -> measureRate "fromWAsync" fromWAsync r 0 0 range)++    let rates = [1, 10, 100, 1000+#ifndef __GHCJS__+                , 10000, 25000+#endif+                ]+     in describe "fromWAsync no consumer delay and 1 sec producer delay" $+            forM_ rates (\r -> measureRate "fromWAsync" fromWAsync r 0 1 range)++    let rates = [1, 10, 100, 1000, 10000+#ifndef __GHCJS__+                , 100000, 1000000+#endif+                ]+     in describe "aheadly no consumer delay no producer delay" $+            forM_ rates (\r -> measureRate "aheadly" fromAhead r 0 0 range)++    -- XXX after the change to stop workers when the heap is clearing+    -- thi does not work well at a 25000 ops per second, need to fix.+    let rates = [1, 10, 100, 1000+#ifndef __GHCJS__+                , 10000, 12500+#endif+                ]+     in describe "aheadly no consumer delay and 1 sec producer delay" $+            forM_ rates (\r -> measureRate "aheadly" fromAhead r 0 1 range)++    describe "asyncly with 1 sec producer delay and some consumer delay" $ do+        -- ideally it should take 10 x 1 + 1 seconds+        forM_ [1] (\r -> measureRate "asyncly" fromAsync r 1 1 (11, 16))+        -- ideally it should take 10 x 2 + 1 seconds+        forM_ [1] (\r -> measureRate "asyncly" fromAsync r 2 1 (21, 23))+        -- ideally it should take 10 x 3 + 1 seconds+        forM_ [1] (\r -> measureRate "asyncly" fromAsync r 3 1 (31, 33))++    describe "aheadly with 1 sec producer delay and some consumer delay" $ do+        forM_ [1] (\r -> measureRate "aheadly" fromAhead r 1 1 (11, 16))+        forM_ [1] (\r -> measureRate "aheadly" fromAhead r 2 1 (21, 23))+        forM_ [1] (\r -> measureRate "aheadly" fromAhead r 3 1 (31, 33))
+ test/Streamly/Test/Prelude/Serial.hs view
@@ -0,0 +1,676 @@+-- |+-- Module      : Streamly.Test.Prelude.Serial+-- Copyright   : (c) 2020 Composewell Technologies+--+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Test.Prelude.Serial where++import Control.Concurrent ( threadDelay )+import Control.Monad ( when, forM_ )+import Data.Function ( (&) )+import Data.IORef ( newIORef, readIORef, writeIORef, modifyIORef' )+import Data.Int (Int64)+import Data.List (group, intercalate)+import Data.Maybe ( isJust, fromJust )+import Foreign.Storable (Storable)+#if __GLASGOW_HASKELL__ < 808+import Data.Semigroup ((<>))+#endif+import Data.Semigroup (Sum(..), getSum)+import Test.Hspec.QuickCheck+import Test.QuickCheck+    ( Gen+    , Property+    , Arbitrary(..)+    , choose+    , elements+    , forAll+    , frequency+    , listOf+    , listOf1+    , suchThat+    , vectorOf+    , withMaxSuccess+    )+import Test.QuickCheck.Monadic (assert, monadicIO, pick, run)+import Test.Hspec as H++import Streamly.Prelude (SerialT, IsStream, serial, fromSerial)+#ifndef COVERAGE_BUILD+import Streamly.Prelude (avgRate, maxBuffer)+#endif+import qualified Streamly.Prelude as S+import qualified Streamly.Internal.Data.Fold as FL+import qualified Streamly.Internal.Data.Unfold as UF+import qualified Streamly.Internal.Data.Stream.IsStream as IS+import qualified Streamly.Data.Array.Foreign as A++import Streamly.Internal.Data.Time.Units+       (AbsTime, NanoSecond64(..), toRelTime64, diffAbsTime64)++#ifdef DEVBUILD+import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime)+#endif++import Streamly.Test.Common+import Streamly.Test.Prelude.Common++splitOnSeq :: Spec+splitOnSeq = do+    describe "Tests for splitOnSeq" $ do+        it "splitOnSeq' \"hello\" \"\" = [\"\"]"+          $ splitOnSeq' "hello" "" `shouldReturn` [""]+        it "splitOnSeq' \"hello\" \"hello\" = [\"\", \"\"]"+          $ splitOnSeq' "hello" "hello" `shouldReturn` ["", ""]+        it "splitOnSeq' \"x\" \"hello\" = [\"hello\"]"+          $ splitOnSeq' "x" "hello" `shouldReturn` ["hello"]+        it "splitOnSeq' \"h\" \"hello\" = [\"\", \"ello\"]"+          $ splitOnSeq' "h" "hello" `shouldReturn` ["", "ello"]+        it "splitOnSeq' \"o\" \"hello\" = [\"hell\", \"\"]"+          $ splitOnSeq' "o" "hello" `shouldReturn` ["hell", ""]+        it "splitOnSeq' \"e\" \"hello\" = [\"h\", \"llo\"]"+          $ splitOnSeq' "e" "hello" `shouldReturn` ["h", "llo"]+        it "splitOnSeq' \"l\" \"hello\" = [\"he\", \"\", \"o\"]"+          $ splitOnSeq' "l" "hello" `shouldReturn` ["he", "", "o"]+        it "splitOnSeq' \"ll\" \"hello\" = [\"he\", \"o\"]"+          $ splitOnSeq' "ll" "hello" `shouldReturn` ["he", "o"]++    where++    splitOnSeq' pat xs =+        S.toList $ IS.splitOnSeq (A.fromList pat) FL.toList (S.fromList xs)++splitOnSuffixSeq :: Spec+splitOnSuffixSeq = do+    describe "Tests for splitOnSuffixSeq" $ do+        it "splitSuffixOn_ \".\" \"\" []"+          $ splitSuffixOn_ "." "" `shouldReturn` []+        it "splitSuffixOn_ \".\" \".\" [\"\"]"+          $ splitSuffixOn_ "." "." `shouldReturn` [""]+        it "splitSuffixOn_ \".\" \"a\" [\"a\"]"+          $ splitSuffixOn_ "." "a" `shouldReturn` ["a"]+        it "splitSuffixOn_ \".\" \".a\" [\"\",\"a\"]"+          $ splitSuffixOn_ "." ".a" `shouldReturn` ["", "a"]+        it "splitSuffixOn_ \".\" \"a.\" [\"a\"]"+          $ splitSuffixOn_ "." "a." `shouldReturn` ["a"]+        it "splitSuffixOn_ \".\" \"a.b\" [\"a\",\"b\"]"+          $ splitSuffixOn_ "." "a.b" `shouldReturn` ["a", "b"]+        it "splitSuffixOn_ \".\" \"a.b.\" [\"a\",\"b\"]"+          $ splitSuffixOn_ "." "a.b." `shouldReturn` ["a", "b"]+        it "splitSuffixOn_ \".\" \"a..b..\" [\"a\",\"\",\"b\",\"\"]"+          $ splitSuffixOn_ "." "a..b.." `shouldReturn` ["a", "", "b", ""]++    where++    splitSuffixOn_ pat xs =+        S.toList+             $ IS.splitOnSuffixSeq (A.fromList pat) FL.toList (S.fromList xs)++splitterProperties ::+       forall a. (Arbitrary a, Eq a, Show a, Storable a, Enum a)+    => a+    -> String+    -> Spec+splitterProperties sep desc = do+    describe (desc <> " splitOnSeq")+        $ do++            forM_ [0, 1, 2, 4]+                $ intercalateSplitEqId splitOnSeq_ intercalate IS.intercalate++            forM_ [0, 1, 2, 4]+                $ concatSplitIntercalateEqConcat+                      splitOnSeq_+                      intercalate+                      IS.intercalate++            -- Exclusive case+            splitIntercalateEqId splitOnSeq_ intercalate IS.intercalate++    describe (desc <> " splitOn")+        $ do++            intercalateSplitEqId splitOn_ intercalate IS.intercalate 1++            concatSplitIntercalateEqConcat+                splitOn_ intercalate IS.intercalate 1++            -- Exclusive case+            splitIntercalateEqId splitOn_ intercalate IS.intercalate++    describe (desc <> " splitOnSuffixSeq")+        $ do++            forM_ [0, 1, 2, 4]+                $ intercalateSplitEqIdNoSepEnd+                      splitOnSuffixSeq_+                      intercalate+                      IS.intercalate++            forM_ [0, 1, 2, 4]+                $ concatSplitIntercalateEqConcat+                      splitOnSuffixSeq_+                      intercalateSuffix+                      IS.intercalateSuffix++            -- Exclusive case+            splitIntercalateEqId+                splitOnSuffixSeq_+                intercalateSuffix+                IS.intercalateSuffix++    describe (desc <> " splitOnSuffix")+        $ do++            intercalateSplitEqIdNoSepEnd+                splitOnSuffix_ intercalate IS.intercalate 1++            concatSplitIntercalateEqConcat+                splitOnSuffix_ intercalateSuffix IS.intercalateSuffix 1++            -- Exclusive case+            splitIntercalateEqId+                splitOnSuffix_ intercalateSuffix IS.intercalateSuffix++    where++    splitOnSeq_ xs ys =+        S.toList $ IS.splitOnSeq (A.fromList ys) FL.toList (S.fromList xs)++    splitOnSuffixSeq_ xs ys =+        S.toList $ IS.splitOnSuffixSeq (A.fromList ys) FL.toList (S.fromList xs)++    splitOn_ xs ys =+        S.toList $ IS.splitOn (== (head ys)) FL.toList (S.fromList xs)++    splitOnSuffix_ xs ys =+        S.toList $ IS.splitOnSuffix (== (head ys)) FL.toList (S.fromList xs)++    intercalateSuffix xs yss = intercalate xs yss ++ xs++    nonSepElem :: Gen a+    nonSepElem = suchThat arbitrary (/= sep)++    listWithSep :: Gen [a]+    listWithSep = listOf $ frequency [(3, arbitrary), (1, elements [sep])]++    listWithoutSep :: Gen [a]+    listWithoutSep = vectorOf 4 nonSepElem++    listsWithoutSep :: Gen [[a]]+    listsWithoutSep = listOf listWithoutSep++    listsWithoutSep1 :: Gen [[a]]+    listsWithoutSep1 = listOf1 listWithoutSep++    intercalateSplitEqId splitter lIntercalater sIntercalater i =+        let name =+                "intercalater . splitter == id ("+                    <> show i <> " element separator)"+         in prop name+                $ forAll listWithSep+                $ \xs -> withMaxSuccess maxTestCount $ monadicIO $ testCase xs++        where++        testCase xs = do+            ys <- splitter xs (replicate i sep)+            szs <-+                IS.toList+                    $ sIntercalater UF.fromList (replicate i sep)+                    $ IS.fromList ys+            let lzs = lIntercalater (replicate i sep) ys+            listEquals (==) szs xs+            listEquals (==) lzs xs++    intercalateSplitEqIdNoSepEnd splitter lIntercalater sIntercalater i =+        let name =+                "intercalater . splitter . (++ [x \\= sep]) == id ("+                    <> show i <> " element separator)"+         in prop name+                $ forAll ((,) <$> listWithSep <*> nonSepElem)+                $ \(xs_, nonSep) -> do+                      let xs = xs_ ++ [nonSep]+                      withMaxSuccess maxTestCount $ monadicIO $ testCase xs++        where++        testCase xs = do+            ys <- splitter xs (replicate i sep)+            szs <-+                IS.toList+                    $ sIntercalater UF.fromList (replicate i sep)+                    $ IS.fromList ys+            let lzs = lIntercalater (replicate i sep) ys+            listEquals (==) szs xs+            listEquals (==) lzs xs++    concatSplitIntercalateEqConcat splitter lIntercalater sIntercalater i =+        let name =+                "concat . splitter . S.intercalater == "+                    <> "concat ("+                    <> show i <> " element separator/possibly empty list)"+         in prop name+                $ forAll listsWithoutSep+                $ \xss -> withMaxSuccess maxTestCount $ monadicIO $ testCase xss++        where++        testCase xss = do+            let lxs = lIntercalater (replicate i sep) xss+            lys <- splitter lxs (replicate i sep)+            sxs <-+                S.toList+                    $ sIntercalater UF.fromList (replicate i sep)+                    $ S.fromList xss+            sys <- splitter sxs (replicate i sep)+            listEquals (==) (concat lys) (concat xss)+            listEquals (==) (concat sys) (concat xss)++    splitIntercalateEqId splitter lIntercalater sIntercalater =+        let name =+                "splitter . intercalater == id"+                    <> " (exclusive separator/non-empty list)"+         in prop name+                $ forAll listsWithoutSep1+                $ \xss -> do+                      withMaxSuccess maxTestCount $ monadicIO $ testCase xss++        where++        testCase xss = do+            let lxs = lIntercalater [sep] xss+            lys <- splitter lxs [sep]+            sxs <- S.toList $ sIntercalater UF.fromList [sep] $ S.fromList xss+            sys <- splitter sxs [sep]+            listEquals (==) lys xss+            listEquals (==) sys xss+++groupSplitOps :: String -> Spec+groupSplitOps desc = do+    -- splitting+    splitOnSeq+    splitOnSuffixSeq++    -- splitting properties+    splitterProperties (0 :: Int) desc+    -- XXX This will fail+    -- splitterProperties (0 :: Word8) desc++    prop (desc <> " intercalate [x] . splitOn (== x) == id") $+        forAll listWithZeroes $ \xs -> do+            withMaxSuccess maxTestCount $+                monadicIO $ do+                    ys <- S.toList $ S.splitOn (== 0) toListFL (S.fromList xs)+                    listEquals (==) (intercalate [0] ys) xs++    where++    listWithZeroes :: Gen [Int]+    listWithZeroes = listOf $ frequency [(3, arbitrary), (1, elements [0])]++-- |+-- After grouping (and folding) Int stream using @>@ operation,+-- the first @Int@ of every @[Int]@ in the @[Int]@ stream should be the minimum.+testGroupsBy :: Property+testGroupsBy =+    forAll (choose (0, maxStreamLen)) $ \len ->+        forAll (vectorOf len (arbitrary :: Gen Int)) $ \vec -> monadicIO $ do+            r <- run $ S.all (\ls ->+                case ls of+                    [] -> True+                    (x:_) -> x == minimum ls)+                $ S.groupsBy (>) FL.toList+                $ S.fromList vec+            assert r++testGroups :: Property+testGroups =+    forAll (choose (0, maxStreamLen)) $ \len ->+        forAll (vectorOf len (arbitrary :: Gen Int)) $ \vec -> monadicIO $ do+            r <- run $ S.toList $ S.groups FL.toList $ S.fromList vec+            assert $ r == group vec++testGroupsByRolling :: Property+testGroupsByRolling =+    forAll (choose (0, maxStreamLen)) $ \len ->+        forAll (vectorOf len (arbitrary :: Gen Int)) $ \vec -> monadicIO $ do+            r <- run $ S.toList $ S.groupsByRolling (==) FL.toList $ S.fromList vec+            assert $ r == group vec++-- |+-- If the list is empty, returns Nothing,+-- else wraps the minimum value of the list in Just.+maybeMinimum :: [Int] -> Maybe Int+maybeMinimum [] = Nothing+maybeMinimum ls = Just $ minimum ls++-- |+-- Checks if the @[Int]@ is non-increasing.+decreasing :: [Maybe Int] -> Bool+decreasing [] = True+decreasing xs = all (== True) $ zipWith (<=) (tail xs) xs++-- |+-- To check if the minimum elements (after grouping on @>@)+-- are non-increasing (either decrease or remain the same).+-- Had an element been strictly greater, it would have been grouped+-- with that element only.+testGroupsBySep :: Property+testGroupsBySep =+    forAll (choose (0, maxStreamLen)) $ \len ->+        forAll (vectorOf len (arbitrary :: Gen Int)) $ \vec -> monadicIO $ do+            a <- run $ S.toList+                $ S.map maybeMinimum+                $ S.groupsBy (>) FL.toList+                $ S.fromList vec+            assert $ decreasing a++groupingOps :: Spec+groupingOps = do+    prop "groupsBy" testGroupsBy+    prop "S.groups = groups" testGroups+    prop "S.groupsByRolling = groups" testGroupsByRolling+    prop "testGroupsBySep" testGroupsBySep++associativityCheck+    :: String+    -> (SerialT IO Int -> SerialT IO Int)+    -> Spec+associativityCheck desc t = prop desc assocCheckProp+  where+    assocCheckProp :: [Int] -> [Int] -> [Int] -> Property+    assocCheckProp xs ys zs =+        monadicIO $ do+            let xStream = S.fromList xs+                yStream = S.fromList ys+                zStream = S.fromList zs+            infixAssocstream <-+                run $ S.toList $ t $ xStream `serial` yStream `serial` zStream+            assocStream <- run $ S.toList $ t $ xStream <> yStream <> zStream+            listEquals (==) infixAssocstream assocStream++max_length :: Int+max_length = 1000++tenPow8 :: Int64+tenPow8 = 10^(8 :: Int)++tenPow7 :: Int64+tenPow7 = 10^(7 :: Int)++takeDropTime :: NanoSecond64+takeDropTime = NanoSecond64 $ 5 * tenPow8++checkTakeDropTime :: (Maybe AbsTime, Maybe AbsTime) -> IO Bool+checkTakeDropTime (mt0, mt1) = do+    let graceTime = NanoSecond64 $ 8 * tenPow7+    case mt0 of+        Nothing -> return True+        Just t0 ->+            case mt1 of+                Nothing -> return True+                Just t1 -> do+                    let tMax = toRelTime64 (takeDropTime + graceTime)+                    let tMin = toRelTime64 (takeDropTime - graceTime)+                    let t = diffAbsTime64 t1 t0+                    let r = t >= tMin && t <= tMax+                    when (not r) $ putStrLn $+                        "t = " ++ show t +++                        " tMin = " ++ show tMin +++                        " tMax = " ++ show tMax+                    return r++#ifdef DEVBUILD+testTakeInterval :: IO Bool+testTakeInterval = do+    r <-+          S.fold (FL.tee FL.head FL.last)+        $ IS.takeInterval takeDropTime+        $ S.repeatM (threadDelay 1000 >> getTime Monotonic)+    checkTakeDropTime r++testDropInterval :: IO Bool+testDropInterval = do+    t0 <- getTime Monotonic+    mt1 <-+          S.head+        $ IS.dropInterval takeDropTime+        $ S.repeatM (threadDelay 1000 >> getTime Monotonic)+    checkTakeDropTime (Just t0, mt1)+#endif++unfold :: Property+unfold = monadicIO $ do+    a <- pick $ choose (0, max_length `div` 2)+    b <- pick $ choose (0, max_length)+    let unf = UF.enumerateFromToIntegral b+    ls <- S.toList $ S.unfold unf a+    return $ ls == [a..b]++unfold0 :: Property+unfold0 = monadicIO $ do+    a <- pick $ choose (0, max_length `div` 2)+    b <- pick $ choose (0, max_length)+    let unf = UF.supply a (UF.enumerateFromToIntegral b)+    ls <- S.toList $ IS.unfold0 unf+    return $ ls == [a..b]++testFromCallback :: IO Int+testFromCallback = do+    ref <- newIORef Nothing+    let stream = S.map Just (IS.fromCallback (setCallback ref))+                    `S.parallel` runCallback ref+    S.sum $ S.map fromJust $ S.takeWhile isJust stream++    where++    setCallback ref cb = do+        writeIORef ref (Just cb)++    runCallback ref = S.fromEffect $ do+        cb <-+              S.repeatM (readIORef ref)+                & IS.delayPost 0.1+                & S.mapMaybe id+                & S.head++        S.fromList [1..100]+            & IS.delayPost 0.001+            & S.mapM_ (fromJust cb)+        threadDelay 100000+        return Nothing++foldIterateM :: Property+foldIterateM =+    forAll (listOf (chooseInt (0, max_length))) $ \lst -> monadicIO $ do+        let s1 = Prelude.sum lst+            strm = S.fromList lst+        ms2 <-+            S.last+                $ S.map getSum+                $ IS.foldIterateM+                      (return . FL.take 1 . FL.sconcat)+                      (Sum 0)+                $ S.map Sum strm+        case ms2 of+            Nothing -> assert $ s1 == 0+            Just s2 -> assert $ s1 == s2++moduleName :: String+moduleName = "Prelude.Serial"++main :: IO ()+main = hspec+  $ H.parallel+#ifdef COVERAGE_BUILD+  $ modifyMaxSuccess (const 10)+#endif+  $ describe moduleName $ do+    let serialOps :: IsStream t => ((SerialT IO a -> t IO a) -> Spec) -> Spec+        serialOps spec = mapOps spec $ makeOps fromSerial+#ifndef COVERAGE_BUILD+            <> [("rate AvgRate 0.00000001", fromSerial . avgRate 0.00000001)]+            <> [("maxBuffer -1", fromSerial . maxBuffer (-1))]+#endif+    let toListSerial :: SerialT IO a -> IO [a]+        toListSerial = S.toList . fromSerial++    describe "Runners" $ do+        -- XXX use an IORef to store and check the side effects+        it "simple serially" $+            (S.drain . fromSerial) (return (0 :: Int)) `shouldReturn` ()+        it "simple serially with IO" $+            (S.drain . fromSerial) (S.fromEffect $ putStrLn "hello") `shouldReturn` ()++    describe "Empty" $+        it "Monoid - mempty" $+            toListSerial mempty `shouldReturn` ([] :: [Int])+        -- it "Alternative - empty" $+        --     (toListSerial empty) `shouldReturn` ([] :: [Int])+        -- it "MonadPlus - mzero" $+        --     (toListSerial mzero) `shouldReturn` ([] :: [Int])++    describe "Construction" $ do+        -- Add all the construction tests for all stream types.+        serialOps   $ prop "serially repeat" . constructWithRepeat+        serialOps   $ prop "serially repeatM" . constructWithRepeatM+        serialOps   $ prop "serially replicate" . constructWithReplicate+        serialOps   $ prop "serially replicateM" . constructWithReplicateM+        serialOps   $ prop "serially intFromThenTo" .+                            constructWithIntFromThenTo+#if __GLASGOW_HASKELL__ >= 806+        serialOps   $ prop "serially DoubleFromThenTo" .+                            constructWithDoubleFromThenTo+#endif+        serialOps   $ prop "serially iterate" . constructWithIterate+        -- XXX test for all types of streams+        serialOps   $ prop "serially iterateM" . constructWithIterateM+        serialOps $ prop "serially enumerate" . constructWithEnumerate id+        serialOps $ prop "serially enumerateTo" . constructWithEnumerateTo id+        serialOps $ prop "serially fromIndices" . constructWithFromIndices+        serialOps $ prop "serially fromIndicesM" . constructWithFromIndicesM+        serialOps $ prop "serially fromList" . constructWithFromList id+        serialOps $ prop "serially fromListM" . constructWithFromListM id+        serialOps $ prop "serially unfoldr" . constructWithUnfoldr id+        serialOps $ prop "serially fromPure" . constructWithFromPure id+        serialOps $ prop "serially fromEffect" . constructWithFromEffect id+        serialOps $ prop "serially cons" . constructWithCons S.cons+        serialOps $ prop "serially consM" . constructWithConsM S.consM id+        serialOps $ prop "serially (.:)" . constructWithCons (S..:)+        serialOps $ prop "serially (|:)" . constructWithConsM (S.|:) id++        describe "From Generators" $ do+            prop "unfold" unfold+            prop "unfold0" unfold0++    describe "Simple Operations" $ serialOps simpleOps++    describe "Functor operations" $ do+        serialOps    $ functorOps S.fromFoldable "serially" (==)+        serialOps    $ functorOps folded "serially folded" (==)++    describe "Monoid operations" $ do+        serialOps $ monoidOps "serially" mempty (==)++    describe "Serial loops" $ loops fromSerial id reverse++    describe "Bind and Monoidal composition combinations" $ do+        -- XXX Taking a long time when serialOps is used.+        bindAndComposeSimpleOps "Serial" sortEq fromSerial+        bindAndComposeHierarchyOps "Serial" fromSerial+        serialOps $ nestTwoStreams "Serial" id id+        serialOps $ nestTwoStreamsApp "Serial" id id+        composeAndComposeSimpleSerially "Serial <> " (repeat [1..9]) fromSerial+        composeAndComposeSimpleAheadly "Serial <> " (repeat [1 .. 9]) fromSerial+        composeAndComposeSimpleWSerially+            "Serial <> "+            [[1..9], [1..9], [1,3,2,4,6,5,7,9,8], [1,3,2,4,6,5,7,9,8]]+            fromSerial++    describe "Semigroup operations" $ do+        serialOps $ semigroupOps "serially" (==)+        serialOps $ associativityCheck "serial == <>"++    describe "Applicative operations" $ do+        -- The tests using sorted equality are weaker tests+        -- We need to have stronger unit tests for all those+        -- XXX applicative with three arguments+        serialOps $ applicativeOps S.fromFoldable "serially" (==)+        serialOps $ applicativeOps folded "serially folded" (==)+        serialOps $ applicativeOps1 S.fromFoldable "serially" (==)+        serialOps $ applicativeOps1 S.fromFoldable "serially folded" (==)++    -- XXX add tests for indexed/indexedR+    describe "Zip operations" $ do+        -- We test only the serial zip with serial streams and the parallel+        -- stream, because the rate setting in these streams can slow down+        -- zipAsync.+        serialOps   $ prop "zip monadic serially" . zipMonadic S.fromFoldable (==)+        serialOps   $ prop "zip monadic serially folded" . zipMonadic folded (==)++    -- XXX add merge tests like zip tests+    -- for mergeBy, we can split a list randomly into two lists and+    -- then merge them, it should result in original list+    -- describe "Merge operations" $ do++    describe "Monad operations" $ do+        serialOps   $ prop "serially monad then" . monadThen S.fromFoldable (==)+        serialOps   $ prop "serially monad then folded" . monadThen folded (==)+        serialOps   $ prop "serially monad bind" . monadBind S.fromFoldable (==)+        serialOps   $ prop "serially monad bind folded"  . monadBind folded (==)++    describe "Stream transform and combine operations" $ do+        serialOps    $ transformCombineOpsCommon S.fromFoldable "serially" (==)+        serialOps    $ transformCombineOpsCommon folded "serially" (==)+        serialOps    $ transformCombineOpsOrdered S.fromFoldable "serially" (==)+        serialOps    $ transformCombineOpsOrdered folded "serially" (==)++#ifdef DEVBUILD+        describe "Filtering" $ do+            it "takeInterval" (testTakeInterval `shouldReturn` True)+            it "dropInterval" (testDropInterval `shouldReturn` True)+#endif++    describe "Stream group and split operations" $ do+        groupSplitOps "serially"++    describe "Stream elimination operations" $ do+        serialOps    $ eliminationOps S.fromFoldable "serially"+        serialOps    $ eliminationOps folded "serially folded"+        serialOps    $ eliminationOpsWord8 S.fromFoldable "serially"+        serialOps    $ eliminationOpsWord8 folded "serially folded"+        serialOps $ \t ->+            prop "drainWhile (> 0)" $ \n ->+                withMaxSuccess maxTestCount $+                monadicIO $ do+                    let xs = [1..n]+                    ioRef <- run $ newIORef ([] :: [Int])+                    run $+                        S.drainWhile (> 0) . t $+                        S.mapM (\a -> modifyIORef' ioRef (a :) >> return a) $+                        S.fromList xs+                    strm <- run $ readIORef ioRef+                    listEquals (==) (reverse strm) (takeWhile (> 0) xs)++    -- XXX Add a test where we chain all transformation APIs and make sure that+    -- the state is being passed through all of them.+    describe "Stream serial elimination operations" $ do+        serialOps    $ eliminationOpsOrdered S.fromFoldable "serially"+        serialOps    $ eliminationOpsOrdered folded "serially folded"++    describe "Tests for S.groupsBy" groupingOps++    describe "Tests for exceptions" $ serialOps $ exceptionOps "serially"++    describe "Composed MonadThrow serially" $ composeWithMonadThrow fromSerial++    it "fromCallback" $ testFromCallback `shouldReturn` (50*101)++    describe "Nesting" $ do+        prop "foldIterateM" foldIterateM
+ test/Streamly/Test/Prelude/WAsync.hs view
@@ -0,0 +1,172 @@+-- |+-- Module      : Streamly.Test.Prelude.WAsync+-- Copyright   : (c) 2020 Composewell Technologies+--+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Test.Prelude.WAsync where++#ifdef DEVBUILD+import Control.Concurrent ( threadDelay )+#endif+import Data.List (sort)+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup ((<>))+#endif+import Test.Hspec.QuickCheck+import Test.Hspec as H++import Streamly.Prelude+import qualified Streamly.Prelude as S++import Streamly.Test.Prelude.Common++moduleName :: String+moduleName = "Prelude.WAsync"++main :: IO ()+main = hspec+  $ H.parallel+#ifdef COVERAGE_BUILD+  $ modifyMaxSuccess (const 10)+#endif+  $ describe moduleName $ do+    let wAsyncOps :: IsStream t => ((WAsyncT IO a -> t IO a) -> Spec) -> Spec+        wAsyncOps spec = mapOps spec $ makeOps fromWAsync+#ifndef COVERAGE_BUILD+            <> [("maxBuffer (-1)", fromWAsync . maxBuffer (-1))]+#endif++    describe "Construction" $ do+        wAsyncOps $ prop "wAsyncly replicateM" . constructWithReplicateM+        -- XXX add tests for fromIndices+        wAsyncOps $ prop "wAsyncly cons" . constructWithCons S.cons+        wAsyncOps $ prop "wAsyncly consM" . constructWithConsM S.consM sort+        wAsyncOps $ prop "wAsyncly (.:)" . constructWithCons (S..:)+        wAsyncOps $ prop "wAsyncly (|:)" . constructWithConsM (S.|:) sort++    describe "Functor operations" $ do+        wAsyncOps $ functorOps S.fromFoldable "wAsyncly" sortEq+        wAsyncOps $ functorOps folded "wAsyncly folded" sortEq++    describe "Monoid operations" $ do+        wAsyncOps $ monoidOps "wAsyncly" mempty sortEq++    describe "WAsync loops" $ loops fromWAsync sort sort++    describe "Bind and Monoidal composition combinations" $ do+        wAsyncOps $ bindAndComposeSimpleOps "WAsync" sortEq+        wAsyncOps $ bindAndComposeHierarchyOps "WAsync"+        wAsyncOps $ nestTwoStreams "WAsync" sort sort+        wAsyncOps $ nestTwoStreamsApp "WAsync" sort sort++    describe "Semigroup operations" $ do+        wAsyncOps $ semigroupOps "wAsyncly" sortEq++    describe "Applicative operations" $ do+        wAsyncOps $ applicativeOps S.fromFoldable "wAsyncly applicative" sortEq+        wAsyncOps $ applicativeOps folded "wAsyncly applicative folded" sortEq++    -- XXX add tests for indexed/indexedR+    describe "Zip operations" $+        -- We test only the serial zip with serial streams and the parallel+        -- stream, because the rate setting in these streams can slow down+        -- zipAsync.+     do+        wAsyncOps $ prop "zip applicative wAsyncly" . zipAsyncApplicative S.fromFoldable (==)+        wAsyncOps $ prop "zip applicative wAsyncly folded" . zipAsyncApplicative folded (==)+        wAsyncOps $+            prop "zip monadic wAsyncly" . zipAsyncMonadic S.fromFoldable (==)+        wAsyncOps $ prop "zip monadic wAsyncly folded" . zipAsyncMonadic folded (==)++    -- XXX add merge tests like zip tests+    -- for mergeBy, we can split a list randomly into two lists and+    -- then merge them, it should result in original list+    -- describe "Merge operations" $ do++    describe "Monad operations" $ do+        wAsyncOps $ prop "wAsyncly monad then" . monadThen S.fromFoldable sortEq+        wAsyncOps $ prop "wAsyncly monad then folded" . monadThen folded sortEq+        wAsyncOps $ prop "wAsyncly monad bind" . monadBind S.fromFoldable sortEq+        wAsyncOps $ prop "wAsyncly monad bind folded" . monadBind folded sortEq++    describe "Stream transform and combine operations" $ do+        wAsyncOps $ transformCombineOpsCommon S.fromFoldable "wAsyncly" sortEq+        wAsyncOps $ transformCombineOpsCommon folded "wAsyncly" sortEq++    describe "Stream elimination operations" $ do+        wAsyncOps $ eliminationOps S.fromFoldable "wAsyncly"+        wAsyncOps $ eliminationOps folded "wAsyncly folded"+        wAsyncOps $ eliminationOpsWord8 S.fromFoldable "wAsyncly"+        wAsyncOps $ eliminationOpsWord8 folded "wAsyncly folded"++    -- describe "WAsync interleaved (<>) ordering check" $+    --     interleaveCheck fromWAsync (<>)+    -- describe "WAsync interleaved mappend ordering check" $+    --     interleaveCheck fromWAsync mappend++    -- XXX this keeps failing intermittently, need to investigate+    -- describe "WAsync (<>) time order check" $+    --     parallelCheck fromWAsync (<>)+    -- describe "WAsync mappend time order check" $+    --     parallelCheck fromWAsync mappend++    describe "Tests for exceptions" $ wAsyncOps $ exceptionOps "wAsyncly"+    describe "Composed MonadThrow wAsyncly" $ composeWithMonadThrow fromWAsync++    -- Ad-hoc tests+    it "takes n from stream of streams" (takeCombined 3 fromWAsync)++#ifdef DEVBUILD+    let timed :: (IsStream t, Monad (t IO)) => Int -> t IO Int+        timed x = S.fromEffect (threadDelay (x * 100000)) >> return x++    -- These are not run fromParallel because the timing gets affected+    -- unpredictably when other tests are running on the same machine.+    --+    -- Also, they fail intermittently due to scheduling delays, so not run on+    -- CI machines.+    describe "Nested parallel and serial compositions" $ do+        let t = timed+            p = fromWAsync+            s = fromSerial+        {-+        -- This is not correct, the result can also be [4,4,8,0,8,0,2,2]+        -- because of parallelism of [8,0] and [8,0].+        it "Nest <|>, <>, <|> (1)" $+            let t = timed+             in toListSerial (+                    ((t 8 <|> t 4) <> (t 2 <|> t 0))+                <|> ((t 8 <|> t 4) <> (t 2 <|> t 0)))+            `shouldReturn` ([4,4,8,8,0,0,2,2])+        -}+        it "Nest <|>, <>, <|> (2)" $+            (S.toList . fromWAsync) (+                   s (p (t 4 <> t 8) <> p (t 1 <> t 2))+                <> s (p (t 4 <> t 8) <> p (t 1 <> t 2)))+            `shouldReturn` ([4,4,8,8,1,1,2,2])+        -- FIXME: These two keep failing intermittently on Mac OS X+        -- Need to examine and fix the tests.+        {-+        it "Nest <|>, <=>, <|> (1)" $+            let t = timed+             in toListSerial (+                    ((t 8 <|> t 4) <=> (t 2 <|> t 0))+                <|> ((t 9 <|> t 4) <=> (t 2 <|> t 0)))+            `shouldReturn` ([4,4,0,0,8,2,9,2])+        it "Nest <|>, <=>, <|> (2)" $+            let t = timed+             in toListSerial (+                    ((t 4 <|> t 8) <=> (t 1 <|> t 2))+                <|> ((t 4 <|> t 9) <=> (t 1 <|> t 2)))+            `shouldReturn` ([4,4,1,1,8,2,9,2])+        -}+        it "Nest <|>, <|>, <|>" $+            (S.toList . fromWAsync) (+                    ((t 4 <> t 8) <> (t 0 <> t 2))+                <> ((t 4 <> t 8) <> (t 0 <> t 2)))+            `shouldReturn` ([0,0,2,2,4,4,8,8])+#endif
+ test/Streamly/Test/Prelude/WSerial.hs view
@@ -0,0 +1,184 @@+-- |+-- Module      : Streamly.Test.Prelude.WSerial+-- Copyright   : (c) 2020 Composewell Technologies+--+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Test.Prelude.WSerial where++import Data.List (sort)+#if __GLASGOW_HASKELL__ < 808+import Data.Semigroup ((<>))+#endif+import Test.QuickCheck (Property, forAll)+import Test.Hspec.QuickCheck+import Test.QuickCheck.Monadic (monadicIO, run)+import Test.Hspec as H++import qualified Streamly.Internal.Data.Stream.Serial as Serial++import Streamly.Prelude hiding (repeat)+import qualified Streamly.Prelude as S++import Streamly.Test.Common+import Streamly.Test.Prelude.Common++associativityCheck+    :: String+    -> (WSerialT IO Int -> SerialT IO Int)+    -> Spec+associativityCheck desc t = prop desc assocCheckProp+  where+    assocCheckProp :: [Int] -> [Int] -> [Int] -> Property+    assocCheckProp xs ys zs =+        monadicIO $ do+            let xStream = S.fromList xs+                yStream = S.fromList ys+                zStream = S.fromList zs+            infixAssocstream <-+                run $ S.toList $ t $ xStream `wSerial` yStream `wSerial` zStream+            assocStream <- run $ S.toList $ t $ xStream <> yStream <> zStream+            listEquals (==) infixAssocstream assocStream++interleaveCheck :: IsStream t+    => (t IO Int -> SerialT IO Int)+    -> (t IO Int -> t IO Int -> t IO Int)+    -> Spec+interleaveCheck t f =+    it "Interleave four" $+        (S.toList . t) ((singleton 0 `f` singleton 1) `f` (singleton 100 `f` singleton 101))+            `shouldReturn` [0, 100, 1, 101]++    where++    singleton :: IsStream t => a -> t m a+    singleton a = a .: nil++wSerialMinLengthProp :: Property+wSerialMinLengthProp =+    forAll (chooseInt (0, 10))+        $ \len -> S.length (combined len) `shouldReturn` 2 * len + 1++    where++    finiteStream len = S.take len $ S.repeat (1 :: Int)+    infiniteStream = S.repeat 1+    combined len = infiniteStream `Serial.wSerialMin` finiteStream len++moduleName :: String+moduleName = "Prelude.WSerial"++main :: IO ()+main = hspec+  $ H.parallel+#ifdef COVERAGE_BUILD+  $ modifyMaxSuccess (const 10)+#endif+  $ describe moduleName $ do+    let wSerialOps :: IsStream t => ((WSerialT IO a -> t IO a) -> Spec) -> Spec+        wSerialOps spec = mapOps spec $ makeOps fromWSerial+#ifndef COVERAGE_BUILD+            <> [("rate AvgRate 0.00000001", fromWSerial . avgRate 0.00000001)]+            <> [("maxBuffer (-1)", fromWSerial . maxBuffer (-1))]+#endif++    describe "Construction" $ do+        wSerialOps  $ prop "wSerially repeat" . constructWithRepeat+        wSerialOps  $ prop "wSerially repeatM" . constructWithRepeatM+        wSerialOps  $ prop "wSerially replicateM" . constructWithReplicate+        wSerialOps  $ prop "wSerially replicateM" . constructWithReplicateM+        wSerialOps $ prop "wSerially cons" . constructWithCons S.cons+        wSerialOps $ prop "wSerially consM" . constructWithConsM S.consM id+        wSerialOps $ prop "wSerially (.:)" . constructWithCons (S..:)+        wSerialOps $ prop "wSerially (|:)" . constructWithConsM (S.|:) id++    describe "Functor operations" $ do+        wSerialOps   $ functorOps S.fromFoldable "wSerially" (==)+        wSerialOps   $ functorOps folded "wSerially folded" (==)++    describe "Monoid operations" $ do+        wSerialOps   $ monoidOps "wSerially" mempty sortEq++    describe "Bind and Monoidal composition combinations" $ do+        -- XXX Taking a long time when wSerialOps is used.+        bindAndComposeSimpleOps "WSerial" sortEq fromWSerial+        bindAndComposeHierarchyOps "WSerial" fromWSerial+        wSerialOps $ nestTwoStreams "WSerial" id sort+        wSerialOps $ nestTwoStreamsApp "WSerial" id sort+        composeAndComposeSimpleSerially+            "WSerial <> "+            [ [1, 4, 2, 7, 3, 5, 8, 6, 9]+            , [1, 7, 4, 8, 2, 9, 5, 3, 6]+            , [1, 4, 2, 7, 3, 5, 8, 6, 9]+            , [1, 7, 4, 8, 2, 9, 5, 3, 6]+            ]+            fromWSerial+        composeAndComposeSimpleWSerially+            "WSerial <> "+            [ [1, 4, 2, 7, 3, 5, 8, 6, 9]+            , [1, 7, 4, 8, 2, 9, 5, 3, 6]+            , [1, 4, 3, 7, 2, 6, 9, 5, 8]+            , [1, 7, 4, 9, 3, 8, 6, 2, 5]+            ]+            fromWSerial++    describe "Semigroup operations" $ do+        wSerialOps $ semigroupOps "wSerially" (==)+        wSerialOps $ associativityCheck "wSerial == <>"++    describe "Applicative operations" $ do+        wSerialOps $ applicativeOps S.fromFoldable "wSerially applicative" sortEq+        wSerialOps $ applicativeOps folded "wSerially applicative folded" sortEq++    -- XXX add tests for indexed/indexedR+    describe "Zip operations" $ do+        -- We test only the serial zip with serial streams and the parallel+        -- stream, because the rate setting in these streams can slow down+        -- zipAsync.+        wSerialOps  $ prop "zip monadic wSerially" . zipMonadic S.fromFoldable (==)+        wSerialOps  $ prop "zip monadic wSerially folded" . zipMonadic folded (==)++    describe "Monad operations" $ do+        wSerialOps  $ prop "wSerially monad then" . monadThen S.fromFoldable sortEq+        wSerialOps  $ prop "wSerially monad then folded" . monadThen folded sortEq+        wSerialOps  $ prop "wSerially monad bind" . monadBind S.fromFoldable sortEq+        wSerialOps  $ prop "wSerially monad bind folded" . monadBind folded sortEq++    describe "Stream transform and combine operations" $ do+        wSerialOps   $ transformCombineOpsCommon S.fromFoldable "wSerially" sortEq+        wSerialOps   $ transformCombineOpsCommon folded "wSerially" sortEq++    describe "Stream elimination operations" $ do+        wSerialOps   $ eliminationOps S.fromFoldable "wSerially"+        wSerialOps   $ eliminationOps folded "wSerially folded"+        wSerialOps   $ eliminationOpsWord8 S.fromFoldable "wSerially"+        wSerialOps   $ eliminationOpsWord8 folded "wSerially folded"++    -- XXX Add a test where we chain all transformation APIs and make sure that+    -- the state is being passed through all of them.+    describe "Stream serial elimination operations" $ do+        wSerialOps   $ eliminationOpsOrdered S.fromFoldable "wSerially"+        wSerialOps   $ eliminationOpsOrdered folded "wSerially folded"++    ---------------------------------------------------------------------------+    -- Semigroup/Monoidal Composition strict ordering checks+    ---------------------------------------------------------------------------++    describe "WSerial interleaved (<>) ordering check" $+        interleaveCheck fromWSerial (<>)+    describe "WSerial interleaved mappend ordering check" $+        interleaveCheck fromWSerial mappend++    describe "Tests for exceptions" $ wSerialOps $ exceptionOps "wSerially"+    describe "Composed MonadThrow wSerially" $ composeWithMonadThrow fromWSerial++    ---------------------------------------------------------------------------+    -- Termination checks+    ---------------------------------------------------------------------------++    describe "wSerialMin termination" $+             prop "len (infinite `wSerialMin` finite) = 2 * len(finite) + 1"+                  wSerialMinLengthProp
+ test/Streamly/Test/Prelude/ZipAsync.hs view
@@ -0,0 +1,68 @@+-- |+-- Module      : Streamly.Test.Prelude.ZipAsync+-- Copyright   : (c) 2020 Composewell Technologies+--+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Test.Prelude.ZipAsync where++import Test.Hspec.QuickCheck+import Test.Hspec as H++import Streamly.Prelude+import qualified Streamly.Prelude as S++import Streamly.Test.Prelude.Common++moduleName :: String+moduleName = "Prelude.ZipAsync"++main :: IO ()+main = hspec+  $ H.parallel+#ifdef COVERAGE_BUILD+  $ modifyMaxSuccess (const 10)+#endif+  $ describe moduleName $ do+    -- Note, the "pure" of applicative Zip streams generates and infinite+    -- stream and therefore maxBuffer (-1) must not be used for that case.+    let zipAsyncOps :: IsStream t => ((ZipAsyncM IO a -> t IO a) -> Spec) -> Spec+        zipAsyncOps spec = mapOps spec $ makeOps fromZipAsync++    describe "Functor operations" $ do+        zipAsyncOps  $ functorOps S.fromFoldable "zipAsyncly" (==)+        zipAsyncOps  $ functorOps folded "zipAsyncly folded" (==)++    describe "Monoid operations" $ do+        zipAsyncOps  $ monoidOps "zipAsyncly" mempty (==)++    describe "Semigroup operations" $ do+        zipAsyncOps  $ semigroupOps "zipAsyncly" (==)++    -- XXX add tests for indexed/indexedR+    describe "Zip operations" $ do+        zipAsyncOps $+            prop "zipAsyncly applicative" . zipApplicative S.fromFoldable (==)+        zipAsyncOps $+            prop "zipAsyncly applicative folded" . zipApplicative folded (==)++    describe "Stream transform and combine operations" $ do+        zipAsyncOps  $ transformCombineOpsCommon S.fromFoldable "zipAsyncly" (==)+        zipAsyncOps  $ transformCombineOpsCommon folded "zipAsyncly" (==)+        zipAsyncOps  $ transformCombineOpsOrdered S.fromFoldable "zipAsyncly" (==)+        zipAsyncOps  $ transformCombineOpsOrdered folded "zipAsyncly" (==)++    describe "Stream elimination operations" $ do+        zipAsyncOps  $ eliminationOps S.fromFoldable "zipAsyncly"+        zipAsyncOps  $ eliminationOps folded "zipAsyncly folded"+        zipAsyncOps  $ eliminationOpsWord8 S.fromFoldable "zipAsyncly"+        zipAsyncOps  $ eliminationOpsWord8 folded "zipAsyncly folded"++    -- XXX Add a test where we chain all transformation APIs and make sure that+    -- the state is being passed through all of them.+    describe "Stream serial elimination operations" $ do+        zipAsyncOps  $ eliminationOpsOrdered S.fromFoldable "zipAsyncly"+        zipAsyncOps  $ eliminationOpsOrdered folded "zipAsyncly folded"
+ test/Streamly/Test/Prelude/ZipSerial.hs view
@@ -0,0 +1,74 @@+-- |+-- Module      : Streamly.Test.Prelude.ZipSerial+-- Copyright   : (c) 2020 Composewell Technologies+--+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Test.Prelude.ZipSerial where++#if __GLASGOW_HASKELL__ < 808+import Data.Semigroup ((<>))+#endif+import Test.Hspec.QuickCheck+import Test.Hspec as H++import Streamly.Prelude+import qualified Streamly.Prelude as S++import Streamly.Test.Prelude.Common++moduleName :: String+moduleName = "Prelude.ZipSerial"++main :: IO ()+main = hspec+  $ H.parallel+#ifdef COVERAGE_BUILD+  $ modifyMaxSuccess (const 10)+#endif+  $ describe moduleName $ do+    let zipSerialOps :: IsStream t+            => ((ZipSerialM IO a -> t IO a) -> Spec) -> Spec+        zipSerialOps spec = mapOps spec $ makeOps fromZipSerial+#ifndef COVERAGE_BUILD+            <> [("rate AvgRate 0.00000001", fromZipSerial . avgRate 0.00000001)]+            <> [("maxBuffer (-1)", fromZipSerial . maxBuffer (-1))]+#endif++    describe "Functor operations" $ do+        zipSerialOps $ functorOps S.fromFoldable "zipSerially" (==)+        zipSerialOps $ functorOps folded "zipSerially folded" (==)++    describe "Monoid operations" $ do+        zipSerialOps $ monoidOps "zipSerially" mempty (==)++    describe "Semigroup operations" $ do+        zipSerialOps $ semigroupOps "zipSerially" (==)++    -- XXX add tests for indexed/indexedR+    describe "Zip operations" $ do+        zipSerialOps $+            prop "zipSerially applicative" . zipApplicative S.fromFoldable (==)+        zipSerialOps $+            prop "zipSerially applicative folded" . zipApplicative folded (==)++    describe "Stream transform and combine operations" $ do+        zipSerialOps $ transformCombineOpsCommon S.fromFoldable "zipSerially" (==)+        zipSerialOps $ transformCombineOpsCommon folded "zipSerially" (==)+        zipSerialOps $ transformCombineOpsOrdered S.fromFoldable "zipSerially" (==)+        zipSerialOps $ transformCombineOpsOrdered folded "zipSerially" (==)++    describe "Stream elimination operations" $ do+        zipSerialOps $ eliminationOps S.fromFoldable "zipSerially"+        zipSerialOps $ eliminationOps folded "zipSerially folded"+        zipSerialOps $ eliminationOpsWord8 S.fromFoldable "zipSerially"+        zipSerialOps $ eliminationOpsWord8 folded "zipSerially folded"++    -- XXX Add a test where we chain all transformation APIs and make sure that+    -- the state is being passed through all of them.+    describe "Stream serial elimination operations" $ do+        zipSerialOps $ eliminationOpsOrdered S.fromFoldable "zipSerially"+        zipSerialOps $ eliminationOpsOrdered folded "zipSerially folded"
+ test/Streamly/Test/Unicode/Stream.hs view
@@ -0,0 +1,186 @@+module Streamly.Test.Unicode.Stream (main) where++import Data.Char (ord, chr)+import Data.Word (Word8)+import Test.QuickCheck+    ( Property+    , forAll+    , Gen+    , listOf+    , arbitraryASCIIChar+    , arbitraryUnicodeChar+    , arbitrary+    , expectFailure+    , vectorOf+    , choose+    )+import Test.QuickCheck.Monadic (run, monadicIO, assert)++import qualified Streamly.Data.Array.Foreign as A+import qualified Streamly.Internal.Data.Array.Stream.Foreign as AS+import qualified Streamly.Prelude as S+import qualified Streamly.Unicode.Stream as SS+import qualified Streamly.Internal.Unicode.Stream as IUS+import qualified Streamly.Internal.Unicode.Array.Char as IUA+import qualified Test.Hspec as H++import Test.Hspec.QuickCheck++-- Coverage build takes too long with default number of tests+{-+maxTestCount :: Int+#ifdef DEVBUILD+maxTestCount = 100+#else+maxTestCount = 10+#endif+-}++-- Use quickcheck-unicode instead?+genUnicode :: Gen String+genUnicode = listOf arbitraryUnicodeChar++genWord8 :: Gen [Word8]+genWord8 = listOf arbitrary++propDecodeEncodeId' :: Property+propDecodeEncodeId' =+    forAll genUnicode $ \list ->+        monadicIO $ do+            let wrds = SS.encodeUtf8' $ S.fromList list+            chrs <- S.toList $ SS.decodeUtf8' wrds+            assert (chrs == list)++-- XXX need to use invalid characters+propDecodeEncodeId :: Property+propDecodeEncodeId =+    forAll genUnicode $ \list ->+        monadicIO $ do+            let wrds = SS.encodeUtf8 $ S.fromList list+            chrs <- S.toList $ SS.decodeUtf8 wrds+            assert (chrs == list)++propDecodeEncodeIdArrays :: Property+propDecodeEncodeIdArrays =+    forAll genUnicode $ \list ->+        monadicIO $ do+            let wrds = SS.encodeUtf8' $ S.fromList list+            chrs <- S.toList $ IUS.decodeUtf8Arrays+                                    (S.fold A.write wrds)+            assert (chrs == list)++unicodeTestData :: [Char]+unicodeTestData = "z\72150\83468;L$Wz| ?_i/J ."++latin1TestData :: [Char]+latin1TestData = "z\214\f;L$Wz| ?_i/J ."++propASCIIToLatin1 :: Property+propASCIIToLatin1 =+    forAll (choose (1, 1000)) $ \len ->+        forAll (vectorOf len arbitraryASCIIChar) $ \list ->+            monadicIO $ do+                let wrds = SS.decodeLatin1 $ SS.encodeLatin1 $ S.fromList list+                lst <- run $  S.toList wrds+                assert (list == lst)++propUnicodeToLatin1 :: Property+propUnicodeToLatin1 =+    monadicIO $ do+        let wrds =+                SS.decodeLatin1+                    $ SS.encodeLatin1+                    $ S.fromList unicodeTestData+        lst <- run $  S.toList wrds+        assert (latin1TestData == lst)++propUnicodeToLatin1' :: Property+propUnicodeToLatin1' =+    monadicIO $ do+        let wrds =+                SS.decodeLatin1+                    $ SS.encodeLatin1'+                    $ S.fromList unicodeTestData+        lst <- run $  S.toList wrds+        assert (latin1TestData == lst)++testLines :: Property+testLines =+    forAll genUnicode $ \list ->+        monadicIO $ do+            xs <- S.toList+                $ S.map A.toList+                $ IUA.lines+                $ S.fromList list+            assert (xs == lines list)++testLinesArray :: Property+testLinesArray =+    forAll genWord8 $ \list ->+        monadicIO $ do+            xs <- S.toList+                    $ S.map A.toList+                    $ AS.splitOnSuffix 10+                    $ S.fromPure (A.fromList list)+            assert (xs == map (map (fromIntegral . ord))+                              (lines (map (chr .  fromIntegral) list)))++testWords :: Property+testWords =+    forAll genUnicode $ \list ->+        monadicIO $ do+            xs <- S.toList+                $ S.map A.toList+                $ IUA.words+                $ S.fromList list+            assert (xs == words list)++testUnlines :: Property+testUnlines =+  forAll genUnicode $ \list ->+      monadicIO $ do+          xs <- S.toList+              $ IUA.unlines+              $ IUA.lines+              $ S.fromList list+          assert (xs == unlines (lines list))++testUnwords :: Property+testUnwords =+  forAll genUnicode $ \list ->+      monadicIO $ do+          xs <- run+              $ S.toList+              $ IUA.unwords+              $ IUA.words+              $ S.fromList list+          assert (xs == unwords (words list))++moduleName :: String+moduleName = "Unicode.Stream"++main :: IO ()+main = H.hspec+  $ H.parallel+  $ modifyMaxSuccess (const 1000)+  $ H.describe moduleName $ do+    H.describe "UTF8 - Encoding / Decoding" $ do+        prop "decodeUtf8' . encodeUtf8' == id" propDecodeEncodeId'+        prop "decodeUtf8 . encodeUtf8' == id" propDecodeEncodeId+        prop "decodeUtf8Arrays . encodeUtf8' == id"+                propDecodeEncodeIdArrays+        prop "Streamly.Data.String.lines == Prelude.lines" testLines+        prop "Arrays Streamly.Data.String.lines == Prelude.lines"+            testLinesArray+        prop "Streamly.Data.String.words == Prelude.words" testWords+        prop+            "Streamly.Data.String.unlines . Streamly.Data.String.lines == unlines . lines"+            testUnlines+        prop+            "Streamly.Data.String.unwords . Streamly.Data.String.words == unwords . words"+            testUnwords++    H.describe "Latin1 - Encoding / Decoding" $ do+        prop "ASCII to Latin1" propASCIIToLatin1+        prop "Unicode to Latin1" propUnicodeToLatin1+        prop "Unicode to Latin1'" $ expectFailure  propUnicodeToLatin1'
− test/String.hs 
@@ -1,135 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}--module Main (main) where--import Data.Char (ord, chr)-import Data.Word (Word8)-import Test.Hspec.QuickCheck-import Test.QuickCheck-       (Property, forAll, Gen, listOf, arbitraryUnicodeChar, arbitrary)-import Test.QuickCheck.Monadic (run, monadicIO, assert)--import           Test.Hspec as H--import qualified Streamly.Memory.Array as A-import qualified Streamly.Internal.Memory.ArrayStream as AS-import qualified Streamly.Prelude as S-import qualified Streamly.Data.Unicode.Stream as SS-import qualified Streamly.Internal.Data.Unicode.Stream as IUS-import qualified Streamly.Internal.Memory.Unicode.Array as IUA---- Coverage build takes too long with default number of tests-{--maxTestCount :: Int-#ifdef DEVBUILD-maxTestCount = 100-#else-maxTestCount = 10-#endif--}---- Use quickcheck-unicode instead?-genUnicode :: Gen String-genUnicode = listOf arbitraryUnicodeChar--genWord8 :: Gen [Word8]-genWord8 = listOf arbitrary--propDecodeEncodeId :: Property-propDecodeEncodeId =-    forAll genUnicode $ \list ->-        monadicIO $ do-            let wrds = SS.encodeUtf8 $ S.fromList list-            chrs <- S.toList $ SS.decodeUtf8 wrds-            assert (chrs == list)---- XXX need to use invalid characters-propDecodeEncodeIdLenient :: Property-propDecodeEncodeIdLenient =-    forAll genUnicode $ \list ->-        monadicIO $ do-            let wrds = SS.encodeUtf8 $ S.fromList list-            chrs <- S.toList $ SS.decodeUtf8Lax wrds-            assert (chrs == list)--propDecodeEncodeIdArrays :: Property-propDecodeEncodeIdArrays =-    forAll genUnicode $ \list ->-        monadicIO $ do-            let wrds = SS.encodeUtf8 $ S.fromList list-            chrs <- S.toList $ IUS.decodeUtf8ArraysLenient-                                    (S.fold A.write wrds)-            assert (chrs == list)--testLines :: Property-testLines =-    forAll genUnicode $ \list ->-        monadicIO $ do-            xs <- S.toList-                $ S.map A.toList-                $ IUA.lines-                $ S.fromList list-            assert (xs == lines list)--testLinesArray :: Property-testLinesArray =-    forAll genWord8 $ \list ->-        monadicIO $ do-            xs <- S.toList-                    $ S.map A.toList-                    $ AS.splitOnSuffix 10-                    $ S.yield (A.fromList list)-            assert (xs == map (map (fromIntegral . ord))-                              (lines (map (chr .  fromIntegral) list)))--testWords :: Property-testWords =-    forAll genUnicode $ \list ->-        monadicIO $ do-            xs <- S.toList-                $ S.map A.toList-                $ IUA.words-                $ S.fromList list-            assert (xs == words list)--testUnlines :: Property-testUnlines =-  forAll genUnicode $ \list ->-      monadicIO $ do-          xs <- S.toList-              $ IUA.unlines-              $ IUA.lines-              $ S.fromList list-          assert (xs == unlines (lines list))--testUnwords :: Property-testUnwords =-  forAll genUnicode $ \list ->-      monadicIO $ do-          xs <- run-              $ S.toList-              $ IUA.unwords-              $ IUA.words-              $ S.fromList list-          assert (xs == unwords (words list))--main :: IO ()-main = hspec-    $ H.parallel-    $ modifyMaxSuccess (const 1000)-    $ do-    describe "UTF8 - Encoding / Decoding" $ do-        prop "decodeUtf8 . encodeUtf8 == id" $ propDecodeEncodeId-        prop "decodeUtf8Lax . encodeUtf8 == id" $ propDecodeEncodeIdLenient-        prop "decodeUtf8ArraysLenient . encodeUtf8 == id"-                $ propDecodeEncodeIdArrays-        prop "Streamly.Data.String.lines == Prelude.lines" $ testLines-        prop "Arrays Streamly.Data.String.lines == Prelude.lines" $ testLinesArray-        prop "Streamly.Data.String.words == Prelude.words" $ testWords-        prop-            "Streamly.Data.String.unlines . Streamly.Data.String.lines == unlines . lines"-             $ testUnlines-        prop-            "Streamly.Data.String.unwords . Streamly.Data.String.words == unwords . words"-             $ testUnwords
+ test/lib/Streamly/Test/Common.hs view
@@ -0,0 +1,65 @@+-- |+-- Module      : Streamly.Test.Common+-- Copyright   : (c) 2020 Composewell Technologies+--+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Test.Common+    ( equals+    , listEquals+    , checkListEqual+    , chooseInt+    ) where++import Control.Monad (when)+import Control.Monad.IO.Class (MonadIO(..))+import Data.List ((\\))+#if __GLASGOW_HASKELL__ < 808+import Data.Semigroup ((<>))+#endif+import Test.QuickCheck (Property, Gen, choose, counterexample)+import Test.QuickCheck.Monadic (PropertyM, assert, monitor, monadicIO)++equals+    :: (Show a, Monad m)+    => (a -> a -> Bool) -> a -> a -> PropertyM m ()+equals eq stream list = do+    when (not $ stream `eq` list) $+        monitor+            (counterexample $+             "stream " <> show stream+             <> "\nlist   " <> show list+            )+    assert (stream `eq` list)++listEquals+    :: (Show a, Eq a, MonadIO m)+    => ([a] -> [a] -> Bool) -> [a] -> [a] -> PropertyM m ()+listEquals eq stream list = do+    when (not $ stream `eq` list) $ liftIO $ putStrLn $+                  "stream " <> show stream+             <> "\nlist   " <> show list+             <> "\nstream length  " <> show (length stream)+             <> "\nlist length  " <> show (length list)+             <> "\nstream \\\\ list " <> show (stream \\ list)+             <> "\nlist \\\\ stream " <> show (list \\ stream)+    when (not $ stream `eq` list) $+        monitor+            (counterexample $+                  "stream " <> show stream+             <> "\nlist   " <> show list+             <> "\nstream length  " <> show (length stream)+             <> "\nlist length  " <> show (length list)+             <> "\nstream \\\\ list " <> show (stream \\ list)+             <> "\nlist \\\\ stream " <> show (list \\ stream)+             )+    assert (stream `eq` list)++checkListEqual :: (Show a, Eq a) => [a] -> [a] -> Property+checkListEqual ls_1 ls_2 = monadicIO (listEquals (==) ls_1 ls_2)++chooseInt :: (Int, Int) -> Gen Int+chooseInt = choose
+ test/lib/Streamly/Test/Prelude/Common.hs view
@@ -0,0 +1,1740 @@+-- |+-- Module      : Streamly.Test.Prelude.Common+-- Copyright   : (c) 2020 Composewell Technologies+--+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Test.Prelude.Common+    (+    -- * Construction operations+      constructWithRepeat+    , constructWithRepeatM+    , constructWithReplicate+    , constructWithReplicateM+    , constructWithIntFromThenTo+#if __GLASGOW_HASKELL__ >= 806+    , constructWithDoubleFromThenTo+#endif+    , constructWithIterate+    , constructWithIterateM+    , constructWithEnumerate+    , constructWithEnumerateTo+    , constructWithFromIndices+    , constructWithFromIndicesM+    , constructWithFromList+    , constructWithFromListM+    , constructWithUnfoldr+    , constructWithCons+    , constructWithConsM+    , constructWithFromPure+    , constructWithFromEffect+    , simpleOps+    -- * Applicative operations+    , applicativeOps+    , applicativeOps1+    -- * Elimination operations+    , eliminationOpsOrdered+    , eliminationOpsWord8+    , eliminationOps+    -- * Functor operations+    , functorOps+    -- * Monoid operations+    , monoidOps+    , loops+    , bindAndComposeSimpleOps+    , bindAndComposeHierarchyOps+    , nestTwoStreams+    , nestTwoStreamsApp+    , composeAndComposeSimpleSerially+    , composeAndComposeSimpleAheadly+    , composeAndComposeSimpleWSerially+    -- * Semigroup operations+    , semigroupOps+    , parallelCheck+    -- * Transformation operations+    , transformCombineOpsOrdered+    , transformCombineOpsCommon+    , toListFL+    -- * Monad operations+    , monadBind+    , monadThen+    -- * Zip operations+    , zipApplicative+    , zipMonadic+    , zipAsyncApplicative+    , zipAsyncMonadic+    -- * Exception operations+    , exceptionOps+    -- * MonadThrow operations+    , composeWithMonadThrow+    -- * Cleanup tests+    , checkCleanup+    -- * Adhoc tests+    , takeCombined+    -- * Default values+    , maxTestCount+    , maxStreamLen+    -- * Helper operations+    , folded+    , makeCommonOps+    , makeOps+    , mapOps+    , sortEq+    ) where++import Control.Applicative (ZipList(..), liftA2)+import Control.Exception (Exception, try)+import Control.Concurrent (threadDelay)+import Control.Monad (replicateM)+#ifdef DEVBUILD+import Control.Monad (when)+#endif+import Control.Monad.Catch (throwM, MonadThrow)+import Data.IORef ( IORef, atomicModifyIORef', modifyIORef', newIORef+                  , readIORef, writeIORef)+import Data.List+    ( delete+    , deleteBy+    , elemIndex+    , elemIndices+    , find+    , findIndex+    , findIndices+    , foldl'+    , foldl1'+    , insert+    , intersperse+    , isPrefixOf+    , isSubsequenceOf+    , maximumBy+    , minimumBy+    , scanl'+    , sort+    , stripPrefix+    , unfoldr+    )+import Data.Maybe (mapMaybe)+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup (Semigroup, (<>))+#endif+import GHC.Word (Word8)+import System.Mem (performMajorGC)+import Test.Hspec.QuickCheck+import Test.Hspec+import Test.QuickCheck (Property, choose, forAll, withMaxSuccess)+import Test.QuickCheck.Monadic (assert, monadicIO, run)++import Streamly.Prelude (SerialT, IsStream, (.:), nil, (|&), fromSerial)+#ifndef COVERAGE_BUILD+import Streamly.Prelude (avgRate, rate, maxBuffer, maxThreads)+#endif+import qualified Streamly.Prelude as S+import qualified Streamly.Data.Fold as FL+import qualified Streamly.Internal.Data.Stream.IsStream as S+import qualified Streamly.Internal.Data.Unfold as UF++import Streamly.Test.Common++maxStreamLen :: Int+maxStreamLen = 1000++-- Coverage build takes too long with default number of tests+maxTestCount :: Int+#ifdef DEVBUILD+maxTestCount = 100+#else+maxTestCount = 10+#endif++singleton :: IsStream t => a -> t m a+singleton a = a .: nil++sortEq :: Ord a => [a] -> [a] -> Bool+sortEq a b = sort a == sort b++-------------------------------------------------------------------------------+-- Construction operations+-------------------------------------------------------------------------------++constructWithLen+    :: (Show a, Eq a)+    => (Int -> t IO a)+    -> (Int -> [a])+    -> (t IO a -> SerialT IO a)+    -> Word8+    -> Property+constructWithLen mkStream mkList op len = withMaxSuccess maxTestCount $+    monadicIO $ do+        stream <- run $ (S.toList . op) (mkStream (fromIntegral len))+        let list = mkList (fromIntegral len)+        listEquals (==) stream list++constructWithLenM+    :: (Int -> t IO Int)+    -> (Int -> IO [Int])+    -> (t IO Int -> SerialT IO Int)+    -> Word8+    -> Property+constructWithLenM mkStream mkList op len = withMaxSuccess maxTestCount $+    monadicIO $ do+        stream <- run $ (S.toList . op) (mkStream (fromIntegral len))+        list <- run $ mkList (fromIntegral len)+        listEquals (==) stream list++constructWithReplicate, constructWithReplicateM, constructWithIntFromThenTo+    :: IsStream t+    => (t IO Int -> SerialT IO Int)+    -> Word8+    -> Property++constructWithReplicateM = constructWithLenM stream list+    where list = flip replicateM (return 1 :: IO Int)+          stream = flip S.replicateM (return 1 :: IO Int)++constructWithReplicate = constructWithLen stream list+    where list = flip replicate (1 :: Int)+          stream = flip S.replicate (1 :: Int)++constructWithIntFromThenTo op l =+    forAll (choose (minBound, maxBound)) $ \from ->+    forAll (choose (minBound, maxBound)) $ \next ->+    forAll (choose (minBound, maxBound)) $ \to ->+        let list len = take len [from,next..to]+            stream len = S.take len $ S.enumerateFromThenTo from next to+        in constructWithLen stream list op l++constructWithRepeat, constructWithRepeatM+    :: IsStream t+    => (t IO Int -> SerialT IO Int)+    -> Word8+    -> Property+constructWithRepeat = constructWithLenM stream list+  where+    stream n = S.take n $ S.repeat 1+    list n = return $ replicate n 1++constructWithRepeatM = constructWithLenM stream list+  where+    stream n = S.take n $ S.repeatM (return 1)+    list n = return $ replicate n 1++#if __GLASGOW_HASKELL__ >= 806+-- XXX try very small steps close to 0+constructWithDoubleFromThenTo+    :: IsStream t+    => (t IO Double -> SerialT IO Double)+    -> Word8+    -> Property+constructWithDoubleFromThenTo op l =+    forAll (choose (-9007199254740999,9007199254740999)) $ \from ->+    forAll (choose (-9007199254740999,9007199254740999)) $ \next ->+    forAll (choose (-9007199254740999,9007199254740999)) $ \to ->+        let list len = take len [from,next..to]+            stream len = S.take len $ S.enumerateFromThenTo from next to+        in constructWithLen stream list op l+#endif++constructWithIterate ::+       IsStream t => (t IO Int -> SerialT IO Int) -> Word8 -> Property+constructWithIterate op len =+    withMaxSuccess maxTestCount $+    monadicIO $ do+        stream <-+            run $+            (S.toList . op . S.take (fromIntegral len))+                (S.iterate (+ 1) (0 :: Int))+        let list = take (fromIntegral len) (iterate (+ 1) 0)+        listEquals (==) stream list++constructWithIterateM ::+       IsStream t => (t IO Int -> SerialT IO Int) -> Word8 -> Property+constructWithIterateM op len =+    withMaxSuccess maxTestCount $+    monadicIO $ do+        mvl <- run (newIORef [] :: IO (IORef [Int]))+        let addM mv x y = modifyIORef' mv (++ [y + x]) >> return (y + x)+            list = take (fromIntegral len) (iterate (+ 1) 0)+        run $+            S.drain . op $+            S.take (fromIntegral len) $+            S.iterateM (addM mvl 1) (addM mvl 0 0 :: IO Int)+        streamEffect <- run $ readIORef mvl+        listEquals (==) streamEffect list++constructWithFromIndices ::+       IsStream t => (t IO Int -> SerialT IO Int) -> Word8 -> Property+constructWithFromIndices op len =+    withMaxSuccess maxTestCount $+    monadicIO $ do+        stream <-+            run $ (S.toList . op . S.take (fromIntegral len)) (S.fromIndices id)+        let list = take (fromIntegral len) (iterate (+ 1) 0)+        listEquals (==) stream list++constructWithFromIndicesM ::+       IsStream t => (t IO Int -> SerialT IO Int) -> Word8 -> Property+constructWithFromIndicesM op len =+    withMaxSuccess maxTestCount $+    monadicIO $ do+        mvl <- run (newIORef [] :: IO (IORef [Int]))+        let addIndex mv i = modifyIORef' mv (++ [i]) >> return i+            list = take (fromIntegral len) (iterate (+ 1) 0)+        run $+            S.drain . op $+            S.take (fromIntegral len) $ S.fromIndicesM (addIndex mvl)+        streamEffect <- run $ readIORef mvl+        listEquals (==) streamEffect list++constructWithCons ::+       IsStream t+    => (Int -> t IO Int -> t IO Int)+    -> (t IO Int -> SerialT IO Int)+    -> Word8+    -> Property+constructWithCons cons op len =+    withMaxSuccess maxTestCount $+    monadicIO $ do+        strm <-+            run+               $ S.toList . op . S.take (fromIntegral len)+               $ foldr cons S.nil (repeat 0)+        let list = replicate (fromIntegral len) 0+        listEquals (==) strm list++constructWithConsM ::+       IsStream t+    => (IO Int -> t IO Int -> t IO Int)+    -> ([Int] -> [Int])+    -> (t IO Int -> SerialT IO Int)+    -> Word8+    -> Property+constructWithConsM consM listT op len =+    withMaxSuccess maxTestCount $+    monadicIO $ do+        strm <-+            run $+            S.toList . op . S.take (fromIntegral len) $+            foldr consM S.nil (repeat (return 0))+        let list = replicate (fromIntegral len) 0+        listEquals (==) (listT strm) list++constructWithEnumerate ::+       IsStream t+    => ([Int] -> [Int])+    -> (t IO Int -> SerialT IO Int)+    -> Word8+    -> Property+constructWithEnumerate listT op len =+    withMaxSuccess maxTestCount $+    monadicIO $ do+        strm <- run $ S.toList . op . S.take (fromIntegral len) $ S.enumerate+        let list = take (fromIntegral len) (enumFrom minBound)+        listEquals (==) (listT strm) list++constructWithEnumerateTo ::+       IsStream t+    => ([Int] -> [Int])+    -> (t IO Int -> SerialT IO Int)+    -> Word8+    -> Property+constructWithEnumerateTo listT op len =+    withMaxSuccess maxTestCount $+    monadicIO $ do+        -- It takes forever to enumerate from minBound to len, so+        -- instead we just do till len elements+        strm <- run $ S.toList . op $ S.enumerateTo (minBound + fromIntegral len)+        let list = enumFromTo minBound (minBound + fromIntegral len)+        listEquals (==) (listT strm) list++constructWithFromList ::+       IsStream t+    => ([Int] -> [Int])+    -> (t IO Int -> SerialT IO Int)+    -> Word8+    -> Property+constructWithFromList listT op len =+    withMaxSuccess maxTestCount $+    monadicIO $ do+        strm <- run $ S.toList . op . S.fromList $ [0 .. fromIntegral len]+        let list = [0 .. fromIntegral len]+        listEquals (==) (listT strm) list++constructWithFromListM ::+       IsStream t+    => ([Int] -> [Int])+    -> (t IO Int -> SerialT IO Int)+    -> Word8+    -> Property+constructWithFromListM listT op len =+    withMaxSuccess maxTestCount $+    monadicIO $ do+        strm <-+            run $+            S.toList . op . S.fromListM . fmap pure $ [0 .. fromIntegral len]+        let list = [0 .. fromIntegral len]+        listEquals (==) (listT strm) list++constructWithUnfoldr ::+       IsStream t+    => ([Int] -> [Int])+    -> (t IO Int -> SerialT IO Int)+    -> Word8+    -> Property+constructWithUnfoldr listT op len =+    withMaxSuccess maxTestCount $+    monadicIO $ do+        strm <- run $ S.toList . op $ S.unfoldr unfoldStep 0+        let list = unfoldr unfoldStep 0+        listEquals (==) (listT strm) list+  where+    unfoldStep seed =+        if seed > fromIntegral len+        then Nothing+        else Just (seed, seed + 1)++constructWithFromPure ::+       (IsStream t+#if __GLASGOW_HASKELL__ < 806+       , Monoid (t IO Int)+#endif+       )+    => ([Int] -> [Int])+    -> (t IO Int -> SerialT IO Int)+    -> Word8+    -> Property+constructWithFromPure listT op len =+    withMaxSuccess maxTestCount $+    monadicIO $ do+        strm <-+            run+                $ S.toList . op . S.take (fromIntegral len)+                $ foldMap S.fromPure (repeat 0)+        let list = replicate (fromIntegral len) 0+        listEquals (==) (listT strm) list++constructWithFromEffect ::+       (IsStream t+#if __GLASGOW_HASKELL__ < 806+       , Monoid (t IO Int)+#endif+       )+    => ([Int] -> [Int])+    -> (t IO Int -> SerialT IO Int)+    -> Word8+    -> Property+constructWithFromEffect listT op len =+    withMaxSuccess maxTestCount $+    monadicIO $ do+        strm <-+            run+                $ S.toList . op . S.take (fromIntegral len)+                $ foldMap S.fromEffect (repeat (return 0))+        let list = replicate (fromIntegral len) 0+        listEquals (==) (listT strm) list++simpleProps ::+       (Int -> t IO Int)+    -> (t IO Int -> SerialT IO Int)+    -> Int+    -> Property+simpleProps constr op a = monadicIO $ do+  strm <- run $ S.toList . op . constr $ a+  listEquals (==) strm [a]++simpleOps :: IsStream t => (t IO Int -> SerialT IO Int) -> Spec+simpleOps op = do+  prop "fromPure a = a" $ simpleProps S.fromPure op+  prop "fromEffect a = a" $ simpleProps (S.fromEffect . return) op++-------------------------------------------------------------------------------+-- Applicative operations+-------------------------------------------------------------------------------++applicativeOps+    :: (Applicative (t IO), Semigroup (t IO Int))+    => ([Int] -> t IO Int)+    -> String+    -> ([(Int, Int)] -> [(Int, Int)] -> Bool)+    -> (t IO (Int, Int) -> SerialT IO (Int, Int))+    -> Spec+applicativeOps constr desc eq t = do+    prop (desc <> " <*>") $+        transformFromList2+            constr+            eq+            (\a b -> (,) <$> a <*> b)+            (\a b -> t ((,) <$> a <*> b))+    prop (desc <> " liftA2") $+        transformFromList2 constr eq (liftA2 (,)) (\a b -> t $ liftA2 (,) a b)+    prop (desc <> " Apply - composed first argument") $+        sort <$>+        (S.toList . t) ((,) <$> (pure 1 <> pure 2) <*> pure 3) `shouldReturn`+        [(1, 3), (2, 3)]+    prop (desc <> " Apply - composed second argument") $+        sort <$>+        (S.toList . t) (pure ((,) 1) <*> (pure 2 <> pure 3)) `shouldReturn`+        [(1, 2), (1, 3)]++-- XXX we can combine this with applicativeOps by making the type sufficiently+-- polymorphic.+applicativeOps1+    :: Applicative (t IO)+    => ([Int] -> t IO Int)+    -> String+    -> ([Int] -> [Int] -> Bool)+    -> (t IO Int -> SerialT IO Int)+    -> Spec+applicativeOps1 constr desc eq t = do+    prop (desc <> " *>") $+        transformFromList2 constr eq (*>) (\a b -> t (a *> b))+    prop (desc <> " <*") $+        transformFromList2 constr eq (<*) (\a b -> t (a <* b))++transformFromList2+  :: (Eq c, Show c)+  => ([a] -> t IO a)+  -> ([c] -> [c] -> Bool)+  -> ([a] -> [a] -> [c])+  -> (t IO a -> t IO a -> SerialT IO c)+  -> ([a], [a])+  -> Property+transformFromList2 constr eq listOp op (a, b) =+    withMaxSuccess maxTestCount $+    monadicIO $ do+        stream <- run (S.toList $ op (constr a) (constr b))+        let list = listOp a b+        listEquals eq stream list++-------------------------------------------------------------------------------+-- Elimination operations+-------------------------------------------------------------------------------++eliminateOp+    :: (Show a, Eq a)+    => ([s] -> t IO s)+    -> ([s] -> a)+    -> (t IO s -> IO a)+    -> [s]+    -> Property+eliminateOp constr listOp op a =+    monadicIO $ do+        stream <- run $ op (constr a)+        let list = listOp a+        equals (==) stream list++wrapMaybe :: ([a1] -> a2) -> [a1] -> Maybe a2+wrapMaybe f x = if null x then Nothing else Just (f x)++wrapOutOfBounds :: ([a1] -> Int -> a2) -> Int -> [a1] -> Maybe a2+wrapOutOfBounds f i x | null x = Nothing+                      | i >= length x = Nothing+                      | otherwise = Just (f x i)++wrapThe :: Eq a => [a] -> Maybe a+wrapThe (x:xs)+    | all (x ==) xs = Just x+    | otherwise = Nothing+wrapThe [] = Nothing++-- This is the reference uniq implementation to compare uniq against,+-- we can use uniq from vector package, but for now this should+-- suffice.+referenceUniq :: Eq a => [a] -> [a]+referenceUniq = go+  where+    go [] = []+    go (x:[]) = [x]+    go (x:y:xs)+        | x == y = go (x : xs)+        | otherwise = x : go (y : xs)++eliminationOps+    :: ([Int] -> t IO Int)+    -> String+    -> (t IO Int -> SerialT IO Int)+    -> Spec+eliminationOps constr desc t = do+    -- Elimination+    prop (desc <> " null") $ eliminateOp constr null $ S.null . t+    prop (desc <> " foldl'") $+        eliminateOp constr (foldl' (+) 0) $ S.foldl' (+) 0 . t+    prop (desc <> " foldl1'") $+        eliminateOp constr (wrapMaybe $ foldl1' (+)) $ S.foldl1' (+) . t+#ifdef DEVBUILD+    prop (desc <> " foldr1") $+        eliminateOp constr (wrapMaybe $ foldr1 (+)) $ S.foldr1 (+) . t+#endif+    prop (desc <> " all") $ eliminateOp constr (all even) $ S.all even . t+    prop (desc <> " any") $ eliminateOp constr (any even) $ S.any even . t+    prop (desc <> " and") $ eliminateOp constr (and . fmap (> 0)) $+        (S.and . S.map (> 0)) . t+    prop (desc <> " or") $ eliminateOp constr (or . fmap (> 0)) $+        (S.or . S.map (> 0)) . t+    prop (desc <> " length") $ eliminateOp constr length $ S.length . t+    prop (desc <> " sum") $ eliminateOp constr sum $ S.sum . t+    prop (desc <> " product") $ eliminateOp constr product $ S.product . t+    prop (desc <> " mapM_ sumIORef") $+        eliminateOp constr sum $+        (\strm -> do+             ioRef <- newIORef 0+             let sumInRef a = modifyIORef' ioRef (a +)+             S.mapM_ sumInRef strm+             readIORef ioRef) .+        t+    prop (desc <> "trace sumIORef") $+        eliminateOp constr sum $+        (\strm -> do+             ioRef <- newIORef 0+             let sumInRef a = modifyIORef' ioRef (a +)+             S.drain $ S.trace sumInRef strm+             readIORef ioRef) .+        t++    prop (desc <> " maximum") $+        eliminateOp constr (wrapMaybe maximum) $ S.maximum . t+    prop (desc <> " minimum") $+        eliminateOp constr (wrapMaybe minimum) $ S.minimum . t++    prop (desc <> " maximumBy compare") $+        eliminateOp constr (wrapMaybe maximum) $+        S.maximumBy compare . t+    prop (desc <> " maximumBy flip compare") $+        eliminateOp constr (wrapMaybe $ maximumBy $ flip compare) $+        S.maximumBy (flip compare) . t+    prop (desc <> " minimumBy compare") $+        eliminateOp constr (wrapMaybe minimum) $+        S.minimumBy compare . t+    prop (desc <> " minimumBy flip compare") $+        eliminateOp constr (wrapMaybe $ minimumBy $ flip compare) $+        S.minimumBy (flip compare) . t++    prop (desc <> " findIndex") $+        eliminateOp constr (findIndex odd) $ S.findIndex odd . t+    prop (desc <> " elemIndex") $+        eliminateOp constr (elemIndex 3) $ S.elemIndex 3 . t++    prop (desc <> " !! 5") $+        eliminateOp constr (wrapOutOfBounds (!!) 5) $ (S.!! 5) . t+    prop (desc <> " !! 4") $+        eliminateOp constr (wrapOutOfBounds (!!) 0) $ (S.!! 0) . t++    prop (desc <> " find") $ eliminateOp constr (find even) $ S.find even . t+    prop (desc <> " findM") $ eliminateOp constr (find even) $ S.findM (return . even) . t+    prop (desc <> " lookup") $+        eliminateOp constr (lookup 3 . flip zip [1..]) $+            S.lookup 3 . S.zipWith (\a b -> (b, a)) (S.fromList [(1::Int)..]) . t+    prop (desc <> " the") $ eliminateOp constr wrapThe $ S.the . t++    -- Multi-stream eliminations+    -- XXX Write better tests for substreams.+    prop (desc <> " eqBy (==) t t") $+        eliminateOp constr (\s -> s == s) $ (\s -> S.eqBy (==) s s) . t+    prop (desc <> " cmpBy (==) t t") $+        eliminateOp constr (\s -> compare s s) $ (\s -> S.cmpBy compare s s) . t+    prop (desc <> " isPrefixOf 10") $ eliminateOp constr (isPrefixOf [1..10]) $+        S.isPrefixOf (S.fromList [(1::Int)..10]) . t+    prop (desc <> " isSubsequenceOf 10") $+        eliminateOp constr (isSubsequenceOf $ filter even [1..10]) $+        S.isSubsequenceOf (S.fromList $ filter even [(1::Int)..10]) . t+    prop (desc <> " stripPrefix 10") $ eliminateOp constr (stripPrefix [1..10]) $+        (\s -> s >>= maybe (return Nothing) (fmap Just . S.toList)) .+        S.stripPrefix (S.fromList [(1::Int)..10]) . t++-- head/tail/last may depend on the order in case of parallel streams+-- so we test these only for serial streams.+eliminationOpsOrdered+    :: ([Int] -> t IO Int)+    -> String+    -> (t IO Int -> SerialT IO Int)+    -> Spec+eliminationOpsOrdered constr desc t = do+    prop (desc <> " head") $ eliminateOp constr (wrapMaybe head) $ S.head . t+    prop (desc <> " tail") $ eliminateOp constr (wrapMaybe tail) $ \x -> do+        r <- S.tail (t x)+        case r of+            Nothing -> return Nothing+            Just s -> Just <$> S.toList s+    prop (desc <> " last") $ eliminateOp constr (wrapMaybe last) $ S.last . t+    prop (desc <> " init") $ eliminateOp constr (wrapMaybe init) $ \x -> do+        r <- S.init (t x)+        case r of+            Nothing -> return Nothing+            Just s -> Just <$> S.toList s++elemOp+    :: ([Word8] -> t IO Word8)+    -> (t IO Word8 -> SerialT IO Word8)+    -> (Word8 -> SerialT IO Word8 -> IO Bool)+    -> (Word8 -> [Word8] -> Bool)+    -> (Word8, [Word8])+    -> Property+elemOp constr op streamOp listOp (x, xs) =+    monadicIO $ do+        stream <- run $ (streamOp x . op) (constr xs)+        let list = listOp x xs+        equals (==) stream list++eliminationOpsWord8+    :: ([Word8] -> t IO Word8)+    -> String+    -> (t IO Word8 -> SerialT IO Word8)+    -> Spec+eliminationOpsWord8 constr desc t = do+    prop (desc <> " elem") $ elemOp constr t S.elem elem+    prop (desc <> " notElem") $ elemOp constr t S.notElem notElem++-------------------------------------------------------------------------------+-- Functor operations+-------------------------------------------------------------------------------++functorOps+    :: (Functor (t IO), Semigroup (t IO Int))+    => ([Int] -> t IO Int)+    -> String+    -> ([Int] -> [Int] -> Bool)+    -> (t IO Int -> SerialT IO Int)+    -> Spec+functorOps constr desc eq t = do+    prop (desc <> " id") $ transformFromList constr eq id t+    prop (desc <> " fmap (+1)") $+        transformFromList constr eq (fmap (+ 1)) $ t . fmap (+ 1)+    prop (desc <> " fmap on composed (<>)") $+        sort <$>+        (S.toList . t) (fmap (+ 1) (constr [1] <> constr [2])) `shouldReturn`+        ([2, 3] :: [Int])++transformFromList+    :: (Eq b, Show b) =>+       ([a] -> t IO a)+    -> ([b] -> [b] -> Bool)+    -> ([a] -> [b])+    -> (t IO a -> SerialT IO b)+    -> [a]+    -> Property+transformFromList constr eq listOp op a =+    monadicIO $ do+        stream <- run ((S.toList . op) (constr a))+        let list = listOp a+        listEquals eq stream list+++------------------------------------------------------------------------------+-- Monoid operations+------------------------------------------------------------------------------++monoidOps+    :: (IsStream t, Semigroup (t IO Int))+    => String+    -> t IO Int+    -> ([Int] -> [Int] -> Bool)+    -> (t IO Int -> SerialT IO Int)+    -> Spec+monoidOps desc z eq t = do+    -- XXX these should get covered by the property tests+    prop (desc <> " Compose mempty, mempty") $ spec (z <> z) []+    prop (desc <> " Compose empty at the beginning") $ spec (z <> singleton 1) [1]+    prop (desc <> " Compose empty at the end") $ spec (singleton 1 <> z) [1]+    prop (desc <> " Compose two") $ spec (singleton 0 <> singleton 1) [0, 1]+    prop (desc <> " Compose many") $+        spec (S.concatForFoldableWith (<>) [1 .. 100] singleton) [1 .. 100]++    -- These are not covered by the property tests+    prop (desc <> " Compose three - empty in the middle") $+        spec (singleton 0 <> z <> singleton 1) [0, 1]+    prop (desc <> " Compose left associated") $+        spec+            (((singleton 0 <> singleton 1) <> singleton 2) <> singleton 3)+            [0, 1, 2, 3]+    prop (desc <> " Compose right associated") $+        spec+            (singleton 0 <> (singleton 1 <> (singleton 2 <> singleton 3)))+            [0, 1, 2, 3]+    prop (desc <> " Compose hierarchical (multiple levels)") $+        spec+            (((singleton 0 <> singleton 1) <> (singleton 2 <> singleton 3)) <>+             ((singleton 4 <> singleton 5) <> (singleton 6 <> singleton 7)))+            [0 .. 7]++    where++    tl = S.toList . t+    spec s list =+        monadicIO $ do+            stream <- run $ tl s+            listEquals eq stream list++---------------------------------------------------------------------------+-- Monoidal composition recursion loops+---------------------------------------------------------------------------++loops+    :: (IsStream t, Semigroup (t IO Int), Monad (t IO))+    => (t IO Int -> t IO Int)+    -> ([Int] -> [Int])+    -> ([Int] -> [Int])+    -> Spec+loops t tsrt hsrt = do+    it "Tail recursive loop" $ (tsrt <$> (S.toList . S.adapt) (loopTail 0))+            `shouldReturn` [0..3]++    it "Head recursive loop" $ (hsrt <$> (S.toList . S.adapt) (loopHead 0))+            `shouldReturn` [0..3]++    where+        loopHead x = do+            -- this print line is important for the test (causes a bind)+            S.fromEffect $ putStrLn "LoopHead..."+            t $ (if x < 3 then loopHead (x + 1) else nil) <> return x++        loopTail x = do+            -- this print line is important for the test (causes a bind)+            S.fromEffect $ putStrLn "LoopTail..."+            t $ return x <> (if x < 3 then loopTail (x + 1) else nil)++---------------------------------------------------------------------------+-- Bind and monoidal composition combinations+---------------------------------------------------------------------------++bindAndComposeSimpleOps+    :: IsStream t+    => String+    -> ([Int] -> [Int] -> Bool)+    -> (t IO Int -> SerialT IO Int)+    -> Spec+bindAndComposeSimpleOps desc eq t = do+    bindAndComposeSimple+        ("Bind and compose " <> desc <> " Stream serially/")+        S.fromSerial+    bindAndComposeSimple+        ("Bind and compose " <> desc <> " Stream wSerially/")+        S.fromWSerial+    bindAndComposeSimple+        ("Bind and compose " <> desc <> " Stream aheadly/")+        S.fromAhead+    bindAndComposeSimple+        ("Bind and compose " <> desc <> " Stream asyncly/")+        S.fromAsync+    bindAndComposeSimple+        ("Bind and compose " <> desc <> " Stream wAsyncly/")+        S.fromWAsync+    bindAndComposeSimple+        ("Bind and compose " <> desc <> " Stream parallely/")+        S.fromParallel++    where++    bindAndComposeSimple+        :: (IsStream t2, Semigroup (t2 IO Int), Monad (t2 IO))+        => String+        -> (t2 IO Int -> t2 IO Int)+        -> Spec+    bindAndComposeSimple idesc t2 = do+      -- XXX need a bind in the body of forEachWith instead of a simple return+      prop (idesc <> " Compose many (right fold) with bind") $ \list ->+          monadicIO $ do+              stream <-+                  run $+                  (S.toList . t)+                      (S.adapt . t2 $ S.concatForFoldableWith (<>) list return)+              listEquals eq stream list++      prop (idesc <> " Compose many (left fold) with bind") $ \list ->+          monadicIO $ do+              let forL xs k = foldl (<>) nil $ fmap k xs+              stream <-+                  run $ (S.toList . t) (S.adapt . t2 $ forL list return)+              listEquals eq stream list++---------------------------------------------------------------------------+-- Bind and monoidal composition combinations+---------------------------------------------------------------------------++bindAndComposeHierarchyOps ::+       (IsStream t, Monad (t IO))+    => String+    -> (t IO Int -> SerialT IO Int)+    -> Spec+bindAndComposeHierarchyOps desc t1 = do+    let fldldesc = "Bind and compose foldl, " <> desc <> " Stream "+        fldrdesc = "Bind and compose foldr, " <> desc <> " Stream "++    bindAndComposeHierarchy+        (fldldesc <> "serially") S.fromSerial fldl+    bindAndComposeHierarchy+        (fldrdesc <> "serially") S.fromSerial fldr+    bindAndComposeHierarchy+        (fldldesc <> "wSerially") S.fromWSerial fldl+    bindAndComposeHierarchy+        (fldrdesc <> "wSerially") S.fromWSerial fldr+    bindAndComposeHierarchy+        (fldldesc <> "aheadly") S.fromAhead fldl+    bindAndComposeHierarchy+        (fldrdesc <> "aheadly") S.fromAhead fldr+    bindAndComposeHierarchy+        (fldldesc <> "asyncly") S.fromAsync fldl+    bindAndComposeHierarchy+        (fldrdesc <> "asyncly") S.fromAsync fldr+    bindAndComposeHierarchy+        (fldldesc <> "wAsyncly") S.fromWAsync fldl+    bindAndComposeHierarchy+        (fldrdesc <> "wAsyncly") S.fromWAsync fldr+    bindAndComposeHierarchy+        (fldldesc <> "parallely") S.fromParallel fldl+    bindAndComposeHierarchy+        (fldrdesc <> "parallely")  S.fromParallel fldr++  where++    bindAndComposeHierarchy+        :: (IsStream t2, Monad (t2 IO))+        => String+        -> (t2 IO Int -> t2 IO Int)+        -> ([t2 IO Int] -> t2 IO Int)+        -> Spec+    bindAndComposeHierarchy specdesc t2 g =+        describe specdesc $+        it "Bind and compose nested" $+            (sort <$> (S.toList . t1) bindComposeNested)+                `shouldReturn` (sort (+                    [12, 18]+                    <> replicate 3 13+                    <> replicate 3 17+                    <> replicate 6 14+                    <> replicate 6 16+                    <> replicate 7 15) :: [Int])++        where++        -- bindComposeNested :: WAsyncT IO Int+        bindComposeNested =+            let c1 = tripleCompose (return 1) (return 2) (return 3)+                c2 = tripleCompose (return 4) (return 5) (return 6)+                c3 = tripleCompose (return 7) (return 8) (return 9)+                b = tripleBind c1 c2 c3+        -- it seems to be causing a huge space leak in hspec so disabling this for now+        --            c = tripleCompose b b b+        --            m = tripleBind c c c+        --         in m+            in b++        tripleCompose a b c = S.adapt . t2 $ g [a, b, c]+        tripleBind mx my mz =+            mx >>= \x -> my+            >>= \y -> mz+            >>= \z -> return (x + y + z)++    fldr, fldl :: (IsStream t, Semigroup (t IO Int))+                => [t IO Int] -> t IO Int+    fldr = foldr (<>) nil+    fldl = foldl (<>) nil++-- Nest two lists using different styles of product compositions+nestTwoStreams+    :: (IsStream t, Semigroup (t IO Int), Monad (t IO))+    => String+    -> ([Int] -> [Int])+    -> ([Int] -> [Int])+    -> (t IO Int -> SerialT IO Int)+    -> Spec+nestTwoStreams desc streamListT listT t =+    it ("Nests two streams using monadic " <> desc <> " composition") $ do+    let s1 = S.concatMapFoldableWith (<>) return [1..4]+        s2 = S.concatMapFoldableWith (<>) return [5..8]+    r <- (S.toList . t) $ do+                x <- s1+                y <- s2+                return $ x + y+    streamListT r `shouldBe` listT [6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12]++nestTwoStreamsApp+    :: (IsStream t, Semigroup (t IO Int), Monad (t IO))+    => String+    -> ([Int] -> [Int])+    -> ([Int] -> [Int])+    -> (t IO Int -> SerialT IO Int)+    -> Spec+nestTwoStreamsApp desc streamListT listT t =+    it ("Nests two streams using applicative " <> desc <> " composition") $ do+    let s1 = S.concatMapFoldableWith (<>) return [1..4]+        s2 = S.concatMapFoldableWith (<>) return [5..8]+        r  = (S.toList . t) ((+) <$> s1 <*> s2)+    streamListT <$> r+        `shouldReturn` listT [6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12]+++-- TBD need more such combinations to be tested.+composeAndComposeSimple+    :: ( IsStream t1, Semigroup (t1 IO Int)+       , IsStream t2, Monoid (t2 IO Int), Monad (t2 IO)+#if !(MIN_VERSION_base(4,11,0))+       , Semigroup (t2 IO Int)+#endif+       )+    => (t1 IO Int -> SerialT IO Int)+    -> (t2 IO Int -> t2 IO Int)+    -> [[Int]] -> Spec+composeAndComposeSimple t1 t2 answer = do+    let rfold = S.adapt . t2 . S.concatMapFoldableWith (<>) return+    it "Compose right associated outer expr, right folded inner" $+         (S.toList . t1) (rfold [1,2,3] <> (rfold [4,5,6] <> rfold [7,8,9]))+            `shouldReturn` head answer++    it "Compose left associated outer expr, right folded inner" $+         (S.toList . t1) ((rfold [1,2,3] <> rfold [4,5,6]) <> rfold [7,8,9])+            `shouldReturn` (answer !! 1)++    let lfold xs = S.adapt $ t2 $ foldl (<>) mempty $ fmap return xs+    it "Compose right associated outer expr, left folded inner" $+         (S.toList . t1) (lfold [1,2,3] <> (lfold [4,5,6] <> lfold [7,8,9]))+            `shouldReturn` (answer !! 2)++    it "Compose left associated outer expr, left folded inner" $+         (S.toList . t1) ((lfold [1,2,3] <> lfold [4,5,6]) <> lfold [7,8,9])+            `shouldReturn` (answer !! 3)++composeAndComposeSimpleSerially+    :: (IsStream t, Semigroup (t IO Int))+    => String+    -> [[Int]]+    -> (t IO Int -> SerialT IO Int)+    -> Spec+composeAndComposeSimpleSerially desc answer t = do+    describe (desc <> " and Serial <>") $ composeAndComposeSimple t S.fromSerial answer++composeAndComposeSimpleAheadly+    :: (IsStream t, Semigroup (t IO Int))+    => String+    -> [[Int]]+    -> (t IO Int -> SerialT IO Int)+    -> Spec+composeAndComposeSimpleAheadly desc answer t = do+    describe (desc <> " and Ahead <>") $ composeAndComposeSimple t S.fromAhead answer++composeAndComposeSimpleWSerially+    :: (IsStream t, Semigroup (t IO Int))+    => String+    -> [[Int]]+    -> (t IO Int -> SerialT IO Int)+    -> Spec+composeAndComposeSimpleWSerially desc answer t = do+    describe (desc <> " and WSerial <>") $ composeAndComposeSimple t S.fromWSerial answer++-------------------------------------------------------------------------------+-- Semigroup operations+-------------------------------------------------------------------------------++foldFromList+    :: ([Int] -> t IO Int)+    -> (t IO Int -> SerialT IO Int)+    -> ([Int] -> [Int] -> Bool)+    -> [Int]+    -> Property+foldFromList constr op eq = transformFromList constr eq id op++-- XXX concatenate streams of multiple elements rather than single elements+semigroupOps+    :: (IsStream t+#if __GLASGOW_HASKELL__ < 804+       , Semigroup (t IO Int)+#endif+       , Monoid (t IO Int))+    => String+    -> ([Int] -> [Int] -> Bool)+    -> (t IO Int -> SerialT IO Int)+    -> Spec+semigroupOps desc eq t = do+    prop (desc <> " <>") $ foldFromList (S.concatMapFoldableWith (<>) singleton) t eq+    prop (desc <> " mappend") $ foldFromList (S.concatMapFoldableWith mappend singleton) t eq++-------------------------------------------------------------------------------+-- Transformation operations+-------------------------------------------------------------------------------++transformCombineFromList+    :: Semigroup (t IO Int)+    => ([Int] -> t IO Int)+    -> ([Int] -> [Int] -> Bool)+    -> ([Int] -> [Int])+    -> (t IO Int -> SerialT IO Int)+    -> (t IO Int -> t IO Int)+    -> [Int]+    -> [Int]+    -> [Int]+    -> Property+transformCombineFromList constr eq listOp t op a b c =+    withMaxSuccess maxTestCount $+        monadicIO $ do+            stream <- run ((S.toList . t) $+                constr a <> op (constr b <> constr c))+            let list = a <> listOp (b <> c)+            listEquals eq stream list++-- XXX add tests for MonadReader and MonadError etc. In case an SVar is+-- accidentally passed through them.+--+-- This tests transform ops along with detecting illegal sharing of SVar across+-- conurrent streams. These tests work for all stream types whereas+-- transformCombineOpsOrdered work only for ordered stream types i.e. excluding+-- the Async type.+transformCombineOpsCommon+    :: (IsStream t, Semigroup (t IO Int) , Functor (t IO))+    => ([Int] -> t IO Int)+    -> String+    -> ([Int] -> [Int] -> Bool)+    -> (t IO Int -> SerialT IO Int)+    -> Spec+transformCombineOpsCommon constr desc eq t = do+    let transform = transformCombineFromList constr eq++    -- Filtering+    prop (desc <> " filter False") $+        transform (filter (const False)) t (S.filter (const False))+    prop (desc <> " filter True") $+        transform (filter (const True)) t (S.filter (const True))+    prop (desc <> " filter even") $+        transform (filter even) t (S.filter even)++    prop (desc <> " filterM False") $+        transform (filter (const False)) t (S.filterM (const $ return False))+    prop (desc <> " filterM True") $+        transform (filter (const True)) t (S.filterM (const $ return True))+    prop (desc <> " filterM even") $+        transform (filter even) t (S.filterM (return . even))++    prop (desc <> " take maxBound") $+        transform (take maxBound) t (S.take maxBound)+    prop (desc <> " take 0") $ transform (take 0) t (S.take 0)++    prop (desc <> " takeWhile True") $+        transform (takeWhile (const True)) t (S.takeWhile (const True))+    prop (desc <> " takeWhile False") $+        transform (takeWhile (const False)) t (S.takeWhile (const False))++    prop (desc <> " takeWhileM True") $+        transform (takeWhile (const True)) t (S.takeWhileM (const $ return True))+    prop (desc <> " takeWhileM False") $+        transform (takeWhile (const False)) t (S.takeWhileM (const $ return False))++    prop (desc <> " drop maxBound") $+        transform (drop maxBound) t (S.drop maxBound)+    prop (desc <> " drop 0") $ transform (drop 0) t (S.drop 0)++    prop (desc <> " dropWhile True") $+        transform (dropWhile (const True)) t (S.dropWhile (const True))+    prop (desc <> " dropWhile False") $+        transform (dropWhile (const False)) t (S.dropWhile (const False))++    prop (desc <> " dropWhileM True") $+        transform (dropWhile (const True)) t (S.dropWhileM (const $ return True))+    prop (desc <> " dropWhileM False") $+        transform (dropWhile (const False)) t (S.dropWhileM (const $ return False))++    prop (desc <> " deleteBy (<=) maxBound") $+        transform (deleteBy (<=) maxBound) t (S.deleteBy (<=) maxBound)+    prop (desc <> " deleteBy (==) 4") $+        transform (delete 4) t (S.deleteBy (==) 4)++    -- transformation+    prop (desc <> " mapM (+1)") $+        transform (fmap (+1)) t (S.mapM (\x -> return (x + 1)))++    prop (desc <> " scanl'") $ transform (scanl' (const id) 0) t+                                       (S.scanl' (const id) 0)+    prop (desc <> " postscanl'") $ transform (tail . scanl' (const id) 0) t+                                       (S.postscanl' (const id) 0)+    prop (desc <> " scanlM'") $ transform (scanl' (const id) 0) t+                                       (S.scanlM' (\_ a -> return a) (return 0))+    prop (desc <> " postscanlM'") $ transform (tail . scanl' (const id) 0) t+                                       (S.postscanlM' (\_ a -> return a) (return 0))+    prop (desc <> " scanl1'") $ transform (scanl1 (const id)) t+                                         (S.scanl1' (const id))+    prop (desc <> " scanl1M'") $ transform (scanl1 (const id)) t+                                          (S.scanl1M' (\_ a -> return a))++    let f x = if odd x then Just (x + 100) else Nothing+    prop (desc <> " mapMaybe") $ transform (mapMaybe f) t (S.mapMaybe f)+    prop (desc <> " mapMaybeM") $+        transform (mapMaybe f) t (S.mapMaybeM (return . f))++    -- tap+    prop (desc <> " tap FL.sum . map (+1)") $ \a b ->+        withMaxSuccess maxTestCount $+        monadicIO $ do+            cref <- run $ newIORef 0+            let fldstp _ e = modifyIORef' cref (e +)+                sumfoldinref = FL.foldlM' fldstp (return ())+                op = S.tap sumfoldinref . S.mapM (\x -> return (x+1))+                listOp = fmap (+1)+            stream <- run ((S.toList . t) $ op (constr a <> constr b))+            let list = listOp (a <> b)+            ssum <- run $ readIORef cref+            assert (sum list == ssum)+            listEquals eq stream list++    -- reordering+    prop (desc <> " reverse") $ transform reverse t S.reverse+    prop (desc <> " reverse'") $ transform reverse t S.reverse'++    -- inserting+    prop (desc <> " intersperseM") $+        forAll (choose (minBound, maxBound)) $ \n ->+            transform (intersperse n) t (S.intersperseM $ return n)+    prop (desc <> " intersperse") $+        forAll (choose (minBound, maxBound)) $ \n ->+            transform (intersperse n) t (S.intersperse n)+    prop (desc <> " insertBy 0") $+        forAll (choose (minBound, maxBound)) $ \n ->+            transform (insert n) t (S.insertBy compare n)++    -- multi-stream+    prop (desc <> " concatMap") $+        forAll (choose (0, 100)) $ \n ->+            transform (concatMap (const [1..n]))+                t (S.concatMap (const (S.fromList [1..n])))+    prop (desc <> " concatMapM") $+        forAll (choose (0, 100)) $ \n ->+            transform (concatMap (const [1..n]))+                t (S.concatMapM (const (return $ S.fromList [1..n])))+    prop (desc <> " unfoldMany") $+        forAll (choose (0, 100)) $ \n ->+            transform (concatMap (const [1..n]))+                t (S.unfoldMany (UF.lmap (const undefined)+                                   $ UF.supply [1..n] UF.fromList))++toListFL :: Monad m => FL.Fold m a [a]+toListFL = FL.toList++-- transformation tests that can only work reliably for ordered streams i.e.+-- Serial, Ahead and Zip. For example if we use "take 1" on an async stream, it+-- might yield a different result every time.+transformCombineOpsOrdered+    :: (IsStream t, Semigroup (t IO Int))+    => ([Int] -> t IO Int)+    -> String+    -> ([Int] -> [Int] -> Bool)+    -> (t IO Int -> SerialT IO Int)+    -> Spec+transformCombineOpsOrdered constr desc eq t = do+    let transform = transformCombineFromList constr eq++    -- Filtering+    prop (desc <> " take 1") $ transform (take 1) t (S.take 1)+#ifdef DEVBUILD+    prop (desc <> " take 2") $ transform (take 2) t (S.take 2)+    prop (desc <> " take 3") $ transform (take 3) t (S.take 3)+    prop (desc <> " take 4") $ transform (take 4) t (S.take 4)+    prop (desc <> " take 5") $ transform (take 5) t (S.take 5)+#endif+    prop (desc <> " take 10") $ transform (take 10) t (S.take 10)++    prop (desc <> " takeWhile > 0") $+        transform (takeWhile (> 0)) t (S.takeWhile (> 0))+    prop (desc <> " takeWhileM > 0") $+        transform (takeWhile (> 0)) t (S.takeWhileM (return . (> 0)))++    prop (desc <> " drop 1") $ transform (drop 1) t (S.drop 1)+    prop (desc <> " drop 10") $ transform (drop 10) t (S.drop 10)++    prop (desc <> " dropWhile > 0") $+        transform (dropWhile (> 0)) t (S.dropWhile (> 0))+    prop (desc <> " dropWhileM > 0") $+        transform (dropWhile (> 0)) t (S.dropWhileM (return . (> 0)))+    prop (desc <> " scan") $ transform (scanl' (+) 0) t (S.scanl' (+) 0)++    prop (desc <> " uniq") $ transform referenceUniq t S.uniq++    prop (desc <> " deleteBy (<=) 0") $+        transform (deleteBy (<=) 0) t (S.deleteBy (<=) 0)++    prop (desc <> " findIndices") $+        transform (findIndices odd) t (S.findIndices odd)+    prop (desc <> " findIndices . filter") $+        transform (findIndices odd . filter odd)+                  t+                  (S.findIndices odd . S.filter odd)+    prop (desc <> " elemIndices") $+        transform (elemIndices 0) t (S.elemIndices 0)++    -- XXX this does not fail when the SVar is shared, need to fix.+    prop (desc <> " concurrent application") $+        transform (fmap (+1)) t (|& S.map (+1))++-------------------------------------------------------------------------------+-- Monad operations+-------------------------------------------------------------------------------++monadThen+    :: Monad (t IO)+    => ([Int] -> t IO Int)+    -> ([Int] -> [Int] -> Bool)+    -> (t IO Int -> SerialT IO Int)+    -> ([Int], [Int])+    -> Property+monadThen constr eq t (a, b) = withMaxSuccess maxTestCount $ monadicIO $ do+    stream <- run ((S.toList . t) (constr a >> constr b))+    let list = a >> b+    listEquals eq stream list++monadBind+    :: Monad (t IO)+    => ([Int] -> t IO Int)+    -> ([Int] -> [Int] -> Bool)+    -> (t IO Int -> SerialT IO Int)+    -> ([Int], [Int])+    -> Property+monadBind constr eq t (a, b) = withMaxSuccess maxTestCount $+    monadicIO $ do+        stream <-+            run+                ((S.toList . t)+                     (constr a >>= \x -> (+ x) <$> constr b))+        let list = a >>= \x -> (+ x) <$> b+        listEquals eq stream list++-------------------------------------------------------------------------------+-- Zip operations+-------------------------------------------------------------------------------++zipApplicative+    :: (IsStream t, Applicative (t IO))+    => ([Int] -> t IO Int)+    -> ([(Int, Int)] -> [(Int, Int)] -> Bool)+    -> (t IO (Int, Int) -> SerialT IO (Int, Int))+    -> ([Int], [Int])+    -> Property+zipApplicative constr eq t (a, b) = withMaxSuccess maxTestCount $+    monadicIO $ do+        stream1 <- run ((S.toList . t) ((,) <$> constr a <*> constr b))+        stream2 <- run ((S.toList . t) (pure (,) <*> constr a <*> constr b))+        stream3 <- run ((S.toList . t) (S.zipWith (,) (constr a) (constr b)))+        let list = getZipList $ (,) <$> ZipList a <*> ZipList b+        listEquals eq stream1 list+        listEquals eq stream2 list+        listEquals eq stream3 list++zipMonadic+    :: IsStream t+    => ([Int] -> t IO Int)+    -> ([(Int, Int)] -> [(Int, Int)] -> Bool)+    -> (t IO (Int, Int) -> SerialT IO (Int, Int))+    -> ([Int], [Int])+    -> Property+zipMonadic constr eq t (a, b) = withMaxSuccess maxTestCount $+    monadicIO $ do+        stream1 <-+            run+                ((S.toList . t)+                     (S.zipWithM (curry return) (constr a) (constr b)))+        let list = getZipList $ (,) <$> ZipList a <*> ZipList b+        listEquals eq stream1 list++zipAsyncMonadic+    :: IsStream t+    => ([Int] -> t IO Int)+    -> ([(Int, Int)] -> [(Int, Int)] -> Bool)+    -> (t IO (Int, Int) -> SerialT IO (Int, Int))+    -> ([Int], [Int])+    -> Property+zipAsyncMonadic constr eq t (a, b) = withMaxSuccess maxTestCount $+    monadicIO $ do+        stream1 <-+            run+                ((S.toList . t)+                     (S.zipWithM (curry return) (constr a) (constr b)))+        stream2 <-+            run+                ((S.toList . t)+                     (S.zipAsyncWithM (curry return) (constr a) (constr b)))+        let list = getZipList $ (,) <$> ZipList a <*> ZipList b+        listEquals eq stream1 list+        listEquals eq stream2 list++zipAsyncApplicative+    :: IsStream t+    => ([Int] -> t IO Int)+    -> ([(Int, Int)] -> [(Int, Int)] -> Bool)+    -> (t IO (Int, Int) -> SerialT IO (Int, Int))+    -> ([Int], [Int])+    -> Property+zipAsyncApplicative constr eq t (a, b) = withMaxSuccess maxTestCount $+    monadicIO $ do+        stream <-+            run+                ((S.toList . t)+                     (S.zipAsyncWith (,) (constr a) (constr b)))+        let list = getZipList $ (,) <$> ZipList a <*> ZipList b+        listEquals eq stream list++---------------------------------------------------------------------------+-- Semigroup/Monoidal Composition strict ordering checks+---------------------------------------------------------------------------++parallelCheck :: (IsStream t, Monad (t IO))+    => (t IO Int -> SerialT IO Int)+    -> (t IO Int -> t IO Int -> t IO Int)+    -> Spec+parallelCheck t f = do+    it "Parallel ordering left associated" $+        (S.toList . t) (((event 4 `f` event 3) `f` event 2) `f` event 1)+            `shouldReturn` [1..4]++    it "Parallel ordering right associated" $+        (S.toList . t) (event 4 `f` (event 3 `f` (event 2 `f` event 1)))+            `shouldReturn` [1..4]++    where event n = S.fromEffect (threadDelay (n * 200000)) >> return n++-------------------------------------------------------------------------------+-- Exception ops+-------------------------------------------------------------------------------++beforeProp :: IsStream t => (t IO Int -> SerialT IO Int) -> [Int] -> Property+beforeProp t vec =+    withMaxSuccess maxTestCount $+    monadicIO $ do+        ioRef <- run $ newIORef []+        run+            $ S.drain . t+            $ S.before (writeIORef ioRef [0])+            $ S.mapM (\a -> do atomicModifyIORef' ioRef (\xs -> (xs ++ [a], ()))+                               return a)+            $ S.fromList vec+        refValue <- run $ readIORef ioRef+        listEquals (==) (head refValue : sort (tail refValue)) (0:sort vec)++afterProp :: IsStream t => (t IO Int -> SerialT IO Int) -> [Int] -> Property+afterProp t vec =+    withMaxSuccess maxTestCount $+    monadicIO $ do+        ioRef <- run $ newIORef []+        run+            $ S.drain . t+            $ S.after (modifyIORef' ioRef (0:))+            $ S.mapM (\a -> do atomicModifyIORef' ioRef (\xs -> (a:xs, ()))+                               return a)+            $ S.fromList vec+        refValue <- run $ readIORef ioRef+        listEquals (==) (head refValue : sort (tail refValue)) (0:sort vec)++bracketProp :: IsStream t => (t IO Int -> SerialT IO Int) -> [Int] -> Property+bracketProp t vec =+    withMaxSuccess maxTestCount $+    monadicIO $ do+        ioRef <- run $ newIORef (0 :: Int)+        run $+            S.drain . t $+            S.bracket+                (return ioRef)+                (`writeIORef` 1)+                (\ioref ->+                     S.mapM+                         (\a -> writeIORef ioref 2 >> return a)+                         (S.fromList vec))+        refValue <- run $ readIORef ioRef+        assert $ refValue == 1++#ifdef DEVBUILD+bracketPartialStreamProp ::+       (IsStream t) => (t IO Int -> SerialT IO Int) -> [Int] -> Property+bracketPartialStreamProp t vec =+    forAll (choose (0, length vec)) $ \len -> do+        withMaxSuccess maxTestCount $+            monadicIO $ do+                ioRef <- run $ newIORef (0 :: Int)+                run $+                    S.drain . t $+                    S.take len $+                    S.bracket+                        (writeIORef ioRef 1 >> return ioRef)+                        (`writeIORef` 3)+                        (\ioref ->+                             S.mapM+                                 (\a -> writeIORef ioref 2 >> return a)+                                 (S.fromList vec))+                run $ do+                    performMajorGC+                    threadDelay 1000000+                refValue <- run $ readIORef ioRef+                when (refValue /= 0 && refValue /= 3) $+                    error $ "refValue == " ++ show refValue+#endif++bracketExceptionProp ::+       (IsStream t, MonadThrow (t IO)+#if __GLASGOW_HASKELL__ < 806+       , Semigroup (t IO Int)+#endif+       )+    => (t IO Int -> SerialT IO Int)+    -> Property+bracketExceptionProp t =+    withMaxSuccess maxTestCount $+    monadicIO $ do+        ioRef <- run $ newIORef (0 :: Int)+        res <-+            run $+            try . S.drain . t $+            S.bracket+                (return ioRef)+                (`writeIORef` 1)+                (const $ throwM (ExampleException "E") <> S.nil)+        assert $ res == Left (ExampleException "E")+        refValue <- run $ readIORef ioRef+        assert $ refValue == 1++finallyProp :: (IsStream t) => (t IO Int -> SerialT IO Int) -> [Int] -> Property+finallyProp t vec =+    withMaxSuccess maxTestCount $+    monadicIO $ do+        ioRef <- run $ newIORef (0 :: Int)+        run $+            S.drain . t $+            S.finally+                (writeIORef ioRef 1)+                (S.mapM (\a -> writeIORef ioRef 2 >> return a) (S.fromList vec))+        refValue <- run $ readIORef ioRef+        assert $ refValue == 1++#ifdef DEVBUILD+finallyPartialStreamProp ::+       (IsStream t) => (t IO Int -> SerialT IO Int) -> [Int] -> Property+finallyPartialStreamProp t vec =+    forAll (choose (0, length vec)) $ \len -> do+        withMaxSuccess maxTestCount $+            monadicIO $ do+                ioRef <- run $ newIORef (0 :: Int)+                run $+                    S.drain . t $+                    S.take len $+                    S.finally+                        (writeIORef ioRef 2)+                        (S.mapM+                             (\a -> writeIORef ioRef 1 >> return a)+                             (S.fromList vec))+                run $ do+                    performMajorGC+                    threadDelay 100000+                refValue <- run $ readIORef ioRef+                when (refValue /= 0 && refValue /= 2) $+                    error $ "refValue == " ++ show refValue+#endif++finallyExceptionProp ::+       (IsStream t, MonadThrow (t IO)+#if __GLASGOW_HASKELL__ < 806+       , Semigroup (t IO Int)+#endif+       )+    => (t IO Int -> SerialT IO Int)+    -> Property+finallyExceptionProp t =+    withMaxSuccess maxTestCount $+    monadicIO $ do+        ioRef <- run $ newIORef (0 :: Int)+        res <-+            run $+            try . S.drain . t $+            S.finally+                (writeIORef ioRef 1)+                (throwM (ExampleException "E") <> S.nil)+        assert $ res == Left (ExampleException "E")+        refValue <- run $ readIORef ioRef+        assert $ refValue == 1++onExceptionProp ::+       (IsStream t, MonadThrow (t IO)+#if __GLASGOW_HASKELL__ < 806+       , Semigroup (t IO Int)+#endif+       )+    => (t IO Int -> SerialT IO Int)+    -> Property+onExceptionProp t =+    withMaxSuccess maxTestCount $+    monadicIO $ do+        ioRef <- run $ newIORef (0 :: Int)+        res <-+            run $+            try . S.drain . t $+            S.onException+                (writeIORef ioRef 1)+                (throwM (ExampleException "E") <> S.nil)+        assert $ res == Left (ExampleException "E")+        refValue <- run $ readIORef ioRef+        assert $ refValue == 1++handleProp ::+       IsStream t+    => (t IO Int -> SerialT IO Int)+    -> [Int]+    -> Property+handleProp t vec =+    withMaxSuccess maxTestCount $+    monadicIO $ do+        res <-+            run $+            S.toList . t $+            S.handle+                (\(ExampleException i) -> read i `S.cons` S.fromList vec)+                (S.fromSerial $ S.fromList vec <> throwM (ExampleException "0"))+        assert $ res == vec ++ [0] ++ vec++exceptionOps ::+       (IsStream t, MonadThrow (t IO)+#if __GLASGOW_HASKELL__ < 806+       , Semigroup (t IO Int)+#endif+       )+    => String+    -> (t IO Int -> SerialT IO Int)+    -> Spec+exceptionOps desc t = do+    prop (desc <> " before") $ beforeProp t+    prop (desc <> " after") $ afterProp t+    prop (desc <> " bracket end of stream") $ bracketProp t+#ifdef DEVBUILD+    prop (desc <> " bracket partial stream") $ bracketPartialStreamProp t+#endif+    prop (desc <> " bracket exception in stream") $ bracketExceptionProp t+    prop (desc <> " onException") $ onExceptionProp t+    prop (desc <> " finally end of stream") $ finallyProp t+#ifdef DEVBUILD+    prop (desc <> " finally partial stream") $ finallyPartialStreamProp t+#endif+    prop (desc <> " finally exception in stream") $ finallyExceptionProp t+    prop (desc <> " handle") $ handleProp t++-------------------------------------------------------------------------------+-- Compose with MonadThrow+-------------------------------------------------------------------------------++newtype ExampleException = ExampleException String deriving (Eq, Show)++instance Exception ExampleException++composeWithMonadThrow+    :: ( IsStream t+       , Semigroup (t IO Int)+       , MonadThrow (t IO)+       )+    => (t IO Int -> SerialT IO Int)+    -> Spec+composeWithMonadThrow t = do+    it "Compose throwM, nil" $+        try (tl (throwM (ExampleException "E") <> S.nil))+        `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])+    it "Compose nil, throwM" $+        try (tl (S.nil <> throwM (ExampleException "E")))+        `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])+    oneLevelNestedSum "serially" S.fromSerial+    oneLevelNestedSum "wSerially" S.fromWSerial+    oneLevelNestedSum "asyncly" S.fromAsync+    oneLevelNestedSum "wAsyncly" S.fromWAsync+    -- XXX add two level nesting++    oneLevelNestedProduct "serially" S.fromSerial+    oneLevelNestedProduct "wSerially" S.fromWSerial+    oneLevelNestedProduct "asyncly" S.fromAsync+    oneLevelNestedProduct "wAsyncly"  S.fromWAsync++    where+    tl = S.toList . t+    oneLevelNestedSum desc t1 =+        it ("One level nested sum " <> desc) $ do+            let nested = S.fromFoldable [1..10] <> throwM (ExampleException "E")+                         <> S.fromFoldable [1..10]+            try (tl (S.nil <> t1 nested <> S.fromFoldable [1..10]))+            `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])++    oneLevelNestedProduct desc t1 =+        it ("One level nested product" <> desc) $ do+            let s1 = t $ S.concatMapFoldableWith (<>) return [1..4]+                s2 = t1 $ S.concatMapFoldableWith (<>) return [5..8]+            try $ tl (do+                x <- S.adapt s1+                y <- s2+                if x + y > 10+                then throwM (ExampleException "E")+                else return (x + y)+                )+            `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])++-------------------------------------------------------------------------------+-- Cleanup tests+-------------------------------------------------------------------------------++checkCleanup :: IsStream t+    => Int+    -> (t IO Int -> SerialT IO Int)+    -> (t IO Int -> t IO Int)+    -> IO ()+checkCleanup d t op = do+    r <- newIORef (-1 :: Int)+    S.drain . fromSerial $ do+        _ <- t $ op $ delay r 0 S.|: delay r 1 S.|: delay r 2 S.|: S.nil+        return ()+    performMajorGC+    threadDelay 500000+    res <- readIORef r+    res `shouldBe` 0+    where+    delay ref i = threadDelay (i*d*100000) >> writeIORef ref i >> return i++-------------------------------------------------------------------------------+-- Some ad-hoc tests that failed at times+-------------------------------------------------------------------------------++takeCombined :: (Monad m, Semigroup (t m Int), Show a, Eq a, IsStream t)+    => Int -> (t m Int -> SerialT IO a) -> IO ()+takeCombined n t = do+    let constr = S.fromFoldable+    r <- (S.toList . t) $+            S.take n (constr ([] :: [Int]) <> constr ([] :: [Int]))+    r `shouldBe` []++-------------------------------------------------------------------------------+-- Helper operations+-------------------------------------------------------------------------------++folded :: IsStream t => [a] -> t IO a+folded =+    fromSerial .+    (\xs ->+         case xs of+             [x] -> return x -- singleton stream case+             _ -> S.concatMapFoldableWith (<>) return xs)++#ifndef COVERAGE_BUILD+makeCommonOps :: IsStream t => (t m a -> c) -> [(String, t m a -> c)]+#else+makeCommonOps :: b -> [(String, b)]+#endif+makeCommonOps t =+            [ ("default", t)+#ifndef COVERAGE_BUILD+            , ("rate AvgRate 10000", t . avgRate 10000)+            , ("rate Nothing", t . rate Nothing)+            , ("maxBuffer 0", t . maxBuffer 0)+            , ("maxThreads 0", t . maxThreads 0)+            , ("maxThreads 1", t . maxThreads 1)+            , ("maxThreads -1", t . maxThreads (-1))+#endif+            ]++#ifndef COVERAGE_BUILD+makeOps :: IsStream t => (t m a -> c) -> [(String, t m a -> c)]+#else+makeOps :: b -> [(String, b)]+#endif+makeOps t = makeCommonOps t +++            [+#ifndef COVERAGE_BUILD+              ("maxBuffer 1", t . maxBuffer 1)+#endif+            ]++mapOps :: (a -> Spec) -> [(String, a)] -> Spec+mapOps spec = mapM_ (\(desc, f) -> describe desc $ spec f)
− test/loops.hs 
@@ -1,76 +0,0 @@-import Streamly-import System.IO (stdout, hSetBuffering, BufferMode(LineBuffering))-import Streamly.Prelude (nil, yieldM, drain)--main :: IO ()-main = do-    hSetBuffering stdout LineBuffering--    putStrLn "\nloopTail:\n"-    drain $ do-        x <- loopTail 0-        yieldM $ print (x :: Int)--    putStrLn "\nloopHead:\n"-    drain $ do-        x <- loopHead 0-        yieldM $ print (x :: Int)--    putStrLn "\nloopTailA:\n"-    drain $ do-        x <- loopTailA 0-        yieldM $ print (x :: Int)--    putStrLn "\nloopHeadA:\n"-    drain $ do-        x <- loopHeadA 0-        yieldM $ print (x :: Int)--    putStrLn "\nwSerial:\n"-    drain $ do-        x <- (return 0 <> return 1) `wSerial` (return 100 <> return 101)-        yieldM $ print (x :: Int)--    putStrLn "\nParallel interleave:\n"-    drain $ do-        x <- (return 0 <> return 1) `wAsync` (return 100 <> return 101)-        yieldM $ print (x :: Int)--    where------------------------------------------------------------------------------------ Serial (single-threaded) stream generator loops----------------------------------------------------------------------------------    -- Generates a value and then loops. Can be used to generate an infinite-    -- stream. Interleaves the generator and the consumer.-    loopTail :: Int -> Serial Int-    loopTail x = do-        yieldM $ putStrLn "LoopTail..."-        return x <> (if x < 3 then loopTail (x + 1) else nil)--    -- Loops and then generates a value. The consumer can run only after the-    -- loop has finished.  An infinite generator will not let the consumer run-    -- at all.-    loopHead :: Int -> Serial Int-    loopHead x = do-        yieldM $ putStrLn "LoopHead..."-        (if x < 3 then loopHead (x + 1) else nil) <> return x------------------------------------------------------------------------------------ Concurrent (multi-threaded) adaptive demand-based stream generator loops----------------------------------------------------------------------------------    loopTailA :: Int -> Serial Int-    loopTailA x = do-        yieldM $ putStrLn "LoopTailA..."-        return x `async` (if x < 3 then loopTailA (x + 1) else nil)--    loopHeadA :: Int -> Serial Int-    loopHeadA x = do-        yieldM $ putStrLn "LoopHeadA..."-        (if x < 3 then loopHeadA (x + 1) else nil) `async` return x------------------------------------------------------------------------------------ Parallel (fairly scheduled, multi-threaded) stream generator loops--------------------------------------------------------------------------------
− test/nested-loops.hs 
@@ -1,25 +0,0 @@-import Control.Concurrent (myThreadId)-import System.IO (stdout, hSetBuffering, BufferMode(LineBuffering))-import System.Random (randomIO)-import Streamly-import Streamly.Prelude (drain, nil, yieldM)--main :: IO ()-main = drain $ do-    yieldM $ hSetBuffering stdout LineBuffering-    x <- loop "A " 2-    y <- loop "B " 2-    yieldM $ myThreadId >>= putStr . show-             >> putStr " "-             >> print (x, y)--    where--    -- we can just use-    -- parallely $ mconcat $ replicate n $ yieldM (...)-    loop :: String -> Int -> SerialT IO String-    loop name n = do-        rnd <- yieldM (randomIO :: IO Int)-        let result = name <> show rnd-            repeatIt = if n > 1 then loop name (n - 1) else nil-         in return result `wAsync` repeatIt
− test/parallel-loops.hs 
@@ -1,27 +0,0 @@-import Control.Concurrent (myThreadId, threadDelay)-import System.IO (stdout, hSetBuffering, BufferMode(LineBuffering))-import System.Random (randomIO)-import Streamly-import qualified Streamly.Prelude as S--main :: IO ()-main = do-    hSetBuffering stdout LineBuffering-    S.drain $ do-        x <- S.take 10 $ loop "A" `parallel` loop "B"-        S.yieldM $ myThreadId >>= putStr . show-               >> putStr " got "-               >> print x--    where--    -- we can just use-    -- parallely $ cycle1 $ yieldM (...)-    loop :: String -> Serial (String, Int)-    loop name = do-        S.yieldM $ threadDelay 1000000-        rnd <- S.yieldM (randomIO :: IO Int)-        S.yieldM $ myThreadId >>= putStr . show-               >> putStr " yielding "-               >> print rnd-        return (name, rnd) `parallel` loop name
+ test/streamly-tests.cabal view
@@ -0,0 +1,368 @@+cabal-version:      2.2+name:               streamly-tests+version:            0.0.0+synopsis:           Tests for streamly+description: See streamly-benchmarks for the reason why we use a separate+ package for tests.++flag fusion-plugin+  description: Use fusion plugin for benchmarks and executables+  manual: True+  default: False++flag limit-build-mem+  description: Limits memory when building the executables+  manual: True+  default: False++flag dev+  description: Development build+  manual: True+  default: False++flag has-llvm+  description: Use llvm backend for better performance+  manual: True+  default: False++flag opt+  description: off=-O0 (faster builds), on=-O2+  manual: True+  default: True++-------------------------------------------------------------------------------+-- Common stanzas+-------------------------------------------------------------------------------++common compile-options+    default-language: Haskell2010++    if os(darwin)+      cpp-options:    -DCABAL_OS_DARWIN++    if os(linux)+      cpp-options:    -DCABAL_OS_LINUX++    if os(windows)+      cpp-options:    -DCABAL_OS_WINDOWS++    if flag(dev)+      cpp-options:    -DDEVBUILD++    ghc-options:      -Wall+                      -Wcompat+                      -Wunrecognised-warning-flags+                      -Widentities+                      -Wincomplete-record-updates+                      -Wincomplete-uni-patterns+                      -Wredundant-constraints+                      -Wnoncanonical-monad-instances+                      -Rghc-timing+                      -fno-ignore-asserts++    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 -M512M -RTS++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+        TupleSections+        TypeFamilies+        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 threading-options+  ghc-options:  -threaded+                -with-rtsopts=-N++common optimization-options+  if flag(opt) || flag(fusion-plugin)+    ghc-options: -O2+                 -fdicts-strict+                 -fmax-worker-args=16+                 -fspec-constr-recursive=16+    if flag(fusion-plugin) && !impl(ghcjs) && !impl(ghc < 8.6)+      ghc-options: -fplugin Fusion.Plugin+  else+    ghc-options: -O0++common test-dependencies+  build-depends:+      streamly+    , base              >= 4.9   && < 5+    , containers        >= 0.5   && < 0.7+    , exceptions        >= 0.8   && < 0.11+    , ghc+    , hspec             >= 2.0   && < 3+    , mtl               >= 2.2   && < 3+    , random            >= 1.0.0 && < 2+    , transformers      >= 0.4   && < 0.6+    , QuickCheck        >= 2.13  && < 2.15+    , directory         >= 1.2.2 && < 1.4+    , filepath          >= 1.4.1 && < 1.5+    , temporary         >= 1.3   && < 1.4+    , network           >= 3.1   && < 3.2++  if flag(fusion-plugin) && !impl(ghcjs) && !impl(ghc < 8.6)+     build-depends:+         fusion-plugin     >= 0.2   && < 0.3++-------------------------------------------------------------------------------+-- Library+-------------------------------------------------------------------------------++common lib-options+  import: compile-options+        , optimization-options+        , default-extensions+        , test-dependencies++library+    import: lib-options, test-dependencies+    hs-source-dirs: lib+    exposed-modules: Streamly.Test.Common+                   , Streamly.Test.Prelude.Common+    if flag(limit-build-mem)+      ghc-options: +RTS -M1500M -RTS+++-------------------------------------------------------------------------------+-- Test suite options+-------------------------------------------------------------------------------++common test-options+  import: lib-options+        , threading-options+  ghc-options: -rtsopts+  include-dirs: .+  build-depends: streamly-tests++common always-optimized+  import: compile-options+        , threading-options+        , default-extensions+        , test-dependencies+  ghc-options: -O2+               -fdicts-strict+               -fmax-worker-args=16+               -fspec-constr-recursive=16+               -rtsopts+  if flag(fusion-plugin) && !impl(ghcjs) && !impl(ghc < 8.6)+    ghc-options: -fplugin Fusion.Plugin++-------------------------------------------------------------------------------+-- Test suites in sorted order+-------------------------------------------------------------------------------++test-suite Data.List+  import: test-options+  type: exitcode-stdio-1.0+  main-is: Streamly/Test/Data/List.hs+  cpp-options:  -DUSE_STREAMLY_LIST++test-suite Data.List.Base+  import: test-options+  type: exitcode-stdio-1.0+  main-is: Streamly/Test/Data/List.hs++test-suite Data.Array+  import: test-options+  type: exitcode-stdio-1.0+  main-is: Streamly/Test/Data/Array.hs+  ghc-options: -main-is Streamly.Test.Data.Array.main++test-suite Data.Array.Prim+  import: test-options+  type: exitcode-stdio-1.0+  main-is: Streamly/Test/Data/Array/Prim.hs+  ghc-options: -main-is Streamly.Test.Data.Array.Prim.main++test-suite Data.Array.Prim.Pinned+  import: test-options+  type: exitcode-stdio-1.0+  main-is: Streamly/Test/Data/Array/Prim/Pinned.hs+  ghc-options: -main-is Streamly.Test.Data.Array.Prim.Pinned.main++test-suite Data.Array.Foreign+  import: test-options+  type: exitcode-stdio-1.0+  main-is: Streamly/Test/Data/Array/Foreign.hs+  ghc-options: -main-is Streamly.Test.Data.Array.Foreign.main++test-suite Data.Fold+  import: test-options+  type: exitcode-stdio-1.0+  main-is: Streamly/Test/Data/Fold.hs++test-suite Data.Parser+  import: test-options+  type: exitcode-stdio-1.0+  main-is: Streamly/Test/Data/Parser.hs+  if flag(limit-build-mem)+    ghc-options: +RTS -M1000M -RTS++test-suite Data.Parser.ParserD+  import: test-options+  type: exitcode-stdio-1.0+  main-is: Streamly/Test/Data/Parser/ParserD.hs+  if flag(limit-build-mem)+    ghc-options: +RTS -M1000M -RTS++test-suite Data.SmallArray+  import: test-options+  type: exitcode-stdio-1.0+  main-is: Streamly/Test/Data/SmallArray.hs+  ghc-options: -main-is Streamly.Test.Data.SmallArray.main++test-suite Data.Unfold+  import: test-options+  type: exitcode-stdio-1.0+  main-is: Streamly/Test/Data/Unfold.hs++test-suite FileSystem.Event+  import: test-options+  type: exitcode-stdio-1.0+  main-is: Streamly/Test/FileSystem/Event.hs+  if os(darwin)+    buildable: False++test-suite FileSystem.Handle+  import: test-options+  type: exitcode-stdio-1.0+  main-is: Streamly/Test/FileSystem/Handle.hs+  ghc-options: -main-is Streamly.Test.FileSystem.Handle.main++test-suite Network.Inet.TCP+  import: test-options+  type: exitcode-stdio-1.0+  main-is: Streamly/Test/Network/Inet/TCP.hs++test-suite Network.Socket+  import: test-options+  type: exitcode-stdio-1.0+  main-is: Streamly/Test/Network/Socket.hs++test-suite Prelude+  import: test-options+  type: exitcode-stdio-1.0+  main-is: Streamly/Test/Prelude.hs+  ghc-options: -main-is Streamly.Test.Prelude.main++test-suite Prelude.Ahead+  import: test-options+  type: exitcode-stdio-1.0+  main-is: Streamly/Test/Prelude/Ahead.hs+  ghc-options: -main-is Streamly.Test.Prelude.Ahead.main++test-suite Prelude.Async+  import: test-options+  type: exitcode-stdio-1.0+  main-is: Streamly/Test/Prelude/Async.hs+  ghc-options: -main-is Streamly.Test.Prelude.Async.main++test-suite Prelude.Concurrent+  import: test-options+  type: exitcode-stdio-1.0+  main-is: Streamly/Test/Prelude/Concurrent.hs+  ghc-options: -main-is Streamly.Test.Prelude.Concurrent.main+  if flag(limit-build-mem)+    ghc-options: +RTS -M2000M -RTS++test-suite Prelude.Fold+  import: test-options+  type: exitcode-stdio-1.0+  main-is: Streamly/Test/Prelude/Fold.hs+  ghc-options: -main-is Streamly.Test.Prelude.Fold.main++test-suite Prelude.Parallel+  import: test-options+  type: exitcode-stdio-1.0+  main-is: Streamly/Test/Prelude/Parallel.hs+  ghc-options: -main-is Streamly.Test.Prelude.Parallel.main++test-suite Prelude.Rate+  import:always-optimized+  type: exitcode-stdio-1.0+  main-is: Streamly/Test/Prelude/Rate.hs+  ghc-options: -main-is Streamly.Test.Prelude.Rate.main+  if flag(dev)+    buildable: True+  else+    buildable: False++test-suite Prelude.Serial+  import: test-options+  type: exitcode-stdio-1.0+  main-is: Streamly/Test/Prelude/Serial.hs+  ghc-options: -main-is Streamly.Test.Prelude.Serial.main+  if flag(limit-build-mem)+    ghc-options: +RTS -M1500M -RTS+++test-suite Prelude.WAsync+  import: test-options+  type: exitcode-stdio-1.0+  main-is: Streamly/Test/Prelude/WAsync.hs+  ghc-options: -main-is Streamly.Test.Prelude.WAsync.main++test-suite Prelude.WSerial+  import: test-options+  type: exitcode-stdio-1.0+  main-is: Streamly/Test/Prelude/WSerial.hs+  ghc-options: -main-is Streamly.Test.Prelude.WSerial.main++test-suite Prelude.ZipAsync+  import: test-options+  type: exitcode-stdio-1.0+  main-is: Streamly/Test/Prelude/ZipAsync.hs+  ghc-options: -main-is Streamly.Test.Prelude.ZipAsync.main++test-suite Prelude.ZipSerial+  import: test-options+  type: exitcode-stdio-1.0+  main-is: Streamly/Test/Prelude/ZipSerial.hs+  ghc-options: -main-is Streamly.Test.Prelude.ZipSerial.main++test-suite Unicode.Stream+  import: test-options+  type: exitcode-stdio-1.0+  main-is: Streamly/Test/Unicode/Stream.hs+  ghc-options: -main-is Streamly.Test.Unicode.Stream.main++test-suite version-bounds+  import: test-options+  type: exitcode-stdio-1.0+  main-is: version-bounds.hs