packages feed

streamly 0.8.0 → 0.8.1

raw patch · 216 files changed

+24692/−14814 lines, 216 filesdep +filepathdep +unicode-datadep ~transformers

Dependencies added: filepath, unicode-data

Dependency ranges changed: transformers

Files

− .circleci/config.yml 
@@ -1,417 +0,0 @@-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 
@@ -1,1 +0,0 @@-:set -fobject-code
− .github/workflows/haskell.yml 
@@ -1,160 +0,0 @@-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 
@@ -1,17 +0,0 @@-# 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 
@@ -1,66 +0,0 @@-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 
@@ -1,78 +0,0 @@-# 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
@@ -15,6 +15,43 @@ 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. +## Build and test++Some common commands:++```+$ cabal repl+$ cabal build+$ cabal build --disable-optimization --flags -opt+$ bin/test.sh --quick+$ bin/bench.sh --quick # For nix use "--use-nix"+$ bin/run-ci --targets help # Only supported with nix+$ cabal haddock+$ cabal-docspec --timeout 60 --check-properties --property-variables xs+```++The `bin/test.sh` and `bin/bench.sh` are custom scripts to perform test+and benchmarking tasks conveniently. They support running a group of+tests or benchmarks, coverage, using correct optimization flags for+benchmarking, benchmark comparison reports etc. Use the `--help` option+to see how to use these.  See [benchmark/README.md](benchmark/README.md)+and [test/README.md](test/README.md) for more details.++You can also run tests or benchmarks directly for example:++```+$ cabal test --disable-optimization --flags -opt --test-show-details=streaming --test-option=--color streamly-tests+```++To view haddock docs open the link printed at the end of the haddock+command, in your browser.++Nix users: There is a `default.nix` available which can be used to start+a nix-shell and then use the above commands as usual. nix-shell started+by `default.nix` creates a `.cabal.nix` for cabal configuration and sets+`CABAL_DIR` environment variable to point to that. Therefore, `~/.cabal`+would not be used.+ ## Contributing A Change  If the feature makes significant changes to design, we encourage you to open an@@ -107,8 +144,9 @@  ### Testing -It is a good idea to include tests for the changes where applicable. See the-existing tests [here](test).+It is a good idea to include tests for the changes where applicable. See+the existing tests in the [test](test) directory.  Also see the+[test/README](test/README) for more details on how to run the tests.  ### Documentation @@ -182,16 +220,9 @@  ## 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.+* Use https://streamly.composewell.com/ for searching in reference docs+* Build haddock docs for latest reference docs+* See [the dev directory](dev) for design guidelines and dev documents.  ## Coding Guidelines @@ -199,6 +230,19 @@  Please see [the Haskell coding style guide](https://github.com/composewell/haskell-dev/blob/master/coding-style.rst). +### Type variable ordering++Ordering of variables in `forall` may be important in type applications. In+streams, we usually declare them in this order `t m a`.++Use the same order in constraints as well++Example,++```+func :: forall m a. (MonadIO m, Storable a) => ...+```+ ### StreamD coding style  Some conventions that we follow in the StreamD code are illustrated by the@@ -226,27 +270,3 @@ 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
@@ -2,7 +2,35 @@  <!-- See rendered changelog at https://streamly.composewell.com --> -## 0.8.0+## 0.8.1 (Nov 2021)++See docs/API-changelog.txt for new APIs introduced.++### Bug Fixes++* Several bug fixes in the Array module:+    * Fix writeN fold eating away one element when applied multiple times+      [#1258](https://github.com/composewell/streamly/issues/1258).+    * Fix potentially writing beyond allocated memory when shrinking. Likely+      cause of [#944](https://github.com/composewell/streamly/issues/944).+    * Fix potentially writing beyond allocated memory when writing the last+      element. Likely cause of +      [#944](https://github.com/composewell/streamly/issues/944).+    * Fix missing pointer touch could potentially cause use of freed memory.+    * Fix unnecessary additional allocation due to a bug+* Fix a bug in classifySessionsBy, see +  [PR #1311](https://github.com/composewell/streamly/pull/1311). The bug+  could cause premature ejection of a session when input events with the+  same key are split into multiple sessions.++### Notable Internal API Changes++* `tapAsync` from `Streamly.Internal.Data.Stream.Parallel` has been moved to+  `Streamly.Internal.Data.Stream.IsStream` and renamed to `tapAsyncK`.+* `Fold2` has now been renamed to `Refold` and the corresponding `Fold2`+  combinators have been either renamed or removed.++## 0.8.0 (Jun 2021)  See [API Changelog](docs/API-changelog.txt) for a complete list of signature changes and new APIs introduced.
LICENSE view
@@ -25,3 +25,325 @@ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++-------------------------------------------------------------------------------+base-4.12.0.0 (http://hackage.haskell.org/package/base-4.12.0.0)+-------------------------------------------------------------------------------+This library (libraries/base) is derived from code from several+sources:++  * Code from the GHC project which is largely (c) The University of+    Glasgow, and distributable under a BSD-style license (see below),++  * Code from the Haskell 98 Report which is (c) Simon Peyton Jones+    and freely redistributable (but see the full license for+    restrictions).++  * Code from the Haskell Foreign Function Interface specification,+    which is (c) Manuel M. T. Chakravarty and freely redistributable+    (but see the full license for restrictions).++The full text of these licenses is reproduced below.  All of the+licenses are BSD-style or compatible.++The Glasgow Haskell Compiler License++Copyright 2004, The University Court of the University of Glasgow.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.++- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.++- Neither name of the University nor the names of its contributors may be+used to endorse or promote products derived from this software without+specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH+DAMAGE.++Code derived from the document "Report on the Programming Language+Haskell 98", is distributed under the following license:++  Copyright (c) 2002 Simon Peyton Jones++  The authors intend this Report to belong to the entire Haskell+  community, and so we grant permission to copy and distribute it for+  any purpose, provided that it is reproduced in its entirety,+  including this Notice.  Modified versions of this Report may also be+  copied and distributed for any purpose, provided that the modified+  version is clearly presented as such, and that it does not claim to+  be a definition of the Haskell 98 Language.++Code derived from the document "The Haskell 98 Foreign Function+Interface, An Addendum to the Haskell 98 Report" is distributed under+the following license:++  Copyright (c) 2002 Manuel M. T. Chakravarty++  The authors intend this Report to belong to the entire Haskell+  community, and so we grant permission to copy and distribute it for+  any purpose, provided that it is reproduced in its entirety,+  including this Notice.  Modified versions of this Report may also be+  copied and distributed for any purpose, provided that the modified+  version is clearly presented as such, and that it does not claim to+  be a definition of the Haskell 98 Foreign Function Interface.++-------------------------------------------------------------------------------+bjoern-2008-2009 (http://bjoern.hoehrmann.de/utf-8/decoder/dfa/)+-------------------------------------------------------------------------------+Copyright (c) 2008-2009 Bjoern Hoehrmann <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.++-------------------------------------------------------------------------------+clock-0.7.2 (http://hackage.haskell.org/package/clock-0.7.2)+-------------------------------------------------------------------------------+Copyright (c) 2009-2012, Cetin Sert+Copyright (c) 2010, Eugene Kirpichov++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * The names of contributors may not be used to endorse or promote+      products derived from this software without specific prior+      written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++-------------------------------------------------------------------------------+foldl-1.4.5 (http://hackage.haskell.org/package/foldl-1.4.5)+-------------------------------------------------------------------------------+Copyright (c) 2013 Gabriel Gonzalez+All rights reserved.++Redistribution and use in source and binary forms, with or without modification,+are permitted provided that the following conditions are met:+    * Redistributions of source code must retain the above copyright notice,+      this list of conditions and the following disclaimer.+    * Redistributions in binary form must reproduce the above copyright notice,+      this list of conditions and the following disclaimer in the documentation+      and/or other materials provided with the distribution.+    * Neither the name of Gabriel Gonzalez nor the names of other contributors+      may be used to endorse or promote products derived from this software+      without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++-------------------------------------------------------------------------------+fsnotify-0.3.0.1 (http://hackage.haskell.org/package/fsnotify-0.3.0.1/)+-------------------------------------------------------------------------------+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.++-------------------------------------------------------------------------------+hfsevents-0.1.6 (http://hackage.haskell.org/package/hfsevents-0.1.6)+-------------------------------------------------------------------------------+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.++-------------------------------------------------------------------------------+primitive-0.7.0.0 (https://hackage.haskell.org/package/primitive-0.7.0.0)+-------------------------------------------------------------------------------+Copyright (c) 2008-2009, Roman Leshchinskiy+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.++- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.++- Neither name of the University nor the names of its contributors may be+used to endorse or promote products derived from this software without+specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH+DAMAGE.++-------------------------------------------------------------------------------+transient-0.5.5 (http://hackage.haskell.org/package/transient-0.5.5)+-------------------------------------------------------------------------------+Copyright © 2014-2016 Alberto G. Corona       <https://github.com/agocorona>++Permission is hereby granted, free of charge, to any person obtaining a copy of+this software and associated documentation files (the "Software"), to deal in+the Software without restriction, including without limitation the rights to+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of+the Software, and to permit persons to whom the Software is furnished to do so,+subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.++-------------------------------------------------------------------------------+vector-0.12.0.2 (http://hackage.haskell.org/package/vector-0.12.0.2)+-------------------------------------------------------------------------------+Copyright (c) 2008-2012, Roman Leshchinskiy+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.++- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.++- Neither name of the University nor the names of its contributors may be+used to endorse or promote products derived from this software without+specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH+DAMAGE.
README.md view
@@ -3,38 +3,6 @@ [![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) -<!---Link References.--->--[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--<!---Keep all the unstable links here so that they can be updated to stable-links (for online docs) before we release.--->--<!-- 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--<!-- local files -->-[LICENSE]: LICENSE-[CONTRIBUTING.md]: CONTRIBUTING.md-[docs]: docs/- Streamly is a Haskell library that provides the building blocks to build safe, scalable, modular and high performance software.  Streamly offers: @@ -111,6 +79,9 @@   version number.  As yet unreleased modules and APIs reside in the   `Internal` namespace. +Please use a minor release upper bound to adhere to the Haskell PVP when+using the pre-release (internal) modules.+ ## The Examples  ### Modular Word Counting@@ -621,7 +592,7 @@ significant way:    * Roman Leshchinskiy ([vector](http://hackage.haskell.org/package/vector))-  * Gabriel Gonzalez ([foldl](https://hackage.haskell.org/package/foldl))+  * Gabriella Gonzalez ([foldl](https://hackage.haskell.org/package/foldl))   * Alberto G. Corona ([transient](https://hackage.haskell.org/package/transient))  Please see the [`credits`](./credits/README.md) directory for a full@@ -646,3 +617,35 @@  You can also join our [community chat channel](https://gitter.im/composewell/streamly) on Gitter.++<!--+Link References.+-->++[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++<!--+Keep all the unstable links here so that they can be updated to stable+links (for online docs) before we release.+-->++<!-- 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++<!-- local files -->+[LICENSE]: LICENSE+[CONTRIBUTING.md]: CONTRIBUTING.md+[docs]: docs/
− appveyor.yml 
@@ -1,92 +0,0 @@-# 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%\""
benchmark/Streamly/Benchmark/Data/Array.hs view
@@ -13,7 +13,12 @@  import qualified Streamly.Benchmark.Data.ArrayOps as Ops import qualified Streamly.Data.Array.Foreign as A++#ifdef DATA_ARRAY+import qualified Streamly.Internal.Data.Array as IA+#else import qualified Streamly.Internal.Data.Array.Foreign as IA+#endif import qualified Streamly.Prelude  as S  import Gauge@@ -22,7 +27,6 @@  #ifdef MEMORY_ARRAY import qualified GHC.Exts as GHC-import Foreign.Storable (Storable(..)) #endif  #if !defined(DATA_ARRAY_PRIM) && !defined(DATA_ARRAY_PRIM_PINNED)@@ -36,8 +40,7 @@ #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 :: String -> (Int -> Ops.Stream a) -> Benchmark benchPureSrc name src = benchPure name src id #endif @@ -49,12 +52,11 @@ -- Drain a source that generates an array in the IO monad {-# INLINE benchIOSrc #-} benchIOSrc ::-#if !defined(DATA_ARRAY_PRIM) && !defined(DATA_ARRAY_PRIM_PINNED)+#if !defined(DATA_ARRAY_PRIM) \+    && !defined(DATA_ARRAY_PRIM_PINNED) \+    && !defined(MEMORY_ARRAY)        NFData a => #endif-#ifdef MEMORY_ARRAY-       Storable a =>-#endif        String -> (Int -> IO (Ops.Stream a)) -> Benchmark benchIOSrc name src = benchIO name src id @@ -120,12 +122,16 @@         , 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)+        , 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 value "foldable/foldl'" Ops.foldableFoldl'         , benchPureSink value "foldable/sum" Ops.foldableSum+-} #endif #endif         ]
benchmark/Streamly/Benchmark/Data/Array/Stream/Foreign.hs view
@@ -23,18 +23,26 @@     main   ) where +import Control.DeepSeq (NFData(..))+import Control.Monad (void)+import Control.Monad.Catch (MonadThrow) import Data.Functor.Identity (runIdentity) import Data.Word (Word8) import System.IO (Handle)+import System.Random (randomRIO) 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.Data.Fold as Fold+import qualified Streamly.Internal.Data.Parser.ParserD as ParserD+import qualified Streamly.Internal.Data.Stream.IsStream as Stream (arraysOf) import qualified Streamly.Internal.FileSystem.Handle as Handle import qualified Streamly.Internal.Unicode.Stream as Unicode  import Gauge hiding (env)+import Streamly.Prelude (SerialT, MonadAsync, IsStream) import Streamly.Benchmark.Common import Streamly.Benchmark.Common.Handle @@ -45,6 +53,28 @@ #endif  -------------------------------------------------------------------------------+-- 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 = Stream.unfoldrM step n+    where+    step cnt =+        if cnt > n + value+        then return Nothing+        else return (Just (cnt, cnt + 1))++{-# INLINE benchIO #-}+benchIO+    :: NFData b+    => String -> (Int -> t IO a) -> (t IO a -> IO b) -> Benchmark+benchIO name src sink =+    bench name $ nfIO $ randomRIO (1,1) >>= sink . src++------------------------------------------------------------------------------- -- read chunked using toChunks ------------------------------------------------------------------------------- @@ -184,6 +214,37 @@     ]  -------------------------------------------------------------------------------+-- Parsers+-------------------------------------------------------------------------------++{-# INLINE drainWhile #-}+drainWhile :: MonadThrow m => (a -> Bool) -> ParserD.Parser m a ()+drainWhile p = ParserD.takeWhile p Fold.drain++-------------------------------------------------------------------------------+-- Folds and parsers+-------------------------------------------------------------------------------++{-# INLINE fold #-}+fold :: SerialT IO (Array.Array Int) -> IO ()+fold s = void $ ArrayStream.fold Fold.drain s++{-# INLINE parseArray #-}+parseArray :: Int -> SerialT IO (Array.Array Int) -> IO ()+parseArray value s = void $ ArrayStream.parse (drainWhile (< value)) s++o_1_space_serial_array ::+    Int -> [Array.Array Int] -> [Array.Array Int] -> [Benchmark]+o_1_space_serial_array bound arraysSmall arraysBig =+    [ benchIO "fold (of 100)" (\_ -> Stream.fromList arraysSmall) fold+    , benchIO "fold (single)" (\_ -> Stream.fromList arraysBig) fold+    , benchIO "parse (of 100)" (\_ -> Stream.fromList arraysSmall)+        $ parseArray bound+    , benchIO "parse (single)" (\_ -> Stream.fromList arraysBig)+        $ parseArray bound+    ]++------------------------------------------------------------------------------- -- Driver ------------------------------------------------------------------------------- @@ -193,13 +254,20 @@ main :: IO () main = do     env <- mkHandleBenchEnv-    defaultMain (allBenchmarks env)+    runWithCLIOptsEnv defaultStreamSize alloc (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-          )+    alloc value = do+        small <- Stream.toList $ Stream.arraysOf 100 $ sourceUnfoldrM value 0+        big <- Stream.toList $ Stream.arraysOf value $ sourceUnfoldrM value 0+        return (small, big)++    allBenchmarks env arrays value =+        let (arraysSmall, arraysBig) = arrays+        in [ bgroup (o_1_space_prefix moduleName) $ Prelude.concat+          [ o_1_space_read_chunked env+          , o_1_space_serial_array value arraysSmall arraysBig+          , o_1_space_copy_toChunks_group_ungroup env+          ]         ]
benchmark/Streamly/Benchmark/Data/ArrayOps.hs view
@@ -26,7 +26,9 @@  #if !defined(DATA_ARRAY_PRIM) && !defined(DATA_ARRAY_PRIM_PINNED) #ifdef DEVBUILD+{- import qualified Data.Foldable as F+-} #endif #endif @@ -210,6 +212,7 @@         _ -> P.error "readInstance: no parse"  #ifdef DEVBUILD+{- {-# INLINE foldableFoldl' #-} foldableFoldl' :: Stream Int -> Int foldableFoldl' = F.foldl' (+) 0@@ -217,6 +220,7 @@ {-# INLINE foldableSum #-} foldableSum :: Stream Int -> Int foldableSum = P.sum+-} #endif #endif
benchmark/Streamly/Benchmark/Data/Fold.hs view
@@ -10,6 +10,7 @@ module Main (main) where  import Control.DeepSeq (NFData(..))+import Data.Functor.Identity (Identity) import Data.Map.Strict (Map) import Data.Monoid (Last(..), Sum(..)) import System.Random (randomRIO)@@ -98,18 +99,23 @@             (FL.any (> value))         ) -{--{-# INLINE split_ #-}-split_ :: Monad m-    => Int -> SerialT m Int -> m ()-split_ value =+{-# INLINE serial_ #-}+serial_ :: Monad m => Int -> SerialT m Int -> m Bool+serial_ value =     IP.fold-        (FL.split_+        (FL.serial_             (FL.all (<= (value `div` 2)))             (FL.any (> value))         )--} +{-# INLINE shortest #-}+shortest :: Monad m => SerialT m Int -> m (Either Int Int)+shortest = IP.fold (FL.shortest FL.sum FL.length)++{-# INLINE longest #-}+longest :: Monad m => SerialT m Int -> m (Either Int Int)+longest = IP.fold (FL.longest FL.sum FL.length)+ ------------------------------------------------------------------------------- -- Distributing by parallel application -------------------------------------------------------------------------------@@ -127,6 +133,14 @@     all_ = FL.all (<= value)     any_ = FL.any (> value) +{-# INLINE teeWithFst #-}+teeWithFst :: Monad m => SerialT m Int -> m (Int, Int)+teeWithFst = IP.fold (FL.teeWithFst (,) FL.sum FL.length)++{-# INLINE teeWithMin #-}+teeWithMin :: Monad m => SerialT m Int -> m (Int, Int)+teeWithMin = IP.fold (FL.teeWithMin (,) FL.sum FL.length)+ {-# INLINE distribute #-} distribute :: Monad m => SerialT m Int -> m [Int] distribute = IP.fold (FL.distribute [FL.sum, FL.length])@@ -135,15 +149,24 @@ -- Partitioning ------------------------------------------------------------------------------- +{-# INLINE oddEven #-}+oddEven :: Int -> Either Int Int+oddEven x = if odd x then Left x else Right x+ {-# 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)+partition = IP.fold $ FL.lmap oddEven (FL.partition FL.sum FL.length) +{-# INLINE partitionByFstM #-}+partitionByFstM :: Monad m => SerialT m Int -> m (Int, Int)+partitionByFstM =+    IP.fold (FL.partitionByFstM (return . oddEven) FL.sum FL.length)++{-# INLINE partitionByMinM #-}+partitionByMinM :: Monad m => SerialT m Int -> m (Int, Int)+partitionByMinM =+    IP.fold (FL.partitionByMinM (return . oddEven) FL.sum FL.length)+ {-# INLINE demuxWith  #-} demuxWith ::        (Monad m, Ord k)@@ -160,7 +183,7 @@     -> 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))+demuxDefaultWith f mp = S.fold (FL.demuxDefaultWith f mp (FL.lmap snd FL.sum))  {-# INLINE classifyWith #-} classifyWith ::@@ -173,8 +196,20 @@  {-# 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)+unzip = IP.fold $ FL.lmap (\a -> (a, a)) (FL.unzip FL.sum FL.length) +{-# INLINE unzipWithFstM #-}+unzipWithFstM :: Monad m => SerialT m Int -> m (Int, Int)+unzipWithFstM = do+    let f = \a -> return (a + 1, a)+    IP.fold (FL.unzipWithFstM f FL.sum FL.length)++{-# INLINE unzipWithMinM #-}+unzipWithMinM :: Monad m => SerialT m Int -> m (Int, Int)+unzipWithMinM = do+    let f = \a -> return (a + 1, a)+    IP.fold (FL.unzipWithMinM f FL.sum FL.length)+ ------------------------------------------------------------------------------- -- Benchmarks -------------------------------------------------------------------------------@@ -228,7 +263,7 @@         , benchIOSink               value               "lookup"-              (S.fold (FL.map (\a -> (a, a)) (FL.lookup (value + 1))))+              (S.fold (FL.lmap (\a -> (a, a)) (FL.lookup (value + 1))))         , benchIOSink               value               "findIndex"@@ -252,7 +287,7 @@ 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))+        [ benchIOSink value "map" (S.fold (FL.lmap (+ 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)@@ -276,12 +311,21 @@       [ bgroup             "composition"             [ benchIOSink value "serialWith (all, any)" $ splitAllAny value+            , benchIOSink value "serial_ (all, any)" $ serial_ value             , benchIOSink value "tee (all, any)" $ teeAllAny value             , benchIOSink value "many drain (take 1)" many+            , benchIOSink value "shortest (sum, length)" shortest+            , benchIOSink value "longest (sum, length)" longest             , benchIOSink value "tee (sum, length)" teeSumLength+            , benchIOSink value "teeWithFst (sum, length)" teeWithFst+            , benchIOSink value "teeWithMin (sum, length)" teeWithMin             , benchIOSink value "distribute [sum, length]" distribute             , benchIOSink value "partition (sum, length)" partition+            , benchIOSink value "partitionByFstM (sum, length)" partitionByFstM+            , benchIOSink value "partitionByMinM (sum, length)" partitionByMinM             , benchIOSink value "unzip (sum, length)" unzip+            , benchIOSink value "unzipWithFstM (sum, length)" unzipWithFstM+            , benchIOSink value "unzipWithMinM (sum, length)" unzipWithMinM             , benchIOSink value "demuxDefaultWith [sum, length] sum"                   $ demuxDefaultWith fn mp             , benchIOSink value "demuxWith [sum, length]" $ demuxWith fn mp@@ -309,8 +353,12 @@             [               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)+            , benchIOSink value "toStream"+                (S.fold FL.toStream+                    :: SerialT IO a -> IO (SerialT Identity a))+            , benchIOSink value "toStreamRev"+                (S.fold FL.toStreamRev+                    :: SerialT IO a -> IO (SerialT Identity a))             ]     ]
benchmark/Streamly/Benchmark/Data/Parser.hs view
@@ -74,6 +74,16 @@ -- Parsers ------------------------------------------------------------------------------- +{-# INLINE next #-}+next :: MonadCatch m => Int -> SerialT m Int -> m (Maybe Int)+next value = IP.parse p+ where+  p = do+    m <- PR.next+    case m of+      Just i -> if i >= value then pure m else p+      Nothing -> pure Nothing+ {-# INLINE takeBetween #-} takeBetween :: MonadCatch m => Int -> SerialT m a -> m () takeBetween value =  IP.parse (PR.takeBetween 0 value FL.drain)@@ -97,6 +107,10 @@ takeWhile :: MonadCatch m => Int -> SerialT m Int -> m () takeWhile value = IP.parse (PR.takeWhile (<= value) FL.drain) +{-# INLINE takeP #-}+takeP :: MonadCatch m => Int -> SerialT m a -> m ()+takeP value = IP.parse (PR.takeP value (PR.fromFold FL.drain))+ {-# INLINE groupBy #-} groupBy :: MonadCatch m => SerialT m Int -> m () groupBy = IP.parse (PR.groupBy (<=) FL.drain)@@ -289,11 +303,17 @@ sequence_ value =     IP.parse (F.sequence_ $ replicate value (PR.satisfy (> 0))) +{-# INLINE choiceAsum #-}+choiceAsum :: MonadCatch m => Int -> SerialT m Int -> m Int+choiceAsum value =+    IP.parse (asum (replicate value (PR.satisfy (< 0)))+        AP.<|> PR.satisfy (> 0))+ {-# INLINE choice #-} choice :: MonadCatch m => Int -> SerialT m Int -> m Int choice value =-    IP.parse (asum (replicate value (PR.satisfy (< 0)))-        AP.<|> PR.satisfy (> 0))+    IP.parse+        (PR.choice (replicate value (PR.satisfy (< 0))) AP.<|> PR.satisfy (> 0))  ------------------------------------------------------------------------------- -- Stream transformation@@ -324,9 +344,11 @@  o_1_space_serial :: Int -> [Benchmark] o_1_space_serial value =-    [ benchIOSink value "takeBetween" $ takeBetween value+    [ benchIOSink value "next" $ next value+    , benchIOSink value "takeBetween" $ takeBetween value     , benchIOSink value "takeEQ" $ takeEQ value     , benchIOSink value "takeWhile" $ takeWhile value+    , benchIOSink value "takeP" $ takeP value     , benchIOSink value "drainWhile" $ drainWhile value     , benchIOSink value "sliceBeginWith" $ sliceBeginWith value     , benchIOSink value "groupBy" $ groupBy@@ -383,6 +405,7 @@     -- non-linear time complexity (parserD)     , benchIOSink value "split_" $ split_ value     -- XXX why O(n) heap?+    , benchIOSink value "choice (asum)" $ choiceAsum value     , benchIOSink value "choice" $ choice value      -- These show non-linear time complexity.
benchmark/Streamly/Benchmark/Data/Parser/ParserD.hs view
@@ -60,6 +60,17 @@ benchIOSink value name f =     bench name $ nfIO $ randomRIO (1,1) >>= f . sourceUnfoldrM value +-- Make the input unsorted.+{-# INLINE benchIOSinkRandom #-}+benchIOSinkRandom+    :: (IsStream t, NFData b)+    => Int -> String -> (t IO Int -> IO b) -> Benchmark+benchIOSinkRandom value name f =+    bench name $ nfIO $ randomRIO (1,1)+        >>= f+        . S.map (\x -> if even x then x + 2 else x)+        . sourceUnfoldrM value+ ------------------------------------------------------------------------------- -- Parsers -------------------------------------------------------------------------------@@ -79,6 +90,10 @@ takeWhile :: MonadThrow m => Int -> SerialT m Int -> m () takeWhile value = IP.parseD (drainWhile (<= value)) +{-# INLINE takeP #-}+takeP :: MonadThrow m => Int -> SerialT m a -> m ()+takeP value = IP.parseD (PR.takeP value (PR.fromFold FL.drain))+ {-# INLINE groupBy #-} groupBy :: MonadThrow m => SerialT m Int -> m () groupBy = IP.parseD (PR.groupBy (<=) FL.drain)@@ -212,6 +227,13 @@ parseManyGroupsRolling b =     IP.drain . IP.parseManyD (PR.groupByRolling (\_ _ -> b) FL.drain) +{-# INLINE parseManyGroupsRollingEither #-}+parseManyGroupsRollingEither :: (MonadThrow m, MonadCatch m) =>+    (Int -> Int -> Bool) -> SerialT m Int -> m ()+parseManyGroupsRollingEither cmp =+       IP.drain+    .  IP.parseManyD (PR.groupByRollingEither cmp FL.drain FL.drain)+ ------------------------------------------------------------------------------- -- Parsing with unfolds -------------------------------------------------------------------------------@@ -273,11 +295,17 @@ -- choice using the "Alternative" instance with direct style parser type has -- quadratic performance complexity. --+{-# INLINE choiceAsum #-}+choiceAsum :: MonadCatch m => Int -> SerialT m Int -> m Int+choiceAsum value =+    IP.parseD (asum (replicate value (PR.satisfy (< 0)))+        AP.<|> PR.satisfy (> 0))+ {-# 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))+    IP.parseD+        (PR.choice (replicate value (PR.satisfy (< 0))) AP.<|> PR.satisfy (> 0))  ------------------------------------------------------------------------------- -- Benchmarks@@ -289,6 +317,7 @@ o_1_space_serial :: Int -> [Benchmark] o_1_space_serial value =     [ benchIOSink value "takeWhile" $ takeWhile value+    , benchIOSink value "takeP" $ takeP value     , benchIOSink value "sliceBeginWith" $ sliceBeginWith value     , benchIOSink value "groupBy" $ groupBy     , benchIOSink value "groupByRolling" $ groupByRolling@@ -316,12 +345,18 @@ o_1_space_serial_nested value =     [ benchIOSink value "parseMany" $ parseMany value     , benchIOSink value "parseMany groupBy (bound groups)"-          $ (parseManyGroups False)+          $ parseManyGroups False     , benchIOSink value "parseMany groupRollingBy (bound groups)"-          $ (parseManyGroupsRolling False)-    , benchIOSink value "parseMany groupBy (1 group)" $ (parseManyGroups True)+          $ parseManyGroupsRolling False+    , benchIOSink value "parseMany groupBy (1 group)" $ parseManyGroups True     , benchIOSink value "parseMany groupRollingBy (1 group)"-          $ (parseManyGroupsRolling True)+          $ parseManyGroupsRolling True+    , benchIOSink value "parseMany groupRollingByEither (Left)"+          $ parseManyGroupsRollingEither (<)+    , benchIOSink value "parseMany groupRollingByEither (Right)"+          $ parseManyGroupsRollingEither (>)+    , benchIOSinkRandom value "parseMany groupRollingByEither (Alternating)"+          $ parseManyGroupsRollingEither (>)     ]  o_1_space_serial_unfold :: Int -> [Array.Array Int] -> [Benchmark]@@ -351,6 +386,7 @@     , 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 (asum)/100" $ choiceAsum (value `div` 100)     , benchIOSink value "choice/100" $ choice (value `div` 100)     ]
benchmark/Streamly/Benchmark/Data/Stream/StreamK.hs view
@@ -31,8 +31,9 @@ import qualified Prelude as P import qualified Data.List as List +import qualified Streamly.Internal.Control.Concurrent as S+import qualified Streamly.Internal.Data.Stream.StreamK.Type as S import qualified Streamly.Internal.Data.Stream.StreamK as S-import qualified Streamly.Internal.Data.SVar as S  import Gauge (bench, nfIO, bgroup, Benchmark, defaultMain) @@ -127,7 +128,7 @@  {-# INLINE unfoldrM #-} unfoldrM :: S.MonadAsync m => Int -> Int -> Stream m Int-unfoldrM streamLen n = S.unfoldrM step n+unfoldrM streamLen n = S.unfoldrMWith S.consM step n     where     step cnt =         if cnt > n + streamLen@@ -148,7 +149,7 @@  {-# INLINE replicateM #-} replicateM :: S.MonadAsync m => Int -> Int -> Stream m Int-replicateM streamLen = S.replicateM streamLen . return+replicateM streamLen = S.replicateMWith S.consM streamLen . return  {-# INLINE iterate #-} iterate :: Int -> Int -> Stream m Int@@ -168,8 +169,11 @@     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 :: Foldable f+    => (Stream m b -> Stream m b -> Stream m b)+    -> (a -> Stream m b)+    -> f a+    -> Stream m b concatMapFoldableWith f g = Prelude.foldr (f . g) S.nil  {-# INLINE concatMapFoldableSerial #-}@@ -202,13 +206,13 @@         Just (_, t) -> uncons t  {-# INLINE init #-}-init :: (Monad m, S.IsStream t) => t m a -> m ()+init :: Monad m => Stream m a -> m () init s = do     t <- S.init s     P.mapM_ S.drain t  {-# INLINE tail #-}-tail :: (Monad m, S.IsStream t) => t m a -> m ()+tail :: Monad m => Stream m a -> m () tail s = S.tail s >>= P.mapM_ tail  {-# INLINE nullTail #-}@@ -265,7 +269,7 @@  {-# INLINE mapM #-} mapM :: S.MonadAsync m => Int -> Stream m Int -> m ()-mapM n = composeN n $ S.mapM return+mapM n = composeN n $ S.mapMWith S.consM return  {-# INLINE mapMSerial #-} mapMSerial :: S.MonadAsync m => Int -> Stream m Int -> m ()@@ -339,7 +343,8 @@ -- 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)+iterateScan iterStreamLen maxIters =+    iterateSource iterStreamLen (S.scanl' (+) 0) (maxIters `div` 10)  -- this is quadratic {-# INLINE iterateDropWhileFalse #-}@@ -349,23 +354,27 @@  {-# INLINE iterateMapM #-} iterateMapM :: S.MonadAsync m => Int -> Int -> Int -> Stream m Int-iterateMapM iterStreamLen maxIters = iterateSource iterStreamLen (S.mapM return) maxIters+iterateMapM iterStreamLen =+    iterateSource iterStreamLen (S.mapMWith S.consM return)  {-# INLINE iterateFilterEven #-} iterateFilterEven :: S.MonadAsync m => Int -> Int -> Int -> Stream m Int-iterateFilterEven iterStreamLen maxIters = iterateSource iterStreamLen (S.filter even) maxIters+iterateFilterEven iterStreamLen = iterateSource iterStreamLen (S.filter even)  {-# INLINE iterateTakeAll #-} iterateTakeAll :: S.MonadAsync m => Int -> Int -> Int -> Int -> Stream m Int-iterateTakeAll streamLen iterStreamLen maxIters = iterateSource iterStreamLen (S.take streamLen) maxIters+iterateTakeAll streamLen iterStreamLen =+    iterateSource iterStreamLen (S.take streamLen)  {-# INLINE iterateDropOne #-} iterateDropOne :: S.MonadAsync m => Int -> Int -> Int -> Stream m Int-iterateDropOne iterStreamLen maxIters = iterateSource iterStreamLen (S.drop 1) maxIters+iterateDropOne iterStreamLen = iterateSource iterStreamLen (S.drop 1)  {-# INLINE iterateDropWhileTrue #-}-iterateDropWhileTrue :: S.MonadAsync m => Int -> Int -> Int -> Int -> Stream m Int-iterateDropWhileTrue streamLen iterStreamLen maxIters = iterateSource iterStreamLen (S.dropWhile (<= streamLen)) maxIters+iterateDropWhileTrue :: S.MonadAsync m =>+    Int -> Int -> Int -> Int -> Stream m Int+iterateDropWhileTrue streamLen iterStreamLen =+    iterateSource iterStreamLen (S.dropWhile (<= streamLen))  ------------------------------------------------------------------------------- -- Zipping@@ -375,6 +384,18 @@ zipWith :: Monad m => Stream m Int -> m () zipWith src = drain $ S.zipWith (,) src src +{-# INLINE zipWithM #-}+zipWithM :: Monad m => Stream m Int -> m ()+zipWithM src = drain $ S.zipWithM (curry return) src src++{-# INLINE sortByK #-}+sortByK :: (a -> a -> Ordering) -> Stream m a -> Stream m a+sortByK f = S.concatPairsWith (S.mergeBy f) S.fromPure++{-# INLINE sortBy #-}+sortBy :: Monad m => Stream m Int -> m ()+sortBy = drain . sortByK compare+ ------------------------------------------------------------------------------- -- Mixed Composition -------------------------------------------------------------------------------@@ -471,7 +492,7 @@ {-# INLINE concatMapBySerial #-} concatMapBySerial :: Int -> Int -> Int -> IO () concatMapBySerial outer inner n =-    S.drain $ S.concatMapBy S.serial+    S.drain $ S.concatMapWith S.serial         (unfoldrM inner)         (unfoldrM outer n) @@ -681,7 +702,9 @@          -- This is for comparison with concatMapFoldableWith         , benchIOSrc1 "concatMapWithId (n of 1) (fromFoldable)"-            (S.drain . S.concatMapBy S.serial id . sourceConcatMapId streamLen)+            (S.drain+                . S.concatMapWith S.serial id+                . sourceConcatMapId streamLen)          , benchIOSrc1 "concatMapBy serial (n of 1)"             (concatMapBySerial streamLen 1)@@ -689,6 +712,7 @@             (concatMapBySerial streamLen2 streamLen2)         , benchIOSrc1 "concatMapBy serial (1 of n)"             (concatMapBySerial 1 streamLen)+        , benchFold "sortBy" sortBy (unfoldrM streamLen)         ]     where     streamLen2 = round (P.fromIntegral streamLen**(1/2::P.Double)) -- double nested loop@@ -725,6 +749,7 @@ o_1_space_zipping streamLen =     bgroup "zipping"         [ benchFold "zipWith" zipWith (unfoldrM streamLen)+        , benchFold "zipWithM" zipWithM (unfoldrM streamLen)         ]  o_1_space_mixed :: Int -> Benchmark
benchmark/Streamly/Benchmark/Data/Unfold.hs view
@@ -54,7 +54,7 @@ -- generate numbers up to the argument value {-# INLINE source #-} source :: Monad m => Int -> Unfold m Int Int-source n = UF.enumerateFromToIntegral n+source n = UF.supplySecond n UF.enumerateFromToIntegral  ------------------------------------------------------------------------------- -- Benchmark helpers@@ -73,7 +73,7 @@ drainTransformationDefault ::        Monad m => Int -> (Unfold m Int Int -> Unfold m c d) -> c -> m () drainTransformationDefault to =-    drainTransformation (UF.enumerateFromToIntegral to)+    drainTransformation (UF.supplySecond to UF.enumerateFromToIntegral)  {-# INLINE drainProduct #-} drainProduct ::@@ -96,7 +96,7 @@      where -    src = UF.enumerateFromToIntegral to+    src = UF.supplySecond to UF.enumerateFromToIntegral  ------------------------------------------------------------------------------- -- Operations on input@@ -122,7 +122,7 @@ supplyFirst :: Monad m => Int -> Int -> m () supplyFirst size start =     drainTransformation-        (UF.take size UF.enumerateFromStepIntegral)+        (UF.take size UF.enumerateFromThenIntegral)         (UF.supplyFirst start)         1 @@ -130,7 +130,7 @@ supplySecond :: Monad m => Int -> Int -> m () supplySecond size start =     drainTransformation-        (UF.take size UF.enumerateFromStepIntegral)+        (UF.take size UF.enumerateFromThenIntegral)         (UF.supplySecond 1)         start @@ -148,7 +148,7 @@ swap :: Monad m => Int -> Int -> m () swap size start =     drainTransformation-        (UF.take size UF.enumerateFromStepIntegral)+        (UF.take size UF.enumerateFromThenIntegral)         UF.swap         (1, start) @@ -245,15 +245,19 @@ 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 enumerateFromThenIntegral #-}+enumerateFromThenIntegral :: Monad m => Int -> Int -> m ()+enumerateFromThenIntegral size start =+    drainGeneration (UF.take size UF.enumerateFromThenIntegral) (start, 1)  {-# INLINE enumerateFromToIntegral #-} enumerateFromToIntegral :: Monad m => Int -> Int -> m () enumerateFromToIntegral size start =-    drainGeneration (UF.enumerateFromToIntegral (size + start)) start+    drainGeneration+    ( UF.supplySecond+      (size + start)+      UF.enumerateFromToIntegral+    ) start  {-# INLINE enumerateFromIntegral #-} enumerateFromIntegral :: Monad m => Int -> Int -> m ()@@ -263,18 +267,21 @@ {-# INLINE enumerateFromStepNum #-} enumerateFromStepNum :: Monad m => Int -> Int -> m () enumerateFromStepNum size start =-    drainGeneration (UF.take size (UF.enumerateFromStepNum 1)) start+    drainGeneration (UF.take size (UF.enumerateFromThenNum)) (start, 1) -{-# INLINE numFrom #-}-numFrom :: Monad m => Int -> Int -> m ()-numFrom size start = drainGeneration (UF.take size UF.numFrom) start+{-# INLINE enumerateFromNum #-}+enumerateFromNum :: Monad m => Int -> Int -> m ()+enumerateFromNum size start = drainGeneration (UF.take size UF.enumerateFromNum) 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))+            ( UF.supplySecond+              (intToDouble $ start + size)+              UF.enumerateFromToFractional+            )             (intToDouble start)  -------------------------------------------------------------------------------@@ -434,8 +441,8 @@     where      val = nthRoot 2 value-    unfoldInGen i = return (UF.enumerateFromToIntegral (i + val))-    unfoldOut = UF.enumerateFromToIntegral (start + val)+    unfoldInGen i = return (UF.supplySecond (i + val) UF.enumerateFromToIntegral)+    unfoldOut = UF.supplySecond (start + val) UF.enumerateFromToIntegral  {-# INLINE toNull #-} toNull :: Monad m => Int -> Int -> m ()@@ -638,11 +645,11 @@           , benchIO "repeatM" $ repeatM size           , benchIO "iterateM" $ iterateM size           , benchIO "fromIndicesM" $ fromIndicesM size-          , benchIO "enumerateFromStepIntegral" $ enumerateFromStepIntegral size+          , benchIO "enumerateFromThenIntegral" $ enumerateFromThenIntegral size           , benchIO "enumerateFromToIntegral" $ enumerateFromToIntegral size           , benchIO "enumerateFromIntegral" $ enumerateFromIntegral size           , benchIO "enumerateFromStepNum" $ enumerateFromStepNum size-          , benchIO "numFrom" $ numFrom size+          , benchIO "enumerateFromNum" $ enumerateFromNum size           , benchIO "enumerateFromToFractional" $ enumerateFromToFractional size           ]     ]
benchmark/Streamly/Benchmark/FileSystem/Handle/ReadWrite.hs view
@@ -24,7 +24,7 @@  import System.IO (Handle) import Prelude hiding (last, length)-import Streamly.Internal.Data.Array.Foreign.Type (defaultChunkSize)+import Streamly.Internal.System.IO (defaultChunkSize)  import qualified Streamly.FileSystem.Handle as FH import qualified Streamly.Internal.Data.Unfold as IUF
benchmark/Streamly/Benchmark/Prelude/Async.hs view
@@ -9,7 +9,7 @@  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 qualified Streamly.Internal.Data.Stream.IsStream.Transform as Transform  import Streamly.Benchmark.Common import Streamly.Benchmark.Prelude@@ -48,7 +48,7 @@ foldrSShared count n =       S.drain     $ fromAsync-    $ Internal.foldrSShared (\x xs -> S.consM (return x) xs) S.nil+    $ Transform.foldrSShared (\x xs -> S.consM (return x) xs) S.nil     $ fromSerial     $ sourceUnfoldrM count n
+ benchmark/Streamly/Benchmark/Prelude/Merge.hs view
@@ -0,0 +1,296 @@+-- |+-- Module      : Main+-- Copyright   : (c) 2018 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com++{-# LANGUAGE BangPatterns #-}+{-# 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.Internal.Data.Stream.IsStream (SerialT)+import qualified Data.List as List+import qualified Streamly.Internal.Data.Stream.IsStream as Stream+-- import qualified Streamly.Internal.Data.Unfold as Unfold++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.Merge"++-------------------------------------------------------------------------------+-- Merging+-------------------------------------------------------------------------------++{-# INLINE mergeWith #-}+mergeWith ::+    (  (Int -> Int -> Ordering)+    -> SerialT IO Int+    -> SerialT IO Int+    -> SerialT IO Int+    )+    -> (Int -> Int -> Ordering)+    -> Int -> Int -> IO ()+mergeWith g cmp count n =+    Stream.drain+        $ g+            cmp+            (sourceUnfoldrM count n)+            (sourceUnfoldrM count (n + 1))++{-# INLINE mergeWithM #-}+mergeWithM ::+    (  (Int -> Int -> IO Ordering)+    -> SerialT IO Int+    -> SerialT IO Int+    -> SerialT IO Int+    )+    -> (Int -> Int -> Ordering)+    -> Int -> Int -> IO ()+mergeWithM g cmp count n =+    Stream.drain+        $ g+            (\a b -> return $ cmp a b)+            (sourceUnfoldrM count n)+            (sourceUnfoldrM count (n + 1))++{-# INLINE mergeBy #-}+mergeBy :: (Int -> Int -> Ordering) -> Int -> Int -> IO ()+mergeBy = mergeWith Stream.mergeBy++{-# INLINE mergeByM #-}+mergeByM :: (Int -> Int -> Ordering) -> Int -> Int -> IO ()+mergeByM = mergeWithM Stream.mergeByM++{-# INLINE mergeByMFused #-}+mergeByMFused :: (Int -> Int -> Ordering) -> Int -> Int -> IO ()+mergeByMFused = mergeWithM Stream.mergeByMFused++#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++{-# INLINE _mergeByMFusedCheck #-}+_mergeByMFusedCheck :: IO ()+_mergeByMFusedCheck = mergeWithM Stream.mergeByMFused compare 0 0++inspect $ hasNoTypeClasses '_mergeByMFusedCheck+inspect $ '_mergeByMFusedCheck `hasNoType` ''SPEC+inspect $ '_mergeByMFusedCheck `hasNoType` ''D.Step+#endif++{-# INLINE concatPairsWithMergeBy #-}+concatPairsWithMergeBy :: (Int -> Int -> Ordering) -> Int -> Int -> Int -> IO ()+concatPairsWithMergeBy cmp = concatPairsWith (Stream.mergeBy cmp)++{-# INLINE concatPairsWithMergeByFused #-}+concatPairsWithMergeByFused ::+    (Int -> Int -> Ordering) -> Int -> Int -> Int -> IO ()+concatPairsWithMergeByFused cmp =+    concatPairsWith (Stream.mergeByMFused (\x y -> return $ cmp x y))++-------------------------------------------------------------------------------+-- Interleaving+-------------------------------------------------------------------------------++o_1_space_joining :: Int -> [Benchmark]+o_1_space_joining value =+    [ bgroup "joining (2 of n/2)"+        [ benchIOSrc1+            "mergeBy compare"+            (mergeBy compare (value `div` 2))+        , benchIOSrc1+            "mergeByM compare"+            (mergeByM compare (value `div` 2))+        , benchIOSrc1+            "mergeByMFused compare"+            (mergeByMFused compare (value `div` 2))++        , benchIOSrc1+            "mergeBy (flip compare)"+            (mergeBy (flip compare) (value `div` 2))+        , benchIOSrc1+            "mergeByM (flip compare)"+            (mergeByM (flip compare) (value `div` 2))+        , benchIOSrc1+            "mergeByMFused (flip compare)"+            (mergeByMFused (flip compare) (value `div` 2))++        , benchIOSrc1+            "concatPairsWithMergeBy compare"+            (concatPairsWithMergeBy compare 2 (value `div` 2))+        , benchIOSrc1+            "concatPairsWithMergeBy (flip compare)"+            (concatPairsWithMergeBy (flip compare) 2 (value `div` 2))++        , benchIOSrc1+            "concatPairsWithMergeByFused compare"+            (concatPairsWithMergeByFused compare 2 (value `div` 2))+        , benchIOSrc1+            "concatPairsWithMergeByFused (flip compare)"+            (concatPairsWithMergeByFused (flip compare) 2 (value `div` 2))+        ]+    ]++-------------------------------------------------------------------------------+-- Concat+-------------------------------------------------------------------------------++{-+{-# INLINE sourceUnfoldrMUF #-}+-- (count, value)+sourceUnfoldrMUF :: Monad m => Int -> UF.Unfold m (Int, Int) Int+sourceUnfoldrMUF count = UF.unfoldrM step+    where+    step (cnt, start) =+        return $+            if cnt > start + count+            then Nothing+            else Just (cnt, (cnt + 1, start))++{-# INLINE unfoldManyMergeBy #-}+unfoldManyMergeBy :: Int -> Int -> Int -> IO ()+unfoldManyMergeBy outer inner n =+    S.drain $ (Internal.unfoldManyMergeBy compare)+        -- (UF.lmap return (UF.replicateM inner))+        (UF.lmap (\x -> (x,x)) (sourceUnfoldrMUF inner))+        (sourceUnfoldrM outer n)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'unfoldManyMergeBy+-- inspect $ 'unfoldManyMergeBy `hasNoType` ''SPEC+-- inspect $ 'unfoldManyMergeBy `hasNoType`+--      ''D.ConcatUnfoldMergeState+#endif+-}++{-# INLINE sortBy #-}+sortBy :: (Int -> Int -> Ordering) -> SerialT IO Int -> IO ()+sortBy cmp = Stream.drain . Stream.sortBy cmp++{-+-- For fair comparison with concatPairs, removed sorted segmentation+{-# INLINE listSortBy #-}+listSortBy :: (a -> a -> Ordering) -> [a] -> [a]+listSortBy cmp = mergeAll . sequences+  where+    sequences = fmap (: [])++    mergeAll [x] = x+    mergeAll xs  = mergeAll (mergePairs xs)++    mergePairs (a:b:xs) = let !x = merge a b+                          in x : mergePairs xs+    mergePairs xs       = xs++    merge as@(a:as') bs@(b:bs')+      | a `cmp` b == GT = b:merge as  bs'+      | otherwise       = a:merge as' bs+    merge [] bs         = bs+    merge as []         = as+-}++o_n_heap_concat :: Int -> [Benchmark]+o_n_heap_concat value =+    [ bgroup "concatPairsWith"+        [ benchIOSrc1+            "concatPairsWithMergeBy compare (n of 1)"+            (concatPairsWithMergeBy compare value 1)+        , benchIOSrc1+            "concatPairsWithMergeBy compare (sqrtVal of sqrtVal)"+            (concatPairsWithMergeBy compare sqrtVal sqrtVal)++        , benchIOSrc1+            "concatPairsWithMergeBy (flip compare) (n of 1)"+            (concatPairsWithMergeBy (flip compare) value 1)+        , benchIOSrc1+            "concatPairsWithMergeBy (flip compare) (sqrtVal of sqrtVal)"+            (concatPairsWithMergeBy (flip compare) sqrtVal sqrtVal)++        , benchIOSrc1+            "concatPairsWithMergeByFused compare (n of 1)"+            (concatPairsWithMergeByFused compare value 1)+        , benchIOSrc1+            "concatPairsWithMergeByFused compare (sqrtVal of sqrtVal)"+            (concatPairsWithMergeByFused compare sqrtVal sqrtVal)+        ]+    -- TODO: change sourceUnfoldrM to generate alternating bigger and lower+    -- numbers to simulate a random input for a worst case sort benchmark. We+    -- can use 0 and value as two ints in the state and alternate each in the+    -- output streams, incrementing the lower number of decrementing the higher+    -- number.+    , bgroup "sorting"+        [ benchIOSink value "sortBy compare" (sortBy compare)+        , benchIOSink value "sortBy (flip compare)" (sortBy (flip compare))+        , benchIOSink value "sortBy compare randomized"+            (sortBy compare . Stream.map (\x -> if even x then x + 2 else x))+        {-+        , bench "sortByLists compare"+            $ nf (\x -> listSortBy compare [1..x]) value+        , bench "sortByLists (flip compare)"+            $ nf (\x -> listSortBy (flip compare) [1..x]) value+        , bench "sortByLists compare randomized"+            $ nf (\x -> listSortBy compare+                    (map (\n -> if even n then n + 2 else n) [1..x])+                 )+                 value+        -}+        , bench "sortByLists compare"+            $ nf (\x -> List.sortBy compare [1..x]) value+        , bench "sortByLists (flip compare)"+            $ nf (\x -> List.sortBy (flip compare) [1..x]) value+        , bench "sortByLists compare randomized"+            $ nf (\x -> List.sortBy compare+                    (map (\n -> if even n then n + 2 else n) [1..x])+                 )+                 value+        ]+    ]++    where++    sqrtVal = round $ sqrt (fromIntegral value :: Double)++-------------------------------------------------------------------------------+-- 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) (o_1_space_joining size)+        , bgroup (o_n_heap_prefix moduleName) (o_n_heap_concat size)+        ]
benchmark/Streamly/Benchmark/Prelude/Parallel.hs view
@@ -15,7 +15,6 @@  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@@ -72,7 +71,7 @@  {-# INLINE tapAsyncS #-} tapAsyncS :: S.MonadAsync m => Int -> SerialT m Int -> m ()-tapAsyncS n = composeN n $ Par.tapAsync S.sum+tapAsyncS n = composeN n $ Internal.tapAsyncK S.sum  {-# INLINE tapAsync #-} tapAsync :: S.MonadAsync m => Int -> SerialT m Int -> m ()
benchmark/Streamly/Benchmark/Prelude/Serial.hs view
@@ -16,11 +16,11 @@ 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.NestedStream as NestedStream 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 qualified Serial.Transformation as Transformation+import qualified Serial.NestedFold as NestedFold+import qualified Serial.Lift as Lift  import Streamly.Benchmark.Common @@ -44,10 +44,10 @@     allBenchmarks env size = Prelude.concat         [ Generation.benchmarks moduleName size         , Elimination.benchmarks moduleName size-        , Exceptions.benchmarks moduleName env+        , Exceptions.benchmarks moduleName env size         , Split.benchmarks moduleName env-        , Transformation1.benchmarks moduleName size-        , Transformation2.benchmarks moduleName size-        , Transformation3.benchmarks moduleName size-        , Nested.benchmarks moduleName size+        , Transformation.benchmarks moduleName size+        , NestedFold.benchmarks moduleName size+        , Lift.benchmarks moduleName size+        , NestedStream.benchmarks moduleName size         ]
benchmark/Streamly/Benchmark/Prelude/Serial/Elimination.hs view
@@ -539,7 +539,8 @@     [ 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+        , benchIOSink value "toStreamRev"+            (Internal.toStreamRev :: (SerialT IO Int -> IO (SerialT Identity Int)))         ]     ] @@ -548,7 +549,8 @@     [ 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+        , benchIOSink value "toStream"+            (Internal.toStream :: (SerialT IO Int -> IO (SerialT Identity Int)))         ]     ]
benchmark/Streamly/Benchmark/Prelude/Serial/Exceptions.hs view
@@ -20,9 +20,12 @@  module Serial.Exceptions (benchmarks) where -import Control.Exception (SomeException)+import Control.Exception (SomeException, Exception, throwIO) import System.IO (Handle, hClose, hPutChar) +import qualified Data.IORef as Ref+import qualified Data.Map.Strict as Map+ import qualified Streamly.FileSystem.Handle as FH import qualified Streamly.Internal.Data.Unfold as IUF import qualified Streamly.Internal.FileSystem.Handle as IFH@@ -44,6 +47,79 @@ -- stream exceptions ------------------------------------------------------------------------------- +data BenchException+    = BenchException1+    | BenchException2+    deriving (Show, Eq, Ord)++instance Exception BenchException++retryNoneSimple :: Int -> Int -> IO ()+retryNoneSimple length from =+    IP.drain+        $ IP.retry (Map.singleton BenchException1 length) (const S.nil) source++    where++    source = S.enumerateFromTo from (from + length)++retryNone :: Int -> Int -> IO ()+retryNone length from = do+    ref <- Ref.newIORef (0 :: Int)+    IP.drain+        $ IP.retry (Map.singleton BenchException1 length) (const S.nil)+        $ source ref++    where++    source ref =+        IP.replicateM (from + length)+            $ Ref.modifyIORef' ref (+ 1) >> Ref.readIORef ref++retryAll :: Int -> Int -> IO ()+retryAll length from = do+    ref <- Ref.newIORef 0+    IP.drain+        $ IP.retry (Map.singleton BenchException1 (length + from)) (const S.nil)+        $ source ref++    where++    source ref =+        IP.fromEffect+            $ do+                Ref.modifyIORef' ref (+ 1)+                val <- Ref.readIORef ref+                if val >= length+                then return length+                else throwIO BenchException1++retryUnknown :: Int -> Int -> IO ()+retryUnknown length from = do+    IP.drain+        $ IP.retry (Map.singleton BenchException1 length) (const source)+        $ throwIO BenchException2 `S.before` S.nil++    where++    source = S.enumerateFromTo from (from + length)+++o_1_space_serial_exceptions :: Int -> [Benchmark]+o_1_space_serial_exceptions length =+    [ bgroup+          "exceptions/serial"+          [ benchIOSrc1 "retryNoneSimple" (retryNoneSimple length)+          , benchIOSrc1 "retryNone" (retryNone length)+          , benchIOSrc1 "retryAll" (retryAll length)+          , benchIOSrc1 "retryUnknown" (retryUnknown length)+          ]+    ]++-------------------------------------------------------------------------------+-- copy stream exceptions+-------------------------------------------------------------------------------+ -- | Send the file contents to /dev/null with exception handling readWriteOnExceptionStream :: Handle -> Handle -> IO () readWriteOnExceptionStream inh devNull =@@ -230,11 +306,12 @@     ]  -benchmarks :: String -> BenchEnv -> [Benchmark]-benchmarks moduleName env =+benchmarks :: String -> BenchEnv -> Int -> [Benchmark]+benchmarks moduleName env size =         [ 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+            , o_1_space_serial_exceptions size             ]         ]
+ benchmark/Streamly/Benchmark/Prelude/Serial/Lift.hs view
@@ -0,0 +1,123 @@+-- |+-- Module      : Serial.Lift+-- Copyright   : (c) 2018 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}++module Serial.Lift (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 #-}+{-# SPECIALIZE iterateState :: Int -> SerialT (StateT Int IO) Int #-}+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/Serial/Nested.hs 
@@ -1,486 +0,0 @@--- |--- 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/NestedFold.hs view
@@ -0,0 +1,463 @@+-- |+-- Module      : Serial.NestedFold+-- 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.NestedFold (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 Streamly.Internal.Data.Refold.Type as Refold+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 refoldMany #-}+refoldMany :: Monad m => SerialT m Int -> m ()+refoldMany =+      S.drain+    . S.map getSum+    . Internal.refoldMany (Refold.take 2 Refold.sconcat) (return mempty)+    . 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) (return (Sum 0))+        . S.map Sum++{-# INLINE refoldIterateM #-}+refoldIterateM :: Monad m => SerialT m Int -> m ()+refoldIterateM =+    S.drain+        . S.map getSum+        . Internal.refoldIterateM+            (Refold.take 2 Refold.sconcat) (return (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 "refoldMany" refoldMany+        , benchIOSink value "foldIterateM" foldIterateM+        , benchIOSink value "refoldIterateM" refoldIterateM+        ]+    ]++-------------------------------------------------------------------------------+-- 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'++o_n_heap_buffering :: Int -> [Benchmark]+o_n_heap_buffering value =+    [ bgroup "buffered"+        [+        -- Reversing a stream+          benchIOSink value "reverse" (reverse 1)+        , benchIOSink value "reverse'" (reverse' 1)++        , 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/NestedStream.hs view
@@ -0,0 +1,443 @@+-- |+-- Module      : Serial.NestedStream+-- 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.NestedStream (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++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))+        ]+    ]++-------------------------------------------------------------------------------+-- 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 concatPairWithSerial #-}+concatPairWithSerial :: Int -> Int -> Int -> IO ()+concatPairWithSerial = concatPairsWith Internal.serial++{-# INLINE concatPairWithAppend #-}+concatPairWithAppend :: Int -> Int -> Int -> IO ()+concatPairWithAppend = concatPairsWith Internal.append++-- 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)+        ]+    ]++    where++    sqrtVal = round $ sqrt (fromIntegral value :: Double)++o_n_space_concat :: Int -> [Benchmark]+o_n_space_concat value = sqrtVal `seq`+    [ bgroup "concat"+        [+        -------------------concatPairsWith-----------------++        -- Use large number of streams to check scalability++          benchIOSrc1 "concatPairWithSerial (n of 1)"+            (concatPairWithSerial value 1)+        , benchIOSrc1 "concatPairWithSerial (sqrtVal of sqrtVal)"+            (concatPairWithSerial sqrtVal sqrtVal)+        , benchIOSrc1 "concatPairWithSerial (2 of n/2)"+            (concatPairWithSerial 2 (value `div` 2))++        , benchIOSrc1 "concatPairWithAppend (n of 1)"+            (concatPairWithAppend value 1)+        , benchIOSrc1 "concatPairWithAppend (sqrtVal of sqrtVal)"+            (concatPairWithAppend sqrtVal sqrtVal)+        ]+    ]++    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+            , o_n_space_concat size+            ]+        ]
+ benchmark/Streamly/Benchmark/Prelude/Serial/Transformation.hs view
@@ -0,0 +1,567 @@+-- |+-- Module      : Serial.Transformation+-- 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.Transformation (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/Transformation1.hs 
@@ -1,567 +0,0 @@--- |--- 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 
@@ -1,449 +0,0 @@--- |--- 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 
@@ -1,122 +0,0 @@--- |--- 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/WSerial.hs view
@@ -88,19 +88,55 @@ 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)-        ]-    ]+{-# INLINE sourceUnfoldrMUF #-}+-- (count, value)+sourceUnfoldrMUF :: Monad m => Int -> UF.Unfold m (Int, Int) Int+sourceUnfoldrMUF count = UF.unfoldrM step+    where+    step (cnt, start) =+        return $+            if cnt > start + count+            then Nothing+            else Just (cnt, (cnt + 1, start)) ----------------------------------------------------------------------------------- Concat--------------------------------------------------------------------------------+{-# INLINE unfoldManyInterleave #-}+unfoldManyInterleave :: Int -> Int -> Int -> IO ()+unfoldManyInterleave outer inner n =+    S.drain $ Internal.unfoldManyInterleave+        -- (UF.lmap return (UF.replicateM inner))+        (UF.lmap (\x -> (x,x)) (sourceUnfoldrMUF inner))+        (sourceUnfoldrM outer n) +#ifdef INSPECTION+inspect $ hasNoTypeClasses 'unfoldManyInterleave+-- inspect $ 'unfoldManyInterleave `hasNoType` ''SPEC+-- inspect $ 'unfoldManyInterleave `hasNoType`+--      ''D.ConcatUnfoldInterleaveState+#endif++{-# INLINE unfoldManyRoundRobin #-}+unfoldManyRoundRobin :: Int -> Int -> Int -> IO ()+unfoldManyRoundRobin outer inner n =+    S.drain $ Internal.unfoldManyRoundRobin+        -- (UF.lmap return (UF.replicateM inner))+        (UF.lmap (\x -> (x,x)) (sourceUnfoldrMUF inner))+        (sourceUnfoldrM outer n)++#ifdef INSPECTION+inspect $ hasNoTypeClasses 'unfoldManyRoundRobin+-- inspect $ 'unfoldManyRoundRobin `hasNoType` ''SPEC+-- inspect $ 'unfoldManyRoundRobin `hasNoType`+--      ''D.ConcatUnfoldInterleaveState+#endif++{-# INLINE concatPairsWithWSerial #-}+concatPairsWithWSerial :: Int -> Int -> Int -> IO ()+concatPairsWithWSerial = concatPairsWith Internal.wSerial++{-# INLINE concatPairsWithRoundrobin #-}+concatPairsWithRoundrobin :: Int -> Int -> Int -> IO ()+concatPairsWithRoundrobin = concatPairsWith Internal.roundrobin+ {-# INLINE concatMapWithWSerial #-} concatMapWithWSerial :: Int -> Int -> Int -> IO () concatMapWithWSerial = concatStreamsWith wSerial@@ -110,86 +146,198 @@ inspect $ 'concatMapWithWSerial `hasNoType` ''SPEC #endif +o_1_space_joining :: Int -> [Benchmark]+o_1_space_joining value =+    [ bgroup "joining (2 of n/2)"+        [ benchIOSrc1 "wSerial" (wSerial2 value)+        , benchIOSrc1 "interleave" (interleave2 value)+        , benchIOSrc1 "roundRobin" (roundRobin2 value)+        , benchIOSrc1+              "concatMapWithWSerial"+              (concatMapWithWSerial 2 (value `div` 2))+        , benchIOSrc1+              "concatMapWithInterleave"+              (concatStreamsWith Internal.interleave 2 (value `div` 2))+        , benchIOSrc1+              "concatMapWithRoundrobin"+              (concatStreamsWith Internal.roundrobin 2 (value `div` 2))+        , benchIOSrc1+              "unfoldManyInterleave"+              (unfoldManyInterleave 2 (value `div` 2))+        , benchIOSrc1+            "concatPairsWithWSerial"+            (concatPairsWithWSerial 2 (value `div` 2))+        , benchIOSrc1+            "concatPairsWithRoundrobin"+            (concatPairsWithRoundrobin 2 (value `div` 2))+        ]+    ]++-------------------------------------------------------------------------------+-- Concat+-------------------------------------------------------------------------------+ o_1_space_concat :: Int -> [Benchmark] o_1_space_concat value =-    [ bgroup "concat"+    [ bgroup "concatMapWith"         [ benchIOSrc1-              "concatMapWithWSerial (2,x/2)"-              (concatMapWithWSerial 2 (value `div` 2))+            "concatMapWithWSerial (n of 1)"+            (concatStreamsWith wSerial value 1)         , benchIOSrc1-              "concatMapWithWSerial (x/2,2)"-              (concatMapWithWSerial (value `div` 2) 2)+            "concatMapWithWSerial (sqrtVal of sqrtVal)"+            (concatStreamsWith wSerial sqrtVal sqrtVal)         ]     ] -{-# INLINE unfoldManyInterleaveRepl4xN #-}-unfoldManyInterleaveRepl4xN :: Int -> Int -> IO ()-unfoldManyInterleaveRepl4xN value n =-    S.drain $ Internal.unfoldManyInterleave-        (UF.lmap return (UF.replicateM 4))-        (sourceUnfoldrM (value `div` 4) n)+    where -#ifdef INSPECTION-inspect $ hasNoTypeClasses 'unfoldManyInterleaveRepl4xN--- inspect $ 'unfoldManyInterleaveRepl4xN `hasNoType` ''SPEC--- inspect $ 'unfoldManyInterleaveRepl4xN `hasNoType`---      ''D.ConcatUnfoldInterleaveState-#endif+    sqrtVal = round $ sqrt (fromIntegral value :: Double) -{-# INLINE unfoldManyRoundRobinRepl4xN #-}-unfoldManyRoundRobinRepl4xN :: Int -> Int -> IO ()-unfoldManyRoundRobinRepl4xN value n =-    S.drain $ Internal.unfoldManyRoundRobin-        (UF.lmap return (UF.replicateM 4))-        (sourceUnfoldrM (value `div` 4) n)+o_n_space_concat :: Int -> [Benchmark]+o_n_space_concat value =+    [ bgroup "concatMapWith"+        [+        -- concatMapWith using StreamD versions of interleave operations are+        -- all quadratic, we just measure the sqrtVal benchmark for comparison.+          benchIOSrc1+            "concatMapWithInterleave (sqrtVal of 1)"+            (concatStreamsWith Internal.interleave sqrtVal 1)+        , benchIOSrc1+            "concatMapWithInterleave (sqrtVal of sqrtVal)"+            (concatStreamsWith Internal.interleave sqrtVal sqrtVal)+        , benchIOSrc1+            "concatMapWithRoundrobin (sqrtVal of sqrtVal)"+            (concatStreamsWith Internal.roundrobin sqrtVal sqrtVal)+        ]+    ] -#ifdef INSPECTION-inspect $ hasNoTypeClasses 'unfoldManyRoundRobinRepl4xN--- inspect $ 'unfoldManyRoundRobinRepl4xN `hasNoType` ''SPEC--- inspect $ 'unfoldManyRoundRobinRepl4xN `hasNoType`---      ''D.ConcatUnfoldInterleaveState-#endif+    where +    sqrtVal = round $ sqrt (fromIntegral value :: Double)++{-# INLINE concatPairsWithInterleave #-}+concatPairsWithInterleave :: Int -> Int -> Int -> IO ()+concatPairsWithInterleave = concatPairsWith Internal.interleave++{-# INLINE concatPairsWithInterleaveSuffix #-}+concatPairsWithInterleaveSuffix :: Int -> Int -> Int -> IO ()+concatPairsWithInterleaveSuffix = concatPairsWith Internal.interleaveSuffix++{-# INLINE concatPairsWithInterleaveInfix #-}+concatPairsWithInterleaveInfix :: Int -> Int -> Int -> IO ()+concatPairsWithInterleaveInfix = concatPairsWith Internal.interleaveInfix++{-# INLINE concatPairsWithInterleaveMin #-}+concatPairsWithInterleaveMin :: Int -> Int -> Int -> IO ()+concatPairsWithInterleaveMin = concatPairsWith Internal.interleaveMin+ o_n_heap_concat :: Int -> [Benchmark] o_n_heap_concat value =-    [ bgroup "concat"+    [ bgroup "concatPairsWith"         [-          -- 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)+              "unfoldManyInterleave (n of 1)"+              (unfoldManyInterleave value 1)         , benchIOSrc1-              "unfoldManyRoundRobinRepl (x/4,4)"-              (unfoldManyRoundRobinRepl4xN value)+              "unfoldManyInterleave (sqrtVal of sqrtVal)"+              (unfoldManyInterleave sqrtVal sqrtVal)++        , benchIOSrc1+              "unfoldManyRoundRobin (n of 1)"+              (unfoldManyRoundRobin value 1)+        , benchIOSrc1+              "unfoldManyRoundRobin (sqrtVal of sqrtVal)"+              (unfoldManyRoundRobin sqrtVal sqrtVal)++        , benchIOSrc1+            "concatPairsWithWSerial (n of 1)"+            (concatPairsWithWSerial value 1)+        , benchIOSrc1+            "concatPairsWithWSerial (sqrtVal of sqrtVal)"+            (concatPairsWithWSerial sqrtVal sqrtVal)++        , benchIOSrc1+            "concatPairsWithInterleave (n of 1)"+            (concatPairsWithInterleave value 1)+        , benchIOSrc1+            "concatPairsWithInterleave (sqrtVal of sqrtVal)"+            (concatPairsWithInterleave sqrtVal sqrtVal)++        , benchIOSrc1+            "concatPairsWithInterleaveSuffix (n of 1)"+            (concatPairsWithInterleaveSuffix value 1)+        , benchIOSrc1+            "concatPairsWithInterleaveSuffix (sqrtVal of sqrtVal)"+            (concatPairsWithInterleaveSuffix sqrtVal sqrtVal)++        , benchIOSrc1+            "concatPairsWithInterleaveInfix (n of 1)"+            (concatPairsWithInterleaveInfix value 1)+        , benchIOSrc1+            "concatPairsWithInterleaveInfix (sqrtVal of sqrtVal)"+            (concatPairsWithInterleaveInfix sqrtVal sqrtVal)++        , benchIOSrc1+            "concatPairsWithInterleaveMin (n of 1)"+            (concatPairsWithInterleaveMin value 1)+        , benchIOSrc1+            "concatPairsWithInterleaveMin (sqrtVal of sqrtVal)"+            (concatPairsWithInterleaveMin sqrtVal sqrtVal)++        , benchIOSrc1+            "concatPairsWithRoundrobin (n of 1)"+            (concatPairsWithRoundrobin value 1)+        , benchIOSrc1+            "concatPairsWithRoundrobin (sqrtVal of sqrtVal)"+            (concatPairsWithRoundrobin sqrtVal sqrtVal)         ]     ] +    where++    sqrtVal = round $ sqrt (fromIntegral value :: Double)+ ------------------------------------------------------------------------------- -- 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+    [ bgroup "outer-product"+        [ benchIO+            "drain applicative (+) (sqrtVal of sqrtVal)"+            (toNullAp value fromWSerial)+        , benchIO+            "drain monad (+) (sqrtVal of sqrtVal)"+            (toNullM value fromWSerial)+        , benchIO+            "drain monad (+) (cbrtVal of cbrtVal of cbrtVal)"+            (toNullM3 value fromWSerial)+        , benchIO+            "filterAllOut monad (+) (sqrtVal of sqrtVal)"+            (filterAllOutM value fromWSerial)+        , benchIO+            "filterAllIn monad (+) (sqrtVal of sqrtVal)"+            (filterAllInM value fromWSerial)+        , benchIO+            "filterSome monad (+) (sqrtVal of sqrtVal)"+            (filterSome value fromWSerial)+        , benchIO+            "breakAfterSome monad (+) (sqrtVal of sqrtVal)"+            (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+        "outer-product"+        [ benchIO+            "toList monad (+) (sqrtVal of sqrtVal)"+            (toListM value fromWSerial)+        , benchIO+            "toListSome monad (+) (sqrtVal of sqrtVal)"+            (toListSome value fromWSerial)         ]     ] @@ -214,5 +362,6 @@             , 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)+        , bgroup (o_n_space_prefix moduleName) $+            o_n_space_outerProduct size ++ o_n_space_concat size         ]
benchmark/Streamly/Benchmark/Prelude/ZipSerial.hs view
@@ -84,11 +84,26 @@ inspect $ 'zipWithM `hasNoType` ''D.Step #endif +{-+{-# INLINE concatMapWithZip #-}+concatMapWithZip :: Int -> Int -> Int -> IO ()+concatMapWithZip = concatStreamsWith (S.zipWith (+))+-}++{-# INLINE concatPairsWithZip #-}+concatPairsWithZip :: Int -> Int -> Int -> IO ()+concatPairsWithZip = concatPairsWith (S.zipWith (+))+ 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))+        [ benchIOSrc1 "zip (2 of n/2)" (zipWith (value `div` 2))+        , benchIOSrc1 "zipM (2 of n/2)" (zipWithM (value `div` 2))+        {-+        -- Not correct because of nil stream at end issue.+        , benchIOSrc1 "concatMapWithZip (+) (2 of n/2)"+            (concatMapWithZip 2 (value `div` 2))+        -}         ]     ] @@ -104,10 +119,38 @@     ]  -------------------------------------------------------------------------------+-- Concat+-------------------------------------------------------------------------------++o_n_heap_concat :: Int -> [Benchmark]+o_n_heap_concat value =+    [ bgroup "concatPairsWith"+        [ {- -- This fails with stack overflow.+            benchIOSrc1 "concatMapWithZip (n of 1)"+            (concatMapWithZip value 1)+        -- Not correct because of nil stream at end issue.+        , benchIOSrc1 "concatMapWithZip (sqrtVal of sqrtVal)"+            (concatMapWithZip sqrtVal sqrtVal)+        -}+          benchIOSrc1 "concatPairsWithZip (n of 1)"+            (concatPairsWithZip value 1)+        , benchIOSrc1 "concatPairsWithZip (sqrtVal of sqrtVal)"+            (concatPairsWithZip sqrtVal sqrtVal)+        , benchIOSrc1 "concatPairsWithZip (+) (2 of n/2)"+            (concatPairsWithZip 2 (value `div` 2))+        ]+    ]++    where++    sqrtVal = round $ sqrt (fromIntegral value :: Double)++------------------------------------------------------------------------------- -- Monad outer product -------------------------------------------------------------------------------  {-+-- Not correct because of nil stream at end issue. o_1_space_outerProduct :: Int -> [Benchmark] o_1_space_outerProduct value =     [ bgroup "monad-outer-product"@@ -135,5 +178,8 @@             , o_1_space_mapping size             -- XXX need to fix, timing in ns             -- , o_1_space_outerProduct size+            ]+        , bgroup (o_n_heap_prefix moduleName) $ concat+            [ o_n_heap_concat size             ]         ]
+ benchmark/Streamly/Benchmark/Unicode/Char.hs view
@@ -0,0 +1,82 @@+--+-- Module      : Streamly.Unicode.Char+-- Copyright   : (c) 2021 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++--------------------------------------------------------------------------------+-- Imports+--------------------------------------------------------------------------------++import Control.DeepSeq (NFData)+import Streamly.Internal.Data.Array.Foreign (Array)+import System.FilePath (dropExtensions, takeFileName)+import System.FilePath.Posix ((</>))+import Gauge.Main (Benchmark, bench, bgroup, defaultMain, env, nfIO)+import Streamly.Internal.Unicode.Char+    ( NormalizationMode(NFC, NFD, NFKC, NFKD)+    , normalize+    )+import Streamly.Benchmark.Common (o_1_space_prefix)++import qualified Streamly.Internal.Data.Array.Foreign as Array+import qualified Streamly.Internal.Data.Stream.IsStream as IsStream+import qualified System.Directory as Dir++--------------------------------------------------------------------------------+-- Utilities+--------------------------------------------------------------------------------++moduleName :: String+moduleName = "Unicode.Char"++dataDir :: FilePath+dataDir = "benchmark/Streamly/Benchmark/Unicode/data"++-- Truncate or expand all datasets to this size to provide a normalized+-- measurement view across all datasets and to reduce the effect of noise+-- because of the datasets being too small.+dataSetSize :: Int+dataSetSize = 1000000++makeBench :: (NFData a) => (String, a -> IO ()) -> (String, IO a) -> Benchmark+makeBench (implName, func) (dataName, setup) =+    env setup (bench (implName ++ "/" ++ dataName) . nfIO . func)++strInput :: FilePath -> (String, IO String)+strInput file = (dataName file, fmap (take dataSetSize . cycle) (readFile file))++    where++    dataName = dropExtensions . takeFileName++arrInput :: FilePath -> (String, IO (Array Char))+arrInput file = second (fmap Array.fromList) (strInput file)++    where++    second f (a, b) = (a, f b)++--------------------------------------------------------------------------------+-- Benchmarks+--------------------------------------------------------------------------------++benchFunctions :: [(String, Array Char -> IO ())]+benchFunctions =+    [ ("NFD", IsStream.drain . normalize NFD . Array.toStream)+    , ("NFKD", IsStream.drain . normalize NFKD . Array.toStream)+    , ("NFC", IsStream.drain . normalize NFC . Array.toStream)+    , ("NFKC", IsStream.drain . normalize NFKC . Array.toStream)+    ]++main :: IO ()+main = do+    cdir <- Dir.getCurrentDirectory+    dataFiles <- fmap (dataDir </>) <$> Dir.listDirectory (cdir </> dataDir)+    defaultMain+        [ bgroup+              (o_1_space_prefix moduleName)+              (makeBench <$> benchFunctions <*> map arrInput dataFiles)+        ]
benchmark/Streamly/Benchmark/Unicode/Stream.hs view
@@ -276,7 +276,7 @@             copyStreamLatin1' inh outh         , mkBench "encodeLatin1 . decodeLatin1" env $ \inh outh ->             copyStreamLatin1 inh outh-#ifdef DEVBUILD+#ifdef INCLUDE_STRICT_UTF8         -- Requires valid unicode input         , mkBench "encodeUtf8' . decodeUtf8'" env $ \inh outh ->             _copyStreamUtf8' inh outh
+ benchmark/Streamly/Benchmark/Unicode/Utf8.hs view
@@ -0,0 +1,55 @@+--+-- Module      : Streamly.Unicode.Utf8+-- Copyright   : (c) 2021 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++--------------------------------------------------------------------------------+-- Imports+--------------------------------------------------------------------------------++import Data.Char (chr)+import Streamly.Internal.Unicode.Utf8 (Utf8)++import Gauge hiding (env)+import Streamly.Benchmark.Common++import qualified Streamly.Internal.Unicode.Utf8 as Utf8++--------------------------------------------------------------------------------+-- Utilities+--------------------------------------------------------------------------------++moduleName :: String+moduleName = "Unicode.Stream"++--------------------------------------------------------------------------------+-- Benchmarks+--------------------------------------------------------------------------------++{-# INLINE pack #-}+pack :: Int -> Utf8+pack i = Utf8.pack $ chr <$> [1 .. i]++{-# INLINE packUnpack #-}+packUnpack :: Int -> String+packUnpack = Utf8.unpack . pack++--------------------------------------------------------------------------------+-- Main function+--------------------------------------------------------------------------------++main :: IO ()+main = runWithCLIOpts defaultStreamSize allBenchmarks++    where++    allBenchmarks value =+        [ bgroup+              moduleName+              [ bench "pack" $ nf pack value+              , bench "pack + unpack" $ nf packUnpack value+              ]+        ]
+ benchmark/Streamly/Benchmark/Unicode/data/AllChars.txt view
@@ -0,0 +1,216 @@+This page contains characters from each of the Unicode character blocks.++Basic Latin+! " # $ % & ' ( ) * + , - . / 0 1 2 3 4 5 6 7 8 9 : ; < = > ? @ A B C D E F G H I J K L M N O P Q R S T U V W X Y Z [ \ ] ^ _ ` a b c d e f g h i j k l m n o p q r s t u v w x y z { | } ~+Latin-1 Supplement+  ¡ ¢ £ ¤ ¥ ¦ § ¨ © ª « ¬ ­ ® ¯ ° ± ² ³ ´ µ ¶ · ¸ ¹ º » ¼ ½ ¾ ¿ À Á Â Ã Ä Å Æ Ç È É Ê Ë Ì Í Î Ï Ð Ñ Ò Ó Ô Õ Ö × Ø Ù Ú Û Ü Ý Þ ß à á â ã ä å æ ç è é ê ë ì í î ï ð ñ ò ó ô õ ö ÷ ø ù ú û ü ý þ ÿ+Latin Extended-A+Ā ā Ă ă Ą ą Ć ć Ĉ ĉ Ċ ċ Č č Ď ď Đ đ Ē ē Ĕ ĕ Ė ė Ę ę Ě ě Ĝ ĝ Ğ ğ Ġ ġ Ģ ģ Ĥ ĥ Ħ ħ Ĩ ĩ Ī ī Ĭ ĭ Į į İ ı IJ ij Ĵ ĵ Ķ ķ ĸ Ĺ ĺ Ļ ļ Ľ ľ Ŀ ŀ Ł ł Ń ń Ņ ņ Ň ň ʼn Ŋ ŋ Ō ō Ŏ ŏ Ő ő Œ œ Ŕ ŕ Ŗ ŗ Ř ř Ś ś Ŝ ŝ Ş ş Š š Ţ ţ Ť ť Ŧ ŧ Ũ ũ Ū ū Ŭ ŭ Ů ů Ű ű Ų ų Ŵ ŵ Ŷ ŷ Ÿ Ź ź Ż ż Ž ž ſ+Latin Extended-B+ƀ Ɓ Ƃ ƃ Ƅ ƅ Ɔ Ƈ ƈ Ɖ Ɗ Ƌ ƌ ƍ Ǝ Ə Ɛ Ƒ ƒ Ɠ Ɣ ƕ Ɩ Ɨ Ƙ ƙ ƚ ƛ Ɯ Ɲ ƞ Ɵ Ơ ơ Ƣ ƣ Ƥ ƥ Ʀ Ƨ ƨ Ʃ ƪ ƫ Ƭ ƭ Ʈ Ư ư Ʊ Ʋ Ƴ ƴ Ƶ ƶ Ʒ Ƹ ƹ ƺ ƻ Ƽ ƽ ƾ ƿ ǀ ǁ ǂ ǃ DŽ Dž dž LJ Lj lj NJ Nj nj Ǎ ǎ Ǐ ǐ Ǒ ǒ Ǔ ǔ Ǖ ǖ Ǘ ǘ Ǚ ǚ Ǜ ǜ ǝ Ǟ ǟ Ǡ ǡ Ǣ ǣ Ǥ ǥ Ǧ ǧ Ǩ ǩ Ǫ ǫ Ǭ ǭ Ǯ ǯ ǰ DZ Dz dz Ǵ ǵ Ƕ Ƿ Ǹ ǹ Ǻ ǻ Ǽ ǽ Ǿ ǿ ...+IPA Extensions+ɐ ɑ ɒ ɓ ɔ ɕ ɖ ɗ ɘ ə ɚ ɛ ɜ ɝ ɞ ɟ ɠ ɡ ɢ ɣ ɤ ɥ ɦ ɧ ɨ ɩ ɪ ɫ ɬ ɭ ɮ ɯ ɰ ɱ ɲ ɳ ɴ ɵ ɶ ɷ ɸ ɹ ɺ ɻ ɼ ɽ ɾ ɿ ʀ ʁ ʂ ʃ ʄ ʅ ʆ ʇ ʈ ʉ ʊ ʋ ʌ ʍ ʎ ʏ ʐ ʑ ʒ ʓ ʔ ʕ ʖ ʗ ʘ ʙ ʚ ʛ ʜ ʝ ʞ ʟ ʠ ʡ ʢ ʣ ʤ ʥ ʦ ʧ ʨ ʩ ʪ ʫ ʬ ʭ+Spacing Modifier Letters+ʰ ʱ ʲ ʳ ʴ ʵ ʶ ʷ ʸ ʹ ʺ ʻ ʼ ʽ ʾ ʿ ˀ ˁ ˂ ˃ ˄ ˅ ˆ ˇ ˈ ˉ ˊ ˋ ˌ ˍ ˎ ˏ ː ˑ ˒ ˓ ˔ ˕ ˖ ˗ ˘ ˙ ˚ ˛ ˜ ˝ ˞ ˟ ˠ ˡ ˢ ˣ ˤ ˥ ˦ ˧ ˨ ˩ ˪ ˫ ˬ ˭ ˮ+Combining Diacritical Marks+̀ ́ ̂ ̃ ̄ ̅ ̆ ̇ ̈ ̉ ̊ ̋ ̌ ̍ ̎ ̏ ̐ ̑ ̒ ̓ ̔ ̕ ̖ ̗ ̘ ̙ ̚ ̛ ̜ ̝ ̞ ̟ ̠ ̡ ̢ ̣ ̤ ̥ ̦ ̧ ̨ ̩ ̪ ̫ ̬ ̭ ̮ ̯ ̰ ̱ ̲ ̳ ̴ ̵ ̶ ̷ ̸ ̹ ̺ ̻ ̼ ̽ ̾ ̿ ̀ ́ ͂ ̓ ̈́ ͅ ͆ ͇ ͈ ͉ ͊ ͋ ͌ ͍ ͎ ͏ ͠ ͡ ͢ ͣ ͤ ͥ ͦ ͧ ͨ ͩ ͪ ͫ ͬ ͭ ͮ ͯ+Greek and Coptic+ʹ ͵ ͺ ; ΄ ΅ Ά · Έ Ή Ί Ό Ύ Ώ ΐ Α Β Γ Δ Ε Ζ Η Θ Ι Κ Λ Μ Ν Ξ Ο Π Ρ Σ Τ Υ Φ Χ Ψ Ω Ϊ Ϋ ά έ ή ί ΰ α β γ δ ε ζ η θ ι κ λ μ ν ξ ο π ρ ς σ τ υ φ χ ψ ω ϊ ϋ ό ύ ώ ϐ ϑ ϒ ϓ ϔ ϕ ϖ ϗ Ϙ ϙ Ϛ ϛ Ϝ ϝ Ϟ ϟ Ϡ ϡ Ϣ ϣ Ϥ ϥ Ϧ ϧ Ϩ ϩ Ϫ ϫ Ϭ ϭ Ϯ ϯ ϰ ϱ ϲ ϳ ϴ ϵ ϶+Cyrillic+Ѐ Ё Ђ Ѓ Є Ѕ І Ї Ј Љ Њ Ћ Ќ Ѝ Ў Џ А Б В Г Д Е Ж З И Й К Л М Н О П Р С Т У Ф Х Ц Ч Ш Щ Ъ Ы Ь Э Ю Я а б в г д е ж з и й к л м н о п р с т у ф х ц ч ш щ ъ ы ь э ю я ѐ ё ђ ѓ є ѕ і ї ј љ њ ћ ќ ѝ ў џ Ѡ ѡ Ѣ ѣ Ѥ ѥ Ѧ ѧ Ѩ ѩ Ѫ ѫ Ѭ ѭ Ѯ ѯ Ѱ ѱ Ѳ ѳ Ѵ ѵ Ѷ ѷ Ѹ ѹ Ѻ ѻ Ѽ ѽ Ѿ ѿ ...+Cyrillic Supplementary+Ԁ ԁ Ԃ ԃ Ԅ ԅ Ԇ ԇ Ԉ ԉ Ԋ ԋ Ԍ ԍ Ԏ ԏ+Armenian+Ա Բ Գ Դ Ե Զ Է Ը Թ Ժ Ի Լ Խ Ծ Կ Հ Ձ Ղ Ճ Մ Յ Ն Շ Ո Չ Պ Ջ Ռ Ս Վ Տ Ր Ց Ւ Փ Ք Օ Ֆ ՙ ՚ ՛ ՜ ՝ ՞ ՟ ա բ գ դ ե զ է ը թ ժ ի լ խ ծ կ հ ձ ղ ճ մ յ ն շ ո չ պ ջ ռ ս վ տ ր ց ւ փ ք օ ֆ և ։ ֊+Hebrew+֑ ֒ ֓ ֔ ֕ ֖ ֗ ֘ ֙ ֚ ֛ ֜ ֝ ֞ ֟ ֠ ֡ ֣ ֤ ֥ ֦ ֧ ֨ ֩ ֪ ֫ ֬ ֭ ֮ ֯ ְ ֱ ֲ ֳ ִ ֵ ֶ ַ ָ ֹ ֻ ּ ֽ ־ ֿ ׀ ׁ ׂ ׃ ׄ א ב ג ד ה ו ז ח ט י ך כ ל ם מ ן נ ס ע ף פ ץ צ ק ר ש ת װ ױ ײ ׳ ״+Arabic+، ؛ ؟ ء آ أ ؤ إ ئ ا ب ة ت ث ج ح خ د ذ ر ز س ش ص ض ط ظ ع غ ـ ف ق ك ل م ن ه و ى ي ً ٌ ٍ َ ُ ِ ّ ْ ٓ ٔ ٕ ٠ ١ ٢ ٣ ٤ ٥ ٦ ٧ ٨ ٩ ٪ ٫ ٬ ٭ ٮ ٯ ٰ ٱ ٲ ٳ ٴ ٵ ٶ ٷ ٸ ٹ ٺ ٻ ټ ٽ پ ٿ ڀ ځ ڂ ڃ ڄ څ چ ڇ ڈ ډ ڊ ڋ ڌ ڍ ڎ ڏ ڐ ڑ ڒ ړ ڔ ڕ ږ ڗ ژ ڙ ښ ڛ ڜ ڝ ڞ ڟ ڠ ڡ ڢ ڣ ڤ ڥ ڦ ڧ ڨ ک ڪ ګ ڬ ...+Syriac+܀ ܁ ܂ ܃ ܄ ܅ ܆ ܇ ܈ ܉ ܊ ܋ ܌ ܍ ܏ ܐ ܑ ܒ ܓ ܔ ܕ ܖ ܗ ܘ ܙ ܚ ܛ ܜ ܝ ܞ ܟ ܠ ܡ ܢ ܣ ܤ ܥ ܦ ܧ ܨ ܩ ܪ ܫ ܬ ܰ ܱ ܲ ܳ ܴ ܵ ܶ ܷ ܸ ܹ ܺ ܻ ܼ ܽ ܾ ܿ ݀ ݁ ݂ ݃ ݄ ݅ ݆ ݇ ݈ ݉ ݊+Thaana+ހ ށ ނ ރ ބ ޅ ކ އ ވ މ ފ ދ ތ ލ ގ ޏ ސ ޑ ޒ ޓ ޔ ޕ ޖ ޗ ޘ ޙ ޚ ޛ ޜ ޝ ޞ ޟ ޠ ޡ ޢ ޣ ޤ ޥ ަ ާ ި ީ ު ޫ ެ ޭ ޮ ޯ ް ޱ+Devanagari+ँ ं ः अ आ इ ई उ ऊ ऋ ऌ ऍ ऎ ए ऐ ऑ ऒ ओ औ क ख ग घ ङ च छ ज झ ञ ट ठ ड ढ ण त थ द ध न ऩ प फ ब भ म य र ऱ ल ळ ऴ व श ष स ह ़ ऽ ा ि ी ु ू ृ ॄ ॅ ॆ े ै ॉ ॊ ो ौ ् ॐ ॑ ॒ ॓ ॔ क़ ख़ ग़ ज़ ड़ ढ़ फ़ य़ ॠ ॡ ॢ ॣ । ॥ ० १ २ ३ ४ ५ ६ ७ ८ ९ ॰+Bengali+ঁ ং ঃ অ আ ই ঈ উ ঊ ঋ ঌ এ ঐ ও ঔ ক খ গ ঘ ঙ চ ছ জ ঝ ঞ ট ঠ ড ঢ ণ ত থ দ ধ ন প ফ ব ভ ম য র ল শ ষ স হ ় া ি ী ু ূ ৃ ৄ ে ৈ ো ৌ ্ ৗ ড় ঢ় য় ৠ ৡ ৢ ৣ ০ ১ ২ ৩ ৪ ৫ ৬ ৭ ৮ ৯ ৰ ৱ ৲ ৳ ৴ ৵ ৶ ৷ ৸ ৹ ৺+Gurmukhi+ਂ ਅ ਆ ਇ ਈ ਉ ਊ ਏ ਐ ਓ ਔ ਕ ਖ ਗ ਘ ਙ ਚ ਛ ਜ ਝ ਞ ਟ ਠ ਡ ਢ ਣ ਤ ਥ ਦ ਧ ਨ ਪ ਫ ਬ ਭ ਮ ਯ ਰ ਲ ਲ਼ ਵ ਸ਼ ਸ ਹ ਼ ਾ ਿ ੀ ੁ ੂ ੇ ੈ ੋ ੌ ੍ ਖ਼ ਗ਼ ਜ਼ ੜ ਫ਼ ੦ ੧ ੨ ੩ ੪ ੫ ੬ ੭ ੮ ੯ ੰ ੱ ੲ ੳ ੴ+Gujarati+ઁ ં ઃ અ આ ઇ ઈ ઉ ઊ ઋ ઍ એ ઐ ઑ ઓ ઔ ક ખ ગ ઘ ઙ ચ છ જ ઝ ઞ ટ ઠ ડ ઢ ણ ત થ દ ધ ન પ ફ બ ભ મ ય ર લ ળ વ શ ષ સ હ ઼ ઽ ા િ ી ુ ૂ ૃ ૄ ૅ ે ૈ ૉ ો ૌ ્ ૐ ૠ ૦ ૧ ૨ ૩ ૪ ૫ ૬ ૭ ૮ ૯+Oriya+ଁ ଂ ଃ ଅ ଆ ଇ ଈ ଉ ଊ ଋ ଌ ଏ ଐ ଓ ଔ କ ଖ ଗ ଘ ଙ ଚ ଛ ଜ ଝ ଞ ଟ ଠ ଡ ଢ ଣ ତ ଥ ଦ ଧ ନ ପ ଫ ବ ଭ ମ ଯ ର ଲ ଳ ଶ ଷ ସ ହ ଼ ଽ ା ି ୀ ୁ ୂ ୃ େ ୈ ୋ ୌ ୍ ୖ ୗ ଡ଼ ଢ଼ ୟ ୠ ୡ ୦ ୧ ୨ ୩ ୪ ୫ ୬ ୭ ୮ ୯ ୰+Tamil+ஂ ஃ அ ஆ இ ஈ உ ஊ எ ஏ ஐ ஒ ஓ ஔ க ங ச ஜ ஞ ட ண த ந ன ப ம ய ர ற ல ள ழ வ ஷ ஸ ஹ ா ி ீ ு ூ ெ ே ை ொ ோ ௌ ் ௗ ௧ ௨ ௩ ௪ ௫ ௬ ௭ ௮ ௯ ௰ ௱ ௲+Telugu+ఁ ం ః అ ఆ ఇ ఈ ఉ ఊ ఋ ఌ ఎ ఏ ఐ ఒ ఓ ఔ క ఖ గ ఘ ఙ చ ఛ జ ఝ ఞ ట ఠ డ ఢ ణ త థ ద ధ న ప ఫ బ భ మ య ర ఱ ల ళ వ శ ష స హ ా ి ీ ు ూ ృ ౄ ె ే ై ొ ో ౌ ్ ౕ ౖ ౠ ౡ ౦ ౧ ౨ ౩ ౪ ౫ ౬ ౭ ౮ ౯+Kannada+ಂ ಃ ಅ ಆ ಇ ಈ ಉ ಊ ಋ ಌ ಎ ಏ ಐ ಒ ಓ ಔ ಕ ಖ ಗ ಘ ಙ ಚ ಛ ಜ ಝ ಞ ಟ ಠ ಡ ಢ ಣ ತ ಥ ದ ಧ ನ ಪ ಫ ಬ ಭ ಮ ಯ ರ ಱ ಲ ಳ ವ ಶ ಷ ಸ ಹ ಾ ಿ ೀ ು ೂ ೃ ೄ ೆ ೇ ೈ ೊ ೋ ೌ ್ ೕ ೖ ೞ ೠ ೡ ೦ ೧ ೨ ೩ ೪ ೫ ೬ ೭ ೮ ೯+Malayalam+ം ഃ അ ആ ഇ ഈ ഉ ഊ ഋ ഌ എ ഏ ഐ ഒ ഓ ഔ ക ഖ ഗ ഘ ങ ച ഛ ജ ഝ ഞ ട ഠ ഡ ഢ ണ ത ഥ ദ ധ ന പ ഫ ബ ഭ മ യ ര റ ല ള ഴ വ ശ ഷ സ ഹ ാ ി ീ ു ൂ ൃ െ േ ൈ ൊ ോ ൌ ് ൗ ൠ ൡ ൦ ൧ ൨ ൩ ൪ ൫ ൬ ൭ ൮ ൯+Sinhala+ං ඃ අ ආ ඇ ඈ ඉ ඊ උ ඌ ඍ ඎ ඏ ඐ එ ඒ ඓ ඔ ඕ ඖ ක ඛ ග ඝ ඞ ඟ ච ඡ ජ ඣ ඤ ඥ ඦ ට ඨ ඩ ඪ ණ ඬ ත ථ ද ධ න ඳ ප ඵ බ භ ම ඹ ය ර ල ව ශ ෂ ස හ ළ ෆ ් ා ැ ෑ ි ී ු ූ ෘ ෙ ේ ෛ ො ෝ ෞ ෟ ෲ ෳ ෴+Thai+ก ข ฃ ค ฅ ฆ ง จ ฉ ช ซ ฌ ญ ฎ ฏ ฐ ฑ ฒ ณ ด ต ถ ท ธ น บ ป ผ ฝ พ ฟ ภ ม ย ร ฤ ล ฦ ว ศ ษ ส ห ฬ อ ฮ ฯ ะ ั า ำ ิ ี ึ ื ุ ู ฺ ฿ เ แ โ ใ ไ ๅ ๆ ็ ่ ้ ๊ ๋ ์ ํ ๎ ๏ ๐ ๑ ๒ ๓ ๔ ๕ ๖ ๗ ๘ ๙ ๚ ๛+Lao+ກ ຂ ຄ ງ ຈ ຊ ຍ ດ ຕ ຖ ທ ນ ບ ປ ຜ ຝ ພ ຟ ມ ຢ ຣ ລ ວ ສ ຫ ອ ຮ ຯ ະ ັ າ ຳ ິ ີ ຶ ື ຸ ູ ົ ຼ ຽ ເ ແ ໂ ໃ ໄ ໆ ່ ້ ໊ ໋ ໌ ໍ ໐ ໑ ໒ ໓ ໔ ໕ ໖ ໗ ໘ ໙ ໜ ໝ+Tibetan+ༀ ༁ ༂ ༃ ༄ ༅ ༆ ༇ ༈ ༉ ༊ ་ ༌ ། ༎ ༏ ༐ ༑ ༒ ༓ ༔ ༕ ༖ ༗ ༘ ༙ ༚ ༛ ༜ ༝ ༞ ༟ ༠ ༡ ༢ ༣ ༤ ༥ ༦ ༧ ༨ ༩ ༪ ༫ ༬ ༭ ༮ ༯ ༰ ༱ ༲ ༳ ༴ ༵ ༶ ༷ ༸ ༹ ༺ ༻ ༼ ༽ ༾ ༿ ཀ ཁ ག གྷ ང ཅ ཆ ཇ ཉ ཊ ཋ ཌ ཌྷ ཎ ཏ ཐ ད དྷ ན པ ཕ བ བྷ མ ཙ ཚ ཛ ཛྷ ཝ ཞ ཟ འ ཡ ར ལ ཤ ཥ ས ཧ ཨ ཀྵ ཪ ཱ ི ཱི ུ ཱུ ྲྀ ཷ ླྀ ཹ ེ ཻ ོ ཽ ཾ ཿ ྀ ཱྀ ྂ ྃ ྄ ྅ ྆ ...+Myanmar+က ခ ဂ ဃ င စ ဆ ဇ ဈ ဉ ည ဋ ဌ ဍ ဎ ဏ တ ထ ဒ ဓ န ပ ဖ ဗ ဘ မ ယ ရ လ ဝ သ ဟ ဠ အ ဣ ဤ ဥ ဦ ဧ ဩ ဪ ာ ိ ီ ု ူ ေ ဲ ံ ့ း ္ ၀ ၁ ၂ ၃ ၄ ၅ ၆ ၇ ၈ ၉ ၊ ။ ၌ ၍ ၎ ၏ ၐ ၑ ၒ ၓ ၔ ၕ ၖ ၗ ၘ ၙ+Georgian+Ⴀ Ⴁ Ⴂ Ⴃ Ⴄ Ⴅ Ⴆ Ⴇ Ⴈ Ⴉ Ⴊ Ⴋ Ⴌ Ⴍ Ⴎ Ⴏ Ⴐ Ⴑ Ⴒ Ⴓ Ⴔ Ⴕ Ⴖ Ⴗ Ⴘ Ⴙ Ⴚ Ⴛ Ⴜ Ⴝ Ⴞ Ⴟ Ⴠ Ⴡ Ⴢ Ⴣ Ⴤ Ⴥ ა ბ გ დ ე ვ ზ თ ი კ ლ მ ნ ო პ ჟ რ ს ტ უ ფ ქ ღ ყ შ ჩ ც ძ წ ჭ ხ ჯ ჰ ჱ ჲ ჳ ჴ ჵ ჶ ჷ ჸ ჻+Hangul Jamo+ᄀ ᄁ ᄂ ᄃ ᄄ ᄅ ᄆ ᄇ ᄈ ᄉ ᄊ ᄋ ᄌ ᄍ ᄎ ᄏ ᄐ ᄑ ᄒ ᄓ ᄔ ᄕ ᄖ ᄗ ᄘ ᄙ ᄚ ᄛ ᄜ ᄝ ᄞ ᄟ ᄠ ᄡ ᄢ ᄣ ᄤ ᄥ ᄦ ᄧ ᄨ ᄩ ᄪ ᄫ ᄬ ᄭ ᄮ ᄯ ᄰ ᄱ ᄲ ᄳ ᄴ ᄵ ᄶ ᄷ ᄸ ᄹ ᄺ ᄻ ᄼ ᄽ ᄾ ᄿ ᅀ ᅁ ᅂ ᅃ ᅄ ᅅ ᅆ ᅇ ᅈ ᅉ ᅊ ᅋ ᅌ ᅍ ᅎ ᅏ ᅐ ᅑ ᅒ ᅓ ᅔ ᅕ ᅖ ᅗ ᅘ ᅙ ᅟ ᅠ ᅡ ᅢ ᅣ ᅤ ᅥ ᅦ ᅧ ᅨ ᅩ ᅪ ᅫ ᅬ ᅭ ᅮ ᅯ ᅰ ᅱ ᅲ ᅳ ᅴ ᅵ ᅶ ᅷ ᅸ ᅹ ᅺ ᅻ ᅼ ᅽ ᅾ ᅿ ᆀ ᆁ ᆂ ᆃ ᆄ ...+Ethiopic+ሀ ሁ ሂ ሃ ሄ ህ ሆ ለ ሉ ሊ ላ ሌ ል ሎ ሏ ሐ ሑ ሒ ሓ ሔ ሕ ሖ ሗ መ ሙ ሚ ማ ሜ ም ሞ ሟ ሠ ሡ ሢ ሣ ሤ ሥ ሦ ሧ ረ ሩ ሪ ራ ሬ ር ሮ ሯ ሰ ሱ ሲ ሳ ሴ ስ ሶ ሷ ሸ ሹ ሺ ሻ ሼ ሽ ሾ ሿ ቀ ቁ ቂ ቃ ቄ ቅ ቆ ቈ ቊ ቋ ቌ ቍ ቐ ቑ ቒ ቓ ቔ ቕ ቖ ቘ ቚ ቛ ቜ ቝ በ ቡ ቢ ባ ቤ ብ ቦ ቧ ቨ ቩ ቪ ቫ ቬ ቭ ቮ ቯ ተ ቱ ቲ ታ ቴ ት ቶ ቷ ቸ ቹ ቺ ቻ ቼ ች ቾ ቿ ኀ ኁ ኂ ኃ ኄ ኅ ኆ ኈ ኊ ...+Cherokee+Ꭰ Ꭱ Ꭲ Ꭳ Ꭴ Ꭵ Ꭶ Ꭷ Ꭸ Ꭹ Ꭺ Ꭻ Ꭼ Ꭽ Ꭾ Ꭿ Ꮀ Ꮁ Ꮂ Ꮃ Ꮄ Ꮅ Ꮆ Ꮇ Ꮈ Ꮉ Ꮊ Ꮋ Ꮌ Ꮍ Ꮎ Ꮏ Ꮐ Ꮑ Ꮒ Ꮓ Ꮔ Ꮕ Ꮖ Ꮗ Ꮘ Ꮙ Ꮚ Ꮛ Ꮜ Ꮝ Ꮞ Ꮟ Ꮠ Ꮡ Ꮢ Ꮣ Ꮤ Ꮥ Ꮦ Ꮧ Ꮨ Ꮩ Ꮪ Ꮫ Ꮬ Ꮭ Ꮮ Ꮯ Ꮰ Ꮱ Ꮲ Ꮳ Ꮴ Ꮵ Ꮶ Ꮷ Ꮸ Ꮹ Ꮺ Ꮻ Ꮼ Ꮽ Ꮾ Ꮿ Ᏸ Ᏹ Ᏺ Ᏻ Ᏼ+Unified Canadian Aboriginal Syllabics+ᐁ ᐂ ᐃ ᐄ ᐅ ᐆ ᐇ ᐈ ᐉ ᐊ ᐋ ᐌ ᐍ ᐎ ᐏ ᐐ ᐑ ᐒ ᐓ ᐔ ᐕ ᐖ ᐗ ᐘ ᐙ ᐚ ᐛ ᐜ ᐝ ᐞ ᐟ ᐠ ᐡ ᐢ ᐣ ᐤ ᐥ ᐦ ᐧ ᐨ ᐩ ᐪ ᐫ ᐬ ᐭ ᐮ ᐯ ᐰ ᐱ ᐲ ᐳ ᐴ ᐵ ᐶ ᐷ ᐸ ᐹ ᐺ ᐻ ᐼ ᐽ ᐾ ᐿ ᑀ ᑁ ᑂ ᑃ ᑄ ᑅ ᑆ ᑇ ᑈ ᑉ ᑊ ᑋ ᑌ ᑍ ᑎ ᑏ ᑐ ᑑ ᑒ ᑓ ᑔ ᑕ ᑖ ᑗ ᑘ ᑙ ᑚ ᑛ ᑜ ᑝ ᑞ ᑟ ᑠ ᑡ ᑢ ᑣ ᑤ ᑥ ᑦ ᑧ ᑨ ᑩ ᑪ ᑫ ᑬ ᑭ ᑮ ᑯ ᑰ ᑱ ᑲ ᑳ ᑴ ᑵ ᑶ ᑷ ᑸ ᑹ ᑺ ᑻ ᑼ ᑽ ᑾ ᑿ ᒀ ...+Ogham+  ᚁ ᚂ ᚃ ᚄ ᚅ ᚆ ᚇ ᚈ ᚉ ᚊ ᚋ ᚌ ᚍ ᚎ ᚏ ᚐ ᚑ ᚒ ᚓ ᚔ ᚕ ᚖ ᚗ ᚘ ᚙ ᚚ ᚛ ᚜+Runic+ᚠ ᚡ ᚢ ᚣ ᚤ ᚥ ᚦ ᚧ ᚨ ᚩ ᚪ ᚫ ᚬ ᚭ ᚮ ᚯ ᚰ ᚱ ᚲ ᚳ ᚴ ᚵ ᚶ ᚷ ᚸ ᚹ ᚺ ᚻ ᚼ ᚽ ᚾ ᚿ ᛀ ᛁ ᛂ ᛃ ᛄ ᛅ ᛆ ᛇ ᛈ ᛉ ᛊ ᛋ ᛌ ᛍ ᛎ ᛏ ᛐ ᛑ ᛒ ᛓ ᛔ ᛕ ᛖ ᛗ ᛘ ᛙ ᛚ ᛛ ᛜ ᛝ ᛞ ᛟ ᛠ ᛡ ᛢ ᛣ ᛤ ᛥ ᛦ ᛧ ᛨ ᛩ ᛪ ᛫ ᛬ ᛭ ᛮ ᛯ ᛰ+Tagalog+ᜀ ᜁ ᜂ ᜃ ᜄ ᜅ ᜆ ᜇ ᜈ ᜉ ᜊ ᜋ ᜌ ᜎ ᜏ ᜐ ᜑ ᜒ ᜓ ᜔+Hanunoo+ᜠ ᜡ ᜢ ᜣ ᜤ ᜥ ᜦ ᜧ ᜨ ᜩ ᜪ ᜫ ᜬ ᜭ ᜮ ᜯ ᜰ ᜱ ᜲ ᜳ ᜴ ᜵ ᜶+Buhid+ᝀ ᝁ ᝂ ᝃ ᝄ ᝅ ᝆ ᝇ ᝈ ᝉ ᝊ ᝋ ᝌ ᝍ ᝎ ᝏ ᝐ ᝑ ᝒ ᝓ+Tagbanwa+ᝠ ᝡ ᝢ ᝣ ᝤ ᝥ ᝦ ᝧ ᝨ ᝩ ᝪ ᝫ ᝬ ᝮ ᝯ ᝰ ᝲ ᝳ+Khmer+ក ខ គ ឃ ង ច ឆ ជ ឈ ញ ដ ឋ ឌ ឍ ណ ត ថ ទ ធ ន ប ផ ព ភ ម យ រ ល វ ឝ ឞ ស ហ ឡ អ ឣ ឤ ឥ ឦ ឧ ឨ ឩ ឪ ឫ ឬ ឭ ឮ ឯ ឰ ឱ ឲ ឳ ឴ ឵ ា ិ ី ឹ ឺ ុ ូ ួ ើ ឿ ៀ េ ែ ៃ ោ ៅ ំ ះ ៈ ៉ ៊ ់ ៌ ៍ ៎ ៏ ័ ៑ ្ ៓ ។ ៕ ៖ ៗ ៘ ៙ ៚ ៛ ៜ ០ ១ ២ ៣ ៤ ៥ ៦ ៧ ៨ ៩+Mongolian+᠀ ᠁ ᠂ ᠃ ᠄ ᠅ ᠆ ᠇ ᠈ ᠉ ᠊ ᠋ ᠌ ᠍ ᠎ ᠐ ᠑ ᠒ ᠓ ᠔ ᠕ ᠖ ᠗ ᠘ ᠙ ᠠ ᠡ ᠢ ᠣ ᠤ ᠥ ᠦ ᠧ ᠨ ᠩ ᠪ ᠫ ᠬ ᠭ ᠮ ᠯ ᠰ ᠱ ᠲ ᠳ ᠴ ᠵ ᠶ ᠷ ᠸ ᠹ ᠺ ᠻ ᠼ ᠽ ᠾ ᠿ ᡀ ᡁ ᡂ ᡃ ᡄ ᡅ ᡆ ᡇ ᡈ ᡉ ᡊ ᡋ ᡌ ᡍ ᡎ ᡏ ᡐ ᡑ ᡒ ᡓ ᡔ ᡕ ᡖ ᡗ ᡘ ᡙ ᡚ ᡛ ᡜ ᡝ ᡞ ᡟ ᡠ ᡡ ᡢ ᡣ ᡤ ᡥ ᡦ ᡧ ᡨ ᡩ ᡪ ᡫ ᡬ ᡭ ᡮ ᡯ ᡰ ᡱ ᡲ ᡳ ᡴ ᡵ ᡶ ᡷ ᢀ ᢁ ᢂ ᢃ ᢄ ᢅ ᢆ ᢇ ᢈ ᢉ ᢊ ᢋ ᢌ ᢍ ᢎ ...+Latin Extended Additional+Ḁ ḁ Ḃ ḃ Ḅ ḅ Ḇ ḇ Ḉ ḉ Ḋ ḋ Ḍ ḍ Ḏ ḏ Ḑ ḑ Ḓ ḓ Ḕ ḕ Ḗ ḗ Ḙ ḙ Ḛ ḛ Ḝ ḝ Ḟ ḟ Ḡ ḡ Ḣ ḣ Ḥ ḥ Ḧ ḧ Ḩ ḩ Ḫ ḫ Ḭ ḭ Ḯ ḯ Ḱ ḱ Ḳ ḳ Ḵ ḵ Ḷ ḷ Ḹ ḹ Ḻ ḻ Ḽ ḽ Ḿ ḿ Ṁ ṁ Ṃ ṃ Ṅ ṅ Ṇ ṇ Ṉ ṉ Ṋ ṋ Ṍ ṍ Ṏ ṏ Ṑ ṑ Ṓ ṓ Ṕ ṕ Ṗ ṗ Ṙ ṙ Ṛ ṛ Ṝ ṝ Ṟ ṟ Ṡ ṡ Ṣ ṣ Ṥ ṥ Ṧ ṧ Ṩ ṩ Ṫ ṫ Ṭ ṭ Ṯ ṯ Ṱ ṱ Ṳ ṳ Ṵ ṵ Ṷ ṷ Ṹ ṹ Ṻ ṻ Ṽ ṽ Ṿ ṿ ...+Greek Extended+ἀ ἁ ἂ ἃ ἄ ἅ ἆ ἇ Ἀ Ἁ Ἂ Ἃ Ἄ Ἅ Ἆ Ἇ ἐ ἑ ἒ ἓ ἔ ἕ Ἐ Ἑ Ἒ Ἓ Ἔ Ἕ ἠ ἡ ἢ ἣ ἤ ἥ ἦ ἧ Ἠ Ἡ Ἢ Ἣ Ἤ Ἥ Ἦ Ἧ ἰ ἱ ἲ ἳ ἴ ἵ ἶ ἷ Ἰ Ἱ Ἲ Ἳ Ἴ Ἵ Ἶ Ἷ ὀ ὁ ὂ ὃ ὄ ὅ Ὀ Ὁ Ὂ Ὃ Ὄ Ὅ ὐ ὑ ὒ ὓ ὔ ὕ ὖ ὗ Ὑ Ὓ Ὕ Ὗ ὠ ὡ ὢ ὣ ὤ ὥ ὦ ὧ Ὠ Ὡ Ὢ Ὣ Ὤ Ὥ Ὦ Ὧ ὰ ά ὲ έ ὴ ή ὶ ί ὸ ό ὺ ύ ὼ ώ ᾀ ᾁ ᾂ ᾃ ᾄ ᾅ ᾆ ᾇ ᾈ ᾉ ᾊ ᾋ ᾌ ᾍ ...+General Punctuation+                      ​ ‌ ‍ ‎ ‏ ‐ ‑ ‒ – — ― ‖ ‗ ‘ ’ ‚ ‛ “ ” „ ‟ † ‡ • ‣ ․ ‥ … ‧ 
 
 ‪ ‫ ‬ ‭ ‮   ‰ ‱ ′ ″ ‴ ‵ ‶ ‷ ‸ ‹ › ※ ‼ ‽ ‾ ‿ ⁀ ⁁ ⁂ ⁃ ⁄ ⁅ ⁆ ⁇ ⁈ ⁉ ⁊ ⁋ ⁌ ⁍ ⁎ ⁏ ⁐ ⁑ ⁒ ⁗   ⁠ ⁡ ⁢ ⁣      +Superscripts and Subscripts+⁰ ⁱ ⁴ ⁵ ⁶ ⁷ ⁸ ⁹ ⁺ ⁻ ⁼ ⁽ ⁾ ⁿ ₀ ₁ ₂ ₃ ₄ ₅ ₆ ₇ ₈ ₉ ₊ ₋ ₌ ₍ ₎+Currency Symbols+₠ ₡ ₢ ₣ ₤ ₥ ₦ ₧ ₨ ₩ ₪ ₫ € ₭ ₮ ₯ ₰ ₱+Combining Diacritical Marks for Symbols+⃐ ⃑ ⃒ ⃓ ⃔ ⃕ ⃖ ⃗ ⃘ ⃙ ⃚ ⃛ ⃜ ⃝ ⃞ ⃟ ⃠ ⃡ ⃢ ⃣ ⃤ ⃥ ⃦ ⃧ ⃨ ⃩ ⃪+Letterlike Symbols+℀ ℁ ℂ ℃ ℄ ℅ ℆ ℇ ℈ ℉ ℊ ℋ ℌ ℍ ℎ ℏ ℐ ℑ ℒ ℓ ℔ ℕ № ℗ ℘ ℙ ℚ ℛ ℜ ℝ ℞ ℟ ℠ ℡ ™ ℣ ℤ ℥ Ω ℧ ℨ ℩ K Å ℬ ℭ ℮ ℯ ℰ ℱ Ⅎ ℳ ℴ ℵ ℶ ℷ ℸ ℹ ℺ ℽ ℾ ℿ ⅀ ⅁ ⅂ ⅃ ⅄ ⅅ ⅆ ⅇ ⅈ ⅉ ⅊ ⅋+Number Forms+⅓ ⅔ ⅕ ⅖ ⅗ ⅘ ⅙ ⅚ ⅛ ⅜ ⅝ ⅞ ⅟ Ⅰ Ⅱ Ⅲ Ⅳ Ⅴ Ⅵ Ⅶ Ⅷ Ⅸ Ⅹ Ⅺ Ⅻ Ⅼ Ⅽ Ⅾ Ⅿ ⅰ ⅱ ⅲ ⅳ ⅴ ⅵ ⅶ ⅷ ⅸ ⅹ ⅺ ⅻ ⅼ ⅽ ⅾ ⅿ ↀ ↁ ↂ Ↄ+Arrows+← ↑ → ↓ ↔ ↕ ↖ ↗ ↘ ↙ ↚ ↛ ↜ ↝ ↞ ↟ ↠ ↡ ↢ ↣ ↤ ↥ ↦ ↧ ↨ ↩ ↪ ↫ ↬ ↭ ↮ ↯ ↰ ↱ ↲ ↳ ↴ ↵ ↶ ↷ ↸ ↹ ↺ ↻ ↼ ↽ ↾ ↿ ⇀ ⇁ ⇂ ⇃ ⇄ ⇅ ⇆ ⇇ ⇈ ⇉ ⇊ ⇋ ⇌ ⇍ ⇎ ⇏ ⇐ ⇑ ⇒ ⇓ ⇔ ⇕ ⇖ ⇗ ⇘ ⇙ ⇚ ⇛ ⇜ ⇝ ⇞ ⇟ ⇠ ⇡ ⇢ ⇣ ⇤ ⇥ ⇦ ⇧ ⇨ ⇩ ⇪ ⇫ ⇬ ⇭ ⇮ ⇯ ⇰ ⇱ ⇲ ⇳ ⇴ ⇵ ⇶ ⇷ ⇸ ⇹ ⇺ ⇻ ⇼ ⇽ ⇾ ⇿+Mathematical Operators+∀ ∁ ∂ ∃ ∄ ∅ ∆ ∇ ∈ ∉ ∊ ∋ ∌ ∍ ∎ ∏ ∐ ∑ − ∓ ∔ ∕ ∖ ∗ ∘ ∙ √ ∛ ∜ ∝ ∞ ∟ ∠ ∡ ∢ ∣ ∤ ∥ ∦ ∧ ∨ ∩ ∪ ∫ ∬ ∭ ∮ ∯ ∰ ∱ ∲ ∳ ∴ ∵ ∶ ∷ ∸ ∹ ∺ ∻ ∼ ∽ ∾ ∿ ≀ ≁ ≂ ≃ ≄ ≅ ≆ ≇ ≈ ≉ ≊ ≋ ≌ ≍ ≎ ≏ ≐ ≑ ≒ ≓ ≔ ≕ ≖ ≗ ≘ ≙ ≚ ≛ ≜ ≝ ≞ ≟ ≠ ≡ ≢ ≣ ≤ ≥ ≦ ≧ ≨ ≩ ≪ ≫ ≬ ≭ ≮ ≯ ≰ ≱ ≲ ≳ ≴ ≵ ≶ ≷ ≸ ≹ ≺ ≻ ≼ ≽ ≾ ≿ ...+Miscellaneous Technical+⌀ ⌁ ⌂ ⌃ ⌄ ⌅ ⌆ ⌇ ⌈ ⌉ ⌊ ⌋ ⌌ ⌍ ⌎ ⌏ ⌐ ⌑ ⌒ ⌓ ⌔ ⌕ ⌖ ⌗ ⌘ ⌙ ⌚ ⌛ ⌜ ⌝ ⌞ ⌟ ⌠ ⌡ ⌢ ⌣ ⌤ ⌥ ⌦ ⌧ ⌨ 〈 〉 ⌫ ⌬ ⌭ ⌮ ⌯ ⌰ ⌱ ⌲ ⌳ ⌴ ⌵ ⌶ ⌷ ⌸ ⌹ ⌺ ⌻ ⌼ ⌽ ⌾ ⌿ ⍀ ⍁ ⍂ ⍃ ⍄ ⍅ ⍆ ⍇ ⍈ ⍉ ⍊ ⍋ ⍌ ⍍ ⍎ ⍏ ⍐ ⍑ ⍒ ⍓ ⍔ ⍕ ⍖ ⍗ ⍘ ⍙ ⍚ ⍛ ⍜ ⍝ ⍞ ⍟ ⍠ ⍡ ⍢ ⍣ ⍤ ⍥ ⍦ ⍧ ⍨ ⍩ ⍪ ⍫ ⍬ ⍭ ⍮ ⍯ ⍰ ⍱ ⍲ ⍳ ⍴ ⍵ ⍶ ⍷ ⍸ ⍹ ⍺ ⍻ ⍼ ⍽ ⍾ ⍿ ...+Control Pictures+␀ ␁ ␂ ␃ ␄ ␅ ␆ ␇ ␈ ␉ ␊ ␋ ␌ ␍ ␎ ␏ ␐ ␑ ␒ ␓ ␔ ␕ ␖ ␗ ␘ ␙ ␚ ␛ ␜ ␝ ␞ ␟ ␠ ␡ ␢ ␣ ␤ ␥ ␦+Optical Character Recognition+⑀ ⑁ ⑂ ⑃ ⑄ ⑅ ⑆ ⑇ ⑈ ⑉ ⑊+Enclosed Alphanumerics+① ② ③ ④ ⑤ ⑥ ⑦ ⑧ ⑨ ⑩ ⑪ ⑫ ⑬ ⑭ ⑮ ⑯ ⑰ ⑱ ⑲ ⑳ ⑴ ⑵ ⑶ ⑷ ⑸ ⑹ ⑺ ⑻ ⑼ ⑽ ⑾ ⑿ ⒀ ⒁ ⒂ ⒃ ⒄ ⒅ ⒆ ⒇ ⒈ ⒉ ⒊ ⒋ ⒌ ⒍ ⒎ ⒏ ⒐ ⒑ ⒒ ⒓ ⒔ ⒕ ⒖ ⒗ ⒘ ⒙ ⒚ ⒛ ⒜ ⒝ ⒞ ⒟ ⒠ ⒡ ⒢ ⒣ ⒤ ⒥ ⒦ ⒧ ⒨ ⒩ ⒪ ⒫ ⒬ ⒭ ⒮ ⒯ ⒰ ⒱ ⒲ ⒳ ⒴ ⒵ Ⓐ Ⓑ Ⓒ Ⓓ Ⓔ Ⓕ Ⓖ Ⓗ Ⓘ Ⓙ Ⓚ Ⓛ Ⓜ Ⓝ Ⓞ Ⓟ Ⓠ Ⓡ Ⓢ Ⓣ Ⓤ Ⓥ Ⓦ Ⓧ Ⓨ Ⓩ ⓐ ⓑ ⓒ ⓓ ⓔ ⓕ ⓖ ⓗ ⓘ ⓙ ⓚ ⓛ ⓜ ⓝ ⓞ ⓟ ...+Box Drawing+─ ━ │ ┃ ┄ ┅ ┆ ┇ ┈ ┉ ┊ ┋ ┌ ┍ ┎ ┏ ┐ ┑ ┒ ┓ └ ┕ ┖ ┗ ┘ ┙ ┚ ┛ ├ ┝ ┞ ┟ ┠ ┡ ┢ ┣ ┤ ┥ ┦ ┧ ┨ ┩ ┪ ┫ ┬ ┭ ┮ ┯ ┰ ┱ ┲ ┳ ┴ ┵ ┶ ┷ ┸ ┹ ┺ ┻ ┼ ┽ ┾ ┿ ╀ ╁ ╂ ╃ ╄ ╅ ╆ ╇ ╈ ╉ ╊ ╋ ╌ ╍ ╎ ╏ ═ ║ ╒ ╓ ╔ ╕ ╖ ╗ ╘ ╙ ╚ ╛ ╜ ╝ ╞ ╟ ╠ ╡ ╢ ╣ ╤ ╥ ╦ ╧ ╨ ╩ ╪ ╫ ╬ ╭ ╮ ╯ ╰ ╱ ╲ ╳ ╴ ╵ ╶ ╷ ╸ ╹ ╺ ╻ ╼ ╽ ╾ ╿+Block Elements+▀ ▁ ▂ ▃ ▄ ▅ ▆ ▇ █ ▉ ▊ ▋ ▌ ▍ ▎ ▏ ▐ ░ ▒ ▓ ▔ ▕ ▖ ▗ ▘ ▙ ▚ ▛ ▜ ▝ ▞ ▟+Geometric Shapes+■ □ ▢ ▣ ▤ ▥ ▦ ▧ ▨ ▩ ▪ ▫ ▬ ▭ ▮ ▯ ▰ ▱ ▲ △ ▴ ▵ ▶ ▷ ▸ ▹ ► ▻ ▼ ▽ ▾ ▿ ◀ ◁ ◂ ◃ ◄ ◅ ◆ ◇ ◈ ◉ ◊ ○ ◌ ◍ ◎ ● ◐ ◑ ◒ ◓ ◔ ◕ ◖ ◗ ◘ ◙ ◚ ◛ ◜ ◝ ◞ ◟ ◠ ◡ ◢ ◣ ◤ ◥ ◦ ◧ ◨ ◩ ◪ ◫ ◬ ◭ ◮ ◯ ◰ ◱ ◲ ◳ ◴ ◵ ◶ ◷ ◸ ◹ ◺ ◻ ◼ ◽ ◾ ◿+Miscellaneous Symbols+☀ ☁ ☂ ☃ ☄ ★ ☆ ☇ ☈ ☉ ☊ ☋ ☌ ☍ ☎ ☏ ☐ ☑ ☒ ☓ ☖ ☗ ☙ ☚ ☛ ☜ ☝ ☞ ☟ ☠ ☡ ☢ ☣ ☤ ☥ ☦ ☧ ☨ ☩ ☪ ☫ ☬ ☭ ☮ ☯ ☰ ☱ ☲ ☳ ☴ ☵ ☶ ☷ ☸ ☹ ☺ ☻ ☼ ☽ ☾ ☿ ♀ ♁ ♂ ♃ ♄ ♅ ♆ ♇ ♈ ♉ ♊ ♋ ♌ ♍ ♎ ♏ ♐ ♑ ♒ ♓ ♔ ♕ ♖ ♗ ♘ ♙ ♚ ♛ ♜ ♝ ♞ ♟ ♠ ♡ ♢ ♣ ♤ ♥ ♦ ♧ ♨ ♩ ♪ ♫ ♬ ♭ ♮ ♯ ♰ ♱ ♲ ♳ ♴ ♵ ♶ ♷ ♸ ♹ ♺ ♻ ♼ ♽ ⚀ ⚁ ⚂ ⚃ ⚄ ...+Dingbats+✁ ✂ ✃ ✄ ✆ ✇ ✈ ✉ ✌ ✍ ✎ ✏ ✐ ✑ ✒ ✓ ✔ ✕ ✖ ✗ ✘ ✙ ✚ ✛ ✜ ✝ ✞ ✟ ✠ ✡ ✢ ✣ ✤ ✥ ✦ ✧ ✩ ✪ ✫ ✬ ✭ ✮ ✯ ✰ ✱ ✲ ✳ ✴ ✵ ✶ ✷ ✸ ✹ ✺ ✻ ✼ ✽ ✾ ✿ ❀ ❁ ❂ ❃ ❄ ❅ ❆ ❇ ❈ ❉ ❊ ❋ ❍ ❏ ❐ ❑ ❒ ❖ ❘ ❙ ❚ ❛ ❜ ❝ ❞ ❡ ❢ ❣ ❤ ❥ ❦ ❧ ❨ ❩ ❪ ❫ ❬ ❭ ❮ ❯ ❰ ❱ ❲ ❳ ❴ ❵ ❶ ❷ ❸ ❹ ❺ ❻ ❼ ❽ ❾ ❿ ➀ ➁ ➂ ➃ ➄ ➅ ➆ ➇ ➈ ➉ ➊ ➋ ➌ ...+Miscellaneous Mathematical Symbols-A+⟐ ⟑ ⟒ ⟓ ⟔ ⟕ ⟖ ⟗ ⟘ ⟙ ⟚ ⟛ ⟜ ⟝ ⟞ ⟟ ⟠ ⟡ ⟢ ⟣ ⟤ ⟥ ⟦ ⟧ ⟨ ⟩ ⟪ ⟫+Supplemental Arrows-A+⟰ ⟱ ⟲ ⟳ ⟴ ⟵ ⟶ ⟷ ⟸ ⟹ ⟺ ⟻ ⟼ ⟽ ⟾ ⟿+Braille Patterns+⠀ ⠁ ⠂ ⠃ ⠄ ⠅ ⠆ ⠇ ⠈ ⠉ ⠊ ⠋ ⠌ ⠍ ⠎ ⠏ ⠐ ⠑ ⠒ ⠓ ⠔ ⠕ ⠖ ⠗ ⠘ ⠙ ⠚ ⠛ ⠜ ⠝ ⠞ ⠟ ⠠ ⠡ ⠢ ⠣ ⠤ ⠥ ⠦ ⠧ ⠨ ⠩ ⠪ ⠫ ⠬ ⠭ ⠮ ⠯ ⠰ ⠱ ⠲ ⠳ ⠴ ⠵ ⠶ ⠷ ⠸ ⠹ ⠺ ⠻ ⠼ ⠽ ⠾ ⠿ ⡀ ⡁ ⡂ ⡃ ⡄ ⡅ ⡆ ⡇ ⡈ ⡉ ⡊ ⡋ ⡌ ⡍ ⡎ ⡏ ⡐ ⡑ ⡒ ⡓ ⡔ ⡕ ⡖ ⡗ ⡘ ⡙ ⡚ ⡛ ⡜ ⡝ ⡞ ⡟ ⡠ ⡡ ⡢ ⡣ ⡤ ⡥ ⡦ ⡧ ⡨ ⡩ ⡪ ⡫ ⡬ ⡭ ⡮ ⡯ ⡰ ⡱ ⡲ ⡳ ⡴ ⡵ ⡶ ⡷ ⡸ ⡹ ⡺ ⡻ ⡼ ⡽ ⡾ ⡿ ...+Supplemental Arrows-B+⤀ ⤁ ⤂ ⤃ ⤄ ⤅ ⤆ ⤇ ⤈ ⤉ ⤊ ⤋ ⤌ ⤍ ⤎ ⤏ ⤐ ⤑ ⤒ ⤓ ⤔ ⤕ ⤖ ⤗ ⤘ ⤙ ⤚ ⤛ ⤜ ⤝ ⤞ ⤟ ⤠ ⤡ ⤢ ⤣ ⤤ ⤥ ⤦ ⤧ ⤨ ⤩ ⤪ ⤫ ⤬ ⤭ ⤮ ⤯ ⤰ ⤱ ⤲ ⤳ ⤴ ⤵ ⤶ ⤷ ⤸ ⤹ ⤺ ⤻ ⤼ ⤽ ⤾ ⤿ ⥀ ⥁ ⥂ ⥃ ⥄ ⥅ ⥆ ⥇ ⥈ ⥉ ⥊ ⥋ ⥌ ⥍ ⥎ ⥏ ⥐ ⥑ ⥒ ⥓ ⥔ ⥕ ⥖ ⥗ ⥘ ⥙ ⥚ ⥛ ⥜ ⥝ ⥞ ⥟ ⥠ ⥡ ⥢ ⥣ ⥤ ⥥ ⥦ ⥧ ⥨ ⥩ ⥪ ⥫ ⥬ ⥭ ⥮ ⥯ ⥰ ⥱ ⥲ ⥳ ⥴ ⥵ ⥶ ⥷ ⥸ ⥹ ⥺ ⥻ ⥼ ⥽ ⥾ ⥿+Miscellaneous Mathematical Symbols-B+⦀ ⦁ ⦂ ⦃ ⦄ ⦅ ⦆ ⦇ ⦈ ⦉ ⦊ ⦋ ⦌ ⦍ ⦎ ⦏ ⦐ ⦑ ⦒ ⦓ ⦔ ⦕ ⦖ ⦗ ⦘ ⦙ ⦚ ⦛ ⦜ ⦝ ⦞ ⦟ ⦠ ⦡ ⦢ ⦣ ⦤ ⦥ ⦦ ⦧ ⦨ ⦩ ⦪ ⦫ ⦬ ⦭ ⦮ ⦯ ⦰ ⦱ ⦲ ⦳ ⦴ ⦵ ⦶ ⦷ ⦸ ⦹ ⦺ ⦻ ⦼ ⦽ ⦾ ⦿ ⧀ ⧁ ⧂ ⧃ ⧄ ⧅ ⧆ ⧇ ⧈ ⧉ ⧊ ⧋ ⧌ ⧍ ⧎ ⧏ ⧐ ⧑ ⧒ ⧓ ⧔ ⧕ ⧖ ⧗ ⧘ ⧙ ⧚ ⧛ ⧜ ⧝ ⧞ ⧟ ⧠ ⧡ ⧢ ⧣ ⧤ ⧥ ⧦ ⧧ ⧨ ⧩ ⧪ ⧫ ⧬ ⧭ ⧮ ⧯ ⧰ ⧱ ⧲ ⧳ ⧴ ⧵ ⧶ ⧷ ⧸ ⧹ ⧺ ⧻ ⧼ ⧽ ⧾ ⧿+Supplemental Mathematical Operators+⨀ ⨁ ⨂ ⨃ ⨄ ⨅ ⨆ ⨇ ⨈ ⨉ ⨊ ⨋ ⨌ ⨍ ⨎ ⨏ ⨐ ⨑ ⨒ ⨓ ⨔ ⨕ ⨖ ⨗ ⨘ ⨙ ⨚ ⨛ ⨜ ⨝ ⨞ ⨟ ⨠ ⨡ ⨢ ⨣ ⨤ ⨥ ⨦ ⨧ ⨨ ⨩ ⨪ ⨫ ⨬ ⨭ ⨮ ⨯ ⨰ ⨱ ⨲ ⨳ ⨴ ⨵ ⨶ ⨷ ⨸ ⨹ ⨺ ⨻ ⨼ ⨽ ⨾ ⨿ ⩀ ⩁ ⩂ ⩃ ⩄ ⩅ ⩆ ⩇ ⩈ ⩉ ⩊ ⩋ ⩌ ⩍ ⩎ ⩏ ⩐ ⩑ ⩒ ⩓ ⩔ ⩕ ⩖ ⩗ ⩘ ⩙ ⩚ ⩛ ⩜ ⩝ ⩞ ⩟ ⩠ ⩡ ⩢ ⩣ ⩤ ⩥ ⩦ ⩧ ⩨ ⩩ ⩪ ⩫ ⩬ ⩭ ⩮ ⩯ ⩰ ⩱ ⩲ ⩳ ⩴ ⩵ ⩶ ⩷ ⩸ ⩹ ⩺ ⩻ ⩼ ⩽ ⩾ ⩿ ...+CJK Radicals Supplement+⺀ ⺁ ⺂ ⺃ ⺄ ⺅ ⺆ ⺇ ⺈ ⺉ ⺊ ⺋ ⺌ ⺍ ⺎ ⺏ ⺐ ⺑ ⺒ ⺓ ⺔ ⺕ ⺖ ⺗ ⺘ ⺙ ⺛ ⺜ ⺝ ⺞ ⺟ ⺠ ⺡ ⺢ ⺣ ⺤ ⺥ ⺦ ⺧ ⺨ ⺩ ⺪ ⺫ ⺬ ⺭ ⺮ ⺯ ⺰ ⺱ ⺲ ⺳ ⺴ ⺵ ⺶ ⺷ ⺸ ⺹ ⺺ ⺻ ⺼ ⺽ ⺾ ⺿ ⻀ ⻁ ⻂ ⻃ ⻄ ⻅ ⻆ ⻇ ⻈ ⻉ ⻊ ⻋ ⻌ ⻍ ⻎ ⻏ ⻐ ⻑ ⻒ ⻓ ⻔ ⻕ ⻖ ⻗ ⻘ ⻙ ⻚ ⻛ ⻜ ⻝ ⻞ ⻟ ⻠ ⻡ ⻢ ⻣ ⻤ ⻥ ⻦ ⻧ ⻨ ⻩ ⻪ ⻫ ⻬ ⻭ ⻮ ⻯ ⻰ ⻱ ⻲ ⻳+Kangxi Radicals+⼀ ⼁ ⼂ ⼃ ⼄ ⼅ ⼆ ⼇ ⼈ ⼉ ⼊ ⼋ ⼌ ⼍ ⼎ ⼏ ⼐ ⼑ ⼒ ⼓ ⼔ ⼕ ⼖ ⼗ ⼘ ⼙ ⼚ ⼛ ⼜ ⼝ ⼞ ⼟ ⼠ ⼡ ⼢ ⼣ ⼤ ⼥ ⼦ ⼧ ⼨ ⼩ ⼪ ⼫ ⼬ ⼭ ⼮ ⼯ ⼰ ⼱ ⼲ ⼳ ⼴ ⼵ ⼶ ⼷ ⼸ ⼹ ⼺ ⼻ ⼼ ⼽ ⼾ ⼿ ⽀ ⽁ ⽂ ⽃ ⽄ ⽅ ⽆ ⽇ ⽈ ⽉ ⽊ ⽋ ⽌ ⽍ ⽎ ⽏ ⽐ ⽑ ⽒ ⽓ ⽔ ⽕ ⽖ ⽗ ⽘ ⽙ ⽚ ⽛ ⽜ ⽝ ⽞ ⽟ ⽠ ⽡ ⽢ ⽣ ⽤ ⽥ ⽦ ⽧ ⽨ ⽩ ⽪ ⽫ ⽬ ⽭ ⽮ ⽯ ⽰ ⽱ ⽲ ⽳ ⽴ ⽵ ⽶ ⽷ ⽸ ⽹ ⽺ ⽻ ⽼ ⽽ ⽾ ⽿ ...+Ideographic Description Characters+⿰ ⿱ ⿲ ⿳ ⿴ ⿵ ⿶ ⿷ ⿸ ⿹ ⿺ ⿻+CJK Symbols and Punctuation+　 、 。 〃 〄 々 〆 〇 〈 〉 《 》 「 」 『 』 【 】 〒 〓 〔 〕 〖 〗 〘 〙 〚 〛 〜 〝 〞 〟 〠 〡 〢 〣 〤 〥 〦 〧 〨 〩 〪 〫 〬 〭 〮 〯 〰 〱 〲 〳 〴 〵 〶 〷 〸 〹 〺 〻 〼 〽 〾 〿+Hiragana+ぁ あ ぃ い ぅ う ぇ え ぉ お か が き ぎ く ぐ け げ こ ご さ ざ し じ す ず せ ぜ そ ぞ た だ ち ぢ っ つ づ て で と ど な に ぬ ね の は ば ぱ ひ び ぴ ふ ぶ ぷ へ べ ぺ ほ ぼ ぽ ま み む め も ゃ や ゅ ゆ ょ よ ら り る れ ろ ゎ わ ゐ ゑ を ん ゔ ゕ ゖ ゙ ゚ ゛ ゜ ゝ ゞ ゟ+Katakana+゠ ァ ア ィ イ ゥ ウ ェ エ ォ オ カ ガ キ ギ ク グ ケ ゲ コ ゴ サ ザ シ ジ ス ズ セ ゼ ソ ゾ タ ダ チ ヂ ッ ツ ヅ テ デ ト ド ナ ニ ヌ ネ ノ ハ バ パ ヒ ビ ピ フ ブ プ ヘ ベ ペ ホ ボ ポ マ ミ ム メ モ ャ ヤ ュ ユ ョ ヨ ラ リ ル レ ロ ヮ ワ ヰ ヱ ヲ ン ヴ ヵ ヶ ヷ ヸ ヹ ヺ ・ ー ヽ ヾ ヿ+Bopomofo+ㄅ ㄆ ㄇ ㄈ ㄉ ㄊ ㄋ ㄌ ㄍ ㄎ ㄏ ㄐ ㄑ ㄒ ㄓ ㄔ ㄕ ㄖ ㄗ ㄘ ㄙ ㄚ ㄛ ㄜ ㄝ ㄞ ㄟ ㄠ ㄡ ㄢ ㄣ ㄤ ㄥ ㄦ ㄧ ㄨ ㄩ ㄪ ㄫ ㄬ+Hangul Compatibility Jamo+ㄱ ㄲ ㄳ ㄴ ㄵ ㄶ ㄷ ㄸ ㄹ ㄺ ㄻ ㄼ ㄽ ㄾ ㄿ ㅀ ㅁ ㅂ ㅃ ㅄ ㅅ ㅆ ㅇ ㅈ ㅉ ㅊ ㅋ ㅌ ㅍ ㅎ ㅏ ㅐ ㅑ ㅒ ㅓ ㅔ ㅕ ㅖ ㅗ ㅘ ㅙ ㅚ ㅛ ㅜ ㅝ ㅞ ㅟ ㅠ ㅡ ㅢ ㅣ ㅤ ㅥ ㅦ ㅧ ㅨ ㅩ ㅪ ㅫ ㅬ ㅭ ㅮ ㅯ ㅰ ㅱ ㅲ ㅳ ㅴ ㅵ ㅶ ㅷ ㅸ ㅹ ㅺ ㅻ ㅼ ㅽ ㅾ ㅿ ㆀ ㆁ ㆂ ㆃ ㆄ ㆅ ㆆ ㆇ ㆈ ㆉ ㆊ ㆋ ㆌ ㆍ ㆎ+Kanbun+㆐ ㆑ ㆒ ㆓ ㆔ ㆕ ㆖ ㆗ ㆘ ㆙ ㆚ ㆛ ㆜ ㆝ ㆞ ㆟+Bopomofo Extended+ㆠ ㆡ ㆢ ㆣ ㆤ ㆥ ㆦ ㆧ ㆨ ㆩ ㆪ ㆫ ㆬ ㆭ ㆮ ㆯ ㆰ ㆱ ㆲ ㆳ ㆴ ㆵ ㆶ ㆷ+Katakana Phonetic Extensions+ㇰ ㇱ ㇲ ㇳ ㇴ ㇵ ㇶ ㇷ ㇸ ㇹ ㇺ ㇻ ㇼ ㇽ ㇾ ㇿ+Enclosed CJK Letters and Months+㈀ ㈁ ㈂ ㈃ ㈄ ㈅ ㈆ ㈇ ㈈ ㈉ ㈊ ㈋ ㈌ ㈍ ㈎ ㈏ ㈐ ㈑ ㈒ ㈓ ㈔ ㈕ ㈖ ㈗ ㈘ ㈙ ㈚ ㈛ ㈜ ㈠ ㈡ ㈢ ㈣ ㈤ ㈥ ㈦ ㈧ ㈨ ㈩ ㈪ ㈫ ㈬ ㈭ ㈮ ㈯ ㈰ ㈱ ㈲ ㈳ ㈴ ㈵ ㈶ ㈷ ㈸ ㈹ ㈺ ㈻ ㈼ ㈽ ㈾ ㈿ ㉀ ㉁ ㉂ ㉃ ㉑ ㉒ ㉓ ㉔ ㉕ ㉖ ㉗ ㉘ ㉙ ㉚ ㉛ ㉜ ㉝ ㉞ ㉟ ㉠ ㉡ ㉢ ㉣ ㉤ ㉥ ㉦ ㉧ ㉨ ㉩ ㉪ ㉫ ㉬ ㉭ ㉮ ㉯ ㉰ ㉱ ㉲ ㉳ ㉴ ㉵ ㉶ ㉷ ㉸ ㉹ ㉺ ㉻ ㉿ ㊀ ㊁ ㊂ ㊃ ㊄ ㊅ ㊆ ㊇ ㊈ ㊉ ㊊ ㊋ ㊌ ㊍ ㊎ ㊏ ㊐ ㊑ ㊒ ...+CJK Compatibility+㌀ ㌁ ㌂ ㌃ ㌄ ㌅ ㌆ ㌇ ㌈ ㌉ ㌊ ㌋ ㌌ ㌍ ㌎ ㌏ ㌐ ㌑ ㌒ ㌓ ㌔ ㌕ ㌖ ㌗ ㌘ ㌙ ㌚ ㌛ ㌜ ㌝ ㌞ ㌟ ㌠ ㌡ ㌢ ㌣ ㌤ ㌥ ㌦ ㌧ ㌨ ㌩ ㌪ ㌫ ㌬ ㌭ ㌮ ㌯ ㌰ ㌱ ㌲ ㌳ ㌴ ㌵ ㌶ ㌷ ㌸ ㌹ ㌺ ㌻ ㌼ ㌽ ㌾ ㌿ ㍀ ㍁ ㍂ ㍃ ㍄ ㍅ ㍆ ㍇ ㍈ ㍉ ㍊ ㍋ ㍌ ㍍ ㍎ ㍏ ㍐ ㍑ ㍒ ㍓ ㍔ ㍕ ㍖ ㍗ ㍘ ㍙ ㍚ ㍛ ㍜ ㍝ ㍞ ㍟ ㍠ ㍡ ㍢ ㍣ ㍤ ㍥ ㍦ ㍧ ㍨ ㍩ ㍪ ㍫ ㍬ ㍭ ㍮ ㍯ ㍰ ㍱ ㍲ ㍳ ㍴ ㍵ ㍶ ㍻ ㍼ ㍽ ㍾ ㍿ ㎀ ㎁ ㎂ ㎃ ...+CJK Unified Ideographs Extension A+㐀 㐁 㐂 㐃 㐄 㐅 㐆 㐇 㐈 㐉 㐊 㐋 㐌 㐍 㐎 㐏 㐐 㐑 㐒 㐓 㐔 㐕 㐖 㐗 㐘 㐙 㐚 㐛 㐜 㐝 㐞 㐟 㐠 㐡 㐢 㐣 㐤 㐥 㐦 㐧 㐨 㐩 㐪 㐫 㐬 㐭 㐮 㐯 㐰 㐱 㐲 㐳 㐴 㐵 㐶 㐷 㐸 㐹 㐺 㐻 㐼 㐽 㐾 㐿 㑀 㑁 㑂 㑃 㑄 㑅 㑆 㑇 㑈 㑉 㑊 㑋 㑌 㑍 㑎 㑏 㑐 㑑 㑒 㑓 㑔 㑕 㑖 㑗 㑘 㑙 㑚 㑛 㑜 㑝 㑞 㑟 㑠 㑡 㑢 㑣 㑤 㑥 㑦 㑧 㑨 㑩 㑪 㑫 㑬 㑭 㑮 㑯 㑰 㑱 㑲 㑳 㑴 㑵 㑶 㑷 㑸 㑹 㑺 㑻 㑼 㑽 㑾 㑿 ...+CJK Unified Ideographs+一 丁 丂 七 丄 丅 丆 万 丈 三 上 下 丌 不 与 丏 丐 丑 丒 专 且 丕 世 丗 丘 丙 业 丛 东 丝 丞 丟 丠 両 丢 丣 两 严 並 丧 丨 丩 个 丫 丬 中 丮 丯 丰 丱 串 丳 临 丵 丶 丷 丸 丹 为 主 丼 丽 举 丿 乀 乁 乂 乃 乄 久 乆 乇 么 义 乊 之 乌 乍 乎 乏 乐 乑 乒 乓 乔 乕 乖 乗 乘 乙 乚 乛 乜 九 乞 也 习 乡 乢 乣 乤 乥 书 乧 乨 乩 乪 乫 乬 乭 乮 乯 买 乱 乲 乳 乴 乵 乶 乷 乸 乹 乺 乻 乼 乽 乾 乿 ...+Yi Syllables+ꀀ ꀁ ꀂ ꀃ ꀄ ꀅ ꀆ ꀇ ꀈ ꀉ ꀊ ꀋ ꀌ ꀍ ꀎ ꀏ ꀐ ꀑ ꀒ ꀓ ꀔ ꀕ ꀖ ꀗ ꀘ ꀙ ꀚ ꀛ ꀜ ꀝ ꀞ ꀟ ꀠ ꀡ ꀢ ꀣ ꀤ ꀥ ꀦ ꀧ ꀨ ꀩ ꀪ ꀫ ꀬ ꀭ ꀮ ꀯ ꀰ ꀱ ꀲ ꀳ ꀴ ꀵ ꀶ ꀷ ꀸ ꀹ ꀺ ꀻ ꀼ ꀽ ꀾ ꀿ ꁀ ꁁ ꁂ ꁃ ꁄ ꁅ ꁆ ꁇ ꁈ ꁉ ꁊ ꁋ ꁌ ꁍ ꁎ ꁏ ꁐ ꁑ ꁒ ꁓ ꁔ ꁕ ꁖ ꁗ ꁘ ꁙ ꁚ ꁛ ꁜ ꁝ ꁞ ꁟ ꁠ ꁡ ꁢ ꁣ ꁤ ꁥ ꁦ ꁧ ꁨ ꁩ ꁪ ꁫ ꁬ ꁭ ꁮ ꁯ ꁰ ꁱ ꁲ ꁳ ꁴ ꁵ ꁶ ꁷ ꁸ ꁹ ꁺ ꁻ ꁼ ꁽ ꁾ ꁿ ...+Yi Radicals+꒐ ꒑ ꒒ ꒓ ꒔ ꒕ ꒖ ꒗ ꒘ ꒙ ꒚ ꒛ ꒜ ꒝ ꒞ ꒟ ꒠ ꒡ ꒢ ꒣ ꒤ ꒥ ꒦ ꒧ ꒨ ꒩ ꒪ ꒫ ꒬ ꒭ ꒮ ꒯ ꒰ ꒱ ꒲ ꒳ ꒴ ꒵ ꒶ ꒷ ꒸ ꒹ ꒺ ꒻ ꒼ ꒽ ꒾ ꒿ ꓀ ꓁ ꓂ ꓃ ꓄ ꓅ ꓆+Hangul Syllables+가 각 갂 갃 간 갅 갆 갇 갈 갉 갊 갋 갌 갍 갎 갏 감 갑 값 갓 갔 강 갖 갗 갘 같 갚 갛 개 객 갞 갟 갠 갡 갢 갣 갤 갥 갦 갧 갨 갩 갪 갫 갬 갭 갮 갯 갰 갱 갲 갳 갴 갵 갶 갷 갸 갹 갺 갻 갼 갽 갾 갿 걀 걁 걂 걃 걄 걅 걆 걇 걈 걉 걊 걋 걌 걍 걎 걏 걐 걑 걒 걓 걔 걕 걖 걗 걘 걙 걚 걛 걜 걝 걞 걟 걠 걡 걢 걣 걤 걥 걦 걧 걨 걩 걪 걫 걬 걭 걮 걯 거 걱 걲 걳 건 걵 걶 걷 걸 걹 걺 걻 걼 걽 걾 걿 ...+Private Use Area+                                                                                                                                ...+CJK Compatibility Ideographs+豈 更 車 賈 滑 串 句 龜 龜 契 金 喇 奈 懶 癩 羅 蘿 螺 裸 邏 樂 洛 烙 珞 落 酪 駱 亂 卵 欄 爛 蘭 鸞 嵐 濫 藍 襤 拉 臘 蠟 廊 朗 浪 狼 郎 來 冷 勞 擄 櫓 爐 盧 老 蘆 虜 路 露 魯 鷺 碌 祿 綠 菉 錄 鹿 論 壟 弄 籠 聾 牢 磊 賂 雷 壘 屢 樓 淚 漏 累 縷 陋 勒 肋 凜 凌 稜 綾 菱 陵 讀 拏 樂 諾 丹 寧 怒 率 異 北 磻 便 復 不 泌 數 索 參 塞 省 葉 說 殺 辰 沈 拾 若 掠 略 亮 兩 凉 梁 糧 良 諒 量 勵 ...+Alphabetic Presentation Forms+ff fi fl ffi ffl ſt st ﬓ ﬔ ﬕ ﬖ ﬗ יִ ﬞ ײַ ﬠ ﬡ ﬢ ﬣ ﬤ ﬥ ﬦ ﬧ ﬨ ﬩ שׁ שׂ שּׁ שּׂ אַ אָ אּ בּ גּ דּ הּ וּ זּ טּ יּ ךּ כּ לּ מּ נּ סּ ףּ פּ צּ קּ רּ שּ תּ וֹ בֿ כֿ פֿ ﭏ+Arabic Presentation Forms-A+ﭐ ﭑ ﭒ ﭓ ﭔ ﭕ ﭖ ﭗ ﭘ ﭙ ﭚ ﭛ ﭜ ﭝ ﭞ ﭟ ﭠ ﭡ ﭢ ﭣ ﭤ ﭥ ﭦ ﭧ ﭨ ﭩ ﭪ ﭫ ﭬ ﭭ ﭮ ﭯ ﭰ ﭱ ﭲ ﭳ ﭴ ﭵ ﭶ ﭷ ﭸ ﭹ ﭺ ﭻ ﭼ ﭽ ﭾ ﭿ ﮀ ﮁ ﮂ ﮃ ﮄ ﮅ ﮆ ﮇ ﮈ ﮉ ﮊ ﮋ ﮌ ﮍ ﮎ ﮏ ﮐ ﮑ ﮒ ﮓ ﮔ ﮕ ﮖ ﮗ ﮘ ﮙ ﮚ ﮛ ﮜ ﮝ ﮞ ﮟ ﮠ ﮡ ﮢ ﮣ ﮤ ﮥ ﮦ ﮧ ﮨ ﮩ ﮪ ﮫ ﮬ ﮭ ﮮ ﮯ ﮰ ﮱ ﯓ ﯔ ﯕ ﯖ ﯗ ﯘ ﯙ ﯚ ﯛ ﯜ ﯝ ﯞ ﯟ ﯠ ﯡ ﯢ ﯣ ﯤ ﯥ ﯦ ﯧ ﯨ ﯩ ﯪ ﯫ ﯬ ﯭ ﯮ ﯯ ﯰ ...+Variation Selectors+︀ ︁ ︂ ︃ ︄ ︅ ︆ ︇ ︈ ︉ ︊ ︋ ︌ ︍ ︎ ️+Combining Half Marks+︠ ︡ ︢ ︣+CJK Compatibility Forms+︰ ︱ ︲ ︳ ︴ ︵ ︶ ︷ ︸ ︹ ︺ ︻ ︼ ︽ ︾ ︿ ﹀ ﹁ ﹂ ﹃ ﹄ ﹅ ﹆ ﹉ ﹊ ﹋ ﹌ ﹍ ﹎ ﹏+Small Form Variants+﹐ ﹑ ﹒ ﹔ ﹕ ﹖ ﹗ ﹘ ﹙ ﹚ ﹛ ﹜ ﹝ ﹞ ﹟ ﹠ ﹡ ﹢ ﹣ ﹤ ﹥ ﹦ ﹨ ﹩ ﹪ ﹫+Arabic Presentation Forms-B+ﹰ ﹱ ﹲ ﹳ ﹴ ﹶ ﹷ ﹸ ﹹ ﹺ ﹻ ﹼ ﹽ ﹾ ﹿ ﺀ ﺁ ﺂ ﺃ ﺄ ﺅ ﺆ ﺇ ﺈ ﺉ ﺊ ﺋ ﺌ ﺍ ﺎ ﺏ ﺐ ﺑ ﺒ ﺓ ﺔ ﺕ ﺖ ﺗ ﺘ ﺙ ﺚ ﺛ ﺜ ﺝ ﺞ ﺟ ﺠ ﺡ ﺢ ﺣ ﺤ ﺥ ﺦ ﺧ ﺨ ﺩ ﺪ ﺫ ﺬ ﺭ ﺮ ﺯ ﺰ ﺱ ﺲ ﺳ ﺴ ﺵ ﺶ ﺷ ﺸ ﺹ ﺺ ﺻ ﺼ ﺽ ﺾ ﺿ ﻀ ﻁ ﻂ ﻃ ﻄ ﻅ ﻆ ﻇ ﻈ ﻉ ﻊ ﻋ ﻌ ﻍ ﻎ ﻏ ﻐ ﻑ ﻒ ﻓ ﻔ ﻕ ﻖ ﻗ ﻘ ﻙ ﻚ ﻛ ﻜ ﻝ ﻞ ﻟ ﻠ ﻡ ﻢ ﻣ ﻤ ﻥ ﻦ ﻧ ﻨ ﻩ ﻪ ﻫ ﻬ ﻭ ﻮ ﻯ ﻰ ...+Halfwidth and Fullwidth Forms+！ ＂ ＃ ＄ ％ ＆ ＇ （ ） ＊ ＋ ， － ． ／ ０ １ ２ ３ ４ ５ ６ ７ ８ ９ ： ； ＜ ＝ ＞ ？ ＠ Ａ Ｂ Ｃ Ｄ Ｅ Ｆ Ｇ Ｈ Ｉ Ｊ Ｋ Ｌ Ｍ Ｎ Ｏ Ｐ Ｑ Ｒ Ｓ Ｔ Ｕ Ｖ Ｗ Ｘ Ｙ Ｚ ［ ＼ ］ ＾ ＿ ｀ ａ ｂ ｃ ｄ ｅ ｆ ｇ ｈ ｉ ｊ ｋ ｌ ｍ ｎ ｏ ｐ ｑ ｒ ｓ ｔ ｕ ｖ ｗ ｘ ｙ ｚ ｛ ｜ ｝ ～ ｟ ｠ ｡ ｢ ｣ ､ ･ ｦ ｧ ｨ ｩ ｪ ｫ ｬ ｭ ｮ ｯ ｰ ｱ ｲ ｳ ｴ ｵ ｶ ｷ ｸ ｹ ｺ ｻ ｼ ｽ ｾ ｿ ﾀ ...+Specials+    �+Old Italic+𐌀 𐌁 𐌂 𐌃 𐌄 𐌅 𐌆 𐌇 𐌈 𐌉 𐌊 𐌋 𐌌 𐌍 𐌎 𐌏 𐌐 𐌑 𐌒 𐌓 𐌔 𐌕 𐌖 𐌗 𐌘 𐌙 𐌚 𐌛 𐌜 𐌝 𐌞 𐌠 𐌡 𐌢 𐌣+Gothic+𐌰 𐌱 𐌲 𐌳 𐌴 𐌵 𐌶 𐌷 𐌸 𐌹 𐌺 𐌻 𐌼 𐌽 𐌾 𐌿 𐍀 𐍁 𐍂 𐍃 𐍄 𐍅 𐍆 𐍇 𐍈 𐍉 𐍊+Deseret+𐐀 𐐁 𐐂 𐐃 𐐄 𐐅 𐐆 𐐇 𐐈 𐐉 𐐊 𐐋 𐐌 𐐍 𐐎 𐐏 𐐐 𐐑 𐐒 𐐓 𐐔 𐐕 𐐖 𐐗 𐐘 𐐙 𐐚 𐐛 𐐜 𐐝 𐐞 𐐟 𐐠 𐐡 𐐢 𐐣 𐐤 𐐥 𐐨 𐐩 𐐪 𐐫 𐐬 𐐭 𐐮 𐐯 𐐰 𐐱 𐐲 𐐳 𐐴 𐐵 𐐶 𐐷 𐐸 𐐹 𐐺 𐐻 𐐼 𐐽 𐐾 𐐿 𐑀 𐑁 𐑂 𐑃 𐑄 𐑅 𐑆 𐑇 𐑈 𐑉 𐑊 𐑋 𐑌 𐑍+Byzantine Musical Symbols+𝀀 𝀁 𝀂 𝀃 𝀄 𝀅 𝀆 𝀇 𝀈 𝀉 𝀊 𝀋 𝀌 𝀍 𝀎 𝀏 𝀐 𝀑 𝀒 𝀓 𝀔 𝀕 𝀖 𝀗 𝀘 𝀙 𝀚 𝀛 𝀜 𝀝 𝀞 𝀟 𝀠 𝀡 𝀢 𝀣 𝀤 𝀥 𝀦 𝀧 𝀨 𝀩 𝀪 𝀫 𝀬 𝀭 𝀮 𝀯 𝀰 𝀱 𝀲 𝀳 𝀴 𝀵 𝀶 𝀷 𝀸 𝀹 𝀺 𝀻 𝀼 𝀽 𝀾 𝀿 𝁀 𝁁 𝁂 𝁃 𝁄 𝁅 𝁆 𝁇 𝁈 𝁉 𝁊 𝁋 𝁌 𝁍 𝁎 𝁏 𝁐 𝁑 𝁒 𝁓 𝁔 𝁕 𝁖 𝁗 𝁘 𝁙 𝁚 𝁛 𝁜 𝁝 𝁞 𝁟 𝁠 𝁡 𝁢 𝁣 𝁤 𝁥 𝁦 𝁧 𝁨 𝁩 𝁪 𝁫 𝁬 𝁭 𝁮 𝁯 𝁰 𝁱 𝁲 𝁳 𝁴 𝁵 𝁶 𝁷 𝁸 𝁹 𝁺 𝁻 𝁼 𝁽 𝁾 𝁿 ...+Musical Symbols+𝄀 𝄁 𝄂 𝄃 𝄄 𝄅 𝄆 𝄇 𝄈 𝄉 𝄊 𝄋 𝄌 𝄍 𝄎 𝄏 𝄐 𝄑 𝄒 𝄓 𝄔 𝄕 𝄖 𝄗 𝄘 𝄙 𝄚 𝄛 𝄜 𝄝 𝄞 𝄟 𝄠 𝄡 𝄢 𝄣 𝄤 𝄥 𝄦 𝄪 𝄫 𝄬 𝄭 𝄮 𝄯 𝄰 𝄱 𝄲 𝄳 𝄴 𝄵 𝄶 𝄷 𝄸 𝄹 𝄺 𝄻 𝄼 𝄽 𝄾 𝄿 𝅀 𝅁 𝅂 𝅃 𝅄 𝅅 𝅆 𝅇 𝅈 𝅉 𝅊 𝅋 𝅌 𝅍 𝅎 𝅏 𝅐 𝅑 𝅒 𝅓 𝅔 𝅕 𝅖 𝅗 𝅘 𝅙 𝅚 𝅛 𝅜 𝅝 𝅗𝅥 𝅘𝅥 𝅘𝅥𝅮 𝅘𝅥𝅯 𝅘𝅥𝅰 𝅘𝅥𝅱 𝅘𝅥𝅲 𝅥 𝅦 𝅧 𝅨 𝅩 𝅪 𝅫 𝅬 𝅭 𝅮 𝅯 𝅰 𝅱 𝅲 𝅳 𝅴 𝅵 𝅶 𝅷 𝅸 𝅹 𝅺 𝅻 𝅼 𝅽 𝅾 𝅿 𝆀 𝆁 𝆂 ...+Mathematical Alphanumeric Symbols+𝐀 𝐁 𝐂 𝐃 𝐄 𝐅 𝐆 𝐇 𝐈 𝐉 𝐊 𝐋 𝐌 𝐍 𝐎 𝐏 𝐐 𝐑 𝐒 𝐓 𝐔 𝐕 𝐖 𝐗 𝐘 𝐙 𝐚 𝐛 𝐜 𝐝 𝐞 𝐟 𝐠 𝐡 𝐢 𝐣 𝐤 𝐥 𝐦 𝐧 𝐨 𝐩 𝐪 𝐫 𝐬 𝐭 𝐮 𝐯 𝐰 𝐱 𝐲 𝐳 𝐴 𝐵 𝐶 𝐷 𝐸 𝐹 𝐺 𝐻 𝐼 𝐽 𝐾 𝐿 𝑀 𝑁 𝑂 𝑃 𝑄 𝑅 𝑆 𝑇 𝑈 𝑉 𝑊 𝑋 𝑌 𝑍 𝑎 𝑏 𝑐 𝑑 𝑒 𝑓 𝑔 𝑖 𝑗 𝑘 𝑙 𝑚 𝑛 𝑜 𝑝 𝑞 𝑟 𝑠 𝑡 𝑢 𝑣 𝑤 𝑥 𝑦 𝑧 𝑨 𝑩 𝑪 𝑫 𝑬 𝑭 𝑮 𝑯 𝑰 𝑱 𝑲 𝑳 𝑴 𝑵 𝑶 𝑷 𝑸 𝑹 𝑺 𝑻 𝑼 𝑽 𝑾 𝑿 𝒀 ...+CJK Unified Ideographs Extension B+𠀀 𠀁 𠀂 𠀃 𠀄 𠀅 𠀆 𠀇 𠀈 𠀉 𠀊 𠀋 𠀌 𠀍 𠀎 𠀏 𠀐 𠀑 𠀒 𠀓 𠀔 𠀕 𠀖 𠀗 𠀘 𠀙 𠀚 𠀛 𠀜 𠀝 𠀞 𠀟 𠀠 𠀡 𠀢 𠀣 𠀤 𠀥 𠀦 𠀧 𠀨 𠀩 𠀪 𠀫 𠀬 𠀭 𠀮 𠀯 𠀰 𠀱 𠀲 𠀳 𠀴 𠀵 𠀶 𠀷 𠀸 𠀹 𠀺 𠀻 𠀼 𠀽 𠀾 𠀿 𠁀 𠁁 𠁂 𠁃 𠁄 𠁅 𠁆 𠁇 𠁈 𠁉 𠁊 𠁋 𠁌 𠁍 𠁎 𠁏 𠁐 𠁑 𠁒 𠁓 𠁔 𠁕 𠁖 𠁗 𠁘 𠁙 𠁚 𠁛 𠁜 𠁝 𠁞 𠁟 𠁠 𠁡 𠁢 𠁣 𠁤 𠁥 𠁦 𠁧 𠁨 𠁩 𠁪 𠁫 𠁬 𠁭 𠁮 𠁯 𠁰 𠁱 𠁲 𠁳 𠁴 𠁵 𠁶 𠁷 𠁸 𠁹 𠁺 𠁻 𠁼 𠁽 𠁾 𠁿 ...+CJK Compatibility Ideographs Supplement+丽 丸 乁 𠄢 你 侮 侻 倂 偺 備 僧 像 㒞 𠘺 免 兔 兤 具 𠔜 㒹 內 再 𠕋 冗 冤 仌 冬 况 𩇟 凵 刃 㓟 刻 剆 割 剷 㔕 勇 勉 勤 勺 包 匆 北 卉 卑 博 即 卽 卿 卿 卿 𠨬 灰 及 叟 𠭣 叫 叱 吆 咞 吸 呈 周 咢 哶 唐 啓 啣 善 善 喙 喫 喳 嗂 圖 嘆 圗 噑 噴 切 壮 城 埴 堍 型 堲 報 墬 𡓤 売 壷 夆 多 夢 奢 𡚨 𡛪 姬 娛 娧 姘 婦 㛮 㛼 嬈 嬾 嬾 𡧈 寃 寘 寧 寳 𡬘 寿 将 当 尢 㞁 屠 屮 峀 岍 𡷤 嵃 𡷦 嵮 嵫 ...+Tags+󠀁 󠀠 󠀡 󠀢 󠀣 󠀤 󠀥 󠀦 󠀧 󠀨 󠀩 󠀪 󠀫 󠀬 󠀭 󠀮 󠀯 󠀰 󠀱 󠀲 󠀳 󠀴 󠀵 󠀶 󠀷 󠀸 󠀹 󠀺 󠀻 󠀼 󠀽 󠀾 󠀿 󠁀 󠁁 󠁂 󠁃 󠁄 󠁅 󠁆 󠁇 󠁈 󠁉 󠁊 󠁋 󠁌 󠁍 󠁎 󠁏 󠁐 󠁑 󠁒 󠁓 󠁔 󠁕 󠁖 󠁗 󠁘 󠁙 󠁚 󠁛 󠁜 󠁝 󠁞 󠁟 󠁠 󠁡 󠁢 󠁣 󠁤 󠁥 󠁦 󠁧 󠁨 󠁩 󠁪 󠁫 󠁬 󠁭 󠁮 󠁯 󠁰 󠁱 󠁲 󠁳 󠁴 󠁵 󠁶 󠁷 󠁸 󠁹 󠁺 󠁻 󠁼 󠁽 󠁾 󠁿+Supplementary Private Use Area-A+󰀀 󰀁 󰀂 󰀃 󰀄 󰀅 󰀆 󰀇 󰀈 󰀉 󰀊 󰀋 󰀌 󰀍 󰀎 󰀏 󰀐 󰀑 󰀒 󰀓 󰀔 󰀕 󰀖 󰀗 󰀘 󰀙 󰀚 󰀛 󰀜 󰀝 󰀞 󰀟 󰀠 󰀡 󰀢 󰀣 󰀤 󰀥 󰀦 󰀧 󰀨 󰀩 󰀪 󰀫 󰀬 󰀭 󰀮 󰀯 󰀰 󰀱 󰀲 󰀳 󰀴 󰀵 󰀶 󰀷 󰀸 󰀹 󰀺 󰀻 󰀼 󰀽 󰀾 󰀿 󰁀 󰁁 󰁂 󰁃 󰁄 󰁅 󰁆 󰁇 󰁈 󰁉 󰁊 󰁋 󰁌 󰁍 󰁎 󰁏 󰁐 󰁑 󰁒 󰁓 󰁔 󰁕 󰁖 󰁗 󰁘 󰁙 󰁚 󰁛 󰁜 󰁝 󰁞 󰁟 󰁠 󰁡 󰁢 󰁣 󰁤 󰁥 󰁦 󰁧 󰁨 󰁩 󰁪 󰁫 󰁬 󰁭 󰁮 󰁯 󰁰 󰁱 󰁲 󰁳 󰁴 󰁵 󰁶 󰁷 󰁸 󰁹 󰁺 󰁻 󰁼 󰁽 󰁾 󰁿 ...+Supplementary Private Use Area-B+􀀀 􀀁 􀀂 􀀃 􀀄 􀀅 􀀆 􀀇 􀀈 􀀉 􀀊 􀀋 􀀌 􀀍 􀀎 􀀏 􀀐 􀀑 􀀒 􀀓 􀀔 􀀕 􀀖 􀀗 􀀘 􀀙 􀀚 􀀛 􀀜 􀀝 􀀞 􀀟 􀀠 􀀡 􀀢 􀀣 􀀤 􀀥 􀀦 􀀧 􀀨 􀀩 􀀪 􀀫 􀀬 􀀭 􀀮 􀀯 􀀰 􀀱 􀀲 􀀳 􀀴 􀀵 􀀶 􀀷 􀀸 􀀹 􀀺 􀀻 􀀼 􀀽 􀀾 􀀿 􀁀 􀁁 􀁂 􀁃 􀁄 􀁅 􀁆 􀁇 􀁈 􀁉 􀁊 􀁋 􀁌 􀁍 􀁎 􀁏 􀁐 􀁑 􀁒 􀁓 􀁔 􀁕 􀁖 􀁗 􀁘 􀁙 􀁚 􀁛 􀁜 􀁝 􀁞 􀁟 􀁠 􀁡 􀁢 􀁣 􀁤 􀁥 􀁦 􀁧 􀁨 􀁩 􀁪 􀁫 􀁬 􀁭 􀁮 􀁯 􀁰 􀁱 􀁲 􀁳 􀁴 􀁵 􀁶 􀁷 􀁸 􀁹 􀁺 􀁻 􀁼 􀁽 􀁾 􀁿 ...
+ benchmark/Streamly/Benchmark/Unicode/data/Deutsch.txt view
@@ -0,0 +1,153 @@+Der FC Bayern München (offiziell: Fußball-Club Bayern, München eingetragener Verein)[1] ist ein Sportverein aus München. Die seit 2002eine eigene Aktiengesellschaft ausgegliederte Profifußballabteilung ist deutscher Rekordmeister, Rekordsieger im DFB-Pokal, Ligapokal sowie Supercup und belegtder Ewigen Tabelle der Bundesliga den ersten Platz. Damit ist Bayern München im Profifußball der erfolgreichste deutsche Fußballverein.+Auf europäischer Ebene gehört der FC Bayern mit sechs Europapokalsiegen, davon vierder Champions League bzw. dem Europapokal der Landesmeister, zu den fünf erfolgreichsten Vereinen. Neben Juventus Turin und Ajax Amsterdam ist er einer der Vereine, die sowohl den Europapokal der Landesmeister, bzw. Champions League, den UEFA-Pokal, als auch den Europapokal der Pokalsieger gewinnen konnten. Zweimal gewann der FC Bayern München zudem den Weltpokal.+Auch wirtschaftlich gehört der Verein zu den weltweit erfolgreichsten: Nach der Saison 2009/10 belegten die Bayern Rang vierder Rangliste der umsatzstärksten Klubs und im April 2011 den gleichen Rangder Liste der wertvollsten Vereine des Forbes Magazine.[2] Mit 171.345 Vereinsmitgliedern (Stand: 18. November 2011) ist der FC Bayern einer der mitgliederstärksten Sportvereine weltweit. Innerhalb der letzten zwölf Monate stieg die Zahl um über 11.000 Mitglieder. Der Verein hat 2952 offizielle Fanclubs (Vorjahr: 2764) mit insgesamt 204.235 registrierten Mitgliedern. Dies ist ein Anstieg von über 12.000 Mitgliedern.[3][4]+Seit 1965 spielt der FC Bayern ununterbrochender Bundesliga, lediglich die ersten zwei Jahre nach Einführung der Bundesliga war die Mannschaft zweitklassig. Die zweite Mannschaft des FC Bayern spielt zurzeitder viertklassigen Regionalliga Süd. Sie gewannder Saison 2003/04 den Meistertitelder damals noch drittklassigen Regionalliga Süd.+Zum FC Bayern gehören zudem weitere Abteilungen, die auch einige Erfolge aufweisen können. So wurden die derzeitder Frauen-Bundesliga spielenden Fußballfrauen 1976 Deutscher Meister. Weitere Erfolge feierten die Basketballer mit zwei Meisterschaften und einem Pokalsieg, die Schachabteilung mit neun Deutschen Meisterschaften und einem Europapokalsieg sowie die Turner mit vier Deutschen Meisterschaften.++Am 27. Februar 1900 fand im Gasthaus „Bäckerhöfl“ eine Sitzung der Fußballabteilung des MTV München statt. Es war kurz zuvor zu einem Streit über die weitere Entwicklung der Fußballabteilung gekommen, da eine Generalversammlung des MTV dem Beitritt des Vereins zum süddeutschen Fußballverband eine Absage erteilt hatte. Um 21:30 Uhr verließen elf Männer, Nägele, Schmid, Karl, Wamsler, Ringler, Focke, Francke, Friedrich, Zöpfel, Pollack und John das Lokal und fanden sich im Restaurant „Gisela“Schwabing ein, um noch am selben Abend den FC Bayern München zu gründen.[5] Den Vorsitz führte Franz John, der auch der erste Vorsitzendeder Geschichte der Bayern werden sollte. Als Vereinsfarben wählte man Blau-Weiß, der Mitgliedsbeitrag wurde auf eine Mark festgesetzt.+Als erster Trainingsplatz diente der stadteigene, heute noch existierende Schyrenplatz. Der erste Gegner war im März 1900 der 1. Münchner FC 1896, der FC Bayern gewann das Spiel mit 5:2. Schnell stießen weitere Spieler zum Verein, so unter anderem drei Spieler der Fußballabteilung des TV München 1860. Im Frühjahr 1900 überließen die Geschäftsleute Wamsler dem FC Bayern ein Grundstück an der Clemensstraße als Spielstätte. Das erste Spiel einer langen und traditionsreichen Derbygeschichte zwischen dem FC Bayern und den „Sechzigern“ fand im Jahr 1902 statt. Der FC Bayern gewann das Spiel mit 3:0. Um den Spielbetrieb auszuweiten, beschloss der Verein 1906 den Übertritt zum Münchner Sport-Club, behielt aber eine gewisse Eigenständigkeit bei, was sichder Bezeichnung „F.A. Bayern im Münchner SC“ (F.A. = Fußballabteilung) ausdrückte. Infolge der Fusion trat Bayern nunweißen Hemden und roten Hosen an, diese Farben lösten damit das Blau-Weiß aus der Gründungszeit ab, die Bezeichnung Die Roten war geboren. Auf lokaler Ebene entwickelten sich die „Bayern“ zur unangefochtenen Nummer Eins im Fußball, im Wettbewerb auf süddeutscher Ebene waren sie hingegen weniger erfolgreich. Zu sehr dominierten zu dieser Zeit noch die Mannschaften, die bereitsden 1890er Jahren entlang des Oberrheins zwischen Freiburg und Frankfurt entstanden waren und sich weiterentwickelt hatten, das Fußballgeschehen.+1907 mussten die Bayern die Sportanlage an der Karl-Theodor-Straße aufgeben und zum Sportplatz an der Leopoldstraße umziehen. Eingeweiht wurde damit auch die erste Tribüne auf einem FußballplatzMünchen. Im Eröffnungsspiel gab es ein 8:1 gegen Wacker München. Bereits 1908 hatte der FC Bayern mehr als 300 Mitglieder, acht Mannschaften und mehr als 100 Jugendspieler. Dies hatte eine Satzungsänderung zur Folge, wodurch Verwaltungsarbeit und der Sportbereich getrennt wurden. Die Spieler hatten dadurch mehr Zeit sich auf den Sport zu konzentrieren. 1910 konnten sie das erste Mal an der Endrunde zur Süddeutschen Meisterschaft teilnehmen. Am Ende belegte der FCB den 2. Platz hinter dem Karlsruher FV. Im selben Jahr stellten die Bayern mit Max Gablonsky ihren ersten Nationalspieler.+Während des Ersten Weltkrieges kam der Sport zeitweise zum Erliegen und im Verein und dessen Umfeld gab es ein ständiges Auf und Ab. Erst von der Spielzeit 1919/20 an warSüddeutschland wieder ein regelmäßiger Ligabetrieb gewährleistet. Im Oktober 1919 traten die Bayern aus dem Münchner SC aus und fusionierten mit dem Turnverein Jahn zum TuSpV Bayern. William Townley wurde erneut als Trainer verpflichtet, womit man die Tradition der englischen Trainer im Verein fortsetzte. Bereitsden Vorkriegsjahren hatten die Bayern mit Coach Taylor, Hoer und Charles Griffith drei Engländer als Trainer, von denen letzterer der erste hauptberufliche Bayerntrainer war.+Im Frühjahr 1924 trennte man sich im Zuge der reinlichen Scheidung wieder vom TuSpV Bayern und trat fortan nur noch als eigenständiger Verein unter dem Namen „FC Bayern München“ auf. Mit dem Schotten Jim McPherson setzten die Bayern erneut auf einen britischen Trainer. 1926 spielten die Bayern um die Süddeutsche Meisterschaft. Die härtesten Konkurrenten kamen damals mit dem 1. FC Nürnberg und der SpVgg. Fürth, die damals als beste Mannschaft Deutschlands galt, aus Bayern. Das Rückspiel gegen Fürth im Grünwalder Stadion wurde live im Radio übertragen und nach einem dramatischen Spiel gewann der FCB mit 4:3. Die Bayern waren zum ersten Male Süddeutscher Meister, scheiterten dann aber schon im Achtelfinale um die deutsche MeisterschaftLeipzig gegen den SV Fortuna Leipzig 02 mit 0:2. Bereits 1928 gelang mit dem ungarischen Trainer Leo Weisz der Gewinn der zweiten Süddeutschen Meisterschaft. Erneut qualifizierte man sich damit zur Endrunde um die Deutsche Meisterschaft und über Siege gegen den FC Wacker Halle und die SpVgg Sülz 07 erreichte der FC Bayern das Halbfinale und feierte damit den bis dahin größten Erfolg der Vereinsgeschichte. Im Duisburger Wedaustadion unterlagen die Bayern dem Hamburger SV jedoch deutlich mit 2:8.+Nach drei gescheiterten Anläufen zum Gewinn der Deutschen Meisterschaftden Jahren 1926, 1928 und 1929 hatte man 1932 mehr Erfolg. Der Trainerwechsel von Kálmán Konrád zu Richard Dombi 1930 erwies sich somit im Nachhinein als gute Entscheidung. Das Finale um die Süddeutsche Meisterschaft verlor der FC Bayern gegen die Eintracht aus Frankfurt und ging als Süddeutscher Vizemeisterdie Endrunde um die Deutsche Meisterschaft. Der Reihe nach traf man auf Minerva 1893 Berlin und den Polizei SV Chemnitz, ehe man im Halbfinale dem Erzrivalen aus Franken, dem 1. FC Nürnberg, gegenüberstand. Das Spiel fandMannheim statt und die Bayern besiegten den bis dahin fünfmaligen Deutschen Meister mit 2:0. Die Tore erzielten Oskar Rohr und Hans Welker. Im Finale am 12. Juni 1932, dasNürnberg ausgetragen wurde, traf man erneut auf die Frankfurter Eintracht, gegen die man schon im Finale um die Süddeutsche Meisterschaft unterlegen war. Tausende Bayern-Fans machten sich auf den Weg, darunter auch etwa 400 Arbeitslose mit dem Fahrrad. Im Nachhinein übernahm der Verein die Kosten für diese Fans für Übernachtung und Eintrittskarten. Am Tage des Endspiels herrschten 30 Grad im Schatten und 55.000 Zuschauer sahen das Spiel im Stadion.der 35. Minute nahm der Frankfurter Hennes Straub auf der Torlinie die Hand zu Hilfe und es gab Elfmeter für den FC Bayern. „Ossi“ Rohr verwandelte sicher zum 1:0.der zweiten Hälfte drängten die Frankfurter auf den Ausgleich, dochder 75. Minute erzielte Franz Krumm das entscheidende 2:0 für Bayern. Nach dem Abpfiff hielt der FC Bayern München zum ersten Malder Vereinsgeschichte die Victoriader Hand. Zum ersten Mal wurde ein Verein aus München Deutscher Meister und die Mannschaft wurde begeistertder Landeshauptstadt empfangen. Die Siegesfeier fand im Münchener Löwenbräukeller statt, die Spieler wurden auf Pferdekutschen zur Feier gebracht.einer der Festreden hieß es, „was man schon im Vorjahr bei 1860 bestimmt gedacht, hat heuer FC Bayern fertig gebracht“.++1933 konnte der Titel nicht verteidigt werden, nachdem der Verein beide Spiele gegen den TSV 1860 München um die Süddeutsche Meisterschaft verloren hatte. Nach der NS-Übernahme der Regierungsgewalt unter der Führung Adolf Hitlers musste Präsident Kurt Landauer auf Grund seiner jüdischen Abstammung auf politischen Druck hin im selben Jahr zurücktreten. Trainer Dombi, ebenfalls jüdischer Abstammung, wechselte kurz daraufdie Schweiz. Der FC Bayern war, im Gegensatz zum Stadtrivalen 1860 München, bei den neuen Machthabern wegen Landauer und Dombi als „Judenclub“ verpönt. Erst Anfang 1943 konnte mit Josef Sauter ein NSDAP-Mitglied als Präsident im Verein eingesetzt werden, die Unterstützung einzelner Spieler für Landauer bei einem Gastspielder Schweiz hatte weitere Repressalien zur Folge.[6]+Zudem verließ auch Oskar Rohr den Verein, um Profispieler bei den Grasshoppers Zürich zu werden. Neuer Trainer wurde Hans Tauchert, der aber nicht an die alten Erfolge anknüpfen konnte und bereits 1934 durch Ludwig Hofmann ersetzt wurde. Hofmann verstarb aber bereits kurze Zeit später an einer Halserkrankung und Richard Michalke übernahm das Amt des Trainers. Damit war die Talfahrt allerdings noch nicht beendet und so stand man im Jahre 1939 kurz vor dem ersten Abstiegder Geschichte des Vereins, konnte die Klasse jedoch gerade noch halten. Im Verlauf des Krieges wurden die Gauligen weiter regionalisiert, um die Wege für die Vereine für Auswärtsspiele möglichst kurz zu halten. Waren die Bayern anfangsder Gauliga Bayern, spielten sie anschließendder Gauliga Südbayern, die durch die Aufteilung der Gauliga Bayern entstand. Kurz vor Ende des Krieges spielte mander Gauliga München-Oberbayern. Im Jahre 1944 konnten Die Roten wieder eine Süddeutsche Meisterschaft gewinnen und qualifizierten sich so erneut für die Endrunde um die Deutsche Meisterschaft. Bereits im Achtelfinale verlor man jedoch nach Verlängerung gegen den VfR Mannheim. Am 13. Juli desselben Jahres wurden die Geschäftsstelle und ein Teil des Archivs bei Bombenangriffen zerstört. Im darauffolgenden Jahr qualifizierte man sich unter Spielertrainer Conny Heidkamp erneut für die Endrunde um die Deutsche Meisterschaft. Die Endrunde wurde im Jahr des Endes des Zweiten Weltkriegs jedoch nicht ausgetragen. Da das Stadion an der Grünwalder Straße bei Bombenangriffen 1943 zerstört und erst im August 1945 wieder freigegeben wurde, trug der FC Bayern seine Spielediesen Jahren im Dantestadion (1943–1944), auf dem Platz an der Schlierseestraße (1944–1945) und auf dem Sportplatz der Hypobank an der Grünwalder Straße (1945) aus.++Nach Ende des Zweiten Weltkriegs wurden alle deutschen Sportvereine durch den Alliierten Kontrollrat aufgelöst und mussten zur Neugründung eine Lizenz beantragen. Spieler des FC Bayern fanden alsbald wieder zusammen, bestritten am 24. Juni 1945 gegen den FC Wacker München das erste Spiel nach Kriegsende und stiegen im November desselben Jahresden Spielbetrieb der Oberliga Süd ein. Der Neuanfang nach dem Krieg war schwierig, fast jährlich wechselten die Trainer und der sportliche Erfolg hielt sich zunächstGrenzen. Im Juni 1947 kehrte Kurt Landauer aus dem Exil zurück, wurde wenige Wochen später erneut zum 1. Vorsitzenden des Vereins gewählt. Seine vierte und letzte Amtszeit endete 1951.+Die Mitgliederzahlen des Vereines entwickelten sichden Nachkriegsjahren positiv. Bald zählte der FC Bayern erneut mehr als 1000 Mitglieder, auch die Jugendabteilungen erlebten regen Zulauf. 1949 erreichte man nochmals die Qualifikationsspiele zur Deutschen Meisterschaft über einen 3. Tabellenplatzder Oberliga.der Qualifikation traf man auf den FC St. Pauli, verlor aber im Wiederholungsspiel, das bereits am nächsten Tag ausgetragen wurde, mit 0:2. Danach begann eine längere sportliche Talfahrt des Vereins, die sogar im Abstieg gipfelte. 1954/55 stiegen die Bayern zum ersten und einzigen Maleihrer Geschichte aus der damaligen obersten Liga ab. Im Folgejahr gelang allerdings der sofortige Wiederaufstieg.++Einer der wenigen sportlichen Höhepunkte der 40er und 50er Jahre war der Gewinn des DFB-Pokals. Im Jahr des Wiederaufstiegs wollten die Bayern ursprünglich gar nicht am DFB-Pokal teilnehmen. Man wollte schlicht Reisekosten sparen. Doch der neue Trainer Willibald Hahn forderte unbedingt eine Teilnahme und konnte sich am Ende gegen die Vereinsführung durchsetzen. Nachdem im Halbfinale der 1. FC Saarbrücken mit 3:1 bezwungen wurde, wartete im Finale die Fortuna aus Düsseldorf. Das Finale fand am 29. Dezember 1957 im Augsburger Rosenaustadion vor 42.000 Zuschauern statt, darunter rund 12.000 Bayernfans. Am Tage des Spiels gab es starke Schneefälle und der Boden war mit Schnee bedeckt. Dies schien den Bayern, die als Außenseiterdas Spiel gingen, sehr entgegenzukommen. Von Anfang an dominierte der FC Bayern das Geschehen und die Fortuna hatte es nur ihrem Torwart Albert Görtz zu verdanken, dass das Spiel lange Zeit 0:0 stand.der 78. Minute gelang es dem überragenden Rudi Jobst nach dreimaligem Anlauf den Ball im Netz unterzubringen. Nachdem man die restliche Spielzeit unbeschadet überstand, war mit dem Abpfiff der erste DFB-Pokalsiegder Geschichte des FC Bayern erreicht.+Spieldaten des Endspiels um den DFB-Pokal 1957+Nach dem überraschenden Pokalerfolg und dem ersten großen Titel seit 1932 trat wieder die Tristesse der Oberliga ein. Man erreichte nur Platz sieben und es gab neuerlich finanzielle Probleme. Letzteres konnte durch Roland Endler gelöst werden. Der Geschäftsmann aus Neuss, ein großer Fan der Bayern, wurde neuer Präsident und die Finanznöte hatten ein Ende.+Mit dem neuen Trainer Adolf Patek ging es 1958/59 zunächst wieder aufwärts. Mit Platz vier zum Ende der Saison erzielte man das beste Resultat seit zehn Jahren.der darauffolgenden Saison wurden dem FC Bayern wegen einer sogenannten „Überbezahlung“ der Spielerder Saison 57/58 vier Punkte abgezogen. Als ursprüngliches Strafmaß waren acht Punkte Abzug vorgesehen, doch ein Einspruch der Bayern brachte eine Strafmilderung. Der Punktabzug führte dennoch dazu, dass der Verein die Endrunde um die Deutsche Meisterschaft verpasste und am Ende nur auf Platz fünf landete. Einziger Höhepunktder Spielzeit 1960/61 war der Sieg im Derby gegen den TSV 1860 München. Nach einem zwischenzeitlichem 2:2 wurden die Löwen am Ende mit 6:2 aus dem Stadion gefegt. Nach einem nur enttäuschenden 8. Platz im Folgejahr musste Trainer Patek seinen Hut nehmen. Für ihn kam Helmut Schneider.+In der Saison 1962/63 trat der Verein zum ersten Maleinem renommierten internationalen Wettbewerb auf: Im Viertelfinale des Messestädte-Pokals schied man gegen Dinamo Zagreb aus. National ging es für die Bayern darum, sich für die kommende neue Bundesliga zu qualifizieren. Deshalb musste mehr als nur der 8. Platz der Vorsaison herauskommen. Zudem begann am 28. April 1962 eine neue Ära beim FC Bayern. Zunächst nur kommissarisch für ein Jahr übernahm Wilhelm Neudecker das Präsidentenamt des Vereins. Es sollten weit mehr als nur das eine werden. Der neue Präsident ließ nur die Neuverpflichtung eines gestandenen Spielers zu. Dieser war Herbert Erhardt. Ansonsten durfte Trainer Schneider nur junge Talente an die Isar holen. Einer von ihnen war ein gewisser Sepp Maier. Am 30. Dezember 1962 musste Stammtorhüter Kosar im Angriff aushelfen und Sepp Maier gab sein Debüt für den FC Bayern als gerade mal 18-Jähriger. Bayern beendete die Saison auf dem 3. Tabellenplatz hinter dem 1. FC Nürnberg und dem TSV 1860 München. Damit verpasste man nicht nur die Endrunde um die Deutsche Meisterschaft, man erhielt am 11. Mai 1963 auch die Absage vom DFB für die neue Bundesliga. Die fadenscheinige Begründung lautete: „Das Gremium war der Auffassung, dass […] es nicht ratsam erscheint, zwei Vereinen am gleichen Ort eine Lizenz für die Bundesliga zu erteilen.“ Somit musste der FC Bayern 1963/64der neu geschaffenen Regionalliga antreten. Helmut Schneiders Vertrag war eigentlich schon verlängert, dennoch musste er daraufhin den Verein verlassen.+Für ihn kam Zlatko Čajkovski. Das erklärte Saisonziel war das Erreichen der Aufstiegsrunde zur Bundesliga. Dieses Ziel konnte mit einem zweiten Platz am Ende der Saison auch erreicht werden. Am 6. Juni 1964 besiegte man im ersten Spiel der Aufstiegsrunde den FC St. Pauli mit 4:0. Es war das erste Pflichtspiel des damals erst 18 Jahre alten Franz Beckenbauer.[7][8]seinem ersten Spiel für die Bayern gelang ihm auch gleich sein erstes Tor. Beckenbauer hatte sich gegen einen Wechsel zum TSV 1860 München und für den FC Bayern entschieden, nachdem ereinem Spiel seines SC München von 1906 gegen den TSV 1860 von einem Gegenspieler geohrfeigt worden war. Dem FC Bayern fehlte am Ende nur ein Punkt zum Aufstieg und es hieß einen neuen Anlauf zu nehmen. Hatten bereitsden beiden Jahren zuvor Maier und Beckenbauer verpflichtet werden können, fehlte jetzt nur noch ein Baustein als Grundlage für die bald folgenden großen Jahre des FC Bayern München. Im Frühjahr 1964 hatte sich der Präsident des TSV 1860 MünchenNördlingen angesagt, um der Familie Müller einen Besuch abzustatten, um deren Sohn zum TSV zu lotsen. Da auch die Bayern Interesse an dem kleinen bulligen Stürmer hatten und davon Wind bekamen, erschienen sie eine Stunde früherNördlingen. Der TSV bot dem jungen Mann nur einen Amateurvertrag über ein Jahr, der FC Bayern einen Profivertrag. Der spätere „Bomber der Nation“, Gerd Müller, wechselte daher im Sommer zum FC Bayern. Čajkovski war gar nicht begeistert von der Verpflichtung des jungen, gedrungenen Stürmers und sagte: „Was soll isch mit dieses Junge, diese Figur, unmöglich.“ Später nannte er ihn liebevoll „kleines dickes Müller“.[9]+Gleichseinem ersten Spiel am 18. Oktober 1964 traf Müller zum 3:0 gegen den Freiburger FC. Zum Ende der Saison 1964/65 stand man mit einem Rekordtorverhältnis von 146:32 als Meister der Regionalliga Süd fest. Gerd Müller erzielte dabei26 Spielen 33 Tore und trugseiner ersten Saison maßgeblich zur Meisterschaft bei.der Aufstiegsrunde machte man gegen Tennis Borussia Berlin alles klar. Der Verein gewann mit 8:0Berlin und stieg damitdie Bundesliga auf.+Vor der ersten Bundesligasaison der Bayern schimpfte Čajkovski, dass er keine fertigen Spieler habe und zufrieden wäre, wenn man die Klasse halten würde. Doch die Mannschaft sollte ihn Lügen strafen. Die Bayern starteten gleich voll durch. Auch wenn man am ersten Spieltag im Derby gegen den TSV 1860 mit 0:1 als Verlierer vom Platz ging, so standen die Bayern am vierten Spieltag das erste Mal an der Tabellenspitze der Bundesliga. Zwar konnte diese nicht gehalten werden, aber das prestigeträchtige Rückspiel gegen den Lokalrivalen TSV 1860 konnte mit 3:0 gewonnen werden, und am Ende belegte man einen mehr als beachtlichen dritten Tabellenplatz. Es war das einzige Malder Geschichte der Bundesliga, dass beide Teams aus München am Ende einer Saison unter den ersten Drei standen. Platz dreider Liga war den Bayern allerdings längst nicht genug. Es gelang ihnen zum zweiten Malder Vereinsgeschichte den DFB-Pokal zu holen. Nach einem klasse Spiel gegen den Meidericher SV behielten die Bayern mit 4:2 die Oberhand und brachten den Pokal nach Hause. Sepp Maier sagte nach dem Spiel: „Hoaß war’s, gschwitzt hamma, und gwunna a no. Grad sche war’s!“ 1966 kamen damit sowohl der Meister der Bundesliga als auch der Pokalsieger aus München.++In der nächsten Saison, 1966/67, blieb das Team nahezu unverändert. Einzig Franz „Bulle“ Roth kam aus Kaufbeuren hinzu, Georg Schwarzenbeck verstärkte das Team aus dem eigenen Nachwuchs. Nach dem Auftritt im inoffiziellen Messestädte-Pokal spielte der FC Bayern erstmalseinem von der UEFA veranstalteten internationalen Wettbewerb, dem Europapokal der Pokalsieger. Diese Saison des Pokalsiegerwettbewerbs wurde zum ersten großen Triumphzug der Bayern auf europäischer Bühne. Über Tatran Prešov, die Shamrock Rovers, Rapid Wien und Standard Lüttich erreichte der FC Bayern völlig überraschend das Finale, das fast zu einem Heimspiel mutierte, da esNürnberg stattfand. An gleicher Stelle hatten die Bayern schon 35 Jahre zuvor den ersten wichtigen Titel für den Verein gewinnen können.+Vor 71.000 Zuschauern erzielte Bulle Rothder Verlängerung (108. Minute) das 1:0 für die Münchner. Gegner im Finale waren die Glasgow Rangers, die zuvor im Achtelfinale den Titelverteidiger Borussia Dortmund aus dem Wettbewerb geworfen hatten. Roth, der Schütze zum einzigen Tor im Finale, hatte zwei Jahre zuvor nochder C-Klasse beim TSV Bertoldshofen gespielt und erzielte jetzt das entscheidende Tor zum ersten internationalen Titel des FC Bayern München. Nach Borussia Dortmund im Jahr zuvor gewann damit erneut ein deutscher Verein den Pokal der Pokalsieger.+Die reguläre Bundesliga-Saison schloss der FC Bayern zwar nur auf Platz sechs ab, jedoch konnte man den DFB-Pokal erfolgreich verteidigen. Auch dieses Finale fand nicht weit von München entfernt statt.Stuttgart sahen 68.000 Zuschauer den erneuten Pokaltriumph der Bayern. Mit 4:0, durch Tore von Müller (2), Ohlhauser und Brenninger (je 1), hatte der Hamburger SV mit Uwe Seeler keine Chance.++Dies war der dritte Pokalerfolg innerhalb von zwölf Monaten. Franz Beckenbauer wurde das erste Malseiner noch jungen Karriere zum „Fußballer des Jahres“ gewählt. Die darauf folgende Saison 1967/68 war nicht das Jahr der Bayern. Im Halbfinale des Europapokals der Pokalsieger 1967/68 scheiterte man am späteren Sieger AC Mailand, im DFB-Pokal warf der damalige Regionalligist VfL Bochum den Titelverteidiger im Halbfinale aus dem Wettbewerb. Die Bundesliga schloss man nur als Fünfter ab. Viel wichtiger aber war wohl, dass man erstmalsder Geschichte der Bundesliga am Erzrivalen TSV 1860 vorbeizog und zwar sowohlder Tabelle als auchder Gunst der ZuschauerMünchen. War vorher der TSV der größere von beiden Münchner Vereinen, so hat der FC Bayern München ihn jetzt überholt. Und daran änderte sich bis heute nichts.+Tschik Čajkovski verließ 1968 nach fünf erfolgreichen Jahren den Verein Richtung Hannover 96. Für ihn kam Branko Zebec. Mit ihm kamen auch Gustl Starek und Peter Pumm. Beide sollten sichZukunft als tragende Säulen seines Konzepts, das auf eine starke Defensive setzte, erweisen. Sein Rezept ging auf und die Bayern gewannen zum ersten Malder Vereinsgeschichte das Double aus Meisterschaft und Pokal. Gleichzeitig gelang zum ersten Mal seit 1937 wieder einem Verein das Double (damals dem FC Schalke 04). Eben jenen FC Schalke bezwang man im Pokalendspiel mit 2:1. Vor dem Spiel nahm Gerd Müller die Ehrung für den „Fußballer des Jahres“ entgegen und Branko Zebec holteseinem ersten Jahr als Trainer gleich Meisterschaft und Pokal.++Am 13. März 1970 löste Udo Lattek den bisherigen Trainer Zebec ab. Mit der Amtsübernahme Latteks begann für den FC Bayern eine neue, noch erfolgreichere Ära. Unter Lattek brachte der FC Bayern die Saison 1969/70 als Zweiter zu Ende. Gerd Müller wurde zum dritten Male Torschützenkönig der Bundesliga mit der Rekordtorzahl von 38 Toreneiner Saison. Zudem wurde er Torschützenkönig bei der Fußball-WM 1970Mexiko.diesem Sommer beendete der langjährige Kapitän Werner Olk seine aktive Karriere. Meister wurde Borussia Mönchengladbach vor den Bayern. Die Rivalität zwischen diesen beiden Vereinen sollte kennzeichnend für die 70er Jahre werden. Beide holtendieser Zeit insgesamt acht Mal die deutsche Meisterschaft. Auchder Folgesaison blieb den Münchnern erneut nur der zweite Platz hinter der Fohlen-Elf aus Gladbach. Belächelte man anfangs die Verpflichtung Latteks, so wurden die Kritiker doch schon früh eines Besseren belehrt. Udo Lattek war bis dahin ohne große Trainererfahrung, dochseiner ersten vollen Saison als Cheftrainer gewann sein Team den DFB-Pokal und wurde erneut Vizemeister. Vor dem Pokalfinale bekam Gerd Müller wiederum eine Auszeichnung als Torschützenkönig, diesmal jedoch sogar als bester Torschütze Europas. Im Finale gegen den 1. FC Köln lagen die Bayern schon nach 13 Minuten mit 0:1 zurück ehe Beckenbauerder 53. Minute ausgleichen konnte. Dem für Franz Roth eingewechselten Edgar Schneider gelang dannder 118. Minute das Siegtor. Die Bayern hatten damit bereits zum fünften Mal das Pokalfinale erreicht und den DFB-Pokal gewonnen. Noch kein Einziges der Finals ging verloren. Es sollte aber der vorerst letzte Pokaltriumph der Bayern für eine ganze Dekade sein. Nach Olkder Vorsaison verließen nun mit Ohlhauser und Starek zwei weitere Leistungsträger den Verein.+Spieldaten des Endspiels um den DFB-Pokal 1971+Vor Beginn der neuen Spielzeit verpflichtete der Verein zwei neue Spieler, die später noch die Zukunft des FC Bayern maßgebend bestimmen sollten: Uli Hoeneß und Paul Breitner. Beide waren damals gerade 18 Jahre alt. Die Saison 1971/72 wurde für den Verein zum Jahr der Rekorde. Vom ersten Spieltag an blieb man 14 SpieleFolge ohne Niederlage. Am Ende wurde man mit 55 Punkten und 101 erzielten Toren Meister. 40 Tore davon erzielte allein Gerd Müller. Zudem wurde Borussia Dortmund mit 11:1 vom Platz gefegt. Dies alles war noch nie dagewesender noch jungen Geschichte der Bundesliga. Einige der Rekorde haben bis heute Bestand. Am 28. Juni 1972 bestritt der FC Bayern München sein erstes Heimspiel im Olympiastadion. Es war gleichzeitig das letzte Spiel der Saison.einem „Endspiel“ um die Meisterschaft wurde der Tabellenzweite Schalke 04 mit 5:1 geschlagen. Bayern war somit erneut Meister. Die Münchner machten auchder nächsten Saison da weiter, wo sieder Vorsaison aufgehört hatten. Vom ersten bis zum letzten Spieltag hieß der Tabellenführer FC Bayern München und wurde mit elf Punkten Vorsprung Meister vor dem 1. FC Köln. Nun war der FCB bereit für höhere AufgabenEuropa. 1974 verteidigte man zum zweiten Mal hintereinander die Meisterschaft, Gerd Müller wurde zum dritten MalFolge Torschützenkönig der Bundesliga und der FC Bayern München bestieg nun zum ersten Mal „Europas Thron“.+In der ersten Runde des Europapokals der Landesmeister kamen die Bayern dabei erst durch ein Elfmeterschießen im Rückspiel beim schwedischen Meister Åtvidabergs FF eine Runde weiter. Danach kam es zum deutsch-deutschen Duell zwischen dem FC Bayern München und Dynamo Dresden. Zur Halbzeit führte Dynamo mit 3:2München, doch die Münchner konnten das Spiel noch drehen und mit 4:3 gewinnen. Somit hatte Dresden eine gute Ausgangssituation für das Rückspiel. Doch die Roten gingen bereits nach zwölf Minuten durch zwei Tore von Hoeneß mit 2:0Führung. Kurz nach der Halbzeitpause gelang den Sachsen allerdingsder 52. Minute der Ausgleich und vier Minuten später sogar der Führungstreffer zum 3:2. Gerd Müller glich jedochder 56. Minute zum 3:3-Endstand aus. Die nächsten beiden Runden überstand man relativ leicht gegen ZSKA Sofia und Újpest Budapest und stand im Finale Atlético Madrid gegenüber. Es war kein herausragendes Spiel und die Konsequenz war ein 0:0 nach 90 Minuten. Sechs Minuten vor Ende der Verlängerung gelang Luis Aragonés das 1:0 für Madrid durch einen Freistoß. Der Schiedsrichter hatte die Pfeife schon im Mund, als Georg „Katsche“ Schwarzenbeck den Ball von Beckenbauer zugespielt bekam. Er sah keine Anspielstation im Mittelfeld, Beckenbauer rief nur „Schieß einfach!“ und so hielt er aus 30 Metern einfach aufs Tor: 1:1der 119. Minute. Schwarzenbeck ging mit diesem Tordie Geschichte des Fußballs ein.+Das 1:1 bedeutete nach damaligen Regeln ein Wiederholungsspiel, das nur zwei Tage später an gleicher Stelle stattfinden sollte.diesem Spiel behielten die Münchner klar die Oberhand und schlugen Atlético mit 4:0. Zum ersten Mal gewann eine deutsche Mannschaft den Pokal der Landesmeister.++1974 verließ Paul Breitner den FC BayernRichtung Real Madrid und es kamen zwei neue Spieler, Klaus Wunder vom MSV Duisburg und ein erst 18-jähriger Stürmer namens Karl-Heinz Rummenigge aus Lippstadt. Rummenigge und Breitner sollten Jahre später als Breitnigge für Furore sorgen. Zunächst aber schied man als beste Mannschaft Europas gegen den MSV Duisburg bereitsder dritten Hauptrunde des DFB-Pokals aus.der Liga erreichte man nur den zehnten Tabellenplatz. Da esder Liga nicht lief, kam es zur Winterpause zu einem Krisengespräch zwischen Lattek und Präsident Neudecker. Lattek schilderte das Gespräch später so: „Herr Neudecker, wir müssen etwas ändern.“ worauf Neudecker mit „Sie haben recht. Sie sind gefeuert.“ antwortete. Neuer Trainer wurde Dettmar Cramer.+Mit Cramer konnte zwar auch nicht die Bundesligasaison gerettet werden, aber passend zum 75- jährigen Vereinsjubiläum gewann der FC Bayern erneut den Pokal der Landesmeister. Über den 1. FC Magdeburg, Ararat Eriwan und den AS Saint-Étienne konnte erneut das Finale erreicht werden. Auf den 1. FC Magdeburg hätte man bereits ein paar Tage früher im Europäischen Supercup treffen können, da Magdeburg den Pokal der Pokalsieger 1974 im Mai gegen den AC Mailand gewonnen hatte. Für den Supercup konnte man sich jedoch auf keinen Termin einigen, so dass das Aufeinandertreffen im Pokal der Landesmeister zusätzlich zum Supercup-Ersatz geriet. Ebenso wie im Jahr zuvor gegen Dynamo Dresden tat man sich auch gegen die Magdeburger schwer, kam aber letzten Endes doch eine Runde weiter.Paris, wo das Finale stattfand, setzten sich die Münchner klar mit 2:0 gegen Leeds United durch.+Spieldaten des Endspiels um den Pokal der Landesmeister 1975+1975/76 lief es zunächst auch unter Cramer nicht besserder Bundesliga. Zur Winterpause belegte man nur Platz zehn. Die Spiele um den UEFA Super Cup gegen Dynamo Kiew verlor man ebenfalls. Doch nach der Winterpause lief es besser und der Verein belegte am Ende den dritten Tabellenplatz. Im DFB-Pokal kamen die Bayern bisHalbfinale, wo man am Hamburger SV scheiterte. Nach Jeunesse Esch, Malmö FF und Benfica Lissabon standen die Bayern im Halbfinale des Pokals der Landesmeister Real Madrid gegenüber. Das Rückspiel im Olympiastadion war restlos ausverkauft, wollte man doch auch Paul Breitner und Günter NetzerDiensten von Real sehen. Nach einem 1:1 im Hinspiel gewann man mit zwei Toren von Gerd Müller 2:0 und zog zum dritten MalFolge ins Finale ein. Dort trafen die Münchner auf den AS Saint-Étienne. Franz Roth zeichnete sich schon wie im Vorjahr als Torschütze im Finale aus, diesmal jedoch gleich als Goldtorschütze: Sein 1:0der 57. Minute war das Einzigeder gesamten Partie und zum dritten Mal war der FC Bayern Gewinner des Landesmeisterpokals. Dieses war zuvor nur den Königlichen aus Madrid (fünf MalFolge) und Ajax Amsterdam von 1971 bis 1973 gelungen.+Nach den Jahren der internationalen Triumphe befand sich die Mannschaft im Umbruch. Einer der letzten großen Höhepunkte war der Gewinn des Weltpokals. Als erste deutsche Mannschaft holte man den Pokal gegen Cruzeiro Belo Horizonte, während man den Supercup erneut verlor, diesmal gegen den RSC Anderlecht. Franz Beckenbauer wurde zum Fußballer Europas gewählt und verließ zum Ende der Saison den FC BayernRichtung Cosmos New York.der Liga wurde man nur Zwölfter und erlebte eine der bittersten Heimpleiten der Geschichte, als man mit 0:7 gegen den FC Schalke 04 verlor. 65 Gegentoreeiner Spielzeit bedeuten den absoluten Negativrekord für die Münchner.+Im Dezember 1977 machte der Verein ein Tauschgeschäft mit Eintracht Frankfurt. Cramer wechselte im Tausch für Trainer Gyula Lóránt an den Main. Bayern wurde nur Tabellenzwölfter, die schlechteste Platzierung der Bundesligageschichte des FC Bayern. Zum Ende der Saison kam Paul Breitner zurück. Für 1,75 Millionen Mark wechselte er von Eintracht Braunschweig zurück an die Isar. Gyula Lóránt wurde bereits im Dezember 1978 beurlaubt und sein bisheriger Co-Trainer Pál Csernai übernahm das Amt des Trainers. Als Nachfolger war Max Merkel im Gespräch, doch die Mannschaft sprach sich gegen ihn aus. Gerd Müller folgte Franz Beckenbauer 1979die USA, Uli Hoeneß wechselte nach Nürnberg und der langjährige Präsident Neudecker trat nach 17 Jahren Amtszeit ab; neuer Präsident wurde Hoffmann. Einziger Lichtblickden unruhigen Zeiten war das neugeschaffene Duo Rummenigge und Breitner, auch Breitnigge genannt. Alleine 26 der erzielten 69 Tore gingen auf das Konto der beiden. Im April 1979 kehrte Uli Hoeneß zum FC Bayern zurück und wurde, obwohl gerade erst 27 Jahre alt, Manager des Vereins.++Im Juli 1979 erreichte den Verein die nächste Hiobsbotschaft. Sepp Maier verletzte sich nach einem Autounfall so schwer, dass die Katze von Anzing, wie er auch genannt wurde, seine Karriere frühzeitig beenden musste. Mit 35 Jahren hatte er 473 Bundesligaspiele bestritten, alle für den FC Bayern, davon 442 Spiele in Folge. Maiers Nachfolger wurde Walter Junghans. Auch der letzte Große der 70er-Ära musste seine Karriere frühzeitig beenden. Katsche Schwarzenbeck bestritt am 18. August 1979 sein letztes Bundesligaspiel gegen den FC Schalke 04. Er zog sich eine Achillessehnenverletzung zu, die ihn zwang, seine Karriere zu beenden. Schwarzenbeck bestritt 416 Bundesligaspiele für die Bayern, in denen er 16 Tore erzielte. Andere rückten dafür ins Rampenlicht beim FC Bayern. Klaus Augenthaler, inzwischen Stammspieler, Dieter Hoeneß, der vom VfB Stuttgart an die Isar kam und natürlich Karl-Heinz Rummenigge. Letzterer wurde 1979 zum Fußballer Europas gewählt.+Im DFB-Pokal schied man blamablerweise gegen die SpVgg Bayreuth schon in der dritten Hauptrunde aus. Als Vierter des Vorjahres in der Bundesliga startete man im UEFA-Pokal, erreichte dort das Halbfinale und unterlag dort abermals im deutsch-deutschen Duell der Eintracht aus Frankfurt trotz eines 2:0 im Hinspiel. Bereits im Jahr zuvor war man im Achtelfinale des UEFA-Pokals gegen Eintracht Frankfurt ausgeschieden. In der Rückrunde der Bundesliga lieferten sich die Bayern ein Kopf-an-Kopf-Rennen mit dem HSV. Erst am letzten Spieltag kam es zur Entscheidung über die Meisterschaft. Bayern München gewann zu Hause im Olympiastadion mit 2:1 durch Tore von Breitner und Rummenigge. Seit dem Gewinn des Weltpokals 1976 konnte nun der erste Titel für die Bayern und zugleich die erste Meisterschaft seit sechs Jahren gefeiert werden. Der Umbruch, eingeleitet 1977/78, war abgeschlossen und die Bayern fanden in die Erfolgsspur zurück.+1980/81 konnte der FC Bayern München erstmals wieder seinen Meistertitel verteidigen, wobei das Duo Breitnigge insgesamt 46 Tore erzielte. Im Pokal der Landesmeister gelangte man bis ins Halbfinale und eliminierte dabei u. a. Ajax Amsterdam. Auch im Halbfinale verlor man kein Spiel gegen den FC Liverpool, musste aber wegen der Auswärtstorregel nach dem 1:1 im Rückspiel in München die Segel streichen. Die Reds aus Liverpool holten im Finale ihren dritten Pokal der Landesmeister. In der dritten Hauptrunde des DFB-Pokals war erneut Endstation. Diesmal war es der 1. FC Kaiserslautern, der die Bayern früh stoppte.+Doch im folgenden Jahr holte der Verein elf Jahre nach dem letzten Sieg zum sechsten Mal den Pokal an die Isar. Das Finale im Frankfurter Waldstadion war eines der außergewöhnlichsten in der Geschichte dieses Wettbewerbs, denn Dieter Hoeneß spielte es trotz einer Kopfverletzung, die er sich im Spiel zuzog, mit Kopfverband zu Ende. Die Bayern lagen zur Halbzeit bereits mit 0:2 gegen den Erzrivalen aus Franken, dem 1. FC Nürnberg, zurück. Nach einem Kopfballduell mit Alois Reinhardt zog sich Hoeneß die schwere Kopfverletzung zu, die zunächst nur notdürftig verbunden wurde. In der Halbzeitpause redete sein Bruder Uli ihm zu, er solle die Zähne zusammenbeißen, denn man würde ihn brauchen. Daraufhin ließ Dieter Hoeneß die Wunde ohne Narkose nähen und erschien zur zweiten Halbzeit wieder auf dem Rasen. Der FC Bayern drehte das Spiel noch und Dieter Hoeneß gelang dabei sogar in der 89. Minute das entscheidende Tor zum 4:2 per Kopf. Auch im Europapokal war man wieder erfolgreicher und gelangte ins Finale des Pokals der Landesmeister, unterlag dort jedoch Aston Villa mit 0:1 trotz einer klaren Dominanz im Spielverlauf. In der Meisterschaft machten der HSV und der 1. FC Köln den Titel unter sich aus. Es blieb nur der 3. Platz für die Münchner, nachdem man am Bökelberg gegen Gladbach mit 0:3 unterlag.+Spieldaten des Endspiels um den DFB-Pokal 1982 und des Endspiels um den Europapokal der Landesmeister 1982+Im Juli 1983 kehrte Udo Lattek als Trainer nach München zurück. Pal Csernai wurde drei Spieltage vor Ablauf der Saison 1982/83 wegen Erfolglosigkeit entlassen. Der FC Bayern konnte diesmal keinen Titel holen und kam auch in kein Finale. So scheiterte man im Pokal der Pokalsieger an der Mannschaft von Alex Ferguson, dem FC Aberdeen, der später auch den Titel holte. In der Bundesliga belegte man nur Platz vier. Zum Saisonende beendete mit Paul Breitner erneut einer der Großen seine Karriere. Mit Jean-Marie Pfaff wurde jedoch auch schon ein neuer Publikumsliebling verpflichtet. Am 33. Spieltag gegen Schalke gab Michael Rummenigge, der Bruder von Karl-Heinz, seinen Einstand bei den Bayern. Unter Lattek folgten nun erneut sehr erfolgreiche Jahre. Die Mannschaft erreichte unter seiner Leitung dreimal hintereinander das Pokalfinale und musste sich nur 1985 Bayer Uerdingen geschlagen geben. Das Finale 1984 gegen Borussia Mönchengladbach musste im Elfmeterschießen entschieden werden. Ausgerechnet Lothar Matthäus, der zur folgenden Spielzeit an die Isar wechselte, verschoss den ersten Elfmeter für Gladbach.+Spieldaten des Endspiels um den DFB-Pokal 1984; Spieldaten des Endspiels um den DFB-Pokal 1985 und Spieldaten des Endspiels um den DFB-Pokal 1986+Erreichten die Bayern 1985 noch das Halbfinale des Europapokals der Pokalsieger, standen sie 1987 wieder im Finale des Pokals der Landesmeister. Dort traf man in Wien auf den FC Porto, der als Außenseiter in die Partie ging. Bis zur 78. Minute führten die Bayern mit 1:0 durch ein Tor von Ludwig Kögl, ehe Rabah Madjer durch ein sensationelles Hackentricktor der Ausgleich gelang. Nur zwei Minuten später folgte das 2:1 des FC Porto und der FC Bayern verpasste erneut die Chance auf den Gewinn des Europapokals der Landesmeister. Die Meisterschaft konnte man in den Jahren 1985 bis 1987 drei Mal in Folge gewinnen. Mit dem Gewinn der Meisterschaft 1986 löste man den 1. FC Nürnberg als Rekordmeister Deutschlands ab, wobei den Bayern in der Saison 1984/85 das seltene Kunststück gelang, vom ersten bis zum letzten Spieltag Tabellenführer der Bundesliga zu sein. Udo Lattek nahm zum Ende der Saison 1986/87 seinen Hut und verabschiedete sich zum letzten Male von den Bayern. In seinen zwei Amtszeiten als Trainer des FC Bayern München gewann er insgesamt sechs Meisterschaften, dreimal den DFB-Pokal und einmal den Landesmeisterpokal.+Spieldaten des Endspiels um den Europapokal der Landesmeister 1987+Auf Udo Lattek folgte Jupp Heynckes als Trainer bei den Bayern. In seiner ersten Saison als verantwortlicher Trainer sprang am Ende Platz zwei hinter Werder Bremen heraus. Es folgte erneut ein Umbruch in der Mannschaft, wobei fünf Nationalspieler den Verein verließen. Matthäus und Brehme gingen zu Inter Mailand und Jean-Marie Pfaff verließ den Verein in Richtung Lierse SK. Immerhin 156 Bundesligaspiele hatte Pfaff für die Bayern absolviert. Nachfolger von Pfaff wurde der damals 25-jährige Raimond Aumann. Neu verpflichtet wurden dafür u. a. Stefan Reuter, Olaf Thon und Roland Grahammer. So klappte es dann für Heynckes mit der Meisterschaft im zweiten Anlauf und Roland Wohlfarth wurde mit 17 Treffern Torschützenkönig der Bundesliga. Im DFB-Pokal war man dagegen nicht so erfolgreich und schied bereits in der dritten Runde gegen den Karlsruher SC aus. Im UEFA-Pokal erreichte man immerhin das Halbfinale. Dort scheiterten die Münchner am späteren Pokalsieger SSC Neapel mit dem damaligen Weltstar Diego Armando Maradona. In besserer Erinnerung aus jener Europapokalsaison 1988/89 dürfte jedoch das Achtelfinalrückspiel bei Inter Mailand sein. Nach einem 0:2 im Hinspiel schafften die Bayern das „Wunder von Mailand“ und gewannen das Rückspiel mit 3:1. Ebenfalls legendär war der Auftritt von Trainer Christoph Daum zusammen mit Bayern-Trainer Heynckes im ZDF-Sportstudio. Dabei kam es zum Eklat, als Daum meinte, dass eine Wetterkarte interessanter sei als ein Gespräch mit Heynckes und sich hinterher noch an seine Stirn tippte. Die Person Daum sollte den FC Bayern noch lange begleiten.++Für die Saison 1989/90, die ähnlich verlief wie die vorherige Saison, kamen sieben neue Spieler hinzu. Der Meistertitel wurde erfolgreich verteidigt, im DFB-Pokal schied der FC Bayern im Achtelfinale beim VfB Stuttgart aus und im Europapokal der Landesmeister wurde das Halbfinale erreicht, wo man am AC Mailand scheiterte. Das „Tor des Jahrzehnts“ gelang Klaus Augenthaler als er im Pokalspiel bei Eintracht Frankfurt aus 48,90 Metern das entscheidende 1:0 erzielte. Mit Augenthaler, Kohler, Pflügler, Reuter, Thon und Aumann fuhren gleich sechs Bayernspieler zur WM 1990 und kamen als Weltmeister zurück.+Die 90er Jahre begannen für die Bayern wie die 80er Jahre endeten. Mit dem Halbfinale im Pokal der Landesmeister erreichte der Verein zum dritten Mal in Folge die Runde der letzten Vier in einem Europapokalwettbewerb. Dies gelang zuletzt fast zehn Jahre zuvor, von 1980 bis 1982. Nach dem SSC Neapel und dem AC Mailand in den Jahren zuvor war diesmal Roter Stern Belgrad Endstation. Dabei schied die Mannschaft knapp und unglücklich aus. Bis zur 90. Minute des Rückspiels führte man mit 2:1 und wäre somit in der Verlängerung gewesen. Doch einen Flatterball von Klaus Augenthaler auf das eigene Tor vermochte Raimond Aumann nicht festzuhalten und mit einem 2:2 zog Roter Stern ins Finale ein. Im DFB-Pokal setzte es ein peinliches 0:1 in der ersten Runde bei den Amateuren vom FV 09 Weinheim, in der Liga wurde man Vizemeister hinter dem 1. FC Kaiserslautern.+Zur neuen Saison wechselten Kohler und Reuter zu Juventus Turin. Allein für Kohler erhielten die Bayern rund 15 Millionen Mark an Ablöse,[10] doch die Ablöse konnte den Verlust von Kohler nicht wettmachen. Thomas Berthold wurde vom AS Rom verpflichtet, konnte ihn aber nicht ersetzen. Klaus Augenthaler hatte zudem seine Karriere beendet, in der er 404 Bundesligaspiele für den FC Bayern absolvierte und siebenmal Meister und dreimal Pokalsieger wurde.[11] Raimond Aumann und Brian Laudrup erlitten beide einen Kreuzbandriss. Die Mannschaft bestand nur noch aus einem Gerippe. Für Aumann und den ebenfalls ausgefallenen Ersatztorwart Sven Scheuer wurde kurzfristig Toni Schumacher verpflichtet, der in acht Bundesligaspielen vor der Winterpause 91/92 für die etatmäßige Nummer 1 das Bayerntor hütete.+Nach dem Zweitrundenaus im Pokal gegen den FC Homburg und einer 1:4-Heimniederlage gegen die Stuttgarter Kickers war der Druck der Öffentlichkeit so groß, dass der Verein Jupp Heynckes am 8. Oktober 1991 entließ. Laut Raimond Aumann hatten die Spieler Tränen in den Augen, als sich Heynckes von ihnen verabschiedete.[12] Uli Hoeneß, der mit Jupp Heynckes befreundet ist und die Entscheidung der Entlassung mitgetragen hatte, sagte Jahre später mehrmals, dass es seine größte Fehlentscheidung gewesen sei.[13]+Betrachtet man die vier Jahre unter Heynckes mit zwei Vizemeisterschaften, zwei Meisterschaften und dem dreimaligen Erreichen des Halbfinals im Europapokal, kann man sicher von einer erfolgreichen Trainerära sprechen. Der öffentliche Druck, der letzten Endes zur Entlassung Jupp Heynckes führte, deutete bereits damals auf die gestiegenen Ansprüche des Vereins, der Fans und der Medien in München hin. Eine Dekade später sollten Trainer trotz zweier Doubles entlassen werden.+Nachfolger von Heynckes wurde Søren Lerby, der von 1983 bis 1986 89 Spiele für den FC Bayern absolviert hatte. Doch auch Lerby vermochte das Ruder nicht herumzureißen und so setzte es im Europapokal sogar eine der deftigsten Niederlagen in der Vereinsgeschichte. In der 2. Runde des UEFA-Pokals wurden die Bayern von B 1903 Kopenhagen mit 6:2 deklassiert. Am Ende belegten die Bayern nur Platz zehn in der Bundesliga und qualifizierten sich das erste Mal seit 1979 nicht für einen internationalen Wettbewerb. Im März 1992 wurde Erich Ribbeck als neuer Trainer und Nachfolger von Lerby verpflichtet. Zudem investierte der Verein im Sommer insgesamt 23,5 Millionen Mark in neue Spieler, für damalige Verhältnisse eine unglaubliche Summe. Allerdings verließen Stefan Effenberg und Brian Laudrup den Verein für 17 Millionen gemeinsam zum AC Florenz. Lothar Matthäus kehrte im Gegenzug nach vier Jahren in Italien an die Isar zurück. Dazu kamen Spieler wie Thomas Helmer, Mehmet Scholl und Jorginho. 32 Spieltage blieb der FC Bayern auf Platz eins der Tabelle und wurde am Ende doch nur Zweiter hinter Werder Bremen.+1994 holten die Münchner endlich den 13. Meistertitel. Zuvor war in der Winterpause Trainer Ribbeck entlassen worden und der damalige Vizepräsident Franz Beckenbauer übernahm zum ersten Mal den Trainerposten bei seinen Bayern.+Zur neuen Spielzeit 1994/1995 wurde Giovanni Trapattoni als Trainer verpflichtet, der jedoch nur ein Jahr an der Isar blieb. Die Sprachprobleme waren zu groß. Als neuer Torhüter stieß Oliver Kahn zu den Bayern, der später zu einer Ikone in München werden sollte. Im Herbst 1994 löste Franz Beckenbauer den seit 1985 amtierenden Fritz Scherer als Präsidenten des Gesamtvereins ab. In der Meisterschaft wurde der FC Bayern nur Sechster, doch konnte unter dem „Mister“ Trapattoni immerhin das Halbfinale des zwischenzeitlich in UEFA Champions League umbenannten Landesmeisterpokals erreicht werden, wo man gegen den späteren Gewinner Ajax Amsterdam allerdings chancenlos war. Wie schon 1990 leistete man sich im DFB-Pokal einen blamablen Ausrutscher in Runde eins. Diesmal hieß der Gegner Vestenbergsgreuth, gegen den man in Nürnberg mit 0:1 unterlag. Durch den Pokalsieg von Borussia Mönchengladbach gelangte der FC Bayern trotz des sechsten Tabellenplatzes doch noch ins internationale Geschäft und konnte in der Folgesaison am UEFA-Pokal teilnehmen. Franz Beckenbauer bezeichnete darauf hin den Wettbewerb als „Cup der Verlierer“.+Mit Otto Rehhagel kam in der Folgesaison ein renommierter Trainer an die Isar, der zuvor 14 Jahre lang den SV Werder Bremen trainiert hatte. Doch trotz Platz zwei in der Liga und des Einzugs ins Endspiel des UEFA-Pokals musste Rehhagel am 27. April 1996 seinen Posten räumen. Franz Beckenbauer nahm erneut Platz auf der Bank, doch es blieb in der Bundesliga beim zweiten Platz hinter Borussia Dortmund. Er gewann jedoch die beiden UEFA-Pokal-Endspiele gegen Girondins Bordeaux. Beckenbauer hatte damit den Europapokal der Pokalsieger, den Pokal der Landesmeister, den Weltpokal, die Europa- und die Weltmeisterschaft als Spieler und die WM und den UEFA-Pokal als Trainer gewonnen. Einzig den europäischen Supercup gewann er nie. Jürgen Klinsmann, der vor der Saison von den Tottenham Hotspurs nach München gewechselt war, stellte in dieser UEFA-Pokal-Saison mit 15 Turniertreffern einen neuen Rekord auf.[14]++Zur neuen Saison kehrte Giovanni Trapattoni an die Isar zurück und wurde mit dem FC Bayern Deutscher Meister der Saison 96/97. Es war sein erster Titel außerhalb Italiens. 1998 holte er mit den Bayern den DFB-Pokal gegen den MSV Duisburg. Der DFB-Pokalsieg 1998 war zugleich der erste Pokalsieg des Vereins seit nunmehr zwölf Jahren. Nach diesem Erfolg verließ der Italiener die Münchner zum zweiten Mal. Unvergessen blieb dabei seine bekannte Wutrede nach einem 0:1 gegen Schalke am 10. März 1998 in einer Pressekonferenz.+Spieldaten des DFB-Pokal Endspiels 1998+1998 kam der Meistermacher der Dortmunder Borussia, Ottmar Hitzfeld, als Trapattoni-Nachfolger nach München. Mit Hitzfeld kehrte auch Stefan Effenberg an die Isar zurück, der bereits von 1990 bis 1992 für den FC Bayern gespielt hatte. Er wurde in den nächsten Jahren zu Hitzfelds verlängertem Arm in der Mannschaft. Unter dem neuen Trainer wurde man auf Anhieb Meister. Dabei hatte man am Ende 15 Punkte Vorsprung auf den Vizemeister Bayer Leverkusen und das Triple schien möglich.+Die Meisterschaft bereits gesichert, stand man am 26. Mai 1999 im Champions-League-Finale in Barcelona der Mannschaft von Manchester United gegenüber, gegen die man in der Gruppenphase zweimal Unentschieden gespielt hatte. Bereits in der 6. Minute gingen die Bayern durch ein Tor von Mario Basler mit 1:0 in Führung. Der FC Bayern war auch im weiteren Verlauf des Spiels überlegen und hätte sowohl durch Mehmet Scholl als auch Carsten Jancker die Führung weiter ausbauen können. Beide trafen jedoch nur den Torpfosten beziehungsweise die Latte. In der 80. Minute ließ sich Lothar Matthäus, bis dahin einer der besten Spieler auf dem Platz, auf eigenen Wunsch auswechseln. Die Mannschaft hielt bis zur Nachspielzeit das 1:0, jedoch gelang es Manchester durch Tore von Sheringham und Solskjær das Spiel innerhalb von zwei Minuten noch in der Nachspielzeit zu drehen. Dieses Champions-League-Finale ging als eines der denkwürdigsten in die Geschichte ein und noch heute wird über die Auswechslung von Matthäus kontrovers diskutiert.+Zweieinhalb Wochen später war Matthäus erneut die tragische Figur, als es im DFB-Pokal-Endspiel gegen Werder Bremen nach Verlängerung 1:1 stand und das Elfmeterschießen entscheiden musste. Den letzten Elfmeter schoss Matthäus, doch Werder-Torwart Rost hielt und somit ging dieses Elfmeterschießen mit 4:5 verloren. Es war das erste Mal, dass der FC Bayern gleich zwei Endspiele in einer Saison verlor. Dies sollte sich in der Saison 2011/12 jedoch in zeitlich umgekehrter Reihenfolge wiederholen.+Spieldaten des DFB-Pokal-Endspiels 1999 und Spieldaten des Champions-League-Endspiels 1999+Wie fast jedes Jahr gab es auch zur Saison 1999/2000 Neuzugänge und Veränderungen beim FC Bayern. So kamen der damals 17-jährige Roque Santa Cruz, Patrik Andersson und Paulo Sérgio neu zum Verein, Thomas Helmer, Ali Daei und später Mario Basler verließen ihn. Die Saison verlief durchaus erfolgreich. Bayern wurde zum 16. Mal Meister, gewann zum 10. Mal den DFB-Pokal (in einer Neuauflage des letztjährigen Endspiels wurde Werder Bremen mit 3:0 besiegt) und erreichte das Halbfinale der Champions League, wo man gegen Real Madrid ausschied, gegen die man in der Gruppenphase noch zweimal gewinnen konnte. Zudem feierte der Verein im Frühjahr 2000 sein 100-jähriges Vereinsjubiläum. Zu diesem Anlass wurde ein Einladungsturnier mit Real Madrid, Manchester United und Galatasaray Istanbul ausgetragen, das der FC Bayern gewinnen konnte.+Die Entscheidung in der Meisterschaft fiel erst am letzten Spieltag. Seit dem 30. Spieltag der Saison hatte Bayer 04 Leverkusen die Tabelle der Bundesliga angeführt. Nach dem 33. Spieltag betrug der Vorsprung drei Punkte. Ein Unentschieden bei der SpVgg Unterhaching hätte der Elf um Trainer Christoph Daum für den ersten Titelgewinn selbst bei einem Sieg der Bayern gegen Werder Bremen gereicht. Doch es kam anders. Bayern erledigte seine Aufgabe zu Hause und gewann mit 3:1. Gleichzeitig gelang es nur wenige Kilometer entfernt den Leverkusenern nicht, den einen Punkt unter Dach und Fach zu bringen. Leverkusen verlor mit 0:2 beim Aufsteiger aus dem Vorort Münchens – Michael Ballack schoss dabei ein Eigentor zum 0:1 – und die Meisterschaft ging an den FC Bayern.++In der Saison 2000/01 gelang es dem FC Bayern, den Titel in der Bundesliga zu verteidigen; im DFB-Pokal scheiterte man bereits in der zweiten Runde im Elfmeterschießen beim 1. FC Magdeburg. Dafür gelang es 25 Jahre nach dem letzten Sieg im Europapokal der Landesmeister und zwei Jahre nach dem dramatischen Endspiel in Barcelona, diesen Pokal zum vierten Mal zu gewinnen.+Als Initialzündung für diesen Erfolg gilt das vorletzte Spiel der zweiten Gruppenphase bei Olympique Lyon. Der FC Bayern hatte nach einer schwachen Leistung mit 0:3 verloren, was Präsident Franz Beckenbauer beim Mitternachtsbankett zu einer berühmt gewordenen Wutrede („Uwe-Seeler-Traditionsmannschaft“) veranlasste. Die Rede zeigte Wirkung, die folgenden fünf Champions-League-Spiele (gegen Arsenal London, Manchester United und Real Madrid) wurden allesamt gewonnen und so stand man schließlich im Finale der Champions League, das man im Mailänder San Siro mit 5:4 im Elfmeterschießen gegen den FC Valencia gewann. Der Held der Partie war wieder einmal Torhüter Oliver Kahn, der drei Elfmeter parierte. Kahn hatte zuvor im Laufe der Saison schon häufig geglänzt, besonders im Halbfinalhinspiel gegen Real Madrid im Santiago Bernabéu.+Einige Tage zuvor war es in der Bundesliga zum Duell um die Meisterschaft gekommen. Bis zum 33. Spieltag war der FC Schalke 04 Tabellenführer. Dann verloren die Knappen ihr Spiel beim VfB Stuttgart durch ein Tor in der 90. Minute mit 0:1. Nur wenige Sekunden später erzielte Alexander Zickler den 2:1-Siegtreffer für den FC Bayern gegen den 1. FC Kaiserslautern. Schalke musste am 34. Spieltag gegen Unterhaching unbedingt gewinnen und auf eine Niederlage der Münchner im Hamburg hoffen, um doch noch Meister zu werden. Der FC Schalke gewann sein Spiel mit 5:3. Zeitgleich blieb die Partie in Hamburg lange torlos, doch in der 90. Minute ging der HSV durch einen Kopfball von Sergej Barbarez mit 1:0 in Führung.+Nach Gelsenkirchen, wo Schalkes Spiel bereits abgepfiffen war, drang die Nachricht, dass das Spiel in Hamburg aus sei und Bayern verloren habe, jedoch wurden im Parkstadion plötzlich Live-Bilder aus Hamburg auf der Anzeigetafel gezeigt. Dort war zu sehen, wie es für die von Oliver Kahn nach vorne gepeitschten Bayern in der dritten Minute der Nachspielzeit einen indirekten Freistoß im HSV-Strafraum gab, da der Torwart des HSV, Mathias Schober, einen Rückpass mit den Händen aufgenommen hatte. Stefan Effenberg nahm sich des Freistoßes an, legte den Ball auf Patrik Andersson vor und dieser schoss den Ball durch die Mauer ins Tor zum 1:1-Endstand. Somit wurde Bayern in der wohl dramatischsten Entscheidung der Bundesligageschichte erneut Meister; Torschütze Andersson verließ Bayern nach Ende der Saison zum FC Barcelona.+Die Saison 2001/02 verlief zunächst weniger erfolgreich. Schon die ersten Entscheidungen konnte der FC Bayern nicht für sich entscheiden. Man verlor im Ligapokal und im europäischen Supercup in Monaco mit 2:3 gegen den FC Liverpool. Am 27. November 2001 wurde in Tokio mit einem 1:0 nach Verlängerung gegen die Boca Juniors zum zweiten Mal nach 1976 der Weltpokal gewonnen. Schütze des Siegtores war Samuel Kuffour. Dies sollte jedoch der einzige Titel der Saison bleiben. In der Bundesliga erreichte man hinter Borussia Dortmund und Bayer Leverkusen nur Platz drei, in der Champions League war im Viertelfinale gegen Real Madrid und im DFB-Pokal im Halbfinale bei Schalke 04 Schluss.++Für Stefan Effenberg, der die Bayern am Ende der letzten Saison verlassen hatte, wurde Michael Ballack verpflichtet, der in der abgelaufenen Saison mit Leverkusen jeweils den zweiten Platz in der Bundesliga, im DFB-Pokal und in der Champions League erreichte. Zudem wechselte dessen Mannschaftskollege Zé Roberto zu den Bayern. Ein weiterer Neuzugang war Sebastian Deisler, der allerdings nach einer Verletzung gleich zu Beginn für lange Zeit ausfiel.+In der Champions-League-Saison 2002/03 konnten die Bayern aus sechs Spielen nur zwei Punkte durch die beiden Unentschieden gegen den RC Lens erringen. Gegen AC Mailand und Deportivo La Coruña setzte es je zwei Niederlagen. Besonders ein Spieler erwies sich dabei für Deportivo als sicherer Schütze und bezwang Oliver Kahn in zwei Spielen vier Mal: Roy Makaay. Im Sommer 2003 wechselte dieser dann für die damalige Rekordsumme von 18,7 Millionen Euro zum FC Bayern München.+Die Saison verlief national jedoch erfolgreich und in der Bundesliga erreichte Bayern am Ende einen Vorsprung von 16 Punkten auf den zweitplatzierten VfB Stuttgart. Zudem gelang erneut der Sieg im DFB-Pokal. Mit 3:1 besiegte man im Finale den 1. FC Kaiserslautern und erreichte so erneut das Double. In der Saison gab Bastian Schweinsteiger seinen Einstand bei den Profis des FC Bayern beim Champions-League-Heimspiel gegen den RC Lens.+Im Frühjahr 2003 kam mit der Kirch-Affäre der wohl größte Skandal der Vereinsgeschichte ans Licht.+Spieldaten des Endspiels um den DFB-Pokal 2003+Saison 2003/04 [Bearbeiten]+Vor der Saison 2003/04 wechselte Martín Demichelis von River Plate Buenos Aires zum FC Bayern. In dieser Saison waren die Münchner gegen den blendend aufspielenden, späteren Meister Werder Bremen mit einem starken Ailton jedoch nicht in der Lage, den Titel zu verteidigen. So blieb am Ende als Zweiter immer noch die direkte Qualifikation zur Champions League im darauf folgenden Jahr. 2003/04 reichte es dort nur zum Achtelfinale, in dem man wie zwei Jahre zuvor gegen Real Madrid ausschied. Im DFB-Pokal war im Viertelfinale bei Alemannia Aachen Endstation. Zum Ende der Saison löste der FC Bayern den Vertrag mit Trainer Hitzfeld, der noch bis Mitte 2005 datiert war, vorzeitig auf.+Saison 2004/05 [Bearbeiten]+Für Hitzfeld kam in der Folgesaison Felix Magath vom VfB Stuttgart. Mit ihm kam der an die Schwaben ausgeliehene Philipp Lahm zurück an die Säbener Straße. Zudem gelang es den Bayern, Lúcio von Bayer Leverkusen für die neue Saison zu verpflichten.+Der neue Trainer hatte auf Anhieb Erfolg mit den Bayern. So gelang es 2004/05 erneut, das Double zu holen. In der Bundesliga zog man zum Ende der zweiten Saisonhälfte einsam seine Kreise und hatte zum Schluss 77 Punkte auf dem Konto und 14 Punkte Vorsprung auf den Tabellenzweiten, den FC Schalke 04, der die Bayern in der Bundesligasaison zweimal schlagen konnte. Dabei hatte Schalke nach dem 25. Spieltag und dem 1:0-Heimsieg noch einen Drei-Punkte-Vorsprung vor den Münchnern, konnte diesen jedoch nicht behaupten und verlor in der Folgezeit 17 Punkte in neun Spielen auf die Bayern. Beide Mannschaften standen sich auch im Finale des DFB-Pokals gegenüber, das die Münchner etwas glücklich aber verdient mit 2:1 für sich entscheiden konnten. In der Champions League mussten die Bayern im Viertelfinale gegen den FC Chelsea die Segel streichen. Zum Ende der Saison bestritt man das letzte Bundesligaspiel im Olympiastadion. Die Begegnung wurde 6:3 gegen den 1. FC Nürnberg gewonnen und so endete die Ära in diesem Stadion mit der deutschen Meisterschaft, wie sie schon 1971/72 begonnen hatte.+Spieldaten des Endspiels um den DFB-Pokal 2005+Saison 2005/06 [Bearbeiten]+Mit der neuen Saison zogen die Bayern in die neu gebaute Allianz Arena um. Und diese wurde so erfolgreich fortgesetzt, wie die Vorsaison endete. In seiner zweiten Saison beim FC Bayern schaffte Magath dabei ein Novum. Unter ihm gelang es dem FC Bayern, als erste deutsche Mannschaft im Fußball der Männer das Double zu verteidigen. Dabei setzte man sich in der Bundesliga am Ende vor Werder Bremen und dem HSV durch. Im Endspiel um den DFB-Pokal bezwang man Eintracht Frankfurt mit 1:0 durch ein Tor von Claudio Pizarro. In der Champions League war im Achtelfinale Schluss. Dabei war man nach einem 1:1 im Hinspiel gegen den AC Mailand im Rückspiel in Italien chancenlos und verlor mit 1:4. Ende der Saison lief der Vertrag von Michael Ballack aus. Bayern machte ihm ein Angebot über 36 Millionen Euro für einen neuen vier Jahre laufenden Vertrag, doch nach langer Überlegung lehnte der Nationalspieler ab und wechselte ablösefrei zum FC Chelsea. Nach der Saison beendete Bixente Lizarazu seine Karriere beim FC Bayern.+Spieldaten des Endspiels um den DFB-Pokal 2006+Saison 2006/07 [Bearbeiten]+Für die Saison 2006/07 wurde kein neuer Spielmacher geholt. Allerdings konnten Lukas Podolski und Mark van Bommel verpflichtet werden. Die dritte Saison beim FC Bayern verlief für Magath dann weniger erfolgreich. Wie drei Jahre zuvor scheiterte man dieses Mal schon im Pokal-Achtelfinale an Alemannia Aachen. Einer der Torschützen für Aachen war Jan Schlaudraff, der im folgenden Sommer zu den Bayern wechseln sollte. Zudem drohte man in der Bundesliga, nur auf Platz vier liegend, die Qualifikation zur Champions League zu verpassen. Deshalb reagierte man beim FC Bayern und holte einen alten Bekannten als Trainer zurück. Am 31. Januar 2007 wurde Felix Magath nach zwei Double-Gewinnen in Folge durch seinen Vorgänger Ottmar Hitzfeld ersetzt. Doch auch er konnte die Qualifikation zur Champions League nicht erreichen und man blieb auf dem vierten Platz, der schlechtesten Platzierung der Bayern der letzten zwölf Jahre. In der Champions League selbst war erneut gegen den AC Mailand Endstation, diesmal im Viertelfinale. Man hatte sich zwar mit einem 2:2 in Mailand eine gute Ausgangsposition für das Rückspiel im eigenen Stadion erarbeitet, verlor dann aber mit 0:2. Durch dieses Ausscheiden und Platz vier in der Liga war man für die nächste Saison erstmals seit der Saison 1996/97 nicht für die Champions League qualifiziert und musste mit dem UEFA-Pokal vorliebnehmen. Nach dieser Saison beendete Mehmet Scholl seine lange Karriere beim FC Bayern. Zuvor hatte Sebastian Deisler im Januar sein Karriereende bekanntgegeben.+Saison 2007/08 [Bearbeiten]+Um eine Saison wie die des Vorjahres nicht erneut zu erleben, investierten die Bayern in der Vorbereitung zur neuen Saison eine Rekordsumme von rund 70 Millionen Euro. Dabei wurden alleine 25 Millionen Euro für Franck Ribéry von Olympique Marseille und 12,5 Millionen Euro für Luca Toni vom AC Florenz ausgegeben. Als dann neben der schon bekannten Verpflichtung von Jan Schlaudraff mit Miroslav Klose auch noch ein dritter neuer Stürmer eingekauft wurde, erbat Roy Makaay seine Freigabe und wechselte zu Feyenoord Rotterdam. Zudem wechselte Hasan Salihamidžić zu Juventus Turin. Vereinseigengewächs Owen Hargreaves, der schon lange Ambitionen für die Premier League geäußert hatte, wechselte für eine Ablösesumme von 25 Millionen Euro zu Manchester United. Neben den oben genannten Spielern wechselte auch Hamit Altıntop von Schalke 04 zu den Bayern.+Die hohen Investitionen lohnten sich und Bayern gelang in dieser Saison der fünfte Double-Gewinn in einem Jahrzehnt und der siebte Double-Gewinn überhaupt. Dabei wurde den Zuschauern auch spielerisch ein erfrischender Fußball geboten, bei dem vor allem Ribéry seine ausgezeichnete Technik unter Beweis stellte. Die Saison selbst verlief recht einseitig. Mit einem Start-Ziel-Sieg erreichte der FC Bayern am Ende einen Vorsprung von zehn Punkten auf Werder Bremen. Im DFB-Pokalfinale wurde Borussia Dortmund mit 2:1 nach Verlängerung besiegt. Im UEFA-Pokal schaffte man es bis ins Halbfinale und musste sich dort nach einem 1:1 im Hinspiel in München dem späteren Gewinner Zenit Sankt Petersburg mit 0:4 in St. Petersburg geschlagen geben.+Neben der herben Halbfinalpleite blieb dabei besonders das Viertelfinalrückspiel in Getafe in Erinnerung. Nach einem 1:1 im Hinspiel in München musste man beim FC Getafe antreten. Nachdem es lange 1:0 für die Gastgeber stand, konnte Ribéry den Rückstand in der 89. Minute ausgleichen. Dadurch kam es zur Verlängerung. Dort stand es schnell 3:1 für Getafe. Erst in der 115. Minute kamen die Bayern durch Luca Toni zum Anschlusstreffer und in der letzten Minute der Verlängerung schaffte es wiederum Toni den Ausgleich zu erzielen. Somit war man aufgrund der mehr geschossenen Auswärtstore im Halbfinale.+In der Winterpause der Saison kündigte Ottmar Hitzfeld bereits an, seinen zum Saisonende auslaufenden Vertrag bei Bayern nicht zu verlängern. Um ihn zu ersetzen, wurde für die neue Saison der ehemalige Spieler Jürgen Klinsmann als neuer Trainer verpflichtet.+Mit dem Rekord von acht gewonnenen Meisterschaften und sechs gewonnenen DFB-Pokalen verließ Oliver Kahn den FC Bayern. Kahn gelang es in seiner letzten Saison, den Rekord von Oliver Reck (22 Gegentore in 34 Spielen aus der Saison 1987/88) mit 21 Gegentoren in 34 Spielen zu unterbieten. Nach der Saison wurde er zum Ehrenspielführer des FC Bayern München ernannt.+Spieldaten des Endspiels um den DFB-Pokal 2008+Saison 2008/09 [Bearbeiten]+Zu Beginn der Saison 2008/09 stand Michael Rensing als die neue Nummer 1 im Tor der Bayern, verlor seinen Platz jedoch im April 2009 an Hans Jörg Butt. Zudem wechselten Tim Borowski und der italienische Weltmeister Massimo Oddo zum Rekordmeister. Nach anfänglichen Schwierigkeiten in der Bundesliga gelang es, sich bis zur Winterpause an den Spitzenreiter, den Aufsteiger TSG 1899 Hoffenheim, heranzuarbeiten und punktgleich mit der TSG überwinterte man auf Platz zwei. Nachdem man die Leistungen in der zweiten Hälfte der Saison nicht stabilisieren konnte, musste Jürgen Klinsmann fünf Spieltage vor Schluss seinen Platz räumen und wurde durch Jupp Heynckes als Cheftrainer und dessen Co-Trainer Hermann Gerland ersetzt.[15] Unter dem neuen Trainer konnte sich die Mannschaft mit vier Siegen und einem Unentschieden hinter dem neuen Meister VfL Wolfsburg den zweiten Platz und somit die direkte Qualifikation für die Champions League der Folgesaison sichern. Im DFB-Pokal war man zuvor schon im Viertelfinale gegen Bayer Leverkusen ausgeschieden. In der Champions League konnte man sich im Achtelfinal-Hinspiel bei Sporting Lissabon mit 5:0 durchsetzen und zog nach einem 7:1 im Rückspiel in das Viertelfinale ein; das Gesamtergebnis von 12:1 gegen Sporting bedeutete Champions-League-Rekord. Im Viertelfinale erlebte man jedoch vier Tage nach einem 1:5 in der Bundesliga beim VfL Wolfsburg das von vielen Fans[16] und Medien befürchtete Hinspiel-Debakel beim FC Barcelona: Nach einer 4:0-Pausenführung im Camp Nou schalteten die zuvor schon kaum geforderten Katalanen noch etwas zurück, führten eine ersatzgeschwächte (ohne Lahm, Lucio, van Buyten und Klose) und katastrophal spielende Bayern-Mannschaft aber weiter vor, ohne ihre großen Chancen in weitere Tore umzumünzen. Nach einem 1:1 im von beiden Mannschaften, besonders aber von Barcelona, nicht mit letztem Einsatz geführtem Rückspiel war die Europapokalsaison für den FC Bayern beendet.+Kurz nach der Winterpause gab Willy Sagnol auf Grund andauernder Beschwerden im Knie sein Karriereende bekannt. Bis März 2009 hatte der von Los Angeles Galaxy ausgeliehene US-Amerikaner Landon Donovan ein etwas glückloses Gastspiel in München.+Den Verein verließen zum Saisonende Lukas Podolski zum 1. FC Köln, Zé Roberto zum HSV und Lúcio zu Inter Mailand. Der vom AC Mailand ausgeliehene Massimo Oddo wurde nicht übernommen.+Saison 2009/10 [Bearbeiten]+Am 1. Juli 2009 übernahm Louis van Gaal, der in der Vorsaison den AZ Alkmaar zur Niederländischen Fußballmeisterschaft führte, den Posten als Chef-Trainer des FC Bayern.+Zugänge zur Saison 2009/10 waren Anatolij Tymoschtschuk von Zenit St. Petersburg, Alexander Baumjohann von Borussia Mönchengladbach, Ivica Olić vom Hamburger SV, Edson Braafheid von Twente Enschede.[17], Danijel Pranjić vom SC Heerenveen[18] und Mario Gómez vom VfB Stuttgart. Letzterer ist mit einer Ablösesumme von 30 Millionen Euro der teuerste Transfer der Bundesligageschichte.[19] Zudem kehrte Andreas Görlitz, der an den Karlsruher SC ausgeliehen war, zum FC Bayern zurück. Daneben rückten aus der zweiten Mannschaft Thomas Müller und Holger Badstuber in den Profikader auf. Am 28. August 2009 wurde schließlich der holländische Nationalspieler Arjen Robben von Real Madrid verpflichtet.[20]+Am Beginn der Saison versuchte van Gaal nochmals, Michael Rensing als Stammtorwart zu installieren. Allerdings konnte dieser abermals nicht überzeugen, so dass er am fünften Spieltag seinen Stammplatz wieder an Hans Jörg Butt abtreten musste. Das erste Saison-Drittel verlief wenig erfolgreich für den FC Bayern. In der Bundesliga rutschte man zwischenzeitlich bis auf Rang 14 ab und auch das Weiterkommen in der Champions League war gefährdet. Im letzten Spiel der Champions-League-Gruppenphase besiegten die Bayern schließlich am 8. Dezember 2009 Juventus Turin auswärts mit 4:1, wodurch sie doch noch die Endrunde der Champions League erreichen konnten. Daneben gelang es dem FC Bayern in der Bundesliga, bis Mitte Februar 2010 neun Spiele hintereinander zu gewinnen und damit den Rückstand auf den Spitzenreiter Bayer Leverkusen, der zwischenzeitlich acht Punkte betragen hatte, auszugleichen. Am 24. Spieltag übernahmen die Bayern schließlich die Tabellenführung in der Bundesliga, die sie bis Saisonende nur noch einmal abgaben. Am letzten Spieltag wurde durch einen 3:1-Sieg bei Hertha BSC die 22. Deutsche Meisterschaft perfekt gemacht. Zudem gewann man das Finale des DFB-Pokals gegen Werder Bremen mit 4:0 und konnte somit den 15. Pokalsieg, gleichzeitig das achte Double, verbuchen.+Spieldaten des Endspiels um den DFB-Pokal 2010+Mit dem Einzug ins Finale der Champions League eröffnete sich die Chance für die Bayern, als erste deutsche Mannschaft das Triple aus Meisterschaft, nationalem sowie internationalem Pokal zu gewinnen. Allerdings verlor man am 22. Mai 2010 im Estadio Santiago Bernabéu in Madrid gegen Inter Mailand mit 0:2 und verpasste damit den historischen Triumph.++Zu Beginn der Saison 2010/2011 konnte der Verein mit einem 2:0 gegen Schalke 04 den von der DFL wieder eingeführten Supercup gewinnen. In der Champions League erreichten die Münchner das Achtelfinale, wo sie gegen Inter Mailand nach einem 1:0-Auswärtssieg durch eine 2:3-Heimniederlage ausschieden. Im DFB-Pokal schieden sie im Halbfinale nach einer 0:1-Heimniederlage gegen Schalke aus.+Am 7. März 2011 wurde vom FC Bayern bekanntgegeben, dass der Vertrag mit Trainer Louis van Gaal am Saisonende zum 30. Juni 2011 vorzeitig und einvernehmlich aufgelöst werden wird. Grund hierfür war laut Pressemitteilung die unterschiedliche Auffassung über die strategische Ausrichtung des Klubs. Nachfolger wurde Jupp Heynckes, der einen Zweijahresvertrag erhielt.[21] Am 10. April 2011 gab der Verein aufgrund der weiteren sportlichen Talfahrt die sofortige Beurlaubung Louis van Gaals bekannt und ernannte den bisherigen Co-Trainer Andries Jonker zum Cheftrainer bis zum Saisonende.[22]+Nach 5 Spielen und 13 von 15 möglichen Punkten unter Jonker schloss die Mannschaft die Saison 2010/2011 als Dritter ab und sicherte sich damit die Teilnahme an der Qualifikation zur Champions League.+In der Bundesligasaison 2011/12 musste man sich erneut Borussia Dortmund geschlagen geben, schaffte mit dem zweiten Platz aber die direkte Champions-League-Qualifikation. Zudem wurde das Pokalfinale am 12. Mai 2012 in Berlin erreicht, in dem man mit 2:5 wieder Borussia Dortmund unterlegen war.+In der Champions League-Qualifikation besiegte man den FC Zürich mit 2:0 und 1:0 und erreichte somit die Gruppenphase. In den Duellen gegen den FC Villarreal, Manchester City und die SSC Neapel gelang es den Roten, bereits nach dem fünften Spieltag als Gruppensieger festzustehen.[23] Über den FC Basel, Olympique Marseille und Real Madrid zog man in das Finale der Champions League ein und verlor am 19. Mai 2012 gegen Chelsea London im eigenen Stadion nach Verlängerung (1:1) im Elfmeterschießen 3:4.+Mit dem jeweils zweiten Platz in Champions League, Meisterschaft und DFB-Pokal ging 2012 als ein Annus horribilis verpasster Chancen in die Vereinsgeschichte ein. +Die erste Mannschaft spielt seit 1965 in der Bundesliga. Der FC Bayern München ist der erfolgreichste deutsche Fußball-Club und deutscher Rekordmeister. Für 21 Meisterschaften seit Einführung der Bundesliga 1963 darf er vier Meistersterne auf dem Trikot tragen. Der FC Bayern ist der erste Verein, dem es gelang, das Double zu verteidigen. Der FC Bayern München ist neben Borussia Dortmund, Borussia Mönchengladbach und dem Hamburger SV der vierte Verein, der seinen Titel in der Fußball-Bundesliga verteidigen konnte. Mit 592 Spieltagen als Tabellenführer belegt der Verein den 1. Platz in der ewigen Liste der Tabellenführer. Neben Ajax Amsterdam und Juventus Turin gelang es dem FC Bayern, alle Europapokale sowie den Weltpokal zu gewinnen. Neben Bayern München gelang es bisher nur Real Madrid und Ajax Amsterdam, den Europapokal der Landesmeister dreimal in Folge zu gewinnen. Deswegen erlaubt es die UEFA unter anderem dem FC Bayern, ein Logo mit dem Champions-League-Pokal zu tragen, in dem zusätzlich die Anzahl aller gewonnenen Europapokale der Landesmeister (4) eingetragen ist. Unter den Vereinspokalen fehlt einzig der europäische Supercup, der bisher noch von keiner deutschen Mannschaft gewonnen wurde.++Die zweite Mannschaft (bis 2005: FC Bayern München Amateure, seitdem offiziell: FC Bayern München II) ist ebenfalls eine Profimannschaft und spielt seit 2011 in der viertklassigen Regionalliga Süd. Von 1973 bis 2011 spielte die Mannschaft stets drittklassig. Betreut wird das Team derzeit von Andries Jonker als Trainer sowie Gerd Müller und Rainer Ulrich als Co-Trainern, Torwarttrainer ist Walter Junghans.+1983 und 1987 erreichten die Bayern-Amateure jeweils das Endspiel um die Deutsche Amateurmeisterschaft. Bei der Einführung der Regionalligen als dritthöchste Spielklasse 1994 war man direkt für die Regionalliga Süd qualifiziert und spielte in dieser Liga bis 2008, als durch einen achten Platz die Qualifikation für die neugegründete 3. Liga gelang, deren Premierensaison man 2008/09 als Fünfter beendete. In der Saison 2003/04 gewannen die Bayern-Amateure mit Spielern wie Zvjezdan Misimović, Piotr Trochowski und Paolo Guerrero die Meisterschaft in der Regionalliga Süd. Für den DFB-Pokal waren die Bayern-Amateure mehrmals qualifiziert, erreichten in der Saison 1993/94 das Achtelfinale sowie 1994/95 und 2004/05 sogar das Viertelfinale, wobei u. a. die Bundesligisten Werder Bremen, VfB Stuttgart, 1. FC Köln und Borussia Mönchengladbach besiegt wurden.+Immer wieder schafften Spieler der zweiten Mannschaft den Sprung in den Kader der Profimannschaft und wurden später Stammspieler, so u. a. Markus Babbel, Philipp Lahm, Owen Hargreaves, Bastian Schweinsteiger oder in jüngerer Zeit Holger Badstuber und Thomas Müller.+In den Anfangsjahren des Vereins wechselten die Spielstätten recht häufig. Das erste Spiel der Vereinsgeschichte fand auf dem städtischen Spielplatz an der Schyrenstraße statt. Der 1. Münchner FC wurde damals mit 5:2 bezwungen. 1901 bis 1907 spielte man dann in Schwabing an der Clemensstraße, um dann an die Leopoldstraße zu wechseln. Da immer mehr Zuschauer zu den Heimspielen des Vereins kamen, wechselte man ab 1920 erneut den Platz, ohne für eine längere Zeit eine feste Heimstätte zu haben. Für 47 Jahre fanden die „Roten“ dann ab 1925 im Grünwalder Stadion ihr festes Zuhause, wobei man bis zum Ende des Zweiten Weltkriegs Untermieter des TSV 1860 München war. Der TSV musste später aus finanziellen Gründen das Stadion an die Stadt München verkaufen. Bayerns Zuschauerrekord im Grünwalder Stadion beläuft sich auf mehr als 50.000 während der Saison 1961/62 gegen den 1. FC Nürnberg. Mit Beginn der Bundesliga waren dann nur noch 44.000 Zuschauer zugelassen.++Nach Fertigstellung des Olympiastadions München für die Olympischen Sommerspiele 1972 zogen die Bayern dorthin um. Das erste Spiel der Bayern fand am letzten Spieltag der Saison 1971/72 statt. FC Schalke 04 hieß der Gegner und wurde vor 79.000 Zuschauern mit 5:1 geschlagen. Nach dem Spiel feierte der Verein seine erste von vielen Deutschen Meisterschaften im Olympiastadion. Durch eine Reduzierung der Stehplätze und kleinere Anpassungen im Stadion sank die offizielle Stadionkapazität schrittweise auf 69.200 Zuschauer bei nationalen Spielen und 59.000 bei internationalen Spielen. Aus Komfortgründen gab der Verein rund 6.000 Plätze, die keine gute Sicht auf das Spielfeld boten, nicht für den Verkauf frei und ließ zu Bundesliga-Spielen nur 63.000 Zuschauer ins Stadion. Ab 1995, ein Jahr nach dem Wiederaufstieg des TSV 1860 München in die Bundesliga trug auch der Stadtrivale seine Heimspiele im Olympiastadion aus, wobei die Löwen bei Spitzenspielen die zulässige Höchstgrenze von 69.200 Zuschauern nutzten.+Das Olympiastadion wurde mit der Zeit immer stärker als nicht mehr zeitgemäß für Fußballspiele auf Spitzenniveau kritisiert. Es gab keine VIP-Logen, das Stadion war nur zu einer Seite hin überdacht und in der weiten und offenen Anlage wollte keine rechte „Fußball-Stimmung“ aufkommen. Auch die vorhandene Tartanbahn und die dadurch bedingte große Entfernung zwischen Zuschauern und Spielgeschehen war Fans und Verantwortlichen ein Dorn im Auge. Zudem kam es bisweilen zu Terminkonflikten, wenn andere Veranstaltungen, wie z.B. Leichtathletikwettbewerbe oder Rockkonzerte im Stadion stattfinden sollten. Viele derartige Veranstaltungen wurden wegen der Beschwerden des FC Bayern als Hauptnutzer, (und mit ca. 5 Millionen DM jährlich größten Mietzahlers) an andere Orte verlegt. Prominentestes „Opfer“ war die alljährliche Rockveranstaltung Rock im Park, die schließlich von München nach Nürnberg verlegt wurde. Der Verein machte sich daher schon länger Gedanken über ein eigenes Stadion in München. Doch über Jahre hinweg fand man keinen geeigneten Platz und auch die Stadt als Eigentümerin der olympischen Spielstätte sträubte sich gegen derartige Pläne, da die Mietzahlungen des FC Bayern eine lukrative Einnahmequelle darstellten, die man nicht verlieren wollte. Als sich Deutschland für die Fußball-Weltmeisterschaft 2006 bewarb, kam das Thema Stadion erneut auf den Tisch, denn mit dem veralteten Olympiastadion wäre München als Spielort für das Turnier undenkbar gewesen. Da es hieß, dass es nirgendwo einen geeigneten Platz für einen Neubau in München geben würde, dachte man zunächst darüber nach, das Olympiastadion aufwendig zu renovieren und grundlegend umzubauen. Auch ein Abriss und Neubau unter dem denkmalgeschützten Zeltdach wurde durchgespielt. All diese Pläne scheiterten letzten Endes aber am Veto des Architekten Günter Behnisch. Um die örtliche Politik unter Zugzwang zu setzen, spekulierte der Verein daraufhin eine Zeitlang öffentlich darüber, das neue Stadion außerhalb der Stadtgrenzen, beispielsweise in Garching oder Poing zu errichten, womit der Stadt München etliches an Steuereinnahmen und Prestige verlorengegangen wäre.++Wollte München also WM-Spielort werden, musste eine Lösung gefunden werden. Verschiedene Standorte wurden auf ihre Tauglichkeit hin geprüft und man einigte sich letzten Endes auf Fröttmaning am nördlichen Ende der Stadt als Standort für die neue Allianz Arena. Nach zähem Ringen wurde in der Kompromisslösung festgezurrt, dass der FC Bayern und 1860 München die neue Arena gemeinsam errichten und nutzen sollten, wobei jegliche Nutzung außerhalb von Fußball ausgeschlossen wurde, um dem Olympiastadion eine gewisse Grundauslastung bei Veranstaltungen zu sichern. Auch dieser Kompromiss wurde von der Öffentlichkeit kontrovers aufgenommen, sodass es sogar zu einer Volksabstimmung über den Stadionneubau kam, die mit etwa 2/3 der Stimmen zu Gunsten des Neubaus ausfiel. Die beiden Vereine trugen die Kosten für den Stadionbau, während die Stadt München und das Land Bayern für die Kosten der Infrastruktur aufkommen sollten. Zu Beginn waren die FC Bayern München AG und die TSV München von 1860 GmbH & Co. KGaA zu je 50 % an der Stadiongesellschaft, der die Arena gehört und sie betreibt, beteiligt. Beide Vereine müssen zur Nutzung der Arena entsprechende Mietentgelte entrichten, woraus die Stadion GmbH wiederum den Kredit, der den Bau finanzierte, bedient. Als die Löwen jedoch erneut in finanzielle Nöte gerieten, verkauften sie ihren 50-Prozent-Anteil an den Mitgesellschafter. Auch eine zunächst ausgehandelte Rückkaufoption wurde inzwischen an die Bayern verkauft. Somit steht das Stadion unter der alleinigen Kontrolle des FC Bayern München.+Baulich ist das Stadion in drei Ränge unterteilt. Dabei besteht die Haupttribüne mit den Ein- und Ausgängen größtenteils aus VIP-Plätzen und sogenannten Business-Seats. Die Fankurven des FC Bayern befinden sich jeweils hinter den Toren. Die Sitzschalen des Stadions sind in Grau, da wohl weder Rot noch Blau dem einen oder anderen der beiden Vereine zuzumuten gewesen wäre. Dies hat allerdings den Nachteil, dass das Stadion auf Grund des vielen Graus recht kühl wirkt. Während der Heimspiele des FCB leuchtet das Stadion außen in Rot. Mehrfarbige Beleuchtungen sind zwar möglich, wurden aber nachträglich polizeilich untersagt, da die Farbwechsel zu erhöhten Unfallzahlen auf der nahen Autobahn A9 geführt hatten.+Das Stadion fasste anfangs 66.000 Zuschauer. Durch eine Neuanordnung der Sitzreihen und den Umbau einiger überbreiter Business-Seats zu normalen Sitzplätzen wurde die Kapazität wenige Monate später auf 69.001 Zuschauer erhöht. Prinzipiell ist eine weitere Aufstockung bis auf über 80.000 Plätze ohne tiefgreifende Baumaßnahmen möglich, der Verein verzichtet aber darauf, vor allem aus Komfortgründen für die Zuschauer.++Das Trainingsgelände des FC Bayern befindet sich in München-Giesing an der Säbener Straße 51. Es gilt als eines der modernsten Trainingsgelände in Europa. Vielfach wird behauptet, das Gelände befände sich im Stadtteil Harlaching, der jedoch wenige Meter weiter südlich beginnt.+Bereits seit 1949 nutzen die Bayern das Gelände an der Säbener Straße, der ehemaligen Bezirkssportanlage Harlaching. 1970 begann der Bau der neuen Geschäftsstelle und des Trainingsgeländes unter Präsident Neudecker. Am 17. Mai 1971 war die Anlage bezugsfertig. Zum ersten Mal in der Geschichte des Vereins waren Geschäftsstelle und Trainingsgelände vereint. Bereits 1979 wurde das Gelände erweitert, worauf Ende der 80er Jahre ein weiterer Ausbau folgte, um neue Gebäude für den Amateur- und Profibereich zu schaffen. Im Jahr 2000 gab es einen Brand im Profitrakt, wobei ein erheblicher Schaden an den Umkleidekabinen, in der medizinischen Abteilung und in der Sauna entstand. 2008 wurde ein neues Servicezentrum fertiggestellt mit einem neuen Fan-Shop auf einer 250 m² großen Fläche, zudem entstand eine Tiefgarage. Das neue Gebäude ist 95 Meter lang, 16 Meter breit und ca. 10 Meter hoch. Die Tiefgarage fasst 270 Stellplätze. Direkt neben dem neuen Gebäude entstand ein neuer Rasenplatz mit mehreren Sitzreihen auf einer Seite, auf dem in der Saison 2008/09 die Heimspiele der B-Jugend-Mannschaften ausgetragen wurden. Zudem wurde ein neuer Kunstrasenplatz mit zwei Kleinfeldern für die E- und F-Jugend angelegt. Des Weiteren wurde das alte Klubrestaurant in eine Kantine für die Vereinsangestellten umgewandelt. Waren früher alle Trainingseinheiten öffentlich, hat sich in jüngerer Zeit der allgemeine Trend durchgesetzt, meist nur noch einmal wöchentlich ein öffentliches Training stattfinden zu lassen. Insgesamt gibt es auf dem Gelände fünf Rasenplätze, zwei Kunstrasenplätze und einen Beachvolleyballplatz.+Nur durch einen Parkplatz und einen Fußweg vom Bayern-Gelände getrennt befindet sich das neue Sportgelände der Sportfreunde München. Durch die Erweiterungsmaßnahmen des FC Bayern musste das alte Gelände der Sportfreunde weichen und wurde um einige Meter nach Süden versetzt. Ein Stück weiter westlich, getrennt durch ein Wohnviertel, befindet sich an der Grünwalder Straße das Trainingsgelände des Erzrivalen TSV 1860 München.+Der FC Bayern München gliedert sich in die FC Bayern München AG und den FC Bayern München e. V. Auf einer außerordentlichen Mitgliederversammlung des Vereins am 14. Februar 2002 wurde die Ausgliederung der Fußballprofiabteilung in die FC Bayern München AG beschlossen. Vorstandsvorsitzender der AG ist Karl-Heinz Rummenigge, während Uli Hoeneß Präsident des FC Bayern München e. V. und Aufsichtsratsvorsitzender der AG ist. Zum e. V. gehören folgende Sportabteilungen: Fußball (Männer: Fußball-Bundesliga, Regionalliga Süd; Frauen: Fußball-Bundesliga der Frauen), Basketball (Männer: Basketball-Bundesliga), Handball, Schach (Männer: Bundesliga, Frauen: 2. Bundesliga), Sportkegeln, Tischtennis und Turnen.++Die Beziehung zwischen dem FC Bayern München und dem Sportartikelhersteller Adidas kann als recht außergewöhnlich bezeichnet werden. Seit 1965 ist Adidas ununterbrochen Ausrüster des Vereins. Von 2002 bis 2010 hielt Adidas einen 10-Prozent-Anteil an der FC Bayern München AG, der für 77 Millionen Euro erworben wurde.[27] Zwischen März 2010 und Juni 2011 erwarb jedoch die Audi AG in drei Schritten Aktien im Wert von 90 Mio. Euro. Dies war verbunden mit einer Kapitalerhöhung von 2,5 Mio. auf 27,5 Mio. Euro.[28] Nach dieser Kapitalerhöhung halten der FC Bayern München e. V. 81,82 Prozent sowie Adidas und Audi je 9,09 Prozent der Aktien an der AG.+Mit Herbert Hainer stellt Adidas den stellvertretenden Aufsichtsratsvorsitzenden der AG.[29] Bis 2007 durfte auch kein Spieler des FC Bayern eine andere Schuhmarke tragen als Adidas, selbst wenn der Spieler einen Vertrag mit einem anderen Ausrüster als Adidas hatte. Erst mit dem Wechsel von Miroslav Klose zu Bayern München änderte sich dies.++Kein anderer Verein Deutschlands hat so viele registrierte Anhänger wie der Rekordmeister. 2952 Fanklubs mit 204.235 Fanklub-Mitgliedern sind beim FC Bayern offiziell registriert (Stand: 18. November 2011).[32] In ganz Deutschland, aber auch weltweit gibt es organisierte Bayern-Fans. Zu den bekanntesten offiziellen Fanclubs gehören die „Red Munichs 89“, die „Red Sharks“ und die „Die 13 Höslwanger“. In den 1970er Jahren gab es mit der „Südkurve 73 und den „Red Angels zwei führende Gruppen beim FC Bayern. 1986 entstand in München die erste reine Hooligangruppe, die so genannte „Service Crew Munich (SCM). Mitte der 1990er Jahre entwickelte sich dann die Ultra-Bewegung. Als erste Gruppe sind hier die „Munichmaniacs 1996 zu erwähnen. Seit 2002 gibt es eine übergreifende Ultra-Gruppe, die Schickeria München. Diese ist aber kein offizieller Fanclub. Als Dachorganisation für Fans und Fanclubs gibt es den Club Nr. 12 mit aktuell über 1400 Mitgliedern.[33] Früher gab es ein Fanheim auf einem alten Bahngelände im Stadtteil Laim, das aber einem Wohngebiet weichen musste. Was die Zahl der nicht organisierten Fans und Anhänger weltweit anbelangt, gehört der FC Bayern München auch international zu den größten Vereinen. Fanbeauftragter ist mit Andreas Brück ein langjähriger Fan aus der Südkurve.+Jahrelang kämpften die Bayern-Fans und Fanclubs um ein neues, reines Fußballstadion, allein schon wegen der zu erwartenden besseren Stimmung. Tatsächlich zeigte sich jedoch nach dem Einzug in die Allianz Arena, dass die Stimmung im Stadion teilweise schlechter ist als im alten Olympiastadion mit Laufbahn und führte in der Vergangenheit zu sehr kontroversen Diskussionen zwischen Vereinsführung und aktiven Fans. Dies mag zum einen an dem so genannten Operettenpublikum liegen, zum anderen aber auch an der Aufteilung und Bauweise der Allianz Arena. So wurden die Fans aus der Südkurve des Olympiastadions im neuen Stadion auf Süd- und Nordkurve aufgeteilt. Im Unterrang der Südkurve befinden sich weniger Stehplätze als in der Südkurve des Olympiastadions, so gibt es zu Bundesligaspielen dort lediglich 6800 Stehplätze.+Zu den Heimspielen der zweiten Mannschaft im Stadion an der Grünwalder Straße finden sich auf der Gegengeraden meist zwischen 50 und 300 aktive Fans ein. Das Stadion wird von ihnen als „Hermann-Gerland-Kampfbahn“ bezeichnet, ein Zeichen der Anerkennung der Arbeit von Hermann Gerland als langjährigem Trainer der Mannschaft. Die seit 2005 vom DFB praktizierte Sprachregelung mit dem Namenszusatz „II“ statt „Amateure“ wird von den Fans nicht akzeptiert.++Das aktuelle offizielle Vereinslied ist „Stern des Südens“, komponiert von Willy Astor und gesungen von Claus Lessmann, dem Leadsänger der Hardrockband Bonfire. Davor war jahrelang das Lied „Forever Number One“ die Hymne des Vereins. Das Lied „Stern des Südens“ befindet sich auf der CD „Heimspiel“ der FC Bayern Fans United und wurde auch als Single veröffentlicht. Die beiden offiziellen Lieder wurden jedoch von der Fanszene wenig akzeptiert, inoffizielle Hymne ist das Lied „Mir san die Bayern“.+Bekannt ist ebenfalls der alte Schlager von Franz Beckenbauer „Gute Freunde kann niemand trennen“. Angestimmt werden nahezu alle Lieder im Unterrang der Südkurve und hier sowohl von der Schickeria München[34] als auch von einem Trompeter und einer Reihe älterer Fans. Auch in der Nordkurve befinden sich aktive Fans, während sich die Zuschauer in den Sitzplatzbereichen meist passiv verhalten.+Überregional haben sich über die Jahre hinweg mehrere Rivalitäten herausgebildet. Meistens entstand so eine Rivalität mit einem Verein, mit dem die Bayern über einen gewissen Zeitraum hinweg um die Meisterschaft rangen. So waren dies Borussia Mönchengladbach in den 1970ern und Borussia Dortmund in den 1990er Jahren. Zudem gibt es noch die Rivalität zum 1. FC Kaiserslautern und die Nord-Süd-Gipfel gegen den Hamburger SV und Werder Bremen.
+ benchmark/Streamly/Benchmark/Unicode/data/Devanagari.txt view
@@ -0,0 +1,699 @@+मधुशाला+मृदु भावों के अंगूरों की आज बना लाया हाला,+प्रियतम, अपने ही हाथों से आज पिलाऊँगा प्याला,+पहले भोग लगा लूँ तेरा फिर प्रसाद जग पाएगा,+सबसे पहले तेरा स्वागत करती मेरी मधुशाला।।१। ++प्यास तुझे तो, विश्व तपाकर पूर्ण निकालूँगा हाला,+एक पाँव से साकी बनकर नाचूँगा लेकर प्याला,+जीवन की मधुता तो तेरे ऊपर कब का वार चुका,+आज निछावर कर दूँगा मैं तुझ पर जग की मधुशाला।।२।++प्रियतम, तू मेरी हाला है, मैं तेरा प्यासा प्याला,+अपने को मुझमें भरकर तू बनता है पीनेवाला,+मैं तुझको छक छलका करता, मस्त मुझे पी तू होता,+एक दूसरे की हम दोनों आज परस्पर मधुशाला।।३।++भावुकता अंगूर लता से खींच कल्पना की हाला,+कवि साकी बनकर आया है भरकर कविता का प्याला,+कभी न कण-भर खाली होगा लाख पिएँ, दो लाख पिएँ!+पाठकगण हैं पीनेवाले, पुस्तक मेरी मधुशाला।।४।++मधुर भावनाओं की सुमधुर नित्य बनाता हूँ हाला,+भरता हूँ इस मधु से अपने अंतर का प्यासा प्याला,+उठा कल्पना के हाथों से स्वयं उसे पी जाता हूँ,+अपने ही में हूँ मैं साकी, पीनेवाला, मधुशाला।।५।++मदिरालय जाने को घर से चलता है पीनेवला,+'किस पथ से जाऊँ?' असमंजस में है वह भोलाभाला,+अलग-अलग पथ बतलाते सब पर मैं यह बतलाता हूँ -+'राह पकड़ तू एक चला चल, पा जाएगा मधुशाला।'। ६।++चलने ही चलने में कितना जीवन, हाय, बिता डाला!+'दूर अभी है', पर, कहता है हर पथ बतलानेवाला,+हिम्मत है न बढूँ आगे को साहस है न फिरुँ पीछे,+किंकर्तव्यविमूढ़ मुझे कर दूर खड़ी है मधुशाला।।७।++मुख से तू अविरत कहता जा मधु, मदिरा, मादक हाला,+हाथों में अनुभव करता जा एक ललित कल्पित प्याला,+ध्यान किए जा मन में सुमधुर सुखकर, सुंदर साकी का,+और बढ़ा चल, पथिक, न तुझको दूर लगेगी मधुशाला।।८।++मदिरा पीने की अभिलाषा ही बन जाए जब हाला,+अधरों की आतुरता में ही जब आभासित हो प्याला,+बने ध्यान ही करते-करते जब साकी साकार, सखे,+रहे न हाला, प्याला, साकी, तुझे मिलेगी मधुशाला।।९।++सुन, कलकल़ , छलछल़ मधुघट से गिरती प्यालों में हाला,+सुन, रूनझुन रूनझुन चल वितरण करती मधु साकीबाला,+बस आ पहुंचे, दुर नहीं कुछ, चार कदम अब चलना है,+चहक रहे, सुन, पीनेवाले, महक रही, ले, मधुशाला।।१०।++जलतरंग बजता, जब चुंबन करता प्याले को प्याला,+वीणा झंकृत होती, चलती जब रूनझुन साकीबाला,+डाँट डपट मधुविक्रेता की ध्वनित पखावज करती है,+मधुरव से मधु की मादकता और बढ़ाती मधुशाला।।११।++मेंहदी रंजित मृदुल हथेली पर माणिक मधु का प्याला,+अंगूरी अवगुंठन डाले स्वर्ण वर्ण साकीबाला,+पाग बैंजनी, जामा नीला डाट डटे पीनेवाले,+इन्द्रधनुष से होड़ लगाती आज रंगीली मधुशाला।।१२।++हाथों में आने से पहले नाज़ दिखाएगा प्याला,+अधरों पर आने से पहले अदा दिखाएगी हाला,+बहुतेरे इनकार करेगा साकी आने से पहले,+पथिक, न घबरा जाना, पहले मान करेगी मधुशाला।।१३।++लाल सुरा की धार लपट सी कह न इसे देना ज्वाला,+फेनिल मदिरा है, मत इसको कह देना उर का छाला,+दर्द नशा है इस मदिरा का विगत स्मृतियाँ साकी हैं,+पीड़ा में आनंद जिसे हो, आए मेरी मधुशाला।।१४।++जगती की शीतल हाला सी पथिक, नहीं मेरी हाला,+जगती के ठंडे प्याले सा पथिक, नहीं मेरा प्याला,+ज्वाल सुरा जलते प्याले में दग्ध हृदय की कविता है,+जलने से भयभीत न जो हो, आए मेरी मधुशाला।।१५।++बहती हाला देखी, देखो लपट उठाती अब हाला,+देखो प्याला अब छूते ही होंठ जला देनेवाला,+'होंठ नहीं, सब देह दहे, पर पीने को दो बूंद मिले'+ऐसे मधु के दीवानों को आज बुलाती मधुशाला।।१६।++धर्मग्रन्थ सब जला चुकी है, जिसके अंतर की ज्वाला,+मंदिर, मसजिद, गिरिजे, सब को तोड़ चुका जो मतवाला,+पंडित, मोमिन, पादिरयों के फंदों को जो काट चुका,+कर सकती है आज उसी का स्वागत मेरी मधुशाला।।१७।++लालायित अधरों से जिसने, हाय, नहीं चूमी हाला,+हर्ष-विकंपित कर से जिसने, हा, न छुआ मधु का प्याला,+हाथ पकड़ लज्जित साकी को पास नहीं जिसने खींचा,+व्यर्थ सुखा डाली जीवन की उसने मधुमय मधुशाला।।१८।++बने पुजारी प्रेमी साकी, गंगाजल पावन हाला,+रहे फेरता अविरत गति से मधु के प्यालों की माला'+'और लिये जा, और पीये जा', इसी मंत्र का जाप करे'+मैं शिव की प्रतिमा बन बैठूं, मंदिर हो यह मधुशाला।।१९।++बजी न मंदिर में घड़ियाली, चढ़ी न प्रतिमा पर माला,+बैठा अपने भवन मुअज्ज़िन देकर मस्जिद में ताला,+लुटे ख़जाने नरपितयों के गिरीं गढ़ों की दीवारें,+रहें मुबारक पीनेवाले, खुली रहे यह मधुशाला।।२०।++बड़े बड़े परिवार मिटें यों, एक न हो रोनेवाला,+हो जाएँ सुनसान महल वे, जहाँ थिरकतीं सुरबाला,+राज्य उलट जाएँ, भूपों की भाग्य सुलक्ष्मी सो जाए,+जमे रहेंगे पीनेवाले, जगा करेगी मधुशाला।।२१।++सब मिट जाएँ, बना रहेगा सुन्दर साकी, यम काला,+सूखें सब रस, बने रहेंगे, किन्तु, हलाहल औ' हाला,+धूमधाम औ' चहल पहल के स्थान सभी सुनसान बनें,+जगा करेगा अविरत मरघट, जगा करेगी मधुशाला।।२२।++भुरा सदा कहलायेगा जग में बाँका, मदचंचल प्याला,+छैल छबीला, रसिया साकी, अलबेला पीनेवाला,+पटे कहाँ से, मधु औ' जग की जोड़ी ठीक नहीं,+जग जर्जर प्रतिदन, प्रतिक्षण, पर नित्य नवेली मधुशाला।।२३।++बिना पिये जो मधुशाला को बुरा कहे, वह मतवाला,+पी लेने पर तो उसके मुह पर पड़ जाएगा ताला,+दास द्रोहियों दोनों में है जीत सुरा की, प्याले की,+विश्वविजयिनी बनकर जग में आई मेरी मधुशाला।।२४।++हरा भरा रहता मदिरालय, जग पर पड़ जाए पाला,+वहाँ मुहर्रम का तम छाए, यहाँ होलिका की ज्वाला,+स्वर्ग लोक से सीधी उतरी वसुधा पर, दुख क्या जाने,+पढ़े मर्सिया दुनिया सारी, ईद मनाती मधुशाला।।२५।++एक बरस में, एक बार ही जगती होली की ज्वाला,+एक बार ही लगती बाज़ी, जलती दीपों की माला,+दुनियावालों, किन्तु, किसी दिन आ मदिरालय में देखो,+दिन को होली, रात दिवाली, रोज़ मनाती मधुशाला।।२६।++नहीं जानता कौन, मनुज आया बनकर पीनेवाला,+कौन अपिरिचत उस साकी से, जिसने दूध पिला पाला,+जीवन पाकर मानव पीकर मस्त रहे, इस कारण ही,+जग में आकर सबसे पहले पाई उसने मधुशाला।।२७।++बनी रहें अंगूर लताएँ जिनसे मिलती है हाला,+बनी रहे वह मिटटी जिससे बनता है मधु का प्याला,+बनी रहे वह मदिर पिपासा तृप्त न जो होना जाने,+बनें रहें ये पीने वाले, बनी रहे यह मधुशाला।।२८।++सकुशल समझो मुझको, सकुशल रहती यदि साकीबाला,+मंगल और अमंगल समझे मस्ती में क्या मतवाला,+मित्रों, मेरी क्षेम न पूछो आकर, पर मधुशाला की,+कहा करो 'जय राम' न मिलकर, कहा करो 'जय मधुशाला'।।२९।++सूर्य बने मधु का विक्रेता, सिंधु बने घट, जल, हाला,+बादल बन-बन आए साकी, भूमि बने मधु का प्याला,+झड़ी लगाकर बरसे मदिरा रिमझिम, रिमझिम, रिमझिम कर,+बेलि, विटप, तृण बन मैं पीऊँ, वर्षा ऋतु हो मधुशाला।।३०।++तारक मणियों से सज्जित नभ बन जाए मधु का प्याला,+सीधा करके भर दी जाए उसमें सागरजल हाला,+मत्त समीरण साकी बनकर अधरों पर छलका जाए,+फैले हों जो सागर तट से विश्व बने यह मधुशाला।।३१।++अधरों पर हो कोई भी रस जिहवा पर लगती हाला,+भाजन हो कोई हाथों में लगता रक्खा है प्याला,+हर सूरत साकी की सूरत में परिवर्तित हो जाती,+आँखों के आगे हो कुछ भी, आँखों में है मधुशाला।।३२।++पौधे आज बने हैं साकी ले ले फूलों का प्याला,+भरी हुई है जिसके अंदर पिरमल-मधु-सुरिभत हाला,+माँग माँगकर भ्रमरों के दल रस की मदिरा पीते हैं,+झूम झपक मद-झंपित होते, उपवन क्या है मधुशाला!।३३।++प्रति रसाल तरू साकी सा है, प्रति मंजरिका है प्याला,+छलक रही है जिसके बाहर मादक सौरभ की हाला,+छक जिसको मतवाली कोयल कूक रही डाली डाली+हर मधुऋतु में अमराई में जग उठती है मधुशाला।।३४।++मंद झकोरों के प्यालों में मधुऋतु सौरभ की हाला+भर भरकर है अनिल पिलाता बनकर मधु-मद-मतवाला,+हरे हरे नव पल्लव, तरूगण, नूतन डालें, वल्लरियाँ,+छक छक, झुक झुक झूम रही हैं, मधुबन में है मधुशाला।।३५।++साकी बन आती है प्रातः जब अरुणा ऊषा बाला,+तारक-मणि-मंडित चादर दे मोल धरा लेती हाला,+अगणित कर-किरणों से जिसको पी, खग पागल हो गाते,+प्रति प्रभात में पूर्ण प्रकृति में मुखिरत होती मधुशाला।।३६।++उतर नशा जब उसका जाता, आती है संध्या बाला,+बड़ी पुरानी, बड़ी नशीली नित्य ढला जाती हाला,+जीवन के संताप शोक सब इसको पीकर मिट जाते+सुरा-सुप्त होते मद-लोभी जागृत रहती मधुशाला।।३७।++अंधकार है मधुविक्रेता, सुन्दर साकी शशिबाला+किरण किरण में जो छलकाती जाम जुम्हाई का हाला,+पीकर जिसको चेतनता खो लेने लगते हैं झपकी+तारकदल से पीनेवाले, रात नहीं है, मधुशाला।।३८।++किसी ओर मैं आँखें फेरूँ, दिखलाई देती हाला+किसी ओर मैं आँखें फेरूँ, दिखलाई देता प्याला,+किसी ओर मैं देखूं, मुझको दिखलाई देता साकी+किसी ओर देखूं, दिखलाई पड़ती मुझको मधुशाला।।३९।++साकी बन मुरली आई साथ लिए कर में प्याला,+जिनमें वह छलकाती लाई अधर-सुधा-रस की हाला,+योगिराज कर संगत उसकी नटवर नागर कहलाए,+देखो कैसों-कैसों को है नाच नचाती मधुशाला।।४०।++वादक बन मधु का विक्रेता लाया सुर-सुमधुर-हाला,+रागिनियाँ बन साकी आई भरकर तारों का प्याला,+विक्रेता के संकेतों पर दौड़ लयों, आलापों में,+पान कराती श्रोतागण को, झंकृत वीणा मधुशाला।।४१।++चित्रकार बन साकी आता लेकर तूली का प्याला,+जिसमें भरकर पान कराता वह बहु रस-रंगी हाला,+मन के चित्र जिसे पी-पीकर रंग-बिरंगे हो जाते,+चित्रपटी पर नाच रही है एक मनोहर मधुशाला।।४२।++घन श्यामल अंगूर लता से खिंच खिंच यह आती हाला,+अरूण-कमल-कोमल कलियों की प्याली, फूलों का प्याला,+लोल हिलोरें साकी बन बन माणिक मधु से भर जातीं,+हंस मत्त होते पी पीकर मानसरोवर मधुशाला।।४३।++हिम श्रेणी अंगूर लता-सी फैली, हिम जल है हाला,+चंचल नदियाँ साकी बनकर, भरकर लहरों का प्याला,+कोमल कूर-करों में अपने छलकाती निशिदिन चलतीं,+पीकर खेत खड़े लहराते, भारत पावन मधुशाला।।४४।++धीर सुतों के हृदय रक्त की आज बना रक्तिम हाला,+वीर सुतों के वर शीशों का हाथों में लेकर प्याला,+अति उदार दानी साकी है आज बनी भारतमाता,+स्वतंत्रता है तृषित कालिका बलिवेदी है मधुशाला।।४५।++दुतकारा मस्जिद ने मुझको कहकर है पीनेवाला,+ठुकराया ठाकुरद्वारे ने देख हथेली पर प्याला,+कहाँ ठिकाना मिलता जग में भला अभागे काफिर को?+शरणस्थल बनकर न मुझे यदि अपना लेती मधुशाला।।४६।++पथिक बना मैं घूम रहा हूँ, सभी जगह मिलती हाला,+सभी जगह मिल जाता साकी, सभी जगह मिलता प्याला,+मुझे ठहरने का, हे मित्रों, कष्ट नहीं कुछ भी होता,+मिले न मंदिर, मिले न मस्जिद, मिल जाती है मधुशाला।।४७।++सजें न मस्जिद और नमाज़ी कहता है अल्लाताला,+सजधजकर, पर, साकी आता, बन ठनकर, पीनेवाला,+शेख, कहाँ तुलना हो सकती मस्जिद की मदिरालय से+चिर विधवा है मस्जिद तेरी, सदा सुहागिन मधुशाला।।४८।++बजी नफ़ीरी और नमाज़ी भूल गया अल्लाताला,+गाज गिरी, पर ध्यान सुरा में मग्न रहा पीनेवाला,+शेख, बुरा मत मानो इसको, साफ़ कहूँ तो मस्जिद को+अभी युगों तक सिखलाएगी ध्यान लगाना मधुशाला!।४९।++मुसलमान औ' हिन्दू है दो, एक, मगर, उनका प्याला,+एक, मगर, उनका मदिरालय, एक, मगर, उनकी हाला,+दोनों रहते एक न जब तक मस्जिद मन्दिर में जाते,+बैर बढ़ाते मस्जिद मन्दिर मेल कराती मधुशाला!।५०।++कोई भी हो शेख नमाज़ी या पंडित जपता माला,+बैर भाव चाहे जितना हो मदिरा से रखनेवाला,+एक बार बस मधुशाला के आगे से होकर निकले,+देखूँ कैसे थाम न लेती दामन उसका मधुशाला!।५१।++और रसों में स्वाद तभी तक, दूर जभी तक है हाला,+इतरा लें सब पात्र न जब तक, आगे आता है प्याला,+कर लें पूजा शेख, पुजारी तब तक मस्जिद मन्दिर में+घूँघट का पट खोल न जब तक झाँक रही है मधुशाला।।५२।++आज करे परहेज़ जगत, पर, कल पीनी होगी हाला,+आज करे इन्कार जगत पर कल पीना होगा प्याला,+होने दो पैदा मद का महमूद जगत में कोई, फिर+जहाँ अभी हैं मन्दिर मस्जिद वहाँ बनेगी मधुशाला।।५३।++यज्ञ अग्नि सी धधक रही है मधु की भटठी की ज्वाला,+ऋषि सा ध्यान लगा बैठा है हर मदिरा पीने वाला,+मुनि कन्याओं सी मधुघट ले फिरतीं साकीबालाएँ,+किसी तपोवन से क्या कम है मेरी पावन मधुशाला।।५४।++सोम सुरा पुरखे पीते थे, हम कहते उसको हाला,+द्रोणकलश जिसको कहते थे, आज वही मधुघट आला,+वेदिवहित यह रस्म न छोड़ो वेदों के ठेकेदारों,+युग युग से है पुजती आई नई नहीं है मधुशाला।।५५।++वही वारूणी जो थी सागर मथकर निकली अब हाला,+रंभा की संतान जगत में कहलाती 'साकीबाला',+देव अदेव जिसे ले आए, संत महंत मिटा देंगे!+किसमें कितना दम खम, इसको खूब समझती मधुशाला।।५६।++कभी न सुन पड़ता, 'इसने, हा, छू दी मेरी हाला',+कभी न कोई कहता, 'उसने जूठा कर डाला प्याला',+सभी जाति के लोग यहाँ पर साथ बैठकर पीते हैं,+सौ सुधारकों का करती है काम अकेले मधुशाला।।५७।++श्रम, संकट, संताप, सभी तुम भूला करते पी हाला,+सबक बड़ा तुम सीख चुके यदि सीखा रहना मतवाला,+व्यर्थ बने जाते हो हिरजन, तुम तो मधुजन ही अच्छे,+ठुकराते हैं मंदिरवाले, पलक बिछाती मधुशाला।।५८।++एक तरह से सबका स्वागत करती है साकीबाला,+अज्ञ विज्ञ में है क्या अंतर हो जाने पर मतवाला,+रंक राव में भेद हुआ है कभी नहीं मदिरालय में,+साम्यवाद की प्रथम प्रचारक है यह मेरी मधुशाला।।५९।++बार बार मैंने आगे बढ़ आज नहीं माँगी हाला,+समझ न लेना इससे मुझको साधारण पीने वाला,+हो तो लेने दो ऐ साकी दूर प्रथम संकोचों को,+मेरे ही स्वर से फिर सारी गूँज उठेगी मधुशाला।।६०।++कल? कल पर विश्वास किया कब करता है पीनेवाला+हो सकते कल कर जड़ जिनसे फिर फिर आज उठा प्याला,+आज हाथ में था, वह खोया, कल का कौन भरोसा है,+कल की हो न मुझे मधुशाला काल कुटिल की मधुशाला।।६१।++आज मिला अवसर, तब फिर क्यों मैं न छकूँ जी-भर हाला+आज मिला मौका, तब फिर क्यों ढाल न लूँ जी-भर प्याला,+छेड़छाड़ अपने साकी से आज न क्यों जी-भर कर लूँ,+एक बार ही तो मिलनी है जीवन की यह मधुशाला।।६२।++आज सजीव बना लो, प्रेयसी, अपने अधरों का प्याला,+भर लो, भर लो, भर लो इसमें, यौवन मधुरस की हाला,+और लगा मेरे होठों से भूल हटाना तुम जाओ,+अथक बनू मैं पीनेवाला, खुले प्रणय की मधुशाला।।६३।++सुमुखी तुम्हारा, सुन्दर मुख ही, मुझको कन्चन का प्याला+छलक रही है जिसमें माणिक रूप मधुर मादक हाला,+मैं ही साकी बनता, मैं ही पीने वाला बनता हूँ+जहाँ कहीं मिल बैठे हम तुम़ वहीं गयी हो मधुशाला।।६४।++दो दिन ही मधु मुझे पिलाकर ऊब उठी साकीबाला,+भरकर अब खिसका देती है वह मेरे आगे प्याला,+नाज़, अदा, अंदाजों से अब, हाय पिलाना दूर हुआ,+अब तो कर देती है केवल फ़र्ज़ - अदाई मधुशाला।।६५।++छोटे-से जीवन में कितना प्यार करुँ, पी लूँ हाला,+आने के ही साथ जगत में कहलाया 'जानेवाला',+स्वागत के ही साथ विदा की होती देखी तैयारी,+बंद लगी होने खुलते ही मेरी जीवन-मधुशाला।।६६।++क्या पीना, निर्द्वन्द न जब तक ढाला प्यालों पर प्याला,+क्या जीना, निश्चिंत न जब तक साथ रहे साकीबाला,+खोने का भय, हाय, लगा है पाने के सुख के पीछे,+मिलने का आनंद न देती मिलकर के भी मधुशाला।।६७।++मुझे पिलाने को लाए हो इतनी थोड़ी-सी हाला! +मुझे दिखाने को लाए हो एक यही छिछला प्याला!+इतनी पी जीने से अच्छा सागर की ले प्यास मरुँ,+सिंधु-तृषा दी किसने रचकर बिंदु-बराबर मधुशाला।।६८।++क्या कहता है, रह न गई अब तेरे भाजन में हाला,+क्या कहता है, अब न चलेगी मादक प्यालों की माला,+थोड़ी पीकर प्यास बढ़ी तो शेष नहीं कुछ पीने को,+प्यास बुझाने को बुलवाकर प्यास बढ़ाती मधुशाला।।६९।++लिखी भाग्य में जितनी बस उतनी ही पाएगा हाला,+लिखा भाग्य में जैसा बस वैसा ही पाएगा प्याला,+लाख पटक तू हाथ पाँव, पर इससे कब कुछ होने का,+लिखी भाग्य में जो तेरे बस वही मिलेगी मधुशाला।।७०।++कर ले, कर ले कंजूसी तू मुझको देने में हाला,+दे ले, दे ले तू मुझको बस यह टूटा फूटा प्याला,+मैं तो सब्र इसी पर करता, तू पीछे पछताएगी,+जब न रहूँगा मैं, तब मेरी याद करेगी मधुशाला।।७१।++ध्यान मान का, अपमानों का छोड़ दिया जब पी हाला,+गौरव भूला, आया कर में जब से मिट्टी का प्याला,+साकी की अंदाज़ भरी झिड़की में क्या अपमान धरा,+दुनिया भर की ठोकर खाकर पाई मैंने मधुशाला।।७२।++क्षीण, क्षुद्र, क्षणभंगुर, दुर्बल मानव मिटटी का प्याला,+भरी हुई है जिसके अंदर कटु-मधु जीवन की हाला,+मृत्यु बनी है निर्दय साकी अपने शत-शत कर फैला,+काल प्रबल है पीनेवाला, संसृति है यह मधुशाला।।७३।++प्याले सा गढ़ हमें किसी ने भर दी जीवन की हाला,+नशा न भाया, ढाला हमने ले लेकर मधु का प्याला,+जब जीवन का दर्द उभरता उसे दबाते प्याले से,+जगती के पहले साकी से जूझ रही है मधुशाला।।७४।++अपने अंगूरों से तन में हमने भर ली है हाला,+क्या कहते हो, शेख, नरक में हमें तपाएगी ज्वाला,+तब तो मदिरा खूब खिंचेगी और पिएगा भी कोई,+हमें नमक की ज्वाला में भी दीख पड़ेगी मधुशाला।।७५।++यम आएगा लेने जब, तब खूब चलूँगा पी हाला,+पीड़ा, संकट, कष्ट नरक के क्या समझेगा मतवाला,+क्रूर, कठोर, कुटिल, कुविचारी, अन्यायी यमराजों के+डंडों की जब मार पड़ेगी, आड़ करेगी मधुशाला।।७६।++यदि इन अधरों से दो बातें प्रेम भरी करती हाला,+यदि इन खाली हाथों का जी पल भर बहलाता प्याला,+हानि बता, जग, तेरी क्या है, व्यर्थ मुझे बदनाम न कर,+मेरे टूटे दिल का है बस एक खिलौना मधुशाला।।७७।++याद न आए दुखमय जीवन इससे पी लेता हाला,+जग चिंताओं से रहने को मुक्त, उठा लेता प्याला,+शौक, साध के और स्वाद के हेतु पिया जग करता है,+पर मै वह रोगी हूँ जिसकी एक दवा है मधुशाला।।७८।++गिरती जाती है दिन प्रतिदन प्रणयनी प्राणों की हाला+भग्न हुआ जाता दिन प्रतिदन सुभगे मेरा तन प्याला,+रूठ रहा है मुझसे रूपसी, दिन दिन यौवन का साकी+सूख रही है दिन दिन सुन्दरी, मेरी जीवन मधुशाला।।७९।++यम आयेगा साकी बनकर साथ लिए काली हाला,+पी न होश में फिर आएगा सुरा-विसुध यह मतवाला,+यह अंतिम बेहोशी, अंतिम साकी, अंतिम प्याला है,+पथिक, प्यार से पीना इसको फिर न मिलेगी मधुशाला।८०।++ढलक रही है तन के घट से, संगिनी जब जीवन हाला+पत्र गरल का ले जब अंतिम साकी है आनेवाला,+हाथ स्पर्श भूले प्याले का, स्वाद सुरा जीव्हा भूले+कानो में तुम कहती रहना, मधु का प्याला मधुशाला।।८१।++मेरे अधरों पर हो अंतिम वस्तु न तुलसीदल प्याला+मेरी जीव्हा पर हो अंतिम वस्तु न गंगाजल हाला,+मेरे शव के पीछे चलने वालों याद इसे रखना+राम नाम है सत्य न कहना, कहना सच्ची मधुशाला।।८२।++मेरे शव पर वह रोये, हो जिसके आंसू में हाला+आह भरे वो, जो हो सुरिभत मदिरा पी कर मतवाला,+दे मुझको वो कान्धा जिनके पग मद डगमग होते हों+और जलूं उस ठौर जहां पर कभी रही हो मधुशाला।।८३।++और चिता पर जाये उंढेला पात्र न घ्रित का, पर प्याला+कंठ बंधे अंगूर लता में मध्य न जल हो, पर हाला,+प्राण प्रिये यदि श्राध करो तुम मेरा तो ऐसे करना+पीने वालों को बुलवा कऱ खुलवा देना मधुशाला।।८४।++नाम अगर कोई पूछे तो, कहना बस पीनेवाला+काम ढालना, और ढालना सबको मदिरा का प्याला,+जाति प्रिये, पूछे यदि कोई कह देना दीवानों की +धर्म बताना प्यालों की ले माला जपना मधुशाला।।८५।++ज्ञात हुआ यम आने को है ले अपनी काली हाला,+पंडित अपनी पोथी भूला, साधू भूल गया माला,+और पुजारी भूला पूजा, ज्ञान सभी ज्ञानी भूला,+किन्तु न भूला मरकर के भी पीनेवाला मधुशाला।।८६।++यम ले चलता है मुझको तो, चलने दे लेकर हाला,+चलने दे साकी को मेरे साथ लिए कर में प्याला,+स्वर्ग, नरक या जहाँ कहीं भी तेरा जी हो लेकर चल,+ठौर सभी हैं एक तरह के साथ रहे यदि मधुशाला।।८७।++पाप अगर पीना, समदोषी तो तीनों - साकी बाला,+नित्य पिलानेवाला प्याला, पी जानेवाली हाला,+साथ इन्हें भी ले चल मेरे न्याय यही बतलाता है,+कैद जहाँ मैं हूँ, की जाए कैद वहीं पर मधुशाला।।८८।++शांत सकी हो अब तक, साकी, पीकर किस उर की ज्वाला,+'और, और' की रटन लगाता जाता हर पीनेवाला,+कितनी इच्छाएँ हर जानेवाला छोड़ यहाँ जाता!+कितने अरमानों की बनकर कब्र खड़ी है मधुशाला।।८९।++जो हाला मैं चाह रहा था, वह न मिली मुझको हाला,+जो प्याला मैं माँग रहा था, वह न मिला मुझको प्याला,+जिस साकी के पीछे मैं था दीवाना, न मिला साकी,+जिसके पीछे था मैं पागल, हा न मिली वह मधुशाला!।९०।++देख रहा हूँ अपने आगे कब से माणिक-सी हाला,+देख रहा हूँ अपने आगे कब से कंचन का प्याला,+'बस अब पाया!'- कह-कह कब से दौड़ रहा इसके पीछे,+किंतु रही है दूर क्षितिज-सी मुझसे मेरी मधुशाला।।९१।++कभी निराशा का तम घिरता, छिप जाता मधु का प्याला,+छिप जाती मदिरा की आभा, छिप जाती साकीबाला,+कभी उजाला आशा करके प्याला फिर चमका जाती,+आँख मिचौली खेल रही है मुझसे मेरी मधुशाला।।९२।++'आ आगे' कहकर कर पीछे कर लेती साकीबाला,+होंठ लगाने को कहकर हर बार हटा लेती प्याला,+नहीं मुझे मालूम कहाँ तक यह मुझको ले जाएगी,+बढ़ा बढ़ाकर मुझको आगे, पीछे हटती मधुशाला।।९३।++हाथों में आने-आने में, हाय, फिसल जाता प्याला,+अधरों पर आने-आने में हाय, ढुलक जाती हाला,+दुनियावालो, आकर मेरी किस्मत की ख़ूबी देखो,+रह-रह जाती है बस मुझको मिलते-मिलते मधुशाला।।९४।++प्राप्य नही है तो, हो जाती लुप्त नहीं फिर क्यों हाला,+प्राप्य नही है तो, हो जाता लुप्त नहीं फिर क्यों प्याला,+दूर न इतनी हिम्मत हारुँ, पास न इतनी पा जाऊँ,+व्यर्थ मुझे दौड़ाती मरु में मृगजल बनकर मधुशाला।।९५।++मिले न, पर, ललचा ललचा क्यों आकुल करती है हाला,+मिले न, पर, तरसा तरसाकर क्यों तड़पाता है प्याला,+हाय, नियति की विषम लेखनी मस्तक पर यह खोद गई+'दूर रहेगी मधु की धारा, पास रहेगी मधुशाला!'।९६।++मदिरालय में कब से बैठा, पी न सका अब तक हाला,+यत्न सहित भरता हूँ, कोई किंतु उलट देता प्याला,+मानव-बल के आगे निर्बल भाग्य, सुना विद्यालय में,+'भाग्य प्रबल, मानव निर्बल' का पाठ पढ़ाती मधुशाला।।९७।++किस्मत में था खाली खप्पर, खोज रहा था मैं प्याला,+ढूँढ़ रहा था मैं मृगनयनी, किस्मत में थी मृगछाला,+किसने अपना भाग्य समझने में मुझसा धोखा खाया,+किस्मत में था अवघट मरघट, ढूँढ़ रहा था मधुशाला।।९८।++उस प्याले से प्यार मुझे जो दूर हथेली से प्याला,+उस हाला से चाव मुझे जो दूर अधर से है हाला,+प्यार नहीं पा जाने में है, पाने के अरमानों में!+पा जाता तब, हाय, न इतनी प्यारी लगती मधुशाला।।९९।++साकी के पास है तनिक सी श्री, सुख, संपित की हाला,+सब जग है पीने को आतुर ले ले किस्मत का प्याला,+रेल ठेल कुछ आगे बढ़ते, बहुतेरे दबकर मरते,+जीवन का संघर्ष नहीं है, भीड़ भरी है मधुशाला।।१००।++साकी, जब है पास तुम्हारे इतनी थोड़ी सी हाला,+क्यों पीने की अभिलषा से, करते सबको मतवाला,+हम पिस पिसकर मरते हैं, तुम छिप छिपकर मुसकाते हो,+हाय, हमारी पीड़ा से है क्रीड़ा करती मधुशाला।।१०१।++साकी, मर खपकर यदि कोई आगे कर पाया प्याला,+पी पाया केवल दो बूंदों से न अधिक तेरी हाला,+जीवन भर का, हाय, पिरश्रम लूट लिया दो बूंदों ने,+भोले मानव को ठगने के हेतु बनी है मधुशाला।।१०२।++जिसने मुझको प्यासा रक्खा बनी रहे वह भी हाला,+जिसने जीवन भर दौड़ाया बना रहे वह भी प्याला,+मतवालों की जिह्वा से हैं कभी निकलते शाप नहीं,+दुखी बनाया जिसने मुझको सुखी रहे वह मधुशाला!।१०३।++नहीं चाहता, आगे बढ़कर छीनूँ औरों की हाला,+नहीं चाहता, धक्के देकर, छीनूँ औरों का प्याला,+साकी, मेरी ओर न देखो मुझको तनिक मलाल नहीं,+इतना ही क्या कम आँखों से देख रहा हूँ मधुशाला।।१०४।++मद, मदिरा, मधु, हाला सुन-सुन कर ही जब हूँ मतवाला,+क्या गति होगी अधरों के जब नीचे आएगा प्याला,+साकी, मेरे पास न आना मैं पागल हो जाऊँगा,+प्यासा ही मैं मस्त, मुबारक हो तुमको ही मधुशाला।।१०५।++क्या मुझको आवश्यकता है साकी से माँगूँ हाला,+क्या मुझको आवश्यकता है साकी से चाहूँ प्याला,+पीकर मदिरा मस्त हुआ तो प्यार किया क्या मदिरा से!+मैं तो पागल हो उठता हूँ सुन लेता यदि मधुशाला।।१०६।++देने को जो मुझे कहा था दे न सकी मुझको हाला,+देने को जो मुझे कहा था दे न सका मुझको प्याला,+समझ मनुज की दुर्बलता मैं कहा नहीं कुछ भी करता,+किन्तु स्वयं ही देख मुझे अब शरमा जाती मधुशाला।।१०७।++एक समय संतुष्ट बहुत था पा मैं थोड़ी-सी हाला,+भोला-सा था मेरा साकी, छोटा-सा मेरा प्याला,+छोटे-से इस जग की मेरे स्वर्ग बलाएँ लेता था,+विस्तृत जग में, हाय, गई खो मेरी नन्ही मधुशाला!।१०८।++बहुतेरे मदिरालय देखे, बहुतेरी देखी हाला,+भाँति भाँति का आया मेरे हाथों में मधु का प्याला,+एक एक से बढ़कर, सुन्दर साकी ने सत्कार किया,+जँची न आँखों में, पर, कोई पहली जैसी मधुशाला।।१०९।++एक समय छलका करती थी मेरे अधरों पर हाला,+एक समय झूमा करता था मेरे हाथों पर प्याला,+एक समय पीनेवाले, साकी आलिंगन करते थे,+आज बनी हूँ निर्जन मरघट, एक समय थी मधुशाला।।११०।++जला हृदय की भट्टी खींची मैंने आँसू की हाला,+छलछल छलका करता इससे पल पल पलकों का प्याला,+आँखें आज बनी हैं साकी, गाल गुलाबी पी होते,+कहो न विरही मुझको, मैं हूँ चलती फिरती मधुशाला!।१११।++कितनी जल्दी रंग बदलती है अपना चंचल हाला,+कितनी जल्दी घिसने लगता हाथों में आकर प्याला,+कितनी जल्दी साकी का आकर्षण घटने लगता है,+प्रात नहीं थी वैसी, जैसी रात लगी थी मधुशाला।।११२।++बूँद बूँद के हेतु कभी तुझको तरसाएगी हाला,+कभी हाथ से छिन जाएगा तेरा यह मादक प्याला,+पीनेवाले, साकी की मीठी बातों में मत आना,+मेरे भी गुण यों ही गाती एक दिवस थी मधुशाला।।११३।++छोड़ा मैंने पथ मतों को तब कहलाया मतवाला,+चली सुरा मेरा पग धोने तोड़ा जब मैंने प्याला,+अब मानी मधुशाला मेरे पीछे पीछे फिरती है,+क्या कारण? अब छोड़ दिया है मैंने जाना मधुशाला।।११४।++यह न समझना, पिया हलाहल मैंने, जब न मिली हाला,+तब मैंने खप्पर अपनाया ले सकता था जब प्याला,+जले हृदय को और जलाना सूझा, मैंने मरघट को+अपनाया जब इन चरणों में लोट रही थी मधुशाला।।११५।++कितनी आई और गई पी इस मदिरालय में हाला,+टूट चुकी अब तक कितने ही मादक प्यालों की माला,+कितने साकी अपना अपना काम खतम कर दूर गए,+कितने पीनेवाले आए, किन्तु वही है मधुशाला।।११६।++कितने होठों को रक्खेगी याद भला मादक हाला,+कितने हाथों को रक्खेगा याद भला पागल प्याला,+कितनी शक्लों को रक्खेगा याद भला भोला साकी,+कितने पीनेवालों में है एक अकेली मधुशाला।।११७।++दर दर घूम रहा था जब मैं चिल्लाता - हाला! हाला!+मुझे न मिलता था मदिरालय, मुझे न मिलता था प्याला,+मिलन हुआ, पर नहीं मिलनसुख लिखा हुआ था किस्मत में,+मैं अब जमकर बैठ गया हूँ, घूम रही है मधुशाला।।११८।++मैं मदिरालय के अंदर हूँ, मेरे हाथों में प्याला,+प्याले में मदिरालय बिंबित करनेवाली है हाला,+इस उधेड़-बुन में ही मेरा सारा जीवन बीत गया -+मैं मधुशाला के अंदर या मेरे अंदर मधुशाला!।११९।++किसे नहीं पीने से नाता, किसे नहीं भाता प्याला,+इस जगती के मदिरालय में तरह-तरह की है हाला,+अपनी-अपनी इच्छा के अनुसार सभी पी मदमाते,+एक सभी का मादक साकी, एक सभी की मधुशाला।।१२०।++वह हाला, कर शांत सके जो मेरे अंतर की ज्वाला, +जिसमें मैं बिंबित-प्रतिबिंबित प्रतिपल, वह मेरा प्याला,+मधुशाला वह नहीं जहाँ पर मदिरा बेची जाती है,+भेंट जहाँ मस्ती की मिलती मेरी तो वह मधुशाला।।१२१।++मतवालापन हाला से ले मैंने तज दी है हाला,+पागलपन लेकर प्याले से, मैंने त्याग दिया प्याला,+साकी से मिल, साकी में मिल अपनापन मैं भूल गया,+मिल मधुशाला की मधुता में भूल गया मैं मधुशाला।।१२२।++मदिरालय के द्वार ठोंकता किस्मत का छूंछा प्याला,+गहरी, ठंडी सांसें भर भर कहता था हर मतवाला,+कितनी थोड़ी सी यौवन की हाला, हा, मैं पी पाया!+बंद हो गई कितनी जल्दी मेरी जीवन मधुशाला।।१२३।++कहाँ गया वह स्वर्गिक साकी, कहाँ गयी सुरिभत हाला,+कहाँ गया स्वपिनल मदिरालय, कहाँ गया स्वर्णिम प्याला!+पीनेवालों ने मदिरा का मूल्य, हाय, कब पहचाना?+फूट चुका जब मधु का प्याला, टूट चुकी जब मधुशाला।।१२४।++अपने युग में सबको अनुपम ज्ञात हुई अपनी हाला, +अपने युग में सबको अदभुत ज्ञात हुआ अपना प्याला,+फिर भी वृद्धों से जब पूछा एक यही उत्तर पाया -+अब न रहे वे पीनेवाले, अब न रही वह मधुशाला!।१२५।++'मय' को करके शुद्ध दिया अब नाम गया उसको, 'हाला'+'मीना' को 'मधुपात्र' दिया 'सागर' को नाम गया 'प्याला',+क्यों न मौलवी चौंकें, बिचकें तिलक-त्रिपुंडी पंडित जी+'मय-महिफल' अब अपना ली है मैंने करके 'मधुशाला'।।१२६।++कितने मर्म जता जाती है बार-बार आकर हाला,+कितने भेद बता जाता है बार-बार आकर प्याला,+कितने अर्थों को संकेतों से बतला जाता साकी,+फिर भी पीनेवालों को है एक पहेली मधुशाला।।१२७।++जितनी दिल की गहराई हो उतना गहरा है प्याला,+जितनी मन की मादकता हो उतनी मादक है हाला,+जितनी उर की भावुकता हो उतना सुन्दर साकी है,+जितना ही जो रिसक, उसे है उतनी रसमय मधुशाला।।१२८।++जिन अधरों को छुए, बना दे मस्त उन्हें मेरी हाला,+जिस कर को छू दे, कर दे विक्षिप्त उसे मेरा प्याला,+आँख चार हों जिसकी मेरे साकी से दीवाना हो,+पागल बनकर नाचे वह जो आए मेरी मधुशाला।।१२९।++हर जिव्हा पर देखी जाएगी मेरी मादक हाला+हर कर में देखा जाएगा मेरे साकी का प्याला+हर घर में चर्चा अब होगी मेरे मधुविक्रेता की+हर आंगन में गमक उठेगी मेरी सुरिभत मधुशाला।।१३०।++मेरी हाला में सबने पाई अपनी-अपनी हाला,+मेरे प्याले में सबने पाया अपना-अपना प्याला,+मेरे साकी में सबने अपना प्यारा साकी देखा,+जिसकी जैसी रुचि थी उसने वैसी देखी मधुशाला।।१३१।++यह मदिरालय के आँसू हैं, नहीं-नहीं मादक हाला,+यह मदिरालय की आँखें हैं, नहीं-नहीं मधु का प्याला,+किसी समय की सुखदस्मृति है साकी बनकर नाच रही,+नहीं-नहीं कवि का हृदयांगण, यह विरहाकुल मधुशाला।।१३२। ++कुचल हसरतें कितनी अपनी, हाय, बना पाया हाला,+कितने अरमानों को करके ख़ाक बना पाया प्याला!+पी पीनेवाले चल देंगे, हाय, न कोई जानेगा,+कितने मन के महल ढहे तब खड़ी हुई यह मधुशाला!।१३३।++विश्व तुम्हारे विषमय जीवन में ला पाएगी हाला+यदि थोड़ी-सी भी यह मेरी मदमाती साकीबाला,+शून्य तुम्हारी घड़ियाँ कुछ भी यदि यह गुंजित कर पाई,+जन्म सफल समझेगी जग में अपना मेरी मधुशाला।।१३४।++बड़े-बड़े नाज़ों से मैंने पाली है साकीबाला,+कलित कल्पना का ही इसने सदा उठाया है प्याला,+मान-दुलारों से ही रखना इस मेरी सुकुमारी को,+विश्व, तुम्हारे हाथों में अब सौंप रहा हूँ मधुशाला।।१३५।++पिरिशष्ट से++स्वयं नहीं पीता, औरों को, किन्तु पिला देता हाला,+स्वयं नहीं छूता, औरों को, पर पकड़ा देता प्याला,+पर उपदेश कुशल बहुतेरों से मैंने यह सीखा है,+स्वयं नहीं जाता, औरों को पहुंचा देता मधुशाला।++मैं कायस्थ कुलोदभव मेरे पुरखों ने इतना ढ़ाला,+मेरे तन के लोहू में है पचहत्तर प्रतिशत हाला,+पुश्तैनी अधिकार मुझे है मदिरालय के आँगन पर,+मेरे दादों परदादों के हाथ बिकी थी मधुशाला।++बहुतों के सिर चार दिनों तक चढ़कर उतर गई हाला,+बहुतों के हाथों में दो दिन छलक झलक रीता प्याला,+पर बढ़ती तासीर सुरा की साथ समय के, इससे ही+और पुरानी होकर मेरी और नशीली मधुशाला।++पितृ पक्ष में पुत्र उठाना अर्ध्य न कर में, पर प्याला+बैठ कहीं पर जाना, गंगा सागर में भरकर हाला+किसी जगह की मिटटी भीगे, तृप्ति मुझे मिल जाएगी+तर्पण अर्पण करना मुझको, पढ़ पढ़ कर के मधुशाला।++- बच्चन
+ benchmark/Streamly/Benchmark/Unicode/data/English.txt view
@@ -0,0 +1,58 @@+Origins[edit]+The standard Italian language has a poetic and literary origin in the twelfth century, and the modern standard of the language was largely shaped by relatively recent events. However, Italian as a language used in the Italian Peninsula has a longer history. In fact the earliest surviving texts that can definitely be called Italian (or more accurately, vernacular, as distinct from its predecessor Vulgar Latin) are legal formulae known as the Placiti Cassinesi from the Province of Benevento that date from 960–963, although the Veronese Riddle contains a late form of Vulgar Latin that can be seen as a very early Italian dialect.[13] What would come to be thought of as Italian was first formalized in the early fourteenth century through the works of Tuscan writer Dante Alighieri, written in his native Florentine. Dante's epic poems, known collectively as the Commedia, to which another Tuscan poet Giovanni Boccaccio later affixed the title Divina, were read throughout Italy and his written dialect became the "canonical standard" that all educated Italians could understand. Dante is still credited with standardizing the Italian language, and thus the dialect of Florence became the basis for what would become the official language of Italy.++Italian often was an official language of the various Italian states predating unification, slowly usurping Latin, even when ruled by foreign powers (such as the Spanish in the Kingdom of Naples, or the Austrians in the Kingdom of Lombardy-Venetia), even though the masses spoke primarily vernacular languages and dialects. Italian was also one of the many recognised languages in the Austro-Hungarian Empire.++Italy has always had a distinctive dialect for each city, because the cities, until recently, were thought of as city-states. Those dialects now have considerable variety. As Tuscan-derived Italian came to be used throughout Italy, features of local speech were naturally adopted, producing various versions of Regional Italian. The most characteristic differences, for instance, between Roman Italian and Milanese Italian are the gemination of initial consonants and the pronunciation of stressed "e", and of "s" in some cases: e.g. va bene "all right": is pronounced [va ˈbːɛne] by a Roman (and by any standard-speaker), [va ˈbene] by a Milanese (and by any speaker whose native dialect lies to the north of La Spezia–Rimini Line); a casa "at home" is [a ˈkːasa] for Roman and standard, [a ˈkaza] for Milanese and generally northern.++In contrast to the Northern Italian language, southern Italian dialects and languages were largely untouched by the Franco-Occitan influences introduced to Italy, mainly by bards from France, during the Middle Ages but, after the Norman conquest of southern Italy, Sicily became the first Italian land to adopt Occitan lyric moods (and words) in poetry. Even in the case of Northern Italian language, however, scholars are careful not to overstate the effects of outsiders on the natural indigenous developments of the languages.++The economic might and relatively advanced development of Tuscany at the time (Late Middle Ages) gave its dialect weight, though the Venetian language remained widespread in medieval Italian commercial life, and Ligurian (or Genoese) remained in use in maritime trade alongside the Mediterranean. The increasing political and cultural relevance of Florence during the periods of the rise of Medici's bank, Humanism, and the Renaissance made its dialect, or rather a refined version of it, a standard in the arts.++Renaissance[edit]+Main article: Italian Renaissance+Starting with the Renaissance, Italian became the language used in the courts of every state in the peninsula. The rediscovery of Dante's De vulgari eloquentia and a renewed interest in linguistics in the sixteenth century, sparked a debate that raged throughout Italy concerning the criteria that should govern the establishment of a modern Italian literary and spoken language. Scholars divided into three factions:++The purists, headed by Venetian Pietro Bembo (who, in his Gli Asolani, claimed the language might be based only on the great literary classics, such as Petrarch and some part of Boccaccio). The purists thought the Divine Comedy not dignified enough, because it used elements from non-lyric registers of the language.+Niccolò Machiavelli and other Florentines preferred the version spoken by ordinary people in their own times.+The courtiers, like Baldassare Castiglione and Gian Giorgio Trissino, insisted that each local vernacular contribute to the new standard.+A fourth faction claimed the best Italian was the one that the papal court adopted, which was a mix of Florentine and the dialect of Rome. Eventually, Bembo's ideas prevailed, and the foundation of the Accademia della Crusca in Florence (1582–1583), the official legislative body of the Italian language led to publication of Agnolo Monosini's Latin tome Floris italicae linguae libri novem in 1604 followed by the first Italian dictionary in 1612.++Modern era[edit]+An important event that helped the diffusion of Italian was the conquest and occupation of Italy by Napoleon in the early nineteenth century (who was himself of Italian-Corsican descent). This conquest propelled the unification of Italy some decades after, and pushed the Italian language into a lingua franca used not only among clerks, nobility and functionaries in the Italian courts but also in the bourgeoisie.++Contemporary times[edit]+Italian literature's first modern novel, I Promessi Sposi (The Betrothed), by Alessandro Manzoni, further defined the standard by "rinsing" his Milanese "in the waters of the Arno" (Florence's river), as he states in the Preface to his 1840 edition.++After unification a huge number of civil servants and soldiers recruited from all over the country introduced many more words and idioms from their home languages ("ciao" is derived from Venetian word "s-cia[v]o" (slave), "panettone" comes from Lombard word "panatton" etc.). Only 2.5% of Italy’s population could speak the Italian standardized language properly when the nation unified in 1861.[14]++Classification[edit]+Italian is a Romance language, and is therefore a descendant of Vulgar Latin. Standard Italian is based on Tuscan, especially its Florentine dialect, and is therefore an Italo-Dalmatian language, to which Sicilian and the extinct Dalmatian also belong, among a few others.++Unlike most other Romance languages, Italian retains Latin's contrast between short and long consonants. As in most Romance languages, stress is distinctive. In particular, among the Romance languages, Italian is the closest to Latin in terms of vocabulary.[12] Lexical similarity is 89% with French, 88% with Catalan, 85% with Sardinian, 82% with Spanish and Portuguese, 78% with Rhaeto-Romance, and 77% with Romanian.[6][15]++Geographic distribution[edit]++The geographic distribution of the Italian language in the world: large Italian-speaking communities are shown in green; light blue indicates areas where the Italian language was used officially during the Italian colonial period.++Use of the Italian language in Europe++Use of the Italian language in Europe and former use in Africa+Europe[edit]+Italian is the official language of Italy and San Marino and is spoken fluently by the majority of the countries' populations. Italian is official, together with French, German and Romansch in Switzerland, with most of the 0.5 million speakers concentrated in the south of the country, in the cantons of Ticino and southern Graubünden (predominately in Italian Girgioni). Italian is the third most spoken language in Switzerland (after German and French), and its use has modestly declined since the 1970s.[16] Italian is also used in administration and official documents in Vatican City.[17]++Italian is widely spoken in Malta, where nearly two-thirds of the population can speak it fluently, making it the most spoken non-official language in Europe in 2005.[18] Italian served as Malta's official language until 1934, while it is also recognized as an official language in Istria County, Croatia and Slovenian Istria, where there are significant and historic Italian populations.[citation needed]++It is used as the official language of the Sovereign Military Order of Malta, a Roman Catholic chivalric order which, while not a nation per se, is still recognized as a sovereign subject of international law.++Italian is also spoken by a minority in Monaco and France (especially in the southeast of the country and Corsica).[19][20] Small Italian-speaking minorities can also be found in Albania and Montenegro.[citation needed]++Africa[edit]+Due to heavy Italian influence during the Italian colonial period, Italian is still widely understood in the countries of Libya and Eritrea.[6] Although it was the primary language since colonial rule, Italian greatly declined under the rule of Muammar Gaddafi, who expelled the Italian Libyan population and made Arabic the sole official language of the country.[21] Nevertheless, Italian remains an important language in the education and economic sectors in Libya. In Eritrea, Italian is a principal language in commerce and the capital city Asmara still has an Italian-language school.[22] Italian was also introduced to Somalia through colonialism and was the sole official language of administration and education during the colonial period but declined after government, educational and economic infrastructure was destroyed in the Somali Civil War. Italian remains spoken as a second language by the elderly and the educated and is also used in the new Federal Government of Somalia.[23][24]++Italian was also used in administration in Ethiopia when the country was briefly occupied by Italy from 1936 to 1941.++Immigrant communities[edit]+Although over 17 million Americans are of Italian descent, only a little over one million people in the United States speak Italian at home.[25] Nevertheless, an Italian language media market does exist in the country.[26]++In Canada, Italian is the second most spoken non-official language when Chinese languages are not combined, with over 660,000 speakers (or abou
+ benchmark/Streamly/Benchmark/Unicode/data/Japanese.txt view
@@ -0,0 +1,855 @@+私は、その男の写真を三葉、見たことがある。+　一葉は、その男の、幼年時代、とでも言うべきであろうか、十歳前後かと推定される頃の写真であって、その子供が大勢の女のひとに取りかこまれ、（それは、その子供の姉たち、妹たち、それから、従姉妹《いとこ》たちかと想像される）庭園の池のほとりに、荒い縞の袴《はかま》をはいて立ち、首を三十度ほど左に傾け、醜く笑っている写真である。醜く？　けれども、鈍い人たち（つまり、美醜などに関心を持たぬ人たち）は、面白くも何とも無いような顔をして、+「可愛い坊ちゃんですね」+　といい加減なお世辞を言っても、まんざら空《から》お世辞に聞えないくらいの、謂《い》わば通俗の「可愛らしさ」みたいな影もその子供の笑顔に無いわけではないのだが、しかし、いささかでも、美醜に就いての訓練を経て来たひとなら、ひとめ見てすぐ、+「なんて、いやな子供だ」+　と頗《すこぶ》る不快そうに呟《つぶや》き、毛虫でも払いのける時のような手つきで、その写真をほうり投げるかも知れない。+　まったく、その子供の笑顔は、よく見れば見るほど、何とも知れず、イヤな薄気味悪いものが感ぜられて来る。どだい、それは、笑顔でない。この子は、少しも笑ってはいないのだ。その証拠には、この子は、両方のこぶしを固く握って立っている。人間は、こぶしを固く握りながら笑えるものでは無いのである。猿だ。猿の笑顔だ。ただ、顔に醜い皺《しわ》を寄せているだけなのである。「皺くちゃ坊ちゃん」とでも言いたくなるくらいの、まことに奇妙な、そうして、どこかけがらわしく、へんにひとをムカムカさせる表情の写真であった。私はこれまで、こんな不思議な表情の子供を見た事が、いちども無かった。+　第二葉の写真の顔は、これはまた、びっくりするくらいひどく変貌《へんぼう》していた。学生の姿である。高等学校時代の写真か、大学時代の写真か、はっきりしないけれども、とにかく、おそろしく美貌の学生である。しかし、これもまた、不思議にも、生きている人間の感じはしなかった。学生服を着て、胸のポケットから白いハンケチを覗《のぞ》かせ、籐椅子《とういす》に腰かけて足を組み、そうして、やはり、笑っている。こんどの笑顔は、皺くちゃの猿の笑いでなく、かなり巧みな微笑になってはいるが、しかし、人間の笑いと、どこやら違う。血の重さ、とでも言おうか、生命《いのち》の渋さ、とでも言おうか、そのような充実感は少しも無く、それこそ、鳥のようではなく、羽毛のように軽く、ただ白紙一枚、そうして、笑っている。つまり、一から十まで造り物の感じなのである。キザと言っても足りない。軽薄と言っても足りない。ニヤケと言っても足りない。おしゃれと言っても、もちろん足りない。しかも、よく見ていると、やはりこの美貌の学生にも、どこか怪談じみた気味悪いものが感ぜられて来るのである。私はこれまで、こんな不思議な美貌の青年を見た事が、いちども無かった。+　もう一葉の写真は、最も奇怪なものである。まるでもう、としの頃がわからない。頭はいくぶん白髪のようである。それが、ひどく汚い部屋（部屋の壁が三箇所ほど崩れ落ちているのが、その写真にハッキリ写っている）の片隅で、小さい火鉢に両手をかざし、こんどは笑っていない。どんな表情も無い。謂わば、坐って火鉢に両手をかざしながら、自然に死んでいるような、まことにいまわしい、不吉なにおいのする写真であった。奇怪なのは、それだけでない。その写真には、わりに顔が大きく写っていたので、私は、つくづくその顔の構造を調べる事が出来たのであるが、額は平凡、額の皺も平凡、眉も平凡、眼も平凡、鼻も口も顎《あご》も、ああ、この顔には表情が無いばかりか、印象さえ無い。特徴が無いのだ。たとえば、私がこの写真を見て、眼をつぶる。既に私はこの顔を忘れている。部屋の壁や、小さい火鉢は思い出す事が出来るけれども、その部屋の主人公の顔の印象は、すっと霧消して、どうしても、何としても思い出せない。画にならない顔である。漫画にも何もならない顔である。眼をひらく。あ、こんな顔だったのか、思い出した、というようなよろこびさえ無い。極端な言い方をすれば、眼をひらいてその写真を再び見ても、思い出せない。そうして、ただもう不愉快、イライラして、つい眼をそむけたくなる。+　所謂《いわゆる》「死相」というものにだって、もっと何か表情なり印象なりがあるものだろうに、人間のからだに駄馬の首でもくっつけたなら、こんな感じのものになるであろうか、とにかく、どこという事なく、見る者をして、ぞっとさせ、いやな気持にさせるのだ。私はこれまで、こんな不思議な男の顔を見た事が、やはり、いちども無かった。+［＃改頁］++++［＃３字下げ］第一の手記［＃「第一の手記」は大見出し］+++　恥の多い生涯を送って来ました。+　自分には、人間の生活というものが、見当つかないのです。自分は東北の田舎に生れましたので、汽車をはじめて見たのは、よほど大きくなってからでした。自分は停車場のブリッジを、上って、降りて、そうしてそれが線路をまたぎ越えるために造られたものだという事には全然気づかず、ただそれは停車場の構内を外国の遊戯場みたいに、複雑に楽しく、ハイカラにするためにのみ、設備せられてあるものだとばかり思っていました。しかも、かなり永い間そう思っていたのです。ブリッジの上ったり降りたりは、自分にはむしろ、ずいぶん垢抜《あかぬ》けのした遊戯で、それは鉄道のサーヴィスの中でも、最も気のきいたサーヴィスの一つだと思っていたのですが、のちにそれはただ旅客が線路をまたぎ越えるための頗る実利的な階段に過ぎないのを発見して、にわかに興が覚めました。+　また、自分は子供の頃、絵本で地下鉄道というものを見て、これもやはり、実利的な必要から案出せられたものではなく、地上の車に乗るよりは、地下の車に乗ったほうが風がわりで面白い遊びだから、とばかり思っていました。+　自分は子供の頃から病弱で、よく寝込みましたが、寝ながら、敷布、枕のカヴァ、掛蒲団のカヴァを、つくづく、つまらない装飾だと思い、それが案外に実用品だった事を、二十歳ちかくになってわかって、人間のつましさに暗然とし、悲しい思いをしました。+　また、自分は、空腹という事を知りませんでした。いや、それは、自分が衣食住に困らない家に育ったという意味ではなく、そんな馬鹿な意味ではなく、自分には「空腹」という感覚はどんなものだか、さっぱりわからなかったのです。へんな言いかたですが、おなかが空いていても、自分でそれに気がつかないのです。小学校、中学校、自分が学校から帰って来ると、周囲の人たちが、それ、おなかが空いたろう、自分たちにも覚えがある、学校から帰って来た時の空腹は全くひどいからな、甘納豆はどう？　カステラも、パンもあるよ、などと言って騒ぎますので、自分は持ち前のおべっか精神を発揮して、おなかが空いた、と呟いて、甘納豆を十粒ばかり口にほうり込むのですが、空腹感とは、どんなものだか、ちっともわかっていやしなかったのです。+　自分だって、それは勿論《もちろん》、大いにものを食べますが、しかし、空腹感から、ものを食べた記憶は、ほとんどありません。めずらしいと思われたものを食べます。豪華と思われたものを食べます。また、よそへ行って出されたものも、無理をしてまで、たいてい食べます。そうして、子供の頃の自分にとって、最も苦痛な時刻は、実に、自分の家の食事の時間でした。+　自分の田舎の家では、十人くらいの家族全部、めいめいのお膳《ぜん》を二列に向い合せに並べて、末っ子の自分は、もちろん一ばん下の座でしたが、その食事の部屋は薄暗く、昼ごはんの時など、十幾人の家族が、ただ黙々としてめしを食っている有様には、自分はいつも肌寒い思いをしました。それに田舎の昔｜気質《かたぎ》の家でしたので、おかずも、たいていきまっていて、めずらしいもの、豪華なもの、そんなものは望むべくもなかったので、いよいよ自分は食事の時刻を恐怖しました。自分はその薄暗い部屋の末席に、寒さにがたがた震える思いで口にごはんを少量ずつ運び、押し込み、人間は、どうして一日に三度々々ごはんを食べるのだろう、実にみな厳粛な顔をして食べている、これも一種の儀式のようなもので、家族が日に三度々々、時刻をきめて薄暗い一部屋に集り、お膳を順序正しく並べ、食べたくなくても無言でごはんを噛《か》みながら、うつむき、家中にうごめいている霊たちに祈るためのものかも知れない、とさえ考えた事があるくらいでした。+　めしを食べなければ死ぬ、という言葉は、自分の耳には、ただイヤなおどかしとしか聞えませんでした。その迷信は、（いまでも自分には、何だか迷信のように思われてならないのですが）しかし、いつも自分に不安と恐怖を与えました。人間は、めしを食べなければ死ぬから、そのために働いて、めしを食べなければならぬ、という言葉ほど自分にとって難解で晦渋《かいじゅう》で、そうして脅迫めいた響きを感じさせる言葉は、無かったのです。+　つまり自分には、人間の営みというものが未《いま》だに何もわかっていない、という事になりそうです。自分の幸福の観念と、世のすべての人たちの幸福の観念とが、まるで食いちがっているような不安、自分はその不安のために夜々、転輾《てんてん》し、呻吟《しんぎん》し、発狂しかけた事さえあります。自分は、いったい幸福なのでしょうか。自分は小さい時から、実にしばしば、仕合せ者だと人に言われて来ましたが、自分ではいつも地獄の思いで、かえって、自分を仕合せ者だと言ったひとたちのほうが、比較にも何もならぬくらいずっとずっと安楽なように自分には見えるのです。+　自分には、禍《わざわ》いのかたまりが十個あって、その中の一個でも、隣人が脊負《せお》ったら、その一個だけでも充分に隣人の生命取りになるのではあるまいかと、思った事さえありました。+　つまり、わからないのです。隣人の苦しみの性質、程度が、まるで見当つかないのです。プラクテカルな苦しみ、ただ、めしを食えたらそれで解決できる苦しみ、しかし、それこそ最も強い痛苦で、自分の例の十個の禍いなど、吹っ飛んでしまう程の、凄惨《せいさん》な阿鼻地獄なのかも知れない、それは、わからない、しかし、それにしては、よく自殺もせず、発狂もせず、政党を論じ、絶望せず、屈せず生活のたたかいを続けて行ける、苦しくないんじゃないか？　エゴイストになりきって、しかもそれを当然の事と確信し、いちども自分を疑った事が無いんじゃないか？　それなら、楽だ、しかし、人間というものは、皆そんなもので、またそれで満点なのではないかしら、わからない、……夜はぐっすり眠り、朝は爽快《そうかい》なのかしら、どんな夢を見ているのだろう、道を歩きながら何を考えているのだろう、金？　まさか、それだけでも無いだろう、人間は、めしを食うために生きているのだ、という説は聞いた事があるような気がするけれども、金のために生きている、という言葉は、耳にした事が無い、いや、しかし、ことに依ると、……いや、それもわからない、……考えれば考えるほど、自分には、わからなくなり、自分ひとり全く変っているような、不安と恐怖に襲われるばかりなのです。自分は隣人と、ほとんど会話が出来ません。何を、どう言ったらいいのか、わからないのです。+　そこで考え出したのは、道化でした。+　それは、自分の、人間に対する最後の求愛でした。自分は、人間を極度に恐れていながら、それでいて、人間を、どうしても思い切れなかったらしいのです。そうして自分は、この道化の一線でわずかに人間につながる事が出来たのでした。おもてでは、絶えず笑顔をつくりながらも、内心は必死の、それこそ千番に一番の兼ね合いとでもいうべき危機一髪の、油汗流してのサーヴィスでした。+　自分は子供の頃から、自分の家族の者たちに対してさえ、彼等がどんなに苦しく、またどんな事を考えて生きているのか、まるでちっとも見当つかず、ただおそろしく、その気まずさに堪える事が出来ず、既に道化の上手になっていました。つまり、自分は、いつのまにやら、一言も本当の事を言わない子になっていたのです。+　その頃の、家族たちと一緒にうつした写真などを見ると、他の者たちは皆まじめな顔をしているのに、自分ひとり、必ず奇妙に顔をゆがめて笑っているのです。これもまた、自分の幼く悲しい道化の一種でした。+　また自分は、肉親たちに何か言われて、口応《くちごた》えした事はいちども有りませんでした。そのわずかなおこごとは、自分には霹靂《へきれき》の如く強く感ぜられ、狂うみたいになり、口応えどころか、そのおこごとこそ、謂わば万世一系の人間の「真理」とかいうものに違いない、自分にはその真理を行う力が無いのだから、もはや人間と一緒に住めないのではないかしら、と思い込んでしまうのでした。だから自分には、言い争いも自己弁解も出来ないのでした。人から悪く言われると、いかにも、もっとも、自分がひどい思い違いをしているような気がして来て、いつもその攻撃を黙して受け、内心、狂うほどの恐怖を感じました。+　それは誰でも、人から非難せられたり、怒られたりしていい気持がするものでは無いかも知れませんが、自分は怒っている人間の顔に、獅子《しし》よりも鰐《わに》よりも竜よりも、もっとおそろしい動物の本性を見るのです。ふだんは、その本性をかくしているようですけれども、何かの機会に、たとえば、牛が草原でおっとりした形で寝ていて、突如、尻尾《しっぽ》でピシッと腹の虻《あぶ》を打ち殺すみたいに、不意に人間のおそろしい正体を、怒りに依って暴露する様子を見て、自分はいつも髪の逆立つほどの戦慄《せんりつ》を覚え、この本性もまた人間の生きて行く資格の一つなのかも知れないと思えば、ほとんど自分に絶望を感じるのでした。+　人間に対して、いつも恐怖に震いおののき、また、人間としての自分の言動に、みじんも自信を持てず、そうして自分ひとりの懊悩《おうのう》は胸の中の小箱に秘め、その憂鬱、ナアヴァスネスを、ひたかくしに隠して、ひたすら無邪気の楽天性を装い、自分はお道化たお変人として、次第に完成されて行きました。+　何でもいいから、笑わせておればいいのだ、そうすると、人間たちは、自分が彼等の所謂「生活」の外にいても、あまりそれを気にしないのではないかしら、とにかく、彼等人間たちの目障りになってはいけない、自分は無だ、風だ、空《そら》だ、というような思いばかりが募り、自分はお道化に依って家族を笑わせ、また、家族よりも、もっと不可解でおそろしい下男や下女にまで、必死のお道化のサーヴィスをしたのです。+　自分は夏に、浴衣の下に赤い毛糸のセエターを着て廊下を歩き、家中の者を笑わせました。めったに笑わない長兄も、それを見て噴き出し、+「それあ、葉ちゃん、似合わない」+　と、可愛くてたまらないような口調で言いました。なに、自分だって、真夏に毛糸のセエターを着て歩くほど、いくら何でも、そんな、暑さ寒さを知らぬお変人ではありません。姉の脚絆《レギンス》を両腕にはめて、浴衣の袖口から覗かせ、以《もっ》てセエターを着ているように見せかけていたのです。+　自分の父は、東京に用事の多いひとでしたので、上野の桜木町に別荘を持っていて、月の大半は東京のその別荘で暮していました。そうして帰る時には家族の者たち、また親戚《しんせき》の者たちにまで、実におびただしくお土産を買って来るのが、まあ、父の趣味みたいなものでした。+　いつかの父の上京の前夜、父は子供たちを客間に集め、こんど帰る時には、どんなお土産がいいか、一人々々に笑いながら尋ね、それに対する子供たちの答をいちいち手帖《てちょう》に書きとめるのでした。父が、こんなに子供たちと親しくするのは、めずらしい事でした。+「葉蔵は？」+　と聞かれて、自分は、口ごもってしまいました。+　何が欲しいと聞かれると、とたんに、何も欲しくなくなるのでした。どうでもいい、どうせ自分を楽しくさせてくれるものなんか無いんだという思いが、ちらと動くのです。と、同時に、人から与えられるものを、どんなに自分の好みに合わなくても、それを拒む事も出来ませんでした。イヤな事を、イヤと言えず、また、好きな事も、おずおずと盗むように、極めてにがく味《あじわ》い、そうして言い知れぬ恐怖感にもだえるのでした。つまり、自分には、二者選一の力さえ無かったのです。これが、後年に到り、いよいよ自分の所謂「恥の多い生涯」の、重大な原因ともなる性癖の一つだったように思われます。+　自分が黙って、もじもじしているので、父はちょっと不機嫌な顔になり、+「やはり、本か。浅草の仲店にお正月の獅子舞いのお獅子、子供がかぶって遊ぶのには手頃な大きさのが売っていたけど、欲しくないか」+　欲しくないか、と言われると、もうダメなんです。お道化た返事も何も出来やしないんです。お道化役者は、完全に落第でした。+「本が、いいでしょう」+　長兄は、まじめな顔をして言いました。+「そうか」+　父は、興覚め顔に手帖に書きとめもせず、パチと手帖を閉じました。+　何という失敗、自分は父を怒らせた、父の復讐《ふくしゅう》は、きっと、おそるべきものに違いない、いまのうちに何とかして取りかえしのつかぬものか、とその夜、蒲団の中でがたがた震えながら考え、そっと起きて客間に行き、父が先刻、手帖をしまい込んだ筈の机の引き出しをあけて、手帖を取り上げ、パラパラめくって、お土産の注文記入の個所を見つけ、手帖の鉛筆をなめて、シシマイ、と書いて寝ました。自分はその獅子舞いのお獅子を、ちっとも欲しくは無かったのです。かえって、本のほうがいいくらいでした。けれども、自分は、父がそのお獅子を自分に買って与えたいのだという事に気がつき、父のその意向に迎合して、父の機嫌を直したいばかりに、深夜、客間に忍び込むという冒険を、敢えておかしたのでした。+　そうして、この自分の非常の手段は、果して思いどおりの大成功を以て報いられました。やがて、父は東京から帰って来て、母に大声で言っているのを、自分は子供部屋で聞いていました。+「仲店のおもちゃ屋で、この手帖を開いてみたら、これ、ここに、シシマイ、と書いてある。これは、私の字ではない。はてな？　と首をかしげて、思い当りました。これは、葉蔵のいたずらですよ。あいつは、私が聞いた時には、にやにやして黙っていたが、あとで、どうしてもお獅子が欲しくてたまらなくなったんだね。何せ、どうも、あれは、変った坊主ですからね。知らん振りして、ちゃんと書いている。そんなに欲しかったのなら、そう言えばよいのに。私は、おもちゃ屋の店先で笑いましたよ。葉蔵を早くここへ呼びなさい」+　また一方、自分は、下男や下女たちを洋室に集めて、下男のひとりに滅茶苦茶《めちゃくちゃ》にピアノのキイをたたかせ、（田舎ではありましたが、その家には、たいていのものが、そろっていました）自分はその出鱈目《でたらめ》の曲に合せて、インデヤンの踊りを踊って見せて、皆を大笑いさせました。次兄は、フラッシュを焚《た》いて、自分のインデヤン踊りを撮影して、その写真が出来たのを見ると、自分の腰布（それは更紗《さらさ》の風呂敷でした）の合せ目から、小さいおチンポが見えていたので、これがまた家中の大笑いでした。自分にとって、これまた意外の成功というべきものだったかも知れません。+　自分は毎月、新刊の少年雑誌を十冊以上も、とっていて、またその他《ほか》にも、さまざまの本を東京から取り寄せて黙って読んでいましたので、メチャラクチャラ博士だの、また、ナンジャモンジャ博士などとは、たいへんな馴染《なじみ》で、また、怪談、講談、落語、江戸｜小咄《こばなし》などの類にも、かなり通じていましたから、剽軽《ひょうきん》な事をまじめな顔をして言って、家の者たちを笑わせるのには事を欠きませんでした。+　しかし、嗚呼《ああ》、学校！+　自分は、そこでは、尊敬されかけていたのです。尊敬されるという観念もまた、甚《はなは》だ自分を、おびえさせました。ほとんど完全に近く人をだまして、そうして、或るひとりの全知全能の者に見破られ、木っ葉みじんにやられて、死ぬる以上の赤恥をかかせられる、それが、「尊敬される」という状態の自分の定義でありました。人間をだまして、「尊敬され」ても、誰かひとりが知っている、そうして、人間たちも、やがて、そのひとりから教えられて、だまされた事に気づいた時、その時の人間たちの怒り、復讐は、いったい、まあ、どんなでしょうか。想像してさえ、身の毛がよだつ心地がするのです。+　自分は、金持ちの家に生れたという事よりも、俗にいう「できる」事に依って、学校中の尊敬を得そうになりました。自分は、子供の頃から病弱で、よく一つき二つき、また一学年ちかくも寝込んで学校を休んだ事さえあったのですが、それでも、病み上りのからだで人力車に乗って学校へ行き、学年末の試験を受けてみると、クラスの誰よりも所謂「できて」いるようでした。からだ具合いのよい時でも、自分は、さっぱり勉強せず、学校へ行っても授業時間に漫画などを書き、休憩時間にはそれをクラスの者たちに説明して聞かせて、笑わせてやりました。また、綴り方には、滑稽噺《こっけいばなし》ばかり書き、先生から注意されても、しかし、自分は、やめませんでした。先生は、実はこっそり自分のその滑稽噺を楽しみにしている事を自分は、知っていたからでした。或る日、自分は、れいに依って、自分が母に連れられて上京の途中の汽車で、おしっこを客車の通路にある痰壺《たんつぼ》にしてしまった失敗談（しかし、その上京の時に、自分は痰壺と知らずにしたのではありませんでした。子供の無邪気をてらって、わざと、そうしたのでした）を、ことさらに悲しそうな筆致で書いて提出し、先生は、きっと笑うという自信がありましたので、職員室に引き揚げて行く先生のあとを、そっとつけて行きましたら、先生は、教室を出るとすぐ、自分のその綴り方を、他のクラスの者たちの綴り方の中から選び出し、廊下を歩きながら読みはじめて、クスクス笑い、やがて職員室にはいって読み終えたのか、顔を真赤にして大声を挙げて笑い、他の先生に、さっそくそれを読ませているのを見とどけ、自分は、たいへん満足でした。+　お茶目。+　自分は、所謂お茶目に見られる事に成功しました。尊敬される事から、のがれる事に成功しました。通信簿は全学科とも十点でしたが、操行というものだけは、七点だったり、六点だったりして、それもまた家中の大笑いの種でした。+　けれども自分の本性は、そんなお茶目さんなどとは、凡《およ》そ対蹠《たいせき》的なものでした。その頃、既に自分は、女中や下男から、哀《かな》しい事を教えられ、犯されていました。幼少の者に対して、そのような事を行うのは、人間の行い得る犯罪の中で最も醜悪で下等で、残酷な犯罪だと、自分はいまでは思っています。しかし、自分は、忍びました。これでまた一つ、人間の特質を見たというような気持さえして、そうして、力無く笑っていました。もし自分に、本当の事を言う習慣がついていたなら、悪びれず、彼等の犯罪を父や母に訴える事が出来たのかも知れませんが、しかし、自分は、その父や母をも全部は理解する事が出来なかったのです。人間に訴える、自分は、その手段には少しも期待できませんでした。父に訴えても、母に訴えても、お巡《まわ》りに訴えても、政府に訴えても、結局は世渡りに強い人の、世間に通りのいい言いぶんに言いまくられるだけの事では無いかしら。+　必ず片手落のあるのが、わかり切っている、所詮《しょせん》、人間に訴えるのは無駄である、自分はやはり、本当の事は何も言わず、忍んで、そうしてお道化をつづけているより他、無い気持なのでした。+　なんだ、人間への不信を言っているのか？　へえ？　お前はいつクリスチャンになったんだい、と嘲笑《ちょうしょう》する人も或いはあるかも知れませんが、しかし、人間への不信は、必ずしもすぐに宗教の道に通じているとは限らないと、自分には思われるのですけど。現にその嘲笑する人をも含めて、人間は、お互いの不信の中で［＃「お互いの不信の中で」に傍点］、エホバも何も念頭に置かず、平気で生きているではありませんか。やはり、自分の幼少の頃の事でありましたが、父の属していた或る政党の有名人が、この町に演説に来て、自分は下男たちに連れられて劇場に聞きに行きました。満員で、そうして、この町の特に父と親しくしている人たちの顔は皆、見えて、大いに拍手などしていました。演説がすんで、聴衆は雪の夜道を三々五々かたまって家路に就き、クソミソに今夜の演説会の悪口を言っているのでした。中には、父と特に親しい人の声もまじっていました。父の開会の辞も下手、れいの有名人の演説も何が何やら、わけがわからぬ、とその所謂父の「同志たち」が怒声に似た口調で言っているのです。そうしてそのひとたちは、自分の家に立ち寄って客間に上り込み、今夜の演説会は大成功だったと、しんから嬉しそうな顔をして父に言っていました。下男たちまで、今夜の演説会はどうだったと母に聞かれ、とても面白かった、と言ってけろりとしているのです。演説会ほど面白くないものはない、と帰る途々《みちみち》、下男たちが嘆き合っていたのです。+　しかし、こんなのは、ほんのささやかな一例に過ぎません。互いにあざむき合って、しかもいずれも不思議に何の傷もつかず、あざむき合っている事にさえ気がついていないみたいな、実にあざやかな、それこそ清く明るくほがらかな不信の例が、人間の生活に充満しているように思われます。けれども、自分には、あざむき合っているという事には、さして特別の興味もありません。自分だって、お道化に依って、朝から晩まで人間をあざむいているのです。自分は、修身教科書的な正義とか何とかいう道徳には、あまり関心を持てないのです。自分には、あざむき合っていながら、清く明るく朗らかに［＃「清く明るく朗らかに」に傍点］生きている、或いは生き得る自信を持っているみたいな人間が難解なのです。人間は、ついに自分にその妙諦《みょうてい》を教えてはくれませんでした。それさえわかったら、自分は、人間をこんなに恐怖し、また、必死のサーヴィスなどしなくて、すんだのでしょう。人間の生活と対立してしまって、夜々の地獄のこれほどの苦しみを嘗《な》めずにすんだのでしょう。つまり、自分が下男下女たちの憎むべきあの犯罪をさえ、誰にも訴えなかったのは、人間への不信からではなく、また勿論クリスト主義のためでもなく、人間が、葉蔵という自分に対して信用の殻を固く閉じていたからだったと思います。父母でさえ、自分にとって難解なものを、時折、見せる事があったのですから。+　そうして、その、誰にも訴えない、自分の孤独の匂いが、多くの女性に、本能に依って嗅《か》ぎ当てられ、後年さまざま、自分がつけ込まれる誘因の一つになったような気もするのです。+　つまり、自分は、女性にとって、恋の秘密を守れる男であったというわけなのでした。+［＃改頁］++++［＃３字下げ］第二の手記［＃「第二の手記」は大見出し］+++　海の、波打際、といってもいいくらいに海にちかい岸辺に、真黒い樹肌の山桜の、かなり大きいのが二十本以上も立ちならび、新学年がはじまると、山桜は、褐色のねばっこいような嫩葉《わかば》と共に、青い海を背景にして、その絢爛《けんらん》たる花をひらき、やがて、花吹雪の時には、花びらがおびただしく海に散り込み、海面を鏤《ちりば》めて漂い、波に乗せられ再び波打際に打ちかえされる、その桜の砂浜が、そのまま校庭として使用せられている東北の或る中学校に、自分は受験勉強もろくにしなかったのに、どうやら無事に入学できました。そうして、その中学の制帽の徽章《きしょう》にも、制服のボタンにも、桜の花が図案化せられて咲いていました。+　その中学校のすぐ近くに、自分の家と遠い親戚に当る者の家がありましたので、その理由もあって、父がその海と桜の中学校を自分に選んでくれたのでした。自分は、その家にあずけられ、何せ学校のすぐ近くなので、朝礼の鐘の鳴るのを聞いてから、走って登校するというような、かなり怠惰な中学生でしたが、それでも、れいのお道化に依って、日一日とクラスの人気を得ていました。+　生れてはじめて、謂わば他郷へ出たわけなのですが、自分には、その他郷のほうが、自分の生れ故郷よりも、ずっと気楽な場所のように思われました。それは、自分のお道化もその頃にはいよいよぴったり身について来て、人をあざむくのに以前ほどの苦労を必要としなくなっていたからである、と解説してもいいでしょうが、しかし、それよりも、肉親と他人、故郷と他郷、そこには抜くべからざる演技の難易の差が、どのような天才にとっても、たとい神の子のイエスにとっても、存在しているものなのではないでしょうか。俳優にとって、最も演じにくい場所は、故郷の劇場であって、しかも六親｜眷属《けんぞく》全部そろって坐っている一部屋の中に在っては、いかな名優も演技どころでは無くなるのではないでしょうか。けれども自分は演じて来ました。しかも、それが、かなりの成功を収めたのです。それほどの曲者《くせもの》が、他郷に出て、万が一にも演じ損ねるなどという事は無いわけでした。+　自分の人間恐怖は、それは以前にまさるとも劣らぬくらい烈しく胸の底で蠕動《ぜんどう》していましたが、しかし、演技は実にのびのびとして来て、教室にあっては、いつもクラスの者たちを笑わせ、教師も、このクラスは大庭さえいないと、とてもいいクラスなんだが、と言葉では嘆じながら、手で口を覆って笑っていました。自分は、あの雷の如き蛮声を張り上げる配属将校をさえ、実に容易に噴き出させる事が出来たのです。+　もはや、自分の正体を完全に隠蔽《いんぺい》し得たのではあるまいか、とほっとしかけた矢先に、自分は実に意外にも背後から突き刺されました。それは、背後から突き刺す男のごたぶんにもれず、クラスで最も貧弱な肉体をして、顔も青ぶくれで、そうしてたしかに父兄のお古と思われる袖が聖徳太子の袖みたいに長すぎる上衣《うわぎ》を着て、学課は少しも出来ず、教練や体操はいつも見学という白痴に似た生徒でした。自分もさすがに、その生徒にさえ警戒する必要は認めていなかったのでした。+　その日、体操の時間に、その生徒（姓はいま記憶していませんが、名は竹一といったかと覚えています）その竹一は、れいに依って見学、自分たちは鉄棒の練習をさせられていました。自分は、わざと出来るだけ厳粛な顔をして、鉄棒めがけて、えいっと叫んで飛び、そのまま幅飛びのように前方へ飛んでしまって、砂地にドスンと尻餅をつきました。すべて、計画的な失敗でした。果して皆の大笑いになり、自分も苦笑しながら起き上ってズボンの砂を払っていると、いつそこへ来ていたのか、竹一が自分の背中をつつき、低い声でこう囁《ささや》きました。+「ワザ。ワザ」+　自分は震撼《しんかん》しました。ワザと失敗したという事を、人もあろうに、竹一に見破られるとは全く思いも掛けない事でした。自分は、世界が一瞬にして地獄の業火に包まれて燃え上るのを眼前に見るような心地がして、わあっ！　と叫んで発狂しそうな気配を必死の力で抑えました。+　それからの日々の、自分の不安と恐怖。+　表面は相変らず哀しいお道化を演じて皆を笑わせていましたが、ふっと思わず重苦しい溜息《ためいき》が出て、何をしたってすべて竹一に木っ葉みじんに見破られていて、そうしてあれは、そのうちにきっと誰かれとなく、それを言いふらして歩くに違いないのだ、と考えると、額にじっとり油汗がわいて来て、狂人みたいに妙な眼つきで、あたりをキョロキョロむなしく見廻したりしました。できる事なら、朝、昼、晩、四六時中、竹一の傍《そば》から離れず彼が秘密を口走らないように監視していたい気持でした。そうして、自分が、彼にまつわりついている間に、自分のお道化は、所謂「ワザ」では無くて、ほんものであったというよう思い込ませるようにあらゆる努力を払い、あわよくば、彼と無二の親友になってしまいたいものだ、もし、その事が皆、不可能なら、もはや、彼の死を祈るより他は無い、とさえ思いつめました。しかし、さすがに、彼を殺そうという気だけは起りませんでした。自分は、これまでの生涯に於《お》いて、人に殺されたいと願望した事は幾度となくありましたが、人を殺したいと思った事は、いちどもありませんでした。それは、おそるべき相手に、かえって幸福を与えるだけの事だと考えていたからです。+　自分は、彼を手なずけるため、まず、顔に偽クリスチャンのような「優しい」媚笑《びしょう》を湛《たた》え、首を三十度くらい左に曲げて、彼の小さい肩を軽く抱き、そうして猫撫《ねこな》で声に似た甘ったるい声で、彼を自分の寄宿している家に遊びに来るようしばしば誘いましたが、彼は、いつも、ぼんやりした眼つきをして、黙っていました。しかし、自分は、或る日の放課後、たしか初夏の頃の事でした、夕立ちが白く降って、生徒たちは帰宅に困っていたようでしたが、自分は家がすぐ近くなので平気で外へ飛び出そうとして、ふと下駄箱のかげに、竹一がしょんぼり立っているのを見つけ、行こう、傘を貸してあげる、と言い、臆する竹一の手を引っぱって、一緒に夕立ちの中を走り、家に着いて、二人の上衣を小母さんに乾かしてもらうようにたのみ、竹一を二階の自分の部屋に誘い込むのに成功しました。+　その家には、五十すぎの小母さんと、三十くらいの、眼鏡をかけて、病身らしい背の高い姉娘（この娘は、いちどよそへお嫁に行って、それからまた、家へ帰っているひとでした。自分は、このひとを、ここの家のひとたちにならって、アネサと呼んでいました）それと、最近女学校を卒業したばかりらしい、セッちゃんという姉に似ず背が低く丸顔の妹娘と、三人だけの家族で、下の店には、文房具やら運動用具を少々並べていましたが、主な収入は、なくなった主人が建てて残して行った五六棟の長屋の家賃のようでした。+「耳が痛い」+　竹一は、立ったままでそう言いました。+「雨に濡れたら、痛くなったよ」+　自分が、見てみると、両方の耳が、ひどい耳だれでした。膿《うみ》が、いまにも耳殻の外に流れ出ようとしていました。+「これは、いけない。痛いだろう」+　と自分は大袈裟《おおげさ》におどろいて見せて、+「雨の中を、引っぱり出したりして、ごめんね」+　と女の言葉みたいな言葉を遣って「優しく」謝り、それから、下へ行って綿とアルコールをもらって来て、竹一を自分の膝《ひざ》を枕にして寝かせ、念入りに耳の掃除をしてやりました。竹一も、さすがに、これが偽善の悪計であることには気附かなかったようで、+「お前は、きっと、女に惚《ほ》れられるよ」+　と自分の膝枕で寝ながら、無智なお世辞を言ったくらいでした。+　しかしこれは、おそらく、あの竹一も意識しなかったほどの、おそろしい悪魔の予言のようなものだったという事を、自分は後年に到って思い知りました。惚れると言い、惚れられると言い、その言葉はひどく下品で、ふざけて、いかにも、やにさがったものの感じで、どんなに所謂「厳粛」の場であっても、そこへこの言葉が一言でもひょいと顔を出すと、みるみる憂鬱の伽藍《がらん》が崩壊し、ただのっぺらぼうになってしまうような心地がするものですけれども、惚れられるつらさ、などという俗語でなく、愛せられる不安、とでもいう文学語を用いると、あながち憂鬱の伽藍をぶちこわす事にはならないようですから、奇妙なものだと思います。+　竹一が、自分に耳だれの膿の仕末をしてもらって、お前は惚れられるという馬鹿なお世辞を言い、自分はその時、ただ顔を赤らめて笑って、何も答えませんでしたけれども、しかし、実は、幽《かす》かに思い当るところもあったのでした。でも、「惚れられる」というような野卑な言葉に依って生じるやにさがった雰囲気《ふんいき》に対して、そう言われると、思い当るところもある、などと書くのは、ほとんど落語の若旦那のせりふにさえならぬくらい、おろかしい感懐を示すようなもので、まさか、自分は、そんなふざけた、やにさがった気持で、「思い当るところもあった」わけでは無いのです。+　自分には、人間の女性のほうが、男性よりもさらに数倍難解でした。自分の家族は、女性のほうが男性よりも数が多く、また親戚にも、女の子がたくさんあり、またれいの「犯罪」の女中などもいまして、自分は幼い時から、女とばかり遊んで育ったといっても過言ではないと思っていますが、それは、また、しかし、実に、薄氷を踏む思いで、その女のひとたちと附合って来たのです。ほとんど、まるで見当が、つかないのです。五里霧中で、そうして時たま、虎の尾を踏む失敗をして、ひどい痛手を負い、それがまた、男性から受ける笞《むち》とちがって、内出血みたいに極度に不快に内攻して、なかなか治癒《ちゆ》し難い傷でした。+　女は引き寄せて、つっ放す、或いはまた、女は、人のいるところでは自分をさげすみ、邪慳《じゃけん》にし、誰もいなくなると、ひしと抱きしめる、女は死んだように深く眠る、女は眠るために生きているのではないかしら、その他、女に就いてのさまざまの観察を、すでに自分は、幼年時代から得ていたのですが、同じ人類のようでありながら、男とはまた、全く異った生きもののような感じで、そうしてまた、この不可解で油断のならぬ生きものは、奇妙に自分をかまうのでした。「惚れられる」なんていう言葉も、また「好かれる」という言葉も、自分の場合にはちっとも、ふさわしくなく、「かまわれる」とでも言ったほうが、まだしも実状の説明に適しているかも知れません。+　女は、男よりも更に、道化には、くつろぐようでした。自分がお道化を演じ、男はさすがにいつまでもゲラゲラ笑ってもいませんし、それに自分も男のひとに対し、調子に乗ってあまりお道化を演じすぎると失敗するという事を知っていましたので、必ず適当のところで切り上げるように心掛けていましたが、女は適度という事を知らず、いつまでもいつまでも、自分にお道化を要求し、自分はその限りないアンコールに応じて、へとへとになるのでした。実に、よく笑うのです。いったいに、女は、男よりも快楽をよけいに頬張る事が出来るようです。+　自分が中学時代に世話になったその家の姉娘も、妹娘も、ひまさえあれば、二階の自分の部屋にやって来て、自分はその度毎に飛び上らんばかりにぎょっとして、そうして、ひたすらおびえ、+「御勉強？」+「いいえ」+　と微笑して本を閉じ、+「きょうね、学校でね、コンボウという地理の先生がね」+　とするする口から流れ出るものは、心にも無い滑稽噺でした。+「葉ちゃん、眼鏡をかけてごらん」+　或る晩、妹娘のセッちゃんが、アネサと一緒に自分の部屋へ遊びに来て、さんざん自分にお道化を演じさせた揚句の果に、そんな事を言い出しました。+「なぜ？」+「いいから、かけてごらん。アネサの眼鏡を借りなさい」+　いつでも、こんな乱暴な命令口調で言うのでした。道化師は、素直にアネサの眼鏡をかけました。とたんに、二人の娘は、笑いころげました。+「そっくり。ロイドに、そっくり」+　当時、ハロルド・ロイドとかいう外国の映画の喜劇役者が、日本で人気がありました。+　自分は立って片手を挙げ、+「諸君」+　と言い、+「このたび、日本のファンの皆様がたに、……」+　と一場の挨拶を試み、さらに大笑いさせて、それから、ロイドの映画がそのまちの劇場に来るたび毎に見に行って、ひそかに彼の表情などを研究しました。+　また、或る秋の夜、自分が寝ながら本を読んでいると、アネサが鳥のように素早く部屋へはいって来て、いきなり自分の掛蒲団の上に倒れて泣き、+「葉ちゃんが、あたしを助けてくれるのだわね。そうだわね。こんな家、一緒に出てしまったほうがいいのだわ。助けてね。助けて」+　などと、はげしい事を口走っては、また泣くのでした。けれども、自分には、女から、こんな態度を見せつけられるのは、これが最初ではありませんでしたので、アネサの過激な言葉にも、さして驚かず、かえってその陳腐、無内容に興が覚めた心地で、そっと蒲団から脱け出し、机の上の柿をむいて、その一きれをアネサに手渡してやりました。すると、アネサは、しゃくり上げながらその柿を食べ、+「何か面白い本が無い？　貸してよ」+　と言いました。+　自分は漱石の「吾輩は猫である」という本を、本棚から選んであげました。+「ごちそうさま」+　アネサは、恥ずかしそうに笑って部屋から出て行きましたが、このアネサに限らず、いったい女は、どんな気持で生きているのかを考える事は、自分にとって、蚯蚓《みみず》の思いをさぐるよりも、ややこしく、わずらわしく、薄気味の悪いものに感ぜられていました。ただ、自分は、女があんなに急に泣き出したりした場合、何か甘いものを手渡してやると、それを食べて機嫌を直すという事だけは、幼い時から、自分の経験に依って知っていました。+　また、妹娘のセッちゃんは、その友だちまで自分の部屋に連れて来て、自分がれいに依って公平に皆を笑わせ、友だちが帰ると、セッちゃんは、必ずその友だちの悪口を言うのでした。あのひとは不良少女だから、気をつけるように、ときまって言うのでした。そんなら、わざわざ連れて来なければ、よいのに、おかげで自分の部屋の来客の、ほとんど全部が女、という事になってしまいました。+　しかし、それは、竹一のお世辞の「惚れられる」事の実現では未だ決して無かったのでした。つまり、自分は、日本の東北のハロルド・ロイドに過ぎなかったのです。竹一の無智なお世辞が、いまわしい予言として、なまなまと生きて来て、不吉な形貌を呈するようになったのは、更にそれから、数年経った後の事でありました。+　竹一は、また、自分にもう一つ、重大な贈り物をしていました。+「お化けの絵だよ」+　いつか竹一が、自分の二階へ遊びに来た時、ご持参の、一枚の原色版の口絵を得意そうに自分に見せて、そう説明しました。+　おや？　と思いました。その瞬間、自分の落ち行く道が決定せられたように、後年に到って、そんな気がしてなりません。自分は、知っていました。それは、ゴッホの例の自画像に過ぎないのを知っていました。自分たちの少年の頃には、日本ではフランスの所謂印象派の画が大流行していて、洋画鑑賞の第一歩を、たいていこのあたりからはじめたもので、ゴッホ、ゴーギャン、セザンヌ、ルナアルなどというひとの絵は、田舎の中学生でも、たいていその写真版を見て知っていたのでした。自分なども、ゴッホの原色版をかなりたくさん見て、タッチの面白さ、色彩の鮮やかさに興趣を覚えてはいたのですが、しかし、お化けの絵、だとは、いちども考えた事が無かったのでした。+「では、こんなのは、どうかしら。やっぱり、お化けかしら」+　自分は本棚から、モジリアニの画集を出し、焼けた赤銅のような肌の、れいの裸婦の像を竹一に見せました。+「すげえなあ」+　竹一は眼を丸くして感嘆しました。+「地獄の馬みたい」+「やっぱり、お化けかね」+「おれも、こんなお化けの絵がかきたいよ」+　あまりに人間を恐怖している人たちは、かえって、もっともっと、おそろしい妖怪《ようかい》を確実にこの眼で見たいと願望するに到る心理、神経質な、ものにおびえ易い人ほど、暴風雨の更に強からん事を祈る心理、ああ、この一群の画家たちは、人間という化け物に傷《いた》めつけられ、おびやかされた揚句の果、ついに幻影を信じ、白昼の自然の中に、ありありと妖怪を見たのだ、しかも彼等は、それを道化などでごまかさず、見えたままの表現に努力したのだ、竹一の言うように、敢然と「お化けの絵」をかいてしまったのだ、ここに将来の自分の、仲間がいる、と自分は、涙が出たほどに興奮し、+「僕も画くよ。お化けの絵を画くよ。地獄の馬を、画くよ」+　と、なぜだか、ひどく声をひそめて、竹一に言ったのでした。+　自分は、小学校の頃から、絵はかくのも、見るのも好きでした。けれども、自分のかいた絵は、自分の綴り方ほどには、周囲の評判が、よくありませんでした。自分は、どだい人間の言葉を一向に信用していませんでしたので、綴り方などは、自分にとって、ただお道化の御挨拶みたいなもので、小学校、中学校、と続いて先生たちを狂喜させて来ましたが、しかし、自分では、さっぱり面白くなく、絵だけは、（漫画などは別ですけれども）その対象の表現に、幼い我流ながら、多少の苦心を払っていました。学校の図画のお手本はつまらないし、先生の絵は下手くそだし、自分は、全く出鱈目にさまざまの表現法を自分で工夫して試みなければならないのでした。中学校へはいって、自分は油絵の道具も一｜揃《そろ》い持っていましたが、しかし、そのタッチの手本を、印象派の画風に求めても、自分の画いたものは、まるで千代紙細工のようにのっぺりして、ものになりそうもありませんでした。けれども自分は、竹一の言葉に依って、自分のそれまでの絵画に対する心構えが、まるで間違っていた事に気が附きました。美しいと感じたものを、そのまま美しく表現しようと努力する甘さ、おろかしさ。マイスターたちは、何でも無いものを、主観に依って美しく創造し、或いは醜いものに嘔吐《おうと》をもよおしながらも、それに対する興味を隠さず、表現のよろこびにひたっている、つまり、人の思惑に少しもたよっていないらしいという、画法のプリミチヴな虎の巻を、竹一から、さずけられて、れいの女の来客たちには隠して、少しずつ、自画像の制作に取りかかってみました。+　自分でも、ぎょっとしたほど、陰惨な絵が出来上りました。しかし、これこそ胸底にひた隠しに隠している自分の正体なのだ、おもては陽気に笑い、また人を笑わせているけれども、実は、こんな陰鬱な心を自分は持っているのだ、仕方が無い、とひそかに肯定し、けれどもその絵は、竹一以外の人には、さすがに誰にも見せませんでした。自分のお道化の底の陰惨を見破られ、急にケチくさく警戒せられるのもいやでしたし、また、これを自分の正体とも気づかず、やっぱり新趣向のお道化と見なされ、大笑いの種にせられるかも知れぬという懸念もあり、それは何よりもつらい事でしたので、その絵はすぐに押入れの奥深くしまい込みました。+　また、学校の図画の時間にも、自分はあの「お化け式手法」は秘めて、いままでどおりの美しいものを美しく画く式の凡庸なタッチで画いていました。+　自分は竹一にだけは、前から自分の傷み易い神経を平気で見せていましたし、こんどの自画像も安心して竹一に見せ、たいへんほめられ、さらに二枚三枚と、お化けの絵を画きつづけ、竹一からもう一つの、+「お前は、偉い絵画きになる」+　という予言を得たのでした。+　惚れられるという予言と、偉い絵画きになるという予言と、この二つの予言を馬鹿の竹一に依って額に刻印せられて、やがて、自分は東京へ出て来ました。+　自分は、美術学校にはいりたかったのですが、父は、前から自分を高等学校にいれて、末は官吏にするつもりで、自分にもそれを言い渡してあったので、口応え一つ出来ないたちの自分は、ぼんやりそれに従ったのでした。四年から受けて見よ、と言われたので、自分も桜と海の中学はもういい加減あきていましたし、五年に進級せず、四年修了のままで、東京の高等学校に受験して合格し、すぐに寮生活にはいりましたが、その不潔と粗暴に辟易《へきえき》して、道化どころではなく、医師に肺浸潤の診断書を書いてもらい、寮から出て、上野桜木町の父の別荘に移りました。自分には、団体生活というものが、どうしても出来ません。それにまた、青春の感激だとか、若人の誇りだとかいう言葉は、聞いて寒気がして来て、とても、あの、ハイスクール・スピリットとかいうものには、ついて行けなかったのです。教室も寮も、ゆがめられた性慾の、はきだめみたいな気さえして、自分の完璧《かんぺき》に近いお道化も、そこでは何の役にも立ちませんでした。+　父は議会の無い時は、月に一週間か二週間しかその家に滞在していませんでしたので、父の留守の時は、かなり広いその家に、別荘番の老夫婦と自分と三人だけで、自分は、ちょいちょい学校を休んで、さりとて東京見物などをする気も起らず（自分はとうとう、明治神宮も、楠正成《くすのきまさしげ》の銅像も、泉岳寺の四十七士の墓も見ずに終りそうです）家で一日中、本を読んだり、絵をかいたりしていました。父が上京して来ると、自分は、毎朝そそくさと登校するのでしたが、しかし、本郷千駄木町の洋画家、安田新太郎氏の画塾に行き、三時間も四時間も、デッサンの練習をしている事もあったのです。高等学校の寮から脱けたら、学校の授業に出ても、自分はまるで聴講生みたいな特別の位置にいるような、それは自分のひがみかも知れなかったのですが、何とも自分自身で白々しい気持がして来て、いっそう学校へ行くのが、おっくうになったのでした。自分には、小学校、中学校、高等学校を通じて、ついに愛校心というものが理解できずに終りました。校歌などというものも、いちども覚えようとした事がありません。+　自分は、やがて画塾で、或る画学生から、酒と煙草と淫売婦《いんばいふ》と質屋と左翼思想とを知らされました。妙な取合せでしたが、しかし、それは事実でした。+　その画学生は、堀木正雄といって、東京の下町に生れ、自分より六つ年長者で、私立の美術学校を卒業して、家にアトリエが無いので、この画塾に通い、洋画の勉強をつづけているのだそうです。+「五円、貸してくれないか」+　お互いただ顔を見知っているだけで、それまで一言も話合った事が無かったのです。自分は、へどもどして五円差し出しました。+「よし、飲もう。おれが、お前におごるんだ。よかチゴじゃのう」+　自分は拒否し切れず、その画塾の近くの、蓬莱《ほうらい》町のカフエに引っぱって行かれたのが、彼との交友のはじまりでした。+「前から、お前に眼をつけていたんだ。それそれ、そのはにかむような微笑、それが見込みのある芸術家特有の表情なんだ。お近づきのしるしに、乾杯！　キヌさん、こいつは美男子だろう？　惚れちゃいけないぜ。こいつが塾へ来たおかげで、残念ながらおれは、第二番の美男子という事になった」+　堀木は、色が浅黒く端正な顔をしていて、画学生には珍らしく、ちゃんとした脊広《せびろ》を着て、ネクタイの好みも地味で、そうして頭髪もポマードをつけてまん中からぺったりとわけていました。+　自分は馴れぬ場所でもあり、ただもうおそろしく、腕を組んだりほどいたりして、それこそ、はにかむような微笑ばかりしていましたが、ビイルを二、三杯飲んでいるうちに、妙に解放せられたような軽さを感じて来たのです。+「僕は、美術学校にはいろうと思っていたんですけど、……」+「いや、つまらん。あんなところは、つまらん。学校は、つまらん。われらの教師は、自然の中にあり！　自然に対するパアトス！」+　しかし、自分は、彼の言う事に一向に敬意を感じませんでした。馬鹿なひとだ、絵も下手にちがいない、しかし、遊ぶのには、いい相手かも知れないと考えました。つまり、自分はその時、生れてはじめて、ほんものの都会の与太者を見たのでした。それは、自分と形は違っていても、やはり、この世の人間の営みから完全に遊離してしまって、戸迷いしている点に於いてだけは、たしかに同類なのでした。そうして、彼はそのお道化を意識せずに行い、しかも、そのお道化の悲惨に全く気がついていないのが、自分と本質的に異色のところでした。+　ただ遊ぶだけだ、遊びの相手として附合っているだけだ、とつねに彼を軽蔑《けいべつ》し、時には彼との交友を恥ずかしくさえ思いながら、彼と連れ立って歩いているうちに、結局、自分は、この男にさえ打ち破られました。+　しかし、はじめは、この男を好人物、まれに見る好人物とばかり思い込み、さすが人間恐怖の自分も全く油断をして、東京のよい案内者が出来た、くらいに思っていました。自分は、実は、ひとりでは、電車に乗ると車掌がおそろしく、歌舞伎座へはいりたくても、あの正面玄関の緋《ひ》の絨緞《じゅうたん》が敷かれてある階段の両側に並んで立っている案内嬢たちがおそろしく、レストランへはいると、自分の背後にひっそり立って、皿のあくのを待っている給仕のボーイがおそろしく、殊にも勘定を払う時、ああ、ぎごちない自分の手つき、自分は買い物をしてお金を手渡す時には、吝嗇《りんしょく》ゆえでなく、あまりの緊張、あまりの恥ずかしさ、あまりの不安、恐怖に、くらくら目まいして、世界が真暗になり、ほとんど半狂乱の気持になってしまって、値切るどころか、お釣を受け取るのを忘れるばかりでなく、買った品物を持ち帰るのを忘れた事さえ、しばしばあったほどなので、とても、ひとりで東京のまちを歩けず、それで仕方なく、一日一ぱい家の中で、ごろごろしていたという内情もあったのでした。+　それが、堀木に財布を渡して一緒に歩くと、堀木は大いに値切って、しかも遊び上手というのか、わずかなお金で最大の効果のあるような支払い振りを発揮し、また、高い円タクは敬遠して、電車、バス、ポンポン蒸気など、それぞれ利用し分けて、最短時間で目的地へ着くという手腕をも示し、淫売婦のところから朝帰る途中には、何々という料亭に立ち寄って朝風呂へはいり、湯豆腐で軽くお酒を飲むのが、安い割に、ぜいたくな気分になれるものだと実地教育をしてくれたり、その他、屋台の牛めし焼とりの安価にして滋養に富むものたる事を説き、酔いの早く発するのは、電気ブランの右に出るものはないと保証し、とにかくその勘定に就いては自分に、一つも不安、恐怖を覚えさせた事がありませんでした。+　さらにまた、堀木と附合って救われるのは、堀木が聞き手の思惑などをてんで無視して、その所謂｜情熱《パトス》の噴出するがままに、（或いは、情熱とは、相手の立場を無視する事かも知れませんが）四六時中、くだらないおしゃべりを続け、あの、二人で歩いて疲れ、気まずい沈黙におちいる危懼《きく》が、全く無いという事でした。人に接し、あのおそろしい沈黙がその場にあらわれる事を警戒して、もともと口の重い自分が、ここを先途《せんど》と必死のお道化を言って来たものですが、いまこの堀木の馬鹿が、意識せずに、そのお道化役をみずからすすんでやってくれているので、自分は、返事もろくにせずに、ただ聞き流し、時折、まさか、などと言って笑っておれば、いいのでした。+　酒、煙草、淫売婦、それは皆、人間恐怖を、たとい一時でも、まぎらす事の出来るずいぶんよい手段である事が、やがて自分にもわかって来ました。それらの手段を求めるためには、自分の持ち物全部を売却しても悔いない気持さえ、抱くようになりました。+　自分には、淫売婦というものが、人間でも、女性でもない、白痴か狂人のように見え、そのふところの中で、自分はかえって全く安心して、ぐっすり眠る事が出来ました。みんな、哀しいくらい、実にみじんも慾というものが無いのでした。そうして、自分に、同類の親和感とでもいったようなものを覚えるのか、自分は、いつも、その淫売婦たちから、窮屈でない程度の自然の好意を示されました。何の打算も無い好意、押し売りでは無い好意、二度と来ないかも知れぬひとへの好意、自分には、その白痴か狂人の淫売婦たちに、マリヤの円光を現実に見た夜もあったのです。+　しかし、自分は、人間への恐怖からのがれ、幽かな一夜の休養を求めるために、そこへ行き、それこそ自分と「同類」の淫売婦たちと遊んでいるうちに、いつのまにやら無意識の、或るいまわしい雰囲気を身辺にいつもただよわせるようになった様子で、これは自分にも全く思い設けなかった所謂「おまけの附録」でしたが、次第にその「附録」が、鮮明に表面に浮き上って来て、堀木にそれを指摘せられ、愕然《がくぜん》として、そうして、いやな気が致しました。はたから見て、俗な言い方をすれば、自分は、淫売婦に依って女の修行をして、しかも、最近めっきり腕をあげ、女の修行は、淫売婦に依るのが一ばん厳しく、またそれだけに効果のあがるものだそうで、既に自分には、あの、「女達者」という匂いがつきまとい、女性は、（淫売婦に限らず）本能に依ってそれを嗅ぎ当て寄り添って来る、そのような、卑猥《ひわい》で不名誉な雰囲気を、「おまけの附録」としてもらって、そうしてそのほうが、自分の休養などよりも、ひどく目立ってしまっているらしいのでした。+　堀木はそれを半分はお世辞で言ったのでしょうが、しかし、自分にも、重苦しく思い当る事があり、たとえば、喫茶店の女から稚拙な手紙をもらった覚えもあるし、桜木町の家の隣りの将軍のはたちくらいの娘が、毎朝、自分の登校の時刻には、用も無さそうなのに、ご自分の家の門を薄化粧して出たりはいったりしていたし、牛肉を食いに行くと、自分が黙っていても、そこの女中が、……また、いつも買いつけの煙草屋の娘から手渡された煙草の箱の中に、……また、歌舞伎を見に行って隣りの席のひとに、……また、深夜の市電で自分が酔って眠っていて、……また、思いがけなく故郷の親戚の娘から、思いつめたような手紙が来て、……また、誰かわからぬ娘が、自分の留守中にお手製らしい人形を、……自分が極度に消極的なので、いずれも、それっきりの話で、ただ断片、それ以上の進展は一つもありませんでしたが、何か女に夢を見させる雰囲気が、自分のどこかにつきまとっている事は、それは、のろけだの何だのといういい加減な冗談でなく、否定できないのでありました。自分は、それを堀木ごとき者に指摘せられ、屈辱に似た苦《にが》さを感ずると共に、淫売婦と遊ぶ事にも、にわかに興が覚めました。+　堀木は、また、その見栄坊《みえぼう》のモダニティから、（堀木の場合、それ以外の理由は、自分には今もって考えられませんのですが）或る日、自分を共産主義の読書会とかいう（Ｒ・Ｓとかいっていたか、記憶がはっきり致しません）そんな、秘密の研究会に連れて行きました。堀木などという人物にとっては、共産主義の秘密会合も、れいの「東京案内」の一つくらいのものだったのかも知れません。自分は所謂「同志」に紹介せられ、パンフレットを一部買わされ、そうして上座のひどい醜い顔の青年から、マルクス経済学の講義を受けました。しかし、自分には、それはわかり切っている事のように思われました。それは、そうに違いないだろうけれども、人間の心には、もっとわけのわからない、おそろしいものがある。慾、と言っても、言いたりない、ヴァニティ、と言っても、言いたりない、色と慾、とこう二つ並べても、言いたりない、何だか自分にもわからぬが、人間の世の底に、経済だけでない、へんに怪談じみたものがあるような気がして、その怪談におびえ切っている自分には、所謂唯物論を、水の低きに流れるように自然に肯定しながらも、しかし、それに依って、人間に対する恐怖から解放せられ、青葉に向って眼をひらき、希望のよろこびを感ずるなどという事は出来ないのでした。けれども、自分は、いちども欠席せずに、そのＲ・Ｓ（と言ったかと思いますが、間違っているかも知れません）なるものに出席し、「同志」たちが、いやに一大事の如く、こわばった顔をして、一プラス一は二、というような、ほとんど初等の算術めいた理論の研究にふけっているのが滑稽に見えてたまらず、れいの自分のお道化で、会合をくつろがせる事に努め、そのためか、次第に研究会の窮屈な気配もほぐれ、自分はその会合に無くてかなわぬ人気者という形にさえなって来たようでした。この、単純そうな人たちは、自分の事を、やはりこの人たちと同じ様に単純で、そうして、楽天的なおどけ者の「同志」くらいに考えていたかも知れませんが、もし、そうだったら、自分は、この人たちを一から十まで、あざむいていたわけです。自分は、同志では無かったんです。けれども、その会合に、いつも欠かさず出席して、皆にお道化のサーヴィスをして来ました。+　好きだったからなのです。自分には、その人たちが、気にいっていたからなのです。しかし、それは必ずしも、マルクスに依って結ばれた親愛感では無かったのです。+　非合法。自分には、それが幽かに楽しかったのです。むしろ、居心地がよかったのです。世の中の合法というもののほうが、かえっておそろしく、（それには、底知れず強いものが予感せられます）そのからくりが不可解で、とてもその窓の無い、底冷えのする部屋には坐っておられず、外は非合法の海であっても、それに飛び込んで泳いで、やがて死に到るほうが、自分には、いっそ気楽のようでした。+　日蔭者《ひかげもの》、という言葉があります。人間の世に於いて、みじめな、敗者、悪徳者を指差していう言葉のようですが、自分は、自分を生れた時からの日蔭者［＃「生れた時からの日蔭者」に傍点］のような気がしていて、世間から、あれは日蔭者だと指差されている程のひとと逢うと、自分は、必ず、優しい心になるのです。そうして、その自分の「優しい心」は、自身でうっとりするくらい優しい心でした。+　また、犯人意識、という言葉もあります。自分は、この人間の世の中に於いて、一生その意識に苦しめられながらも、しかし、それは自分の糟糠《そうこう》の妻の如き好｜伴侶《はんりょ》で、そいつと二人きりで侘《わ》びしく遊びたわむれているというのも、自分の生きている姿勢の一つだったかも知れないし、また、俗に、脛《すね》に傷持つ身、という言葉もあるようですが、その傷は、自分の赤ん坊の時から、自然に片方の脛にあらわれて、長ずるに及んで治癒するどころか、いよいよ深くなるばかりで、骨にまで達し、夜々の痛苦は千変万化の地獄とは言いながら、しかし、（これは、たいへん奇妙な言い方ですけど）その傷は、次第に自分の血肉よりも［＃「血肉よりも」に傍点］親しくなり、その傷の痛みは、すなわち傷の生きている感情、または愛情の囁《ささや》きのようにさえ思われる、そんな男にとって、れいの地下運動のグルウプの雰囲気が、へんに安心で、居心地がよく、つまり、その運動の本来の目的よりも、その運動の肌が、自分に合った感じなのでした。堀木の場合は、ただもう阿呆のひやかしで、いちど自分を紹介しにその会合へ行ったきりで、マルキシストは、生産面の研究と同時に、消費面の視察も必要だなどと下手な洒落《しゃれ》を言って、その会合には寄りつかず、とかく自分を、その消費面の視察のほうにばかり誘いたがるのでした。思えば、当時は、さまざまの型のマルキシストがいたものです。堀木のように、虚栄のモダニティから、それを自称する者もあり、また自分のように、ただ非合法の匂いが気にいって、そこに坐り込んでいる者もあり、もしもこれらの実体が、マルキシズムの真の信奉者に見破られたら、堀木も自分も、烈火の如く怒られ、卑劣なる裏切者として、たちどころに追い払われた事でしょう。しかし、自分も、また、堀木でさえも、なかなか除名の処分に遭わず、殊にも自分は、その非合法の世界に於いては、合法の紳士たちの世界に於けるよりも、かえってのびのびと、所謂「健康」に振舞う事が出来ましたので、見込みのある「同志」として、噴き出したくなるほど過度に秘密めかした、さまざまの用事をたのまれるほどになったのです。また、事実、自分は、そんな用事をいちども断ったことは無く、平気でなんでも引受け、へんにぎくしゃくして、犬（同志は、ポリスをそう呼んでいました）にあやしまれ不審｜訊問《じんもん》などを受けてしくじるような事も無かったし、笑いながら、また、ひとを笑わせながら、そのあぶない（その運動の連中は、一大事の如く緊張し、探偵小説の下手な真似みたいな事までして、極度の警戒を用い、そうして自分にたのむ仕事は、まことに、あっけにとられるくらい、つまらないものでしたが、それでも、彼等は、その用事を、さかんに、あぶながって力んでいるのでした）と、彼等の称する仕事を、とにかく正確にやってのけていました。自分のその当時の気持としては、党員になって捕えられ、たとい終身、刑務所で暮すようになったとしても、平気だったのです。世の中の人間の「実生活」というものを恐怖しながら、毎夜の不眠の地獄で呻《うめ》いているよりは、いっそ牢屋《ろうや》のほうが、楽かも知れないとさえ考えていました。+　父は、桜木町の別荘では、来客やら外出やら、同じ家にいても、三日も四日も自分と顔を合せる事が無いほどでしたが、しかし、どうにも、父がけむったく、おそろしく、この家を出て、どこか下宿でも、と考えながらもそれを言い出せずにいた矢先に、父がその家を売払うつもりらしいという事を別荘番の老爺《ろうや》から聞きました。+　父の議員の任期もそろそろ満期に近づき、いろいろ理由のあった事に違いありませんが、もうこれきり選挙に出る意志も無い様子で、それに、故郷に一棟、隠居所など建てたりして、東京に未練も無いらしく、たかが、高等学校の一生徒に過ぎない自分のために、邸宅と召使いを提供して置くのも、むだな事だとでも考えたのか、（父の心もまた、世間の人たちの気持ちと同様に、自分にはよくわかりません）とにかく、その家は、間も無く人手にわたり、自分は、本郷森川町の仙遊館という古い下宿の、薄暗い部屋に引越して、そうして、たちまち金に困りました。+　それまで、父から月々、きまった額の小遣いを手渡され、それはもう、二、三日で無くなっても、しかし、煙草も、酒も、チイズも、くだものも、いつでも家にあったし、本や文房具やその他、服装に関するものなど一切、いつでも、近所の店から所謂「ツケ」で求められたし、堀木におそばか天丼などをごちそうしても、父のひいきの町内の店だったら、自分は黙ってその店を出てもかまわなかったのでした。+　それが急に、下宿のひとり住いになり、何もかも、月々の定額の送金で間に合わせなければならなくなって、自分は、まごつきました。送金は、やはり、二、三日で消えてしまい、自分は慄然《りつぜん》とし、心細さのために狂うようになり、父、兄、姉などへ交互にお金を頼む電報と、イサイフミの手紙（その手紙に於いて訴えている事情は、ことごとく、お道化の虚構でした。人にものを頼むのに、まず、その人を笑わせるのが上策と考えていたのです）を連発する一方、また、堀木に教えられ、せっせと質屋がよいをはじめ、それでも、いつもお金に不自由をしていました。+　所詮、自分には、何の縁故も無い下宿に、ひとりで「生活」して行く能力が無かったのです。自分は、下宿のその部屋に、ひとりでじっとしているのが、おそろしく、いまにも誰かに襲われ、一撃せられるような気がして来て、街に飛び出しては、れいの運動の手伝いをしたり、或いは堀木と一緒に安い酒を飲み廻ったりして、ほとんど学業も、また画の勉強も放棄し、高等学校へ入学して、二年目の十一月、自分より年上の有夫の婦人と情死事件などを起し、自分の身の上は、一変しました。+　学校は欠席するし、学科の勉強も、すこしもしなかったのに、それでも、妙に試験の答案に要領のいいところがあるようで、どうやらそれまでは、故郷の肉親をあざむき通して来たのですが、しかし、もうそろそろ、出席日数の不足など、学校のほうから内密に故郷の父へ報告が行っているらしく、父の代理として長兄が、いかめしい文章の長い手紙を、自分に寄こすようになっていたのでした。けれども、それよりも、自分の直接の苦痛は、金の無い事と、それから、れいの運動の用事が、とても遊び半分の気持では出来ないくらい、はげしく、いそがしくなって来た事でした。中央地区と言ったか、何地区と言ったか、とにかく本郷、小石川、下谷、神田、あの辺の学校全部の、マルクス学生の行動隊々長というものに、自分はなっていたのでした。武装｜蜂起《ほうき》、と聞き、小さいナイフを買い（いま思えば、それは鉛筆をけずるにも足りない、きゃしゃなナイフでした）それを、レンコオトのポケットにいれ、あちこち飛び廻って、所謂《いわゆる》「聯絡《れんらく》」をつけるのでした。お酒を飲んで、ぐっすり眠りたい、しかし、お金がありません。しかも、Ｐ（党の事を、そういう隠語で呼んでいたと記憶していますが、或いは、違っているかも知れません）のほうからは、次々と息をつくひまも無いくらい、用事の依頼がまいります。自分の病弱のからだでは、とても勤まりそうも無くなりました。もともと、非合法の興味だけから、そのグルウプの手伝いをしていたのですし、こんなに、それこそ冗談から駒が出たように、いやにいそがしくなって来ると、自分は、ひそかにＰのひとたちに、それはお門《かど》ちがいでしょう、あなたたちの直系のものたちにやらせたらどうですか、というようないまいましい感を抱くのを禁ずる事が出来ず、逃げました。逃げて、さすがに、いい気持はせず、死ぬ事にしました。+　その頃、自分に特別の好意を寄せている女が、三人いました。ひとりは、自分の下宿している仙遊館の娘でした。この娘は、自分がれいの運動の手伝いでへとへとになって帰り、ごはんも食べずに寝てしまってから、必ず用箋《ようせん》と万年筆を持って自分の部屋にやって来て、+「ごめんなさい。下では、妹や弟がうるさくて、ゆっくり手紙も書けないのです」+　と言って、何やら自分の机に向って一時間以上も書いているのです。+　自分もまた、知らん振りをして寝ておればいいのに、いかにもその娘が何か自分に言ってもらいたげの様子なので、れいの受け身の奉仕の精神を発揮して、実に一言も口をききたくない気持なのだけれども、くたくたに疲れ切っているからだに、ウムと気合いをかけて腹這《はらば》いになり、煙草を吸い、+「女から来たラヴ・レターで、風呂をわかしてはいった男があるそうですよ」+「あら、いやだ。あなたでしょう？」+「ミルクをわかして飲んだ事はあるんです」+「光栄だわ、飲んでよ」+　早くこのひと、帰らねえかなあ、手紙だなんて、見えすいているのに。へへののもへじでも書いているのに違いないんです。+「見せてよ」+　と死んでも見たくない思いでそう言えば、あら、いやよ、あら、いやよ、と言って、そのうれしがる事、ひどくみっともなく、興が覚めるばかりなのです。そこで自分は、用事でも言いつけてやれ、と思うんです。+「すまないけどね、電車通りの薬屋に行って、カルモチンを買って来てくれない？　あんまり疲れすぎて、顔がほてって、かえって眠れないんだ。すまないね。お金は、……」+「いいわよ、お金なんか」+　よろこんで立ちます。用を言いつけるというのは、決して女をしょげさせる事ではなく、かえって女は、男に用事をたのまれると喜ぶものだという事も、自分はちゃんと知っているのでした。+　もうひとりは、女子高等師範の文科生の所謂「同志」でした。このひととは、れいの運動の用事で、いやでも毎日、顔を合せなければならなかったのです。打ち合せがすんでからも、その女は、いつまでも自分について歩いて、そうして、やたらに自分に、ものを買ってくれるのでした。+「私を本当の姉だと思っていてくれていいわ」+　そのキザに身震いしながら、自分は、+「そのつもりでいるんです」+　と、愁《うれ》えを含んだ微笑の表情を作って答えます。とにかく、怒らせては、こわい、何とかして、ごまかさなければならぬ、という思い一つのために、自分はいよいよその醜い、いやな女に奉仕をして、そうして、ものを買ってもらっては、（その買い物は、実に趣味の悪い品ばかりで、自分はたいてい、すぐにそれを、焼きとり屋の親爺《おやじ》などにやってしまいました）うれしそうな顔をして、冗談を言っては笑わせ、或る夏の夜、どうしても離れないので、街の暗いところで、そのひとに帰ってもらいたいばかりに、キスをしてやりましたら、あさましく狂乱の如く興奮し、自動車を呼んで、そのひとたちの運動のために秘密に借りてあるらしいビルの事務所みたいな狭い洋室に連れて行き、朝まで大騒ぎという事になり、とんでもない姉だ、と自分はひそかに苦笑しました。+　下宿屋の娘と言い、またこの「同志」と言い、どうしたって毎日、顔を合せなければならぬ具合になっていますので、これまでの、さまざまの女のひとのように、うまく避けられず、つい、ずるずるに、れいの不安の心から、この二人のご機嫌をただ懸命に取り結び、もはや自分は、金縛り同様の形になっていました。+　同じ頃また自分は、銀座の或る大カフエの女給から、思いがけぬ恩を受け、たったいちど逢っただけなのに、それでも、その恩にこだわり、やはり身動き出来ないほどの、心配やら、空《そら》おそろしさを感じていたのでした。その頃になると、自分も、敢えて堀木の案内に頼らずとも、ひとりで電車にも乗れるし、また、歌舞伎座にも行けるし、または、絣《かすり》の着物を着て、カフエにだってはいれるくらいの、多少の図々しさを装えるようになっていたのです。心では、相変らず、人間の自信と暴力とを怪しみ、恐れ、悩みながら、うわべだけは、少しずつ、他人と真顔の挨拶、いや、ちがう、自分はやはり敗北のお道化の苦しい笑いを伴わずには、挨拶できないたちなのですが、とにかく、無我夢中のへどもどの挨拶でも、どうやら出来るくらいの「伎倆《ぎりょう》」を、れいの運動で走り廻ったおかげ？　または、女の？　または、酒？　けれども、おもに金銭の不自由のおかげで修得しかけていたのです。どこにいても、おそろしく、かえって大カフエでたくさんの酔客または女給、ボーイたちにもまれ、まぎれ込む事が出来たら、自分のこの絶えず追われているような心も落ちつくのではなかろうか、と十円持って、銀座のその大カフエに、ひとりではいって、笑いながら相手の女給に、+「十円しか無いんだからね、そのつもりで」+　と言いました。+「心配要りません」+　どこかに関西の訛《なま》りがありました。そうして、その一言が、奇妙に自分の、震えおののいている心をしずめてくれました。いいえ、お金の心配が要らなくなったからではありません、そのひとの傍にいる事に心配が要らないような気がしたのです。+　自分は、お酒を飲みました。そのひとに安心しているので、かえってお道化など演じる気持も起らず、自分の地金《じがね》の無口で陰惨なところを隠さず見せて、黙ってお酒を飲みました。+「こんなの、おすきか？」+　女は、さまざまの料理を自分の前に並べました。自分は首を振りました。+「お酒だけか？　うちも飲もう」+　秋の、寒い夜でした。自分は、ツネ子（といったと覚えていますが、記憶が薄れ、たしかではありません。情死の相手の名前をさえ忘れているような自分なのです）に言いつけられたとおりに、銀座裏の、或る屋台のお鮨《すし》やで、少しもおいしくない鮨を食べながら、（そのひとの名前は忘れても、その時の鮨のまずさだけは、どうした事か、はっきり記憶に残っています。そうして、青大将の顔に似た顔つきの、丸坊主のおやじが、首を振り振り、いかにも上手みたいにごまかしながら鮨を握っている様も、眼前に見るように鮮明に思い出され、後年、電車などで、はて見た顔だ、といろいろ考え、なんだ、あの時の鮨やの親爺に似ているんだ、と気が附き苦笑した事も再三あったほどでした。あのひとの名前も、また、顔かたちさえ記憶から遠ざかっている現在なお、あの鮨やの親爺の顔だけは絵にかけるほど正確に覚えているとは、よっぽどあの時の鮨がまずく、自分に寒さと苦痛を与えたものと思われます。もともと、自分は、うまい鮨を食わせる店というところに、ひとに連れられて行って食っても、うまいと思った事は、いちどもありませんでした。大き過ぎるのです。親指くらいの大きさにキチッと握れないものかしら、といつも考えていました）そのひとを、待っていました。+　本所の大工さんの二階を、そのひとが借りていました。自分は、その二階で、日頃の自分の陰鬱な心を少しもかくさず、ひどい歯痛に襲われてでもいるように、片手で頬をおさえながら、お茶を飲みました。そうして、自分のそんな姿態が、かえって、そのひとには、気にいったようでした。そのひとも、身のまわりに冷たい木枯しが吹いて、落葉だけが舞い狂い、完全に孤立している感じの女でした。+　一緒にやすみながらそのひとは、自分より二つ年上であること、故郷は広島、あたしには主人があるのよ、広島で床屋さんをしていたの、昨年の春、一緒に東京へ家出して逃げて来たのだけれども、主人は、東京で、まともな仕事をせずそのうちに詐欺罪に問われ、刑務所にいるのよ、あたしは毎日、何やらかやら差し入れしに、刑務所へかよっていたのだけれども、あすから、やめます、などと物語るのでしたが、自分は、どういうものか、女の身の上｜噺《ばなし》というものには、少しも興味を持てないたちで、それは女の語り方の下手なせいか、つまり、話の重点の置き方を間違っているせいなのか、とにかく、自分には、つねに、馬耳東風なのでありました。+　侘びしい。+　自分には、女の千万言の身の上噺よりも、その一言の呟《つぶや》きのほうに、共感をそそられるに違いないと期待していても、この世の中の女から、ついにいちども自分は、その言葉を聞いた事がないのを、奇怪とも不思議とも感じております。けれども、そのひとは、言葉で「侘びしい」とは言いませんでしたが、無言のひどい侘びしさを、からだの外郭に、一寸くらいの幅の気流みたいに持っていて、そのひとに寄り添うと、こちらのからだもその気流に包まれ、自分の持っている多少トゲトゲした陰鬱の気流と程よく溶け合い、「水底の岩に落ち附く枯葉」のように、わが身は、恐怖からも不安からも、離れる事が出来るのでした。+　あの白痴の淫売婦たちのふところの中で、安心してぐっすり眠る思いとは、また、全く異って、（だいいち、あのプロステチュウトたちは、陽気でした）その詐欺罪の犯人の妻と過した一夜は、自分にとって、幸福な（こんな大それた言葉を、なんの躊躇《ちゅうちょ》も無く、肯定して使用する事は、自分のこの全手記に於いて、再び無いつもりです）解放せられた夜でした。+　しかし、ただ一夜でした。朝、眼が覚めて、はね起き、自分はもとの軽薄な、装えるお道化者になっていました。弱虫は、幸福をさえおそれるものです。綿で怪我をするんです。幸福に傷つけられる事もあるんです。傷つけられないうちに、早く、このまま、わかれたいとあせり、れいのお道化の煙幕を張りめぐらすのでした。+「金の切れめが縁の切れめ、ってのはね、あれはね、解釈が逆なんだ。金が無くなると女にふられるって意味、じゃあ無いんだ。男に金が無くなると、男は、ただおのずから意気｜銷沈《しょうちん》して、ダメになり、笑う声にも力が無く、そうして、妙にひがんだりなんかしてね、ついには破れかぶれになり、男のほうから女を振る、半狂乱になって振って振って振り抜くという意味なんだね、金沢大辞林という本に依ればね、可哀そうに。僕にも、その気持わかるがね」+　たしか、そんなふうの馬鹿げた事を言って、ツネ子を噴き出させたような記憶があります。長居は無用、おそれありと、顔も洗わずに素早く引上げたのですが、その時の自分の、「金の切れめが縁の切れめ」という出鱈目《でたらめ》の放言が、のちに到って、意外のひっかかりを生じたのです。+　それから、ひとつき、自分は、その夜の恩人とは逢いませんでした。別れて、日が経つにつれて、よろこびは薄れ、かりそめの恩を受けた事がかえってそらおそろしく、自分勝手にひどい束縛を感じて来て、あのカフエのお勘定を、あの時、全部ツネ子の負担にさせてしまったという俗事さえ、次第に気になりはじめて、ツネ子もやはり、下宿の娘や、あの女子高等師範と同じく、自分を脅迫するだけの女のように思われ、遠く離れていながらも、絶えずツネ子におびえていて、その上に自分は、一緒に休んだ事のある女に、また逢うと、その時にいきなり何か烈火の如く怒られそうな気がしてたまらず、逢うのに頗《すこぶ》るおっくうがる性質でしたので、いよいよ、銀座は敬遠の形でしたが、しかし、そのおっくうがるという性質は、決して自分の狡猾《こうかつ》さではなく、女性というものは、休んでからの事と、朝、起きてからの事との間に、一つの、塵《ちり》ほどの、つながりをも持たせず、完全の忘却の如く、見事に二つの世界を切断させて生きているという不思議な現象を、まだよく呑みこんでいなかったからなのでした。+　十一月の末、自分は、堀木と神田の屋台で安酒を飲み、この悪友は、その屋台を出てからも、さらにどこかで飲もうと主張し、もう自分たちにはお金が無いのに、それでも、飲もう、飲もうよ、とねばるのです。その時、自分は、酔って大胆になっているからでもありましたが、+「よし、そんなら、夢の国に連れて行く。おどろくな、酒池肉林という、……」+「カフエか？」+「そう」+「行こう！」+　というような事になって二人、市電に乗り、堀木は、はしゃいで、+「おれは、今夜は、女に飢え渇いているんだ。女給にキスしてもいいか」+　自分は、堀木がそんな酔態を演じる事を、あまり好んでいないのでした。堀木も、それを知っているので、自分にそんな念を押すのでした。+「いいか。キスするぜ。おれの傍に坐った女給に、きっとキスして見せる。いいか」+「かまわんだろう」+「ありがたい！　おれは女に飢え渇いているんだ」+　銀座四丁目で降りて、その所謂酒池肉林の大カフエに、ツネ子をたのみの綱としてほとんど無一文ではいり、あいているボックスに堀木と向い合って腰をおろしたとたんに、ツネ子ともう一人の女給が走り寄って来て、そのもう一人の女給が自分の傍に、そうしてツネ子は、堀木の傍に、ドサンと腰かけたので、自分は、ハッとしました。ツネ子は、いまにキスされる。+　惜しいという気持ではありませんでした。自分には、もともと所有慾というものは薄く、また、たまに幽かに惜しむ気持はあっても、その所有権を敢然と主張し、人と争うほどの気力が無いのでした。のちに、自分は、自分の内縁の妻が犯されるのを、黙って見ていた事さえあったほどなのです。+　自分は、人間のいざこざに出来るだけ触りたくないのでした。その渦に巻き込まれるのが、おそろしいのでした。ツネ子と自分とは、一夜だけの間柄です。ツネ子は、自分のものではありません。惜しい、など思い上った慾は、自分に持てる筈はありません。けれども、自分は、ハッとしました。+　自分の眼の前で、堀木の猛烈なキスを受ける、そのツネ子の身の上を、ふびんに思ったからでした。堀木によごされたツネ子は、自分とわかれなければならなくなるだろう、しかも自分にも、ツネ子を引き留める程のポジティヴな熱は無い、ああ、もう、これでおしまいなのだ、とツネ子の不幸に一瞬ハッとしたものの、すぐに自分は水のように素直にあきらめ、堀木とツネ子の顔を見較べ、にやにやと笑いました。+　しかし、事態は、実に思いがけなく、もっと悪く展開せられました。+「やめた！」+　と堀木は、口をゆがめて言い、+「さすがのおれも、こんな貧乏くさい女には、……」+　閉口し切ったように、腕組みしてツネ子をじろじろ眺め、苦笑するのでした。+「お酒を。お金は無い」+　自分は、小声でツネ子に言いました。それこそ、浴びるほど飲んでみたい気持でした。所謂俗物の眼から見ると、ツネ子は酔漢のキスにも価いしない、ただ、みすぼらしい、貧乏くさい女だったのでした。案外とも、意外とも、自分には霹靂《へきれき》に撃ちくだかれた思いでした。自分は、これまで例の無かったほど、いくらでも、いくらでも、お酒を飲み、ぐらぐら酔って、ツネ子と顔を見合せ、哀《かな》しく微笑《ほほえ》み合い、いかにもそう言われてみると、こいつはへんに疲れて貧乏くさいだけの女だな、と思うと同時に、金の無い者どうしの親和（貧富の不和は、陳腐のようでも、やはりドラマの永遠のテーマの一つだと自分は今では思っていますが）そいつが、その親和感が、胸に込み上げて来て、ツネ子がいとしく、生れてこの時はじめて、われから積極的に、微弱ながら恋の心の動くのを自覚しました。吐きました。前後不覚になりました。お酒を飲んで、こんなに我を失うほど酔ったのも、その時がはじめてでした。+　眼が覚めたら、枕もとにツネ子が坐っていました。本所の大工さんの二階の部屋に寝ていたのでした。+「金の切れめが縁の切れめ、なんておっしゃって、冗談かと思うていたら、本気か。来てくれないのだもの。ややこしい切れめやな。うちが、かせいであげても、だめか」+「だめ」+　それから、女も休んで、夜明けがた、女の口から「死」という言葉がはじめて出て、女も人間としての営みに疲れ切っていたようでしたし、また、自分も、世の中への恐怖、わずらわしさ、金、れいの運動、女、学業、考えると、とてもこの上こらえて生きて行けそうもなく、そのひとの提案に気軽に同意しました。+　けれども、その時にはまだ、実感としての「死のう」という覚悟は、出来ていなかったのです。どこかに「遊び」がひそんでいました。+　その日の午前、二人は浅草の六区をさまよっていました。喫茶店にはいり、牛乳を飲みました。+「あなた、払うて置いて」+　自分は立って、袂《たもと》からがま口を出し、ひらくと、銅銭が三枚、羞恥《しゅうち》よりも凄惨《せいさん》の思いに襲われ、たちまち脳裡《のうり》に浮ぶものは、仙遊館の自分の部屋、制服と蒲団だけが残されてあるきりで、あとはもう、質草になりそうなものの一つも無い荒涼たる部屋、他には自分のいま着て歩いている絣の着物と、マント、これが自分の現実なのだ、生きて行けない、とはっきり思い知りました。+　自分がまごついているので、女も立って、自分のがま口をのぞいて、+「あら、たったそれだけ？」+　無心の声でしたが、これがまた、じんと骨身にこたえるほどに痛かったのです。はじめて自分が、恋したひとの声だけに、痛かったのです。それだけも、これだけもない、銅銭三枚は、どだいお金でありません。それは、自分が未《いま》だかつて味わった事の無い奇妙な屈辱でした。とても生きておられない屈辱でした。所詮《しょせん》その頃の自分は、まだお金持ちの坊ちゃんという種属から脱し切っていなかったのでしょう。その時、自分は、みずからすすんでも死のうと、実感として［＃「実感として」に傍点］決意したのです。+　その夜、自分たちは、鎌倉の海に飛び込みました。女は、この帯はお店のお友達から借りている帯やから、と言って、帯をほどき、畳んで岩の上に置き、自分もマントを脱ぎ、同じ所に置いて、一緒に入水《じゅすい》しました。+　女のひとは、死にました。そうして、自分だけ助かりました。+　自分が高等学校の生徒ではあり、また父の名にもいくらか、所謂ニュウス・ヴァリュがあったのか、新聞にもかなり大きな問題として取り上げられたようでした。+　自分は海辺の病院に収容せられ、故郷から親戚《しんせき》の者がひとり駈けつけ、さまざまの始末をしてくれて、そうして、くにの父をはじめ一家中が激怒しているから、これっきり生家とは義絶になるかも知れぬ、と自分に申し渡して帰りました。けれども自分は、そんな事より、死んだツネ子が恋いしく、めそめそ泣いてばかりいました。本当に、いままでのひとの中で、あの貧乏くさいツネ子だけを、すきだったのですから。+　下宿の娘から、短歌を五十も書きつらねた長い手紙が来ました。「生きくれよ」というへんな言葉ではじまる短歌ばかり、五十でした。また、自分の病室に、看護婦たちが陽気に笑いながら遊びに来て、自分の手をきゅっと握って帰る看護婦もいました。+　自分の左肺に故障のあるのを、その病院で発見せられ、これがたいへん自分に好都合な事になり、やがて自分が自殺｜幇助《ほうじょ》罪という罪名で病院から警察に連れて行かれましたが、警察では、自分を病人あつかいにしてくれて、特に保護室に収容しました。+　深夜、保護室の隣りの宿直室で、寝ずの番をしていた年寄りのお巡《まわ》りが、間のドアをそっとあけ、+「おい！」+　と自分に声をかけ、+「寒いだろう。こっちへ来て、あたれ」+　と言いました。+　自分は、わざとしおしおと宿直室にはいって行き、椅子に腰かけて火鉢にあたりました。+「やはり、死んだ女が恋いしいだろう」+「はい」+　ことさらに、消え入るような細い声で返事しました。+「そこが、やはり人情というものだ」+　彼は次第に、大きく構えて来ました。+「はじめ、女と関係を結んだのは、どこだ」+　ほとんど裁判官の如く、もったいぶって尋ねるのでした。彼は、自分を子供とあなどり、秋の夜のつれづれに、あたかも彼自身が取調べの主任でもあるかのように装い、自分から猥談《わいだん》めいた述懐を引き出そうという魂胆のようでした。自分は素早くそれを察し、噴き出したいのを怺《こら》えるのに骨を折りました。そんなお巡りの「非公式な訊問」には、いっさい答を拒否してもかまわないのだという事は、自分も知っていましたが、しかし、秋の夜ながに興を添えるため、自分は、あくまでも神妙に、そのお巡りこそ取調べの主任であって、刑罰の軽重の決定もそのお巡りの思召《おぼしめ》し一つに在るのだ、という事を固く信じて疑わないような所謂誠意をおもてにあらわし、彼の助平の好奇心を、やや満足させる程度のいい加減な「陳述」をするのでした。+「うん、それでだいたいわかった。何でも正直に答えると、わしらのほうでも、そこは手心を加える」+「ありがとうございます。よろしくお願いいたします」+　ほとんど入神の演技でした。そうして、自分のためには、何も、一つも、とくにならない力演なのです。+　夜が明けて、自分は署長に呼び出されました。こんどは、本式の取調べなのです。+　ドアをあけて、署長室にはいったとたんに、+「おう、いい男だ。これあ、お前が悪いんじゃない。こんな、いい男に産んだお前のおふくろが悪いんだ」+　色の浅黒い、大学出みたいな感じのまだ若い署長でした。いきなりそう言われて自分は、自分の顔の半面にべったり赤痣《あかあざ》でもあるような、みにくい不具者のような、みじめな気がしました。+　この柔道か剣道の選手のような署長の取調べは、実にあっさりしていて、あの深夜の老巡査のひそかな、執拗《しつよう》きわまる好色の「取調べ」とは、雲泥の差がありました。訊問がすんで、署長は、検事局に送る書類をしたためながら、+「からだを丈夫にしなけれゃ、いかんね。血痰《けったん》が出ているようじゃないか」+　と言いました。+　その朝、へんに咳《せき》が出て、自分は咳の出るたびに、ハンケチで口を覆っていたのですが、そのハンケチに赤い霰《あられ》が降ったみたいに血がついていたのです。けれども、それは、喉《のど》から出た血ではなく、昨夜、耳の下に出来た小さいおできをいじって、そのおできから出た血なのでした。しかし、自分は、それを言い明さないほうが、便宜な事もあるような気がふっとしたものですから、ただ、+「はい」+　と、伏眼になり、殊勝げに答えて置きました。+　署長は書類を書き終えて、+「起訴になるかどうか、それは検事殿がきめることだが、お前の身元引受人に、電報か電話で、きょう横浜の検事局に来てもらうように、たのんだほうがいいな。誰か、あるだろう、お前の保護者とか保証人とかいうものが」+　父の東京の別荘に出入りしていた書画｜骨董《こっとう》商の渋田という、自分たちと同郷人で、父のたいこ持ちみたいな役も勤めていたずんぐりした独身の四十男が、自分の学校の保証人になっているのを、自分は思い出しました。その男の顔が、殊に眼つきが、ヒラメに似ているというので、父はいつもその男をヒラメと呼び、自分も、そう呼びなれていました。+　自分は警察の電話帳を借りて、ヒラメの家の電話番号を捜し、見つかったので、ヒラメに電話して、横浜の検事局に来てくれるように頼みましたら、ヒラメは人が変ったみたいな威張った口調で、それでも、とにかく引受けてくれました。+「おい、その電話機、すぐ消毒したほうがいいぜ。何せ、血痰が出ているんだから」+　自分が、また保護室に引き上げてから、お巡りたちにそう言いつけている署長の大きな声が、保護室に坐っている自分の耳にまで、とどきました。+　お昼すぎ、自分は、細い麻繩で胴を縛られ、それはマントで隠すことを許されましたが、その麻繩の端を若いお巡りが、しっかり握っていて、二人一緒に電車で横浜に向いました。+　けれども、自分には少しの不安も無く、あの警察の保護室も、老巡査もなつかしく、嗚呼《ああ》、自分はどうしてこうなのでしょう、罪人として縛られると、かえってほっとして、そうしてゆったり落ちついて、その時の追憶を、いま書くに当っても、本当にのびのびした楽しい気持になるのです。+　しかし、その時期のなつかしい［＃「なつかしい」に傍点］思い出の中にも、たった一つ、冷汗三斗の、生涯わすれられぬ悲惨なしくじりがあったのです。自分は、検事局の薄暗い一室で、検事の簡単な取調べを受けました。検事は四十歳前後の物静かな、（もし自分が美貌だったとしても、それは謂《い》わば邪淫の美貌だったに違いありませんが、その検事の顔は、正しい美貌、とでも言いたいような、聡明な静謐《せいひつ》の気配を持っていました）コセコセしない人柄のようでしたので、自分も全く警戒せず、ぼんやり陳述していたのですが、突然、れいの咳が出て来て、自分は袂からハンケチを出し、ふとその血を見て、この咳もまた何かの役に立つかも知れぬとあさましい駈引きの心を起し、ゴホン、ゴホンと二つばかり、おまけの贋《にせ》の咳を大袈裟《おおげさ》に附け加えて、ハンケチで口を覆ったまま検事の顔をちらと見た、間一髪、+「ほんとうかい？」+　ものしずかな微笑でした。冷汗三斗、いいえ、いま思い出しても、きりきり舞いをしたくなります。中学時代に、あの馬鹿の竹一から、ワザ、ワザ、と言われて脊中《せなか》を突かれ、地獄に蹴落《けおと》された、その時の思い以上と言っても、決して過言では無い気持です。あれと、これと、二つ、自分の生涯に於ける演技の大失敗の記録です。検事のあんな物静かな侮蔑《ぶべつ》に遭うよりは、いっそ自分は十年の刑を言い渡されたほうが、ましだったと思う事さえ、時たまある程なのです。+　自分は起訴猶予になりました。けれども一向にうれしくなく、世にもみじめな気持で、検事局の控室のベンチに腰かけ、引取り人のヒラメが来るのを待っていました。+　背後の高い窓から夕焼けの空が見え、鴎《かもめ》が、「女」という字みたいな形で飛んでいました。+［＃改頁］++++［＃３字下げ］第三の手記［＃「第三の手記」は大見出し］+++［＃５字下げ］一［＃「一」は中見出し］++　竹一の予言の、一つは当り、一つは、はずれました。惚《ほ》れられるという、名誉で無い予言のほうは、あたりましたが、きっと偉い絵画きになるという、祝福の予言は、はずれました。+　自分は、わずかに、粗悪な雑誌の、無名の下手な漫画家になる事が出来ただけでした。+　鎌倉の事件のために、高等学校からは追放せられ、自分は、ヒラメの家の二階の、三畳の部屋で寝起きして、故郷からは月々、極めて小額の金が、それも直接に自分宛ではなく、ヒラメのところにひそかに送られて来ている様子でしたが、（しかも、それは故郷の兄たちが、父にかくして送ってくれているという形式になっていたようでした）それっきり、あとは故郷とのつながりを全然、断ち切られてしまい、そうして、ヒラメはいつも不機嫌、自分があいそ笑いをしても、笑わず、人間というものはこんなにも簡単に、それこそ手のひらをかえすが如くに変化できるものかと、あさましく、いや、むしろ滑稽に思われるくらいの、ひどい変り様で、+「出ちゃいけませんよ。とにかく、出ないで下さいよ」+　そればかり自分に言っているのでした。+　ヒラメは、自分に自殺のおそれありと、にらんでいるらしく、つまり、女の後を追ってまた海へ飛び込んだりする危険があると見てとっているらしく、自分の外出を固く禁じているのでした。けれども、酒も飲めないし、煙草も吸えないし、ただ、朝から晩まで二階の三畳のこたつにもぐって、古雑誌なんか読んで阿呆同然のくらしをしている自分には、自殺の気力さえ失われていました。+　ヒラメの家は、大久保の医専の近くにあり、書画骨董商、青竜園、だなどと看板の文字だけは相当に気張っていても、一棟二戸の、その一戸で、店の間口も狭く、店内はホコリだらけで、いい加減なガラクタばかり並べ、（もっとも、ヒラメはその店のガラクタにたよって商売しているわけではなく、こっちの所謂旦那の秘蔵のものを、あっちの所謂旦那にその所有権をゆずる場合などに活躍して、お金をもうけているらしいのです）店に坐っている事は殆ど無く、たいてい朝から、むずかしそうな顔をしてそそくさと出かけ、留守は十七、八の小僧ひとり、これが自分の見張り番というわけで、ひまさえあれば近所の子供たちと外でキャッチボールなどしていても、二階の居候をまるで馬鹿か気違いくらいに思っているらしく、大人《おとな》の説教くさい事まで自分に言い聞かせ、自分は、ひとと言い争いの出来ない質《たち》なので、疲れたような、また、感心したような顔をしてそれに耳を傾け、服従しているのでした。この小僧は渋田のかくし子で、それでもへんな事情があって、渋田は所謂親子の名乗りをせず、また渋田がずっと独身なのも、何やらその辺に理由があっての事らしく、自分も以前、自分の家の者たちからそれに就いての噂《うわさ》を、ちょっと聞いたような気もするのですが、自分は、どうも他人の身の上には、あまり興味を持てないほうなので、深い事は何も知りません。しかし、その小僧の眼つきにも、妙に魚の眼を聯想《れんそう》させるところがありましたから、或いは、本当にヒラメのかくし子、……でも、それならば、二人は実に淋しい親子でした。夜おそく、二階の自分には内緒で、二人でおそばなどを取寄せて無言で食べている事がありました。+　ヒラメの家では食事はいつもその小僧がつくり、二階のやっかい者の食事だけは別にお膳《ぜん》に載せて小僧が三度々々二階に持ち運んで来てくれて、ヒラメと小僧は、階段の下のじめじめした四畳半で何やら、カチャカチャ皿小鉢の触れ合う音をさせながら、いそがしげに食事しているのでした。+　三月末の或る夕方、ヒラメは思わぬもうけ口にでもありついたのか、または何か他に策略でもあったのか、（その二つの推察が、ともに当っていたとしても、おそらくは、さらにまたいくつかの、自分などにはとても推察のとどかないこまかい原因もあったのでしょうが）自分を階下の珍らしくお銚子《ちょうし》など附いている食卓に招いて、ヒラメならぬマグロの刺身に、ごちそうの主人《あるじ》みずから感服し、賞讃《しょうさん》し、ぼんやりしている居候にも少しくお酒をすすめ、+「どうするつもりなんです、いったい、これから」+　自分はそれに答えず、卓上の皿から畳鰯《たたみいわし》をつまみ上げ、その小魚たちの銀の眼玉を眺めていたら、酔いがほのぼの発して来て、遊び廻っていた頃がなつかしく、堀木でさえなつかしく、つくづく「自由」が欲しくなり、ふっと、かぼそく泣きそうになりました。+　自分がこの家へ来てからは、道化を演ずる張合いさえ無く、ただもうヒラメと小僧の蔑視の中に身を横たえ、ヒラメのほうでもまた、自分と打ち解けた長噺をするのを避けている様子でしたし、自分もそのヒラメを追いかけて何かを訴える気などは起らず、ほとんど自分は、間抜けづらの居候になり切っていたのです。+「起訴猶予というのは、前科何犯とか、そんなものには、ならない模様です。だから、まあ、あなたの心掛け一つで、更生が出来るわけです。あなたが、もし、改心して、あなたのほうから、真面目に私に相談を持ちかけてくれたら、私も考えてみます」+　ヒラメの話方には、いや、世の中の全部の人の話方には、このようにややこしく、どこか朦朧《もうろう》として、逃腰とでもいったみたいな微妙な複雑さがあり、そのほとんど無益と思われるくらいの厳重な警戒と、無数といっていいくらいの小うるさい駈引とには、いつも自分は当惑し、どうでもいいやという気分になって、お道化で茶化したり、または無言の首肯で一さいおまかせという、謂わば敗北の態度をとってしまうのでした。+　この時もヒラメが、自分に向って、だいたい次のように簡単に報告すれば、それですむ事だったのを自分は後年に到って知り、ヒラメの不必要な用心、いや、世の中の人たちの不可解な見栄、おていさいに、何とも陰鬱な思いをしました。+　ヒラメは、その時、ただこう言えばよかったのでした。+「官立でも私立でも、とにかく四月から、どこかの学校へはいりなさい。あなたの生活費は、学校へはいると、くにから、もっと充分に送って来る事になっているのです。」+　ずっと後になってわかったのですが、事実は、そのようになっていたのでした。そうして、自分もその言いつけに従ったでしょう。それなのに、ヒラメのいやに用心深く持って廻った言い方のために、妙にこじれ、自分の生きて行く方向もまるで変ってしまったのです。+「真面目に私に相談を持ちかけてくれる気持が無ければ、仕様がないですが」+「どんな相談？」+　自分には、本当に何も見当がつかなかったのです。+「それは、あなたの胸にある事でしょう？」+「たとえば？」+「たとえばって、あなた自身、これからどうする気なんです」+「働いたほうが、いいんですか？」+「いや、あなたの気持は、いったいどうなんです」+「だって、学校へはいるといったって、……」+「そりゃ、お金が要ります。しかし、問題は、お金でない。あなたの気持です」+　お金は、くにから来る事になっているんだから、となぜ一こと、言わなかったのでしょう。その一言に依って、自分の気持も、きまった筈なのに、自分には、ただ五里霧中でした。+「どうですか？　何か、将来の希望、とでもいったものが、あるんですか？　いったい、どうも、ひとをひとり世話しているというのは、どれだけむずかしいものだか、世話されているひとには、わかりますまい」+「すみません」+「そりゃ実に、心配なものです。私も、いったんあなたの世話を引受けた以上、あなたにも、生半可《なまはんか》な気持でいてもらいたくないのです。立派に更生の道をたどる、という覚悟のほどを見せてもらいたいのです。たとえば、あなたの将来の方針、それに就いてあなたのほうから私に、まじめに相談を持ちかけて来たなら、私もその相談には応ずるつもりでいます。それは、どうせこんな、貧乏なヒラメの援助なのですから、以前のようなぜいたくを望んだら、あてがはずれます。しかし、あなたの気持がしっかりしていて、将来の方針をはっきり打ち樹《た》て、そうして私に相談をしてくれたら、私は、たといわずかずつでも、あなたの更生のために、お手伝いしようとさえ思っているんです。わかりますか？　私の気持が。いったい、あなたは、これから、どうするつもりでいるのです」+「ここの二階に、置いてもらえなかったら、働いて、……」+「本気で、そんな事を言っているのですか？　いまのこの世の中に、たとい帝国大学校を出たって、……」+「いいえ、サラリイマンになるんでは無いんです」+「それじゃ、何です」+「画家です」+　思い切って、それを言いました。+「へええ？」+　自分は、その時の、頸《くび》をちぢめて笑ったヒラメの顔の、いかにもずるそうな影を忘れる事が出来ません。軽蔑の影にも似て、それとも違い、世の中を海にたとえると、その海の千尋《ちひろ》の深さの箇所に、そんな奇妙な影がたゆとうていそうで、何か、おとなの生活の奥底をチラと覗《のぞ》かせたような笑いでした。+　そんな事では話にも何もならぬ、ちっとも気持がしっかりしていない、考えなさい、今夜一晩まじめに考えてみなさい、と言われ、自分は追われるように二階に上って、寝ても、別に何の考えも浮びませんでした。そうして、あけがたになり、ヒラメの家から逃げました。+　夕方、間違いなく帰ります。左記の友人の許《もと》へ、将来の方針に就いて相談に行って来るのですから、御心配無く。ほんとうに。+　と、用箋に鉛筆で大きく書き、それから、浅草の堀木正雄の住所姓名を記して、こっそり、ヒラメの家を出ました。+　ヒラメに説教せられたのが、くやしくて逃げたわけではありませんでした。まさしく自分は、ヒラメの言うとおり、気持のしっかりしていない男で、将来の方針も何も自分にはまるで見当がつかず、この上、ヒラメの家のやっかいになっているのは、ヒラメにも気の毒ですし、そのうちに、もし万一、自分にも発奮の気持が起り、志を立てたところで、その更生資金をあの貧乏なヒラメから月々援助せられるのかと思うと、とても心苦しくて、いたたまらない気持になったからでした。+　しかし、自分は、所謂「将来の方針」を、堀木ごときに、相談に行こうなどと本気に思って、ヒラメの家を出たのでは無かったのでした。それは、ただ、わずかでも、つかのまでも、ヒラメに安心させて置きたくて、（その間に自分が、少しでも遠くへ逃げのびていたいという探偵小説的な策略から、そんな置手紙を書いた、というよりは、いや、そんな気持も幽《かす》かにあったに違いないのですが、それよりも、やはり自分は、いきなりヒラメにショックを与え、彼を混乱当惑させてしまうのが、おそろしかったばかりに、とでも言ったほうが、いくらか正確かも知れません。どうせ、ばれるにきまっているのに、そのとおりに言うのが、おそろしくて、必ず何かしら飾りをつけるのが、自分の哀しい性癖の一つで、それは世間の人が「嘘つき」と呼んで卑しめている性格に似ていながら、しかし、自分は自分に利益をもたらそうとしてその飾りつけを行った事はほとんど無く、ただ雰囲気《ふんいき》の興覚めた一変が、窒息するくらいにおそろしくて、後で自分に不利益になるという事がわかっていても、れいの自分の「必死の奉仕」それはたといゆがめられ微弱で、馬鹿らしいものであろうと、その奉仕の気持から、つい一言の飾りつけをしてしまうという場合が多かったような気もするのですが、しかし、この習性もまた、世間の所謂「正直者」たちから、大いに乗ぜられるところとなりました）その時、ふっと、記憶の底から浮んで来たままに堀木の住所と姓名を、用箋の端にしたためたまでの事だったのです。+　自分はヒラメの家を出て、新宿まで歩き、懐中の本を売り、そうして、やっぱり途方にくれてしまいました。自分は、皆にあいそがいいかわりに、「友情」というものを、いちども実感した事が無く、堀木のような遊び友達は別として、いっさいの附き合いは、ただ苦痛を覚えるばかりで、その苦痛をもみほぐそうとして懸命にお道化を演じて、かえって、へとへとになり、わずかに知合っているひとの顔を、それに似た顔をさえ、往来などで見掛けても、ぎょっとして、一瞬、めまいするほどの不快な戦慄に襲われる有様で、人に好かれる事は知っていても、人を愛する能力に於《お》いては欠けているところがあるようでした。（もっとも、自分は、世の中の人間にだって、果して、「愛」の能力があるのかどうか、たいへん疑問に思っています）そのような自分に、所謂「親友」など出来る筈は無く、そのうえ自分には、「訪問《ヴィジット》」の能力さえ無かったのです。他人の家の門は、自分にとって、あの神曲の地獄の門以上に薄気味わるく、その門の奥には、おそろしい竜みたいな生臭い奇獣がうごめいている気配を、誇張でなしに、実感せられていたのです。+　誰とも、附き合いが無い。どこへも、訪ねて行けない。+　堀木。+　それこそ、冗談から駒が出た形でした。あの置手紙に、書いたとおりに、自分は浅草の堀木をたずねて行く事にしたのです。自分はこれまで、自分のほうから堀木の家をたずねて行った事は、いちども無く、たいてい電報で堀木を自分のほうに呼び寄せていたのですが、いまはその電報料さえ心細く、それに落ちぶれた身のひがみから、電報を打っただけでは、堀木は、来てくれぬかも知れぬと考えて、何よりも自分に苦手の「訪問」を決意し、溜息《ためいき》をついて市電に乗り、自分にとって、この世の中でたった一つの頼みの綱は、あの堀木なのか、と思い知ったら、何か脊筋《せすじ》の寒くなるような凄《すさま》じい気配に襲われました。+　堀木は、在宅でした。汚い露路の奥の、二階家で、堀木は二階のたった一部屋の六畳を使い、下では、堀木の老父母と、それから若い職人と三人、下駄の鼻緒を縫ったり叩いたりして製造しているのでした。+　堀木は、その日、彼の都会人としての新しい一面を自分に見せてくれました。それは、俗にいうチャッカリ性でした。田舎者の自分が、愕然《がくぜん》と眼をみはったくらいの、冷たく、ずるいエゴイズムでした。自分のように、ただ、とめどなく流れるたちの男では無かったのです。+「お前には、全く呆《あき》れた。親爺さんから、お許しが出たかね。まだかい」+　逃げて来た、とは、言えませんでした。+　自分は、れいに依って、ごまかしました。いまに、すぐ、堀木に気附かれるに違いないのに、ごまかしました。+「それは、どうにかなるさ」+「おい、笑いごとじゃ無いぜ。忠告するけど、馬鹿もこのへんでやめるんだな。おれは、きょうは、用事があるんだがね。この頃、ばかにいそがしいんだ」+「用事って、どんな？」+「おい、おい、座蒲団の糸を切らないでくれよ」+　自分は話をしながら、自分の敷いている座蒲団の綴糸《とじいと》というのか、くくり紐《ひも》というのか、あの総《ふさ》のような四隅の糸の一つを無意識に指先でもてあそび、ぐいと引っぱったりなどしていたのでした。堀木は、堀木の家の品物なら、座蒲団の糸一本でも惜しいらしく、恥じる色も無く、それこそ、眼に角《かど》を立てて、自分をとがめるのでした。考えてみると、堀木は、これまで自分との附合いに於いて何一つ失ってはいなかったのです。+　堀木の老母が、おしるこを二つお盆に載せて持って来ました。+「あ、これは」+　と堀木は、しんからの孝行息子のように、老母に向って恐縮し、言葉づかいも不自然なくらい丁寧に、+「すみません、おしるこですか。豪気だなあ。こんな心配は、要らなかったんですよ。用事で、すぐ外出しなけれゃいけないんですから。いいえ、でも、せっかくの御自慢のおしるこを、もったいない。いただきます。お前も一つ、どうだい。おふくろが、わざわざ作ってくれたんだ。ああ、こいつあ、うめえや。豪気だなあ」+　と、まんざら芝居でも無いみたいに、ひどく喜び、おいしそうに食べるのです。自分もそれを啜《すす》りましたが、お湯のにおいがして、そうして、お餅をたべたら、それはお餅でなく、自分にはわからないものでした。決して、その貧しさを軽蔑したのではありません。（自分は、その時それを、不味《まず》いとは思いませんでしたし、また、老母の心づくしも身にしみました。自分には、貧しさへの恐怖感はあっても、軽蔑感は、無いつもりでいます）あのおしること、それから、そのおしるこを喜ぶ堀木に依って、自分は、都会人のつましい本性、また、内と外をちゃんと区別していとなんでいる東京の人の家庭の実体を見せつけられ、内も外も変りなく、ただのべつ幕無しに人間の生活から逃げ廻ってばかりいる薄馬鹿の自分ひとりだけ完全に取残され、堀木にさえ見捨てられたような気配に、狼狽《ろうばい》し、おしるこのはげた塗箸《ぬりばし》をあつかいながら、たまらなく侘《わ》びしい思いをしたという事を、記して置きたいだけなのです。+「わるいけど、おれは、きょうは用事があるんでね」+　堀木は立って、上衣を着ながらそう言い、+「失敬するぜ、わるいけど」+　その時、堀木に女の訪問者があり、自分の身の上も急転しました。+　堀木は、にわかに活気づいて、+「や、すみません。いまね、あなたのほうへお伺いしようと思っていたのですがね、このひとが突然やって来て、いや、かまわないんです。さあ、どうぞ」+　よほど、あわてているらしく、自分が自分の敷いている座蒲団をはずして裏がえしにして差し出したのを引ったくって、また裏がえしにして、その女のひとにすすめました。部屋には、堀木の座蒲団の他には、客座蒲団がたった一枚しか無かったのです。+　女のひとは痩《や》せて、脊の高いひとでした。その座蒲団は傍にのけて、入口ちかくの片隅に坐りました。+　自分は、ぼんやり二人の会話を聞いていました。女は雑誌社のひとのようで、堀木にカットだか、何だかをかねて頼んでいたらしく、それを受取りに来たみたいな具合いでした。+「いそぎますので」+「出来ています。もうとっくに出来ています。これです、どうぞ」+　電報が来ました。+　堀木が、それを読み、上機嫌のその顔がみるみる険悪になり、+「ちぇっ！　お前、こりゃ、どうしたんだい」+　ヒラメからの電報でした。+「とにかく、すぐに帰ってくれ。おれが、お前を送りとどけるといいんだろうが、おれにはいま、そんなひまは、無えや。家出していながら、その、のんきそうな面《つら》ったら」+「お宅は、どちらなのですか？」+「大久保です」+　ふいと答えてしまいました。+「そんなら、社の近くですから」+　女は、甲州の生れで二十八歳でした。五つになる女児と、高円寺のアパートに住んでいました。夫と死別して、三年になると言っていました。+「あなたは、ずいぶん苦労して育って来たみたいなひとね。よく気がきくわ。可哀そうに」+　はじめて、男めかけみたいな生活をしました。シヅ子（というのが、その女記者の名前でした）が新宿の雑誌社に勤めに出たあとは、自分とそれからシゲ子という五つの女児と二人、おとなしくお留守番という事になりました。それまでは、母の留守には、シゲ子はアパートの管理人の部屋で遊んでいたようでしたが、「気のきく」おじさんが遊び相手として現われたので、大いに御機嫌がいい様子でした。+　一週間ほど、ぼんやり、自分はそこにいました。アパートの窓のすぐ近くの電線に、奴凧《やっこだこ》が一つひっからまっていて、春のほこり風に吹かれ、破られ、それでもなかなか、しつっこく電線にからみついて離れず、何やら首肯《うなず》いたりなんかしているので、自分はそれを見る度毎に苦笑し、赤面し、夢にさえ見て、うなされました。+「お金が、ほしいな」+「……いくら位？」+「たくさん。……金の切れ目が、縁の切れ目、って、本当の事だよ」+「ばからしい。そんな、古くさい、……」+「そう？　しかし、君には、わからないんだ。このままでは、僕は、逃げる事になるかも知れない」+「いったい、どっちが貧乏なのよ。そうして、どっちが逃げるのよ。へんねえ」+「自分でかせいで、そのお金で、お酒、いや、煙草を買いたい。絵だって僕は、堀木なんかより、ずっと上手なつもりなんだ」+　このような時、自分の脳裡におのずから浮びあがって来るものは、あの中学時代に画いた竹一の所謂「お化け」の、数枚の自画像でした。失われた傑作。それは、たびたびの引越しの間に、失われてしまっていたのですが、あれだけは、たしかに優れている絵だったような気がするのです。その後、さまざま画いてみても、その思い出の中の逸品には、遠く遠く及ばず、自分はいつも、胸がからっぽになるような、だるい喪失感になやまされ続けて来たのでした。+　飲み残した一杯のアブサン。+　自分は、その永遠に償い難いような喪失感を、こっそりそう形容していました。絵の話が出ると、自分の眼前に、その飲み残した一杯のアブサンがちらついて来て、ああ、あの絵をこのひとに見せてやりたい、そうして、自分の画才を信じさせたい、という焦燥《しょうそう》にもだえるのでした。+「ふふ、どうだか。あなたは、まじめな顔をして冗談を言うから可愛い」+　冗談ではないのだ、本当なんだ、ああ、あの絵を見せてやりたい、と空転の煩悶《はんもん》をして、ふいと気をかえ、あきらめて、+「漫画さ。すくなくとも、漫画なら、堀木よりは、うまいつもりだ」+　その、ごまかしの道化の言葉のほうが、かえってまじめに信ぜられました。+「そうね。私も、実は感心していたの。シゲ子にいつもかいてやっている漫画、つい私まで噴き出してしまう。やってみたら、どう？　私の社の編輯長《へんしゅうちょう》に、たのんでみてあげてもいいわ」+　その社では、子供相手のあまり名前を知られていない月刊の雑誌を発行していたのでした。+　……あなたを見ると、たいていの女のひとは、何かしてあげたくて、たまらなくなる。……いつも、おどおどしていて、それでいて、滑稽家なんだもの。……時たま、ひとりで、ひどく沈んでいるけれども、そのさまが、いっそう女のひとの心を、かゆがらせる。+　シヅ子に、そのほかさまざまの事を言われて、おだてられても、それが即《すなわ》ち男めかけのけがらわしい特質なのだ、と思えば、それこそいよいよ「沈む」ばかりで、一向に元気が出ず、女よりは金、とにかくシヅ子からのがれて自活したいとひそかに念じ、工夫しているものの、かえってだんだんシヅ子にたよらなければならぬ破目になって、家出の後仕末やら何やら、ほとんど全部、この男まさりの甲州女の世話を受け、いっそう自分は、シヅ子に対し、所謂「おどおど」しなければならぬ結果になったのでした。+　シヅ子の取計らいで、ヒラメ、堀木、それにシヅ子、三人の会談が成立して、自分は、故郷から全く絶縁せられ、そうしてシヅ子と「天下晴れて」同棲《どうせい》という事になり、これまた、シヅ子の奔走のおかげで自分の漫画も案外お金になって、自分はそのお金で、お酒も、煙草も買いましたが、自分の心細さ、うっとうしさは、いよいよつのるばかりなのでした。それこそ「沈み」に「沈み」切って、シヅ子の雑誌の毎月の連載漫画「キンタさんとオタさんの冒険」を画いていると、ふいと故郷の家が思い出され、あまりの侘びしさに、ペンが動かなくなり、うつむいて涙をこぼした事もありました。+　そういう時の自分にとって、幽かな救いは、シゲ子でした。シゲ子は、その頃になって自分の事を、何もこだわらずに「お父ちゃん」と呼んでいました。+「お父ちゃん。お祈りをすると、神様が、何でも下さるって、ほんとう？」+　自分こそ、そのお祈りをしたいと思いました。+　ああ、われに冷き意志を与え給え。われに、「人間」の本質を知らしめ給え。人が人を押しのけても、罪ならずや。われに、怒りのマスクを与え給え。+「うん、そう。シゲちゃんには何でも下さるだろうけれども、お父ちゃんには、駄目かも知れない」+　自分は神にさえ、おびえていました。神の愛は信ぜられず、神の罰だけを信じているのでした。信仰。それは、ただ神の笞《むち》を受けるために、うなだれて審判の台に向う事のような気がしているのでした。地獄は信ぜられても、天国の存在は、どうしても信ぜられなかったのです。+「どうして、ダメなの？」+「親の言いつけに、そむいたから」+「そう？　お父ちゃんはとてもいいひとだって、みんな言うけどな」+　それは、だましているからだ、このアパートの人たち皆に、自分が好意を示されているのは、自分も知っている、しかし、自分は、どれほど皆を恐怖しているか、恐怖すればするほど好かれ、そうして、こちらは好かれると好かれるほど恐怖し、皆から離れて行かねばならぬ、この不幸な病癖を、シゲ子に説明して聞かせるのは、至難の事でした。+「シゲちゃんは、いったい、神様に何をおねだりしたいの？」+　自分は、何気無さそうに話頭を転じました。+「シゲ子はね、シゲ子の本当のお父ちゃんがほしいの」+　ぎょっとして、くらくら目まいしました。敵。自分がシゲ子の敵なのか、シゲ子が自分の敵なのか、とにかく、ここにも自分をおびやかすおそろしい大人がいたのだ、他人、不可解な他人、秘密だらけの他人、シゲ子の顔が、にわかにそのように見えて来ました。+　シゲ子だけは、と思っていたのに、やはり、この者も、あの「不意に虻《あぶ》を叩き殺す牛のしっぽ」を持っていたのでした。自分は、それ以来、シゲ子にさえおどおどしなければならなくなりました。+「色魔《しきま》！　いるかい？」+　堀木が、また自分のところへたずねて来るようになっていたのです。あの家出の日に、あれほど自分を淋しくさせた男なのに、それでも自分は拒否できず、幽かに笑って迎えるのでした。+「お前の漫画は、なかなか人気が出ているそうじゃないか。アマチュアには、こわいもの知らずの糞度胸《くそどきょう》があるからかなわねえ。しかし、油断するなよ。デッサンが、ちっともなってやしないんだから」+　お師匠みたいな態度をさえ示すのです。自分のあの「お化け」の絵を、こいつに見せたら、どんな顔をするだろう、とれいの空転の身悶《みもだ》えをしながら、+「それを言ってくれるな。ぎゃっという悲鳴が出る」+　堀木は、いよいよ得意そうに、+「世渡りの才能だけでは、いつかは、ボロが出るからな」+　世渡りの才能。……自分には、ほんとうに苦笑の他はありませんでした。自分に、世渡りの才能！　しかし、自分のように人間をおそれ、避け、ごまかしているのは、れいの俗諺《ぞくげん》の「さわらぬ神にたたりなし」とかいう怜悧《れいり》狡猾《こうかつ》の処生訓を遵奉しているのと、同じ形だ、という事になるのでしょうか。ああ、人間は、お互い何も相手をわからない、まるっきり間違って見ていながら、無二の親友のつもりでいて、一生、それに気附かず、相手が死ねば、泣いて弔詞なんかを読んでいるのではないでしょうか。+　堀木は、何せ、（それはシヅ子に押してたのまれてしぶしぶ引受けたに違いないのですが）自分の家出の後仕末に立ち合ったひとなので、まるでもう、自分の更生の大恩人か、月下氷人のように振舞い、もっともらしい顔をして自分にお説教めいた事を言ったり、また、深夜、酔っぱらって訪問して泊ったり、また、五円（きまって五円でした）借りて行ったりするのでした。+「しかし、お前の、女道楽もこのへんでよすんだね。これ以上は、世間が、ゆるさないからな」+　世間とは、いったい、何の事でしょう。人間の複数でしょうか。どこに、その世間というものの実体があるのでしょう。けれども、何しろ、強く、きびしく、こわいもの、とばかり思ってこれまで生きて来たのですが、しかし、堀木にそう言われて、ふと、+「世間というのは、君じゃないか」+　という言葉が、舌の先まで出かかって、堀木を怒らせるのがイヤで、ひっこめました。+（それは世間が、ゆるさない）+（世間じゃない。あなたが、ゆるさないのでしょう？）+（そんな事をすると、世間からひどいめに逢うぞ）+（世間じゃない。あなたでしょう？）+（いまに世間から葬られる）+（世間じゃない。葬むるのは、あなたでしょう？）+　汝《なんじ》は、汝個人のおそろしさ、怪奇、悪辣《あくらつ》、古狸《ふるだぬき》性、妖婆《ようば》性を知れ！　などと、さまざまの言葉が胸中に去来したのですが、自分は、ただ顔の汗をハンケチで拭いて、+「冷汗《ひやあせ》、冷汗」+　と言って笑っただけでした。+　けれども、その時以来、自分は、（世間とは個人じゃないか）という、思想めいたものを持つようになったのです。+　そうして、世間というものは、個人ではなかろうかと思いはじめてから、自分は、いままでよりは多少、自分の意志で動く事が出来るようになりました。シヅ子の言葉を借りて言えば、自分は少しわがままになり、おどおどしなくなりました。また、堀木の言葉を借りて言えば、へんにケチになりました。また、シゲ子の言葉を借りて言えば、あまりシゲ子を可愛がらなくなりました。+　無口で、笑わず、毎日々々、シゲ子のおもりをしながら、「キンタさんとオタさんの冒険」やら、またノンキなトウサンの歴然たる亜流の「ノンキ和尚《おしょう》」やら、また、「セッカチピンチャン」という自分ながらわけのわからぬヤケクソの題の連載漫画やらを、各社の御注文（ぽつりぽつり、シヅ子の社の他からも注文が来るようになっていましたが、すべてそれは、シヅ子の社よりも、もっと下品な謂わば三流出版社からの注文ばかりでした）に応じ、実に実に陰鬱な気持で、のろのろと、（自分の画の運筆は、非常におそいほうでした）いまはただ、酒代がほしいばかりに画いて、そうして、シヅ子が社から帰るとそれと交代にぷいと外へ出て、高円寺の駅近くの屋台やスタンド・バアで安くて強い酒を飲み、少し陽気になってアパートへ帰り、+「見れば見るほど、へんな顔をしているねえ、お前は。ノンキ和尚の顔は、実は、お前の寝顔からヒントを得たのだ」+「あなたの寝顔だって、ずいぶんお老けになりましてよ。四十男みたい」+「お前のせいだ。吸い取られたんだ。水の流れと、人の身はあサ。何をくよくよ川端やなあぎいサ」+「騒がないで、早くおやすみなさいよ。それとも、ごはんをあがりますか？」+　落ちついていて、まるで相手にしません。+「酒なら飲むがね。水の流れと、人の身はあサ。人の流れと、いや、水の流れえと、水の身はあサ」+　唄いながら、シヅ子に衣服をぬがせられ、シヅ子の胸に自分の額を押しつけて眠ってしまう、それが自分の日常でした。++［＃ここから２字下げ］+してその翌日《あくるひ》も同じ事を繰返して、+昨日《きのう》に異《かわ》らぬ慣例《しきたり》に従えばよい。+即ち荒っぽい大きな歓楽《よろこび》を避《よ》けてさえいれば、+自然また大きな悲哀《かなしみ》もやって来《こ》ないのだ。+ゆくてを塞《ふさ》ぐ邪魔な石を+蟾蜍《ひきがえる》は廻って通る。+［＃ここで字下げ終わり］++　上田敏訳のギイ・シャルル・クロオとかいうひとの、こんな詩句を見つけた時、自分はひとりで顔を燃えるくらいに赤くしました。+　蟾蜍。+（それが、自分だ。世間がゆるすも、ゆるさぬもない。葬むるも、葬むらぬもない。自分は、犬よりも猫よりも劣等な動物なのだ。蟾蜍。のそのそ動いているだけだ）+　自分の飲酒は、次第に量がふえて来ました。高円寺駅附近だけでなく、新宿、銀座のほうにまで出かけて飲み、外泊する事さえあり、ただもう「慣例《しきたり》」に従わぬよう、バアで無頼漢の振りをしたり、片端からキスしたり、つまり、また、あの情死以前の、いや、あの頃よりさらに荒《すさ》んで野卑な酒飲みになり、金に窮して、シヅ子の衣類を持ち出すほどになりました。+　ここへ来て、あの破れた奴凧に苦笑してから一年以上経って、葉桜の頃、自分は、またもシヅ子の帯やら襦袢《じゅばん》やらをこっそり持ち出して質屋に行き、お金を作って銀座で飲み、二晩つづけて外泊して、三日目の晩、さすがに具合い悪い思いで、無意識に足音をしのばせて、アパートのシヅ子の部屋の前まで来ると、中から、シヅ子とシゲ子の会話が聞えます。+「なぜ、お酒を飲むの？」+「お父ちゃんはね、お酒を好きで飲んでいるのでは、ないんですよ。あんまりいいひとだから、だから、……」+「いいひとは、お酒を飲むの？」+「そうでもないけど、……」+「お父ちゃんは、きっと、びっくりするわね」+「おきらいかも知れない。ほら、ほら、箱から飛び出した」+「セッカチピンチャンみたいね」+「そうねえ」+　シヅ子の、しんから幸福そうな低い笑い声が聞えました。+　自分が、ドアを細くあけて中をのぞいて見ますと、白兎の子でした。ぴょんぴょん部屋中を、はね廻り、親子はそれを追っていました。+（幸福なんだ、この人たちは。自分という馬鹿者が、この二人のあいだにはいって、いまに二人を滅茶苦茶にするのだ。つつましい幸福。いい親子。幸福を、ああ、もし神様が、自分のような者の祈りでも聞いてくれるなら、いちどだけ、生涯にいちどだけでいい、祈る）+　自分は、そこにうずくまって合掌したい気持でした。そっと、ドアを閉め、自分は、また銀座に行き、それっきり、そのアパートには帰りませんでした。+　そうして、京橋のすぐ近くのスタンド・バアの二階に自分は、またも男めかけの形で、寝そべる事になりました。+　世間。どうやら自分にも、それがぼんやりわかりかけて来たような気がしていました。個人と個人の争いで、しかも、その場の争いで、しかも、その場で勝てばいいのだ、人間は決して人間に服従しない［＃「人間は決して人間に服従しない」に傍点］、奴隷でさえ奴隷らしい卑屈なシッペがえしをするものだ、だから、人間にはその場の一本勝負にたよる他、生き伸びる工夫がつかぬのだ、大義名分らしいものを称《とな》えていながら、努力の目標は必ず個人、個人を乗り越えてまた個人、世間の難解は、個人の難解、大洋《オーシャン》は世間でなくて、個人なのだ、と世の中という大海の幻影におびえる事から、多少解放せられて、以前ほど、あれこれと際限の無い心遣いする事なく、謂わば差し当っての必要に応じて、いくぶん図々しく振舞う事を覚えて来たのです。+　高円寺のアパートを捨て、京橋のスタンド・バアのマダムに、+「わかれて来た」+　それだけ言って、それで充分、つまり一本勝負はきまって、その夜から、自分は乱暴にもそこの二階に泊り込む事になったのですが、しかし、おそろしい筈の「世間」は、自分に何の危害も加えませんでしたし、また自分も「世間」に対して何の弁明もしませんでした。マダムが、その気だったら、それですべてがいいのでした。+　自分は、その店のお客のようでもあり、亭主のようでもあり、走り使いのようでもあり、親戚の者のようでもあり、はたから見て甚《はなは》だ得態《えたい》の知れない存在だった筈なのに、「世間」は少しもあやしまず、そうしてその店の常連たちも、自分を、葉ちゃん、葉ちゃんと呼んで、ひどく優しく扱い、そうしてお酒を飲ませてくれるのでした。+　自分は世の中に対して、次第に用心しなくなりました。世の中というところは、そんなに、おそろしいところでは無い、と思うようになりました。つまり、これまでの自分の恐怖感は、春の風には百日咳《ひゃくにちぜき》の黴菌《ばいきん》が何十万、銭湯には、目のつぶれる黴菌が何十万、床屋には禿頭《とくとう》病の黴菌が何十万、省線の吊皮《つりかわ》には疥癬《かいせん》の虫がうようよ、または、おさしみ、牛豚肉の生焼けには、さなだ虫の幼虫やら、ジストマやら、何やらの卵などが必ずひそんでいて、また、はだしで歩くと足の裏からガラスの小さい破片がはいって、その破片が体内を駈けめぐり眼玉を突いて失明させる事もあるとかいう謂わば「科学の迷信」におびやかされていたようなものなのでした。それは、たしかに何十万もの黴菌の浮び泳ぎうごめいているのは、「科学的」にも、正確な事でしょう。と同時に、その存在を完全に黙殺さえすれば、それは自分とみじんのつながりも無くなってたちまち消え失せる「科学の幽霊」に過ぎないのだという事をも、自分は知るようになったのです。お弁当箱に食べ残しのごはん三粒、千万人が一日に三粒ずつ食べ残しても既にそれは、米何俵をむだに捨てた事になる、とか、或いは、一日に鼻紙一枚の節約を千万人が行うならば、どれだけのパルプが浮くか、などという「科学的統計」に、自分は、どれだけおびやかされ、ごはんを一粒でも食べ残す度毎に、また鼻をかむ度毎に、山ほどの米、山ほどのパルプを空費するような錯覚に悩み、自分がいま重大な罪を犯しているみたいな暗い気持になったものですが、しかし、それこそ「科学の嘘」「統計の嘘」「数学の嘘」で、三粒のごはんは集められるものでなく、掛算割算の応用問題としても、まことに原始的で低能なテーマで、電気のついてない暗いお便所の、あの穴に人は何度にいちど片脚を踏みはずして落下させるか、または、省線電車の出入口と、プラットホームの縁《へり》とのあの隙間に、乗客の何人中の何人が足を落とし込むか、そんなプロバビリティを計算するのと同じ程度にばからしく、それは如何《いか》にも有り得る事のようでもありながら、お便所の穴をまたぎそこねて怪我をしたという例は、少しも聞かないし、そんな仮説を「科学的事実」として教え込まれ、それを全く現実として受取り、恐怖していた昨日までの自分をいとおしく思い、笑いたく思ったくらいに、自分は、世の中というものの実体を少しずつ知って来たというわけなのでした。+　そうは言っても、やはり人間というものが、まだまだ、自分にはおそろしく、店のお客と逢うのにも、お酒をコップで一杯ぐいと飲んでからでなければいけませんでした。こわいもの見たさ。自分は、毎晩、それでもお店に出て、子供が、実は少しこわがっている小動物などを、かえって強くぎゅっと握ってしまうみたいに、店のお客に向って酔ってつたない芸術論を吹きかけるようにさえなりました。+　漫画家。ああ、しかし、自分は、大きな歓楽《よろこび》も、また、大きな悲哀《かなしみ》もない無名の漫画家。いかに大きな悲哀《かなしみ》があとでやって来てもいい、荒っぽい大きな歓楽《よろこび》が欲しいと内心あせってはいても、自分の現在のよろこびたるや、お客とむだ事を言い合い、お客の酒を飲む事だけでした。+　京橋へ来て、こういうくだらない生活を既に一年ちかく続け、自分の漫画も、子供相手の雑誌だけでなく、駅売りの粗悪で卑猥《ひわい》な雑誌などにも載るようになり、自分は、上司幾太（情死、生きた）という、ふざけ切った匿名で、汚いはだかの絵など画き、それにたいていルバイヤットの詩句を插入《そうにゅう》しました。++［＃ここから２字下げ］+無駄な御祈りなんか止《よ》せったら+涙を誘うものなんか　かなぐりすてろ+まア一杯いこう　好いことばかり思出して+よけいな心づかいなんか忘れっちまいな++不安や恐怖もて人を脅やかす奴輩《やから》は+自《みずから》の作りし大それた罪に怯《おび》え+死にしものの復讐《ふくしゅう》に備えんと+自《みずから》の頭にたえず計いを為《な》す++よべ　酒充ちて我ハートは喜びに充ち+けさ　さめて只《ただ》に荒涼+いぶかし　一夜《ひとよ》さの中+様変りたる此《この》気分よ++祟《たた》りなんて思うこと止《や》めてくれ+遠くから響く太鼓のように+何がなしそいつは不安だ+屁《へ》ひったこと迄《まで》一々罪に勘定されたら助からんわい++正義は人生の指針たりとや？+さらば血に塗られたる戦場に+暗殺者の切尖《きっさき》に+何の正義か宿れるや？++いずこに指導原理ありや？+いかなる叡智《えいち》の光ありや？+美《うる》わしくも怖《おそろ》しきは浮世なれ+かよわき人の子は背負切れぬ荷をば負わされ++どうにもできない情慾の種子を植えつけられた許《ばか》りに+善だ悪だ罪だ罰だと呪《のろ》わるるばかり+どうにもできない只まごつくばかり+抑え摧《くだ》く力も意志も授けられぬ許りに++どこをどう彷徨《うろつき》まわってたんだい+ナニ批判　検討　再認識？+ヘッ　空《むな》しき夢を　ありもしない幻を+エヘッ　酒を忘れたんで　みんな虚仮《こけ》の思案さ++どうだ　此｜涯《はて》もない大空を御覧よ+此中にポッチリ浮んだ点じゃい+此地球が何んで自転するのか分るもんか+自転　公転　反転も勝手ですわい++至る処《ところ》に　至高の力を感じ+あらゆる国にあらゆる民族に+同一の人間性を発見する+我は異端者なりとかや++みんな聖経をよみ違えてんのよ+でなきゃ常識も智慧《ちえ》もないのよ+生身《いきみ》の喜びを禁じたり　酒を止めたり+いいわ　ムスタッファ　わたしそんなの　大嫌い+［＃ここで字下げ終わり］++　けれども、その頃、自分に酒を止めよ、とすすめる処女がいました。+「いけないわ、毎日、お昼から、酔っていらっしゃる」+　バアの向いの、小さい煙草屋の十七、八の娘でした。ヨシちゃんと言い、色の白い、八重歯のある子でした。自分が、煙草を買いに行くたびに、笑って忠告するのでした。+「なぜ、いけないんだ。どうして悪いんだ。あるだけの酒をのんで、人の子よ、憎悪を消せ消せ消せ、ってね、むかしペルシャのね、まあよそう、悲しみ疲れたるハートに希望を持ち来すは、ただ微醺《びくん》をもたらす玉杯なれ、ってね。わかるかい」+「わからない」+「この野郎。キスしてやるぞ」+「してよ」+　ちっとも悪びれず下唇を突き出すのです。+「馬鹿野郎。貞操観念、……」+　しかし、ヨシちゃんの表情には、あきらかに誰にも汚されていない処女のにおいがしていました。+　としが明けて厳寒の夜、自分は酔って煙草を買いに出て、その煙草屋の前のマンホールに落ちて、ヨシちゃん、たすけてくれえ、と叫び、ヨシちゃんに引き上げられ、右腕の傷の手当を、ヨシちゃんにしてもらい、その時ヨシちゃんは、しみじみ、+「飲みすぎますわよ」+　と笑わずに言いました。+　自分は死ぬのは平気なんだけど、怪我をして出血してそうして不具者などになるのは、まっぴらごめんのほうですので、ヨシちゃんに腕の傷の手当をしてもらいながら、酒も、もういい加減によそうかしら、と思ったのです。+「やめる。あしたから、一滴も飲まない」+「ほんとう？」+「きっと、やめる。やめたら、ヨシちゃん、僕のお嫁になってくれるかい？」+　しかし、お嫁の件は冗談でした。+「モチよ」+　モチとは、「勿論」の略語でした。モボだの、モガだの、その頃いろんな略語がはやっていました。+「ようし。ゲンマンしよう。きっとやめる」+　そうして翌《あく》る日、自分は、やはり昼から飲みました。+　夕方、ふらふら外へ出て、ヨシちゃんの店の前に立ち、+「ヨシちゃん、ごめんね。飲んじゃった」+「あら、いやだ。酔った振りなんかして」+　ハッとしました。酔いもさめた気持でした。+「いや、本当なんだ。本当に飲んだのだよ。酔った振りなんかしてるんじゃない」+「からかわないでよ。ひとがわるい」+　てんで疑おうとしないのです。+「見ればわかりそうなものだ。きょうも、お昼から飲んだのだ。ゆるしてね」+「お芝居が、うまいのねえ」+「芝居じゃあないよ、馬鹿野郎。キスしてやるぞ」+「してよ」+「いや、僕には資格が無い。お嫁にもらうのもあきらめなくちゃならん。顔を見なさい、赤いだろう？　飲んだのだよ」+「それあ、夕陽が当っているからよ。かつごうたって、だめよ。きのう約束したんですもの。飲む筈が無いじゃないの。ゲンマンしたんですもの。飲んだなんて、ウソ、ウソ、ウソ」+　薄暗い店の中に坐って微笑しているヨシちゃんの白い顔、ああ、よごれを知らぬヴァジニティは尊いものだ、自分は今まで、自分よりも若い処女と寝た事がない、結婚しよう、どんな大きな悲哀《かなしみ》がそのために後からやって来てもよい、荒っぽいほどの大きな歓楽《よろこび》を、生涯にいちどでいい、処女性の美しさとは、それは馬鹿な詩人の甘い感傷の幻に過ぎぬと思っていたけれども、やはりこの世の中に生きて在るものだ、結婚して春になったら二人で自転車で青葉の滝を見に行こう、と、その場で決意し、所謂「一本勝負」で、その花を盗むのにためらう事をしませんでした。+　そうして自分たちは、やがて結婚して、それに依って得た歓楽《よろこび》は、必ずしも大きくはありませんでしたが、その後に来た悲哀《かなしみ》は、凄惨《せいさん》と言っても足りないくらい、実に想像を絶して、大きくやって来ました。自分にとって、「世の中」は、やはり底知れず、おそろしいところでした。決して、そんな一本勝負などで、何から何まできまってしまうような、なまやさしいところでも無かったのでした。+++［＃５字下げ］二［＃「二」は中見出し］++　堀木と自分。+　互いに軽蔑《けいべつ》しながら附き合い、そうして互いに自《みずか》らをくだらなくして行く、それがこの世の所謂「交友」というものの姿だとするなら、自分と堀木との間柄も、まさしく「交友」に違いありませんでした。+　自分があの京橋のスタンド・バアのマダムの義侠心《ぎきょうしん》にすがり、（女のひとの義侠心なんて、言葉の奇妙な遣い方ですが、しかし、自分の経験に依ると、少くとも都会の［＃「都会の」に傍点］男女の場合、男よりも女のほうが、その、義侠心とでもいうべきものをたっぷりと持っていました。男はたいてい、おっかなびっくりで、おていさいばかり飾り、そうして、ケチでした）あの煙草屋のヨシ子を内縁の妻にする事が出来て、そうして築地《つきじ》、隅田川の近く、木造の二階建ての小さいアパートの階下の一室を借り、ふたりで住み、酒は止めて、そろそろ自分の定った職業になりかけて来た漫画の仕事に精を出し、夕食後は二人で映画を見に出かけ、帰りには、喫茶店などにはいり、また、花の鉢を買ったりして、いや、それよりも自分をしんから信頼してくれているこの小さい花嫁の言葉を聞き、動作を見ているのが楽しく、これは自分もひょっとしたら、いまにだんだん人間らしいものになる事が出来て、悲惨な死に方などせずにすむのではなかろうかという甘い思いを幽かに胸にあたためはじめていた矢先に、堀木がまた自分の眼前に現われました。+「よう！　色魔。おや？　これでも、いくらか分別くさい顔になりやがった。きょうは、高円寺女史からのお使者なんだがね」+　と言いかけて、急に声をひそめ、お勝手でお茶の仕度をしているヨシ子のほうを顎《あご》でしゃくって、大丈夫かい？　とたずねますので、+「かまわない。何を言ってもいい」+　と自分は落ちついて答えました。+　じっさい、ヨシ子は、信頼の天才と言いたいくらい、京橋のバアのマダムとの間はもとより、自分が鎌倉で起した事件を知らせてやっても、ツネ子との間を疑わず、それは自分が嘘がうまいからというわけでは無く、時には、あからさまな言い方をする事さえあったのに、ヨシ子には、それがみな冗談としか聞きとれぬ様子でした。+「相変らず、しょっていやがる。なに、たいした事じゃないがね、たまには、高円寺のほうへも遊びに来てくれっていう御伝言さ」+　忘れかけると、怪鳥が羽ばたいてやって来て、記憶の傷口をその嘴《くちばし》で突き破ります。たちまち過去の恥と罪の記憶が、ありありと眼前に展開せられ、わあっと叫びたいほどの恐怖で、坐っておられなくなるのです。+「飲もうか」+　と自分。+「よし」+　と堀木。+　自分と堀木。形は、ふたり似ていました。そっくりの人間のような気がする事もありました。もちろんそれは、安い酒をあちこち飲み歩いている時だけの事でしたが、とにかく、ふたり顔を合せると、みるみる同じ形の同じ毛並の犬に変り降雪のちまたを駈けめぐるという具合いになるのでした。+　その日以来、自分たちは再び旧交をあたためたという形になり、京橋のあの小さいバアにも一緒に行き、そうして、とうとう、高円寺のシヅ子のアパートにもその泥酔の二匹の犬が訪問し、宿泊して帰るなどという事にさえなってしまったのです。+　忘れも、しません。むし暑い夏の夜でした。堀木は日暮頃、よれよれの浴衣を着て築地の自分のアパートにやって来て、きょう或る必要があって夏服を質入したが、その質入が老母に知れるとまことに具合いが悪い、すぐ受け出したいから、とにかく金を貸してくれ、という事でした。あいにく自分のところにも、お金が無かったので、例に依って、ヨシ子に言いつけ、ヨシ子の衣類を質屋に持って行かせてお金を作り、堀木に貸しても、まだ少し余るのでその残金でヨシ子に焼酎《しょうちゅう》を買わせ、アパートの屋上に行き、隅田川から時たま幽かに吹いて来るどぶ臭い風を受けて、まことに薄汚い納涼の宴を張りました。+　自分たちはその時、喜劇名詞、悲劇名詞の当てっこをはじめました。これは、自分の発明した遊戯で、名詞には、すべて男性名詞、女性名詞、中性名詞などの別があるけれども、それと同時に、喜劇名詞、悲劇名詞の区別があって然るべきだ、たとえば、汽船と汽車はいずれも悲劇名詞で、市電とバスは、いずれも喜劇名詞、なぜそうなのか、それのわからぬ者は芸術を談ずるに足らん、喜劇に一個でも悲劇名詞をさしはさんでいる劇作家は、既にそれだけで落第、悲劇の場合もまた然り、といったようなわけなのでした。+「いいかい？　煙草は？」+　と自分が問います。+「トラ。（悲劇《トラジディ》の略）」+　と堀木が言下に答えます。+「薬は？」+「粉薬かい？　丸薬かい？」+「注射」+「トラ」+「そうかな？　ホルモン注射もあるしねえ」+「いや、断然トラだ。針が第一、お前、立派なトラじゃないか」+「よし、負けて置こう。しかし、君、薬や医者はね、あれで案外、コメ（喜劇《コメディ》の略）なんだぜ。死は？」+「コメ。牧師も和尚《おしょう》も然りじゃね」+「大出来。そうして、生はトラだなあ」+「ちがう。それも、コメ」+「いや、それでは、何でもかでも皆コメになってしまう。ではね、もう一つおたずねするが、漫画家は？　よもや、コメとは言えませんでしょう？」+「トラ、トラ。大悲劇名詞！」+「なんだ、大トラは君のほうだぜ」+　こんな、下手な駄洒落《だじゃれ》みたいな事になってしまっては、つまらないのですけど、しかし自分たちはその遊戯を、世界のサロンにも嘗《か》つて存しなかった頗《すこぶ》る気のきいたものだと得意がっていたのでした。+　またもう一つ、これに似た遊戯を当時、自分は発明していました。それは、対義語《アントニム》の当てっこでした。黒のアント（対義語《アントニム》の略）は、白。けれども、白のアントは、赤。赤のアントは、黒。+「花のアントは？」+　と自分が問うと、堀木は口を曲げて考え、+「ええっと、花月という料理屋があったから、月だ」+「いや、それはアントになっていない。むしろ、同義語《シノニム》だ。星と菫《すみれ》だって、シノニムじゃないか。アントでない」+「わかった、それはね、蜂《はち》だ」+「ハチ？」+「牡丹《ぼたん》に、……蟻《あり》か？」+「なあんだ、それは画題《モチイフ》だ。ごまかしちゃいけない」+「わかった！　花にむら雲、……」+「月にむら雲だろう」+「そう、そう。花に風。風だ。花のアントは、風」+「まずいなあ、それは浪花節《なにわぶし》の文句じゃないか。おさとが知れるぜ」+「いや、琵琶《びわ》だ」+「なおいけない。花のアントはね、……およそこの世で最も花らしくないもの、それをこそ挙げるべきだ」+「だから、その、……待てよ、なあんだ、女か」+「ついでに、女のシノニムは？」+「臓物」+「君は、どうも、詩《ポエジイ》を知らんね。それじゃあ、臓物のアントは？」+「牛乳」+「これは、ちょっとうまいな。その調子でもう一つ。恥。オントのアント」+「恥知らずさ。流行漫画家上司幾太」+「堀木正雄は？」+　この辺から二人だんだん笑えなくなって、焼酎の酔い特有の、あのガラスの破片が頭に充満しているような、陰鬱な気分になって来たのでした。+「生意気言うな。おれはまだお前のように、繩目の恥辱など受けた事が無えんだ」+　ぎょっとしました。堀木は内心、自分を、真人間あつかいにしていなかったのだ、自分をただ、死にぞこないの、恥知らずの、阿呆のばけものの、謂《い》わば「生ける屍《しかばね》」としか解してくれず、そうして、彼の快楽のために、自分を利用できるところだけは利用する、それっきりの「交友」だったのだ、と思ったら、さすがにいい気持はしませんでしたが、しかしまた、堀木が自分をそのように見ているのも、もっともな話で、自分は昔から、人間の資格の無いみたいな子供だったのだ、やっぱり堀木にさえ軽蔑せられて至当なのかも知れない、と考え直し、+「罪。罪のアントニムは、何だろう。これは、むずかしいぞ」+　と何気無さそうな表情を装って、言うのでした。+「法律さ」+　堀木が平然とそう答えましたので、自分は堀木の顔を見直しました。近くのビルの明滅するネオンサインの赤い光を受けて、堀木の顔は、鬼刑事の如く威厳ありげに見えました。自分は、つくづく呆《あき》れかえり、+「罪ってのは、君、そんなものじゃないだろう」+　罪の対義語が、法律とは！　しかし、世間の人たちは、みんなそれくらいに簡単に考えて、澄まして暮しているのかも知れません。刑事のいないところにこそ罪がうごめいている、と。+「それじゃあ、なんだい、神か？　お前には、どこかヤソ坊主くさいところがあるからな。いや味だぜ」+「まあそんなに、軽く片づけるなよ。も少し、二人で考えて見よう。これはでも、面白いテーマじゃないか。このテーマに対する答一つで、そのひとの全部がわかるような気がするのだ」+「まさか。……罪のアントは、善さ。善良なる市民。つまり、おれみたいなものさ」+「冗談は、よそうよ。しかし、善は悪のアントだ。罪のアントではない」+「悪と罪とは違うのかい？」+「違う、と思う。善悪の概念は人間が作ったものだ。人間が勝手に作った道徳の言葉だ」+「うるせえなあ。それじゃ、やっぱり、神だろう。神、神。なんでも、神にして置けば間違いない。腹がへったなあ」+「いま、したでヨシ子がそら豆を煮ている」+「ありがてえ。好物だ」+　両手を頭のうしろに組んで、仰向《あおむけ》にごろりと寝ました。+「君には、罪というものが、まるで興味ないらしいね」+「そりゃそうさ、お前のように、罪人では無いんだから。おれは道楽はしても、女を死なせたり、女から金を巻き上げたりなんかはしねえよ」+　死なせたのではない、巻き上げたのではない、と心の何処《どこ》かで幽かな、けれども必死の抗議の声が起っても、しかし、また、いや自分が悪いのだとすぐに思いかえしてしまうこの習癖。+　自分には、どうしても、正面切っての議論が出来ません。焼酎の陰鬱な酔いのために刻一刻、気持が険しくなって来るのを懸命に抑えて、ほとんど独りごとのようにして言いました。+「しかし、牢屋《ろうや》にいれられる事だけが罪じゃないんだ。罪のアントがわかれば、罪の実体もつかめるような気がするんだけど、……神、……救い、……愛、……光、……しかし、神にはサタンというアントがあるし、救いのアントは苦悩だろうし、愛には憎しみ、光には闇というアントがあり、善には悪、罪と祈り、罪と悔い、罪と告白、罪と、……嗚呼《ああ》、みんなシノニムだ、罪の対語は何だ」+「ツミの対語は、ミツさ。蜜《みつ》の如く甘しだ。腹がへったなあ。何か食うものを持って来いよ」+「君が持って来たらいいじゃないか！」+　ほとんど生れてはじめてと言っていいくらいの、烈しい怒りの声が出ました。+「ようし、それじゃ、したへ行って、ヨシちゃんと二人で罪を犯して来よう。議論より実地検分。罪のアントは、蜜豆、いや、そら豆か」+　ほとんど、ろれつの廻らぬくらいに酔っているのでした。+「勝手にしろ。どこかへ行っちまえ！」+「罪と空腹、空腹とそら豆、いや、これはシノニムか」+　出鱈目《でたらめ》を言いながら起き上ります。+　罪と罰。ドストイエフスキイ。ちらとそれが、頭脳の片隅をかすめて通り、はっと思いました。もしも、あのドスト氏が、罪と罰をシノニムと考えず、アントニムとして置き並べたものとしたら？　罪と罰、絶対に相通ぜざるもの、氷炭｜相容《あいい》れざるもの。罪と罰をアントとして考えたドストの青みどろ、腐った池、乱麻の奥底の、……ああ、わかりかけた、いや、まだ、……などと頭脳に走馬燈がくるくる廻っていた時に、+「おい！　とんだ、そら豆だ。来い！」+　堀木の声も顔色も変っています。堀木は、たったいまふらふら起きてしたへ行った、かと思うとまた引返して来たのです。+「なんだ」+　異様に殺気立ち、ふたり、屋上から二階へ降り、二階から、さらに階下の自分の部屋へ降りる階段の中途で堀木は立ち止り、+「見ろ！」+　と小声で言って指差します。+　自分の部屋の上の小窓があいていて、そこから部屋の中が見えます。電気がついたままで、二匹の動物がいました。+　自分は、ぐらぐら目まいしながら、これもまた人間の姿だ、これもまた人間の姿だ、おどろく事は無い、など劇《はげ》しい呼吸と共に胸の中で呟《つぶや》き、ヨシ子を助ける事も忘れ、階段に立ちつくしていました。+　堀木は、大きい咳《せき》ばらいをしました。自分は、ひとり逃げるようにまた屋上に駈け上り、寝ころび、雨を含んだ夏の夜空を仰ぎ、そのとき自分を襲った感情は、怒りでも無く、嫌悪でも無く、また、悲しみでも無く、もの凄《すさ》まじい恐怖でした。それも、墓地の幽霊などに対する恐怖ではなく、神社の杉木立で白衣の御神体に逢った時に感ずるかも知れないような、四の五の言わさぬ古代の荒々しい恐怖感でした。自分の若白髪は、その夜からはじまり、いよいよ、すべてに自信を失い、いよいよ、ひとを底知れず疑い、この世の営みに対する一さいの期待、よろこび、共鳴などから永遠にはなれるようになりました。実に、それは自分の生涯に於いて、決定的な事件でした。自分は、まっこうから眉間《みけん》を割られ、そうしてそれ以来その傷は、どんな人間にでも接近する毎に痛むのでした。+「同情はするが、しかし、お前もこれで、少しは思い知ったろう。もう、おれは、二度とここへは来ないよ。まるで、地獄だ。……でも、ヨシちゃんは、ゆるしてやれ。お前だって、どうせ、ろくな奴じゃないんだから。失敬するぜ」+　気まずい場所に、永くとどまっているほど間《ま》の抜けた堀木ではありませんでした。+　自分は起き上って、ひとりで焼酎を飲み、それから、おいおい声を放って泣きました。いくらでも、いくらでも泣けるのでした。+　いつのまにか、背後に、ヨシ子が、そら豆を山盛りにしたお皿を持ってぼんやり立っていました。+「なんにも、しないからって言って、……」+「いい。何も言うな。お前は、ひとを疑う事を知らなかったんだ。お坐り。豆を食べよう」+　並んで坐って豆を食べました。嗚呼、信頼は罪なりや？　相手の男は、自分に漫画をかかせては、わずかなお金をもったい振って置いて行く三十歳前後の無学な小男の商人なのでした。+　さすがにその商人は、その後やっては来ませんでしたが、自分には、どうしてだか、その商人に対する憎悪よりも、さいしょに見つけたすぐその時に大きい咳ばらいも何もせず、そのまま自分に知らせにまた屋上に引返して来た堀木に対する憎しみと怒りが、眠られぬ夜などにむらむら起って呻《うめ》きました。+　ゆるすも、ゆるさぬもありません。ヨシ子は信頼の天才なのです。ひとを疑う事を知らなかったのです。しかし、それゆえの悲惨。+　神に問う。信頼は罪なりや。+　ヨシ子が汚されたという事よりも、ヨシ子の信頼が汚されたという事が、自分にとってそののち永く、生きておられないほどの苦悩の種になりました。自分のような、いやらしくおどおどして、ひとの顔いろばかり伺い、人を信じる能力が、ひび割れてしまっているものにとって、ヨシ子の無垢《むく》の信頼心は、それこそ青葉の滝のようにすがすがしく思われていたのです。それが一夜で、黄色い汚水に変ってしまいました。見よ、ヨシ子は、その夜から自分の一顰《いっぴん》一笑にさえ気を遣うようになりました。+「おい」+　と呼ぶと、ぴくっとして、もう眼のやり場に困っている様子です。どんなに自分が笑わせようとして、お道化を言っても、おろおろし、びくびくし、やたらに自分に敬語を遣うようになりました。+　果して、無垢の信頼心は、罪の原泉なりや。+　自分は、人妻の犯された物語の本を、いろいろ捜して読んでみました。けれども、ヨシ子ほど悲惨な犯され方をしている女は、ひとりも無いと思いました。どだい、これは、てんで物語にも何もなりません。あの小男の商人と、ヨシ子とのあいだに、少しでも恋に似た感情でもあったなら、自分の気持もかえってたすかるかも知れませんが、ただ、夏の一夜、ヨシ子が信頼して、そうして、それっきり、しかもそのために自分の眉間は、まっこうから割られ声が嗄れて若白髪がはじまり、ヨシ子は一生おろおろしなければならなくなったのです。たいていの物語は、その妻の「行為」を夫が許すかどうか、そこに重点を置いていたようでしたが、それは自分にとっては、そんなに苦しい大問題では無いように思われました。許す、許さぬ、そのような権利を留保している夫こそ幸いなる哉《かな》、とても許す事が出来ぬと思ったなら、何もそんなに大騒ぎせずとも、さっさと妻を離縁して、新しい妻を迎えたらどうだろう、それが出来なかったら、所謂《いわゆる》「許して」我慢するさ、いずれにしても夫の気持一つで四方八方がまるく収るだろうに、という気さえするのでした。つまり、そのような事件は、たしかに夫にとって大いなるショックであっても、しかし、それは「ショック」であって、いつまでも尽きること無く打ち返し打ち寄せる波と違い、権利のある夫の怒りでもってどうにでも処理できるトラブルのように自分には思われたのでした。けれども、自分たちの場合、夫に何の権利も無く、考えると何もかも自分がわるいような気がして来て、怒るどころか、おこごと一つも言えず、また、その妻は、その所有している稀《まれ》な美質に依って犯されたのです。しかも、その美質は、夫のかねてあこがれの、無垢の信頼心というたまらなく可憐《かれん》なものなのでした。+　無垢の信頼心は、罪なりや。+　唯一のたのみの美質にさえ、疑惑を抱き、自分は、もはや何もかも、わけがわからなくなり、おもむくところは、ただアルコールだけになりました。自分の顔の表情は極度にいやしくなり、朝から焼酎を飲み、歯がぼろぼろに欠けて、漫画もほとんど猥画《わいが》に近いものを画くようになりました。いいえ、はっきり言います。自分はその頃から、春画のコピイをして密売しました。焼酎を買うお金がほしかったのです。いつも自分から視線をはずしておろおろしているヨシ子を見ると、こいつは全く警戒を知らぬ女だったから、あの商人といちどだけでは無かったのではなかろうか、また、堀木は？　いや、或いは自分の知らない人とも？　と疑惑は疑惑を生み、さりとて思い切ってそれを問い正す勇気も無く、れいの不安と恐怖にのたうち廻る思いで、ただ焼酎を飲んで酔っては、わずかに卑屈な誘導｜訊問《じんもん》みたいなものをおっかなびっくり試み、内心おろかしく一喜一憂し、うわべは、やたらにお道化て、そうして、それから、ヨシ子にいまわしい地獄の愛撫《あいぶ》を加え、泥のように眠りこけるのでした。+　その年の暮、自分は夜おそく泥酔して帰宅し、砂糖水を飲みたく、ヨシ子は眠っているようでしたから、自分でお勝手に行き砂糖壺を捜し出し、ふたを開けてみたら砂糖は何もはいってなくて、黒く細長い紙の小箱がはいっていました。何気なく手に取り、その箱にはられてあるレッテルを見て愕然《がくぜん》としました。そのレッテルは、爪で半分以上も掻《か》きはがされていましたが、洋字の部分が残っていて、それにはっきり書かれていました。ＤＩＡＬ。+　ジアール。自分はその頃もっぱら焼酎で、催眠剤を用いてはいませんでしたが、しかし、不眠は自分の持病のようなものでしたから、たいていの催眠剤にはお馴染《なじ》みでした。ジアールのこの箱一つは、たしかに致死量以上の筈でした。まだ箱の封を切ってはいませんでしたが、しかし、いつかは、やる気で［＃「やる気で」に傍点］こんなところに、しかもレッテルを掻きはがしたりなどして隠していたのに違いありません。可哀想に、あの子にはレッテルの洋字が読めないので、爪で半分掻きはがして、これで大丈夫と思っていたのでしょう。（お前に罪は無い）+　自分は、音を立てないようにそっとコップに水を満たし、それから、ゆっくり箱の封を切って、全部、一気に口の中にほうり、コップの水を落ちついて飲みほし、電燈を消してそのまま寝ました。+　三昼夜、自分は死んだようになっていたそうです。医者は過失と見なして、警察にとどけるのを猶予してくれたそうです。覚醒《かくせい》しかけて、一ばんさきに呟いたうわごとは、うちへ帰る、という言葉だったそうです。うちとは、どこの事を差して言ったのか、当の自分にも、よくわかりませんが、とにかく、そう言って、ひどく泣いたそうです。+　次第に霧がはれて、見ると、枕元にヒラメが、ひどく不機嫌な顔をして坐っていました。+「このまえも、年の暮の事でしてね、お互いもう、目が廻るくらいいそがしいのに、いつも、年の暮をねらって、こんな事をやられたひには、こっちの命がたまらない」+　ヒラメの話の聞き手になっているのは、京橋のバアのマダムでした。+「マダム」+　と自分は呼びました。+「うん、何？　気がついた？」+　マダムは笑い顔を自分の顔の上にかぶせるようにして言いました。+　自分は、ぽろぽろ涙を流し、+「ヨシ子とわかれさせて」+　自分でも思いがけなかった言葉が出ました。+　マダムは身を起し、幽かな溜息をもらしました。+　それから自分は、これもまた実に思いがけない滑稽とも阿呆らしいとも、形容に苦しむほどの失言をしました。+「僕は、女のいないところに行くんだ」+　うわっはっは、とまず、ヒラメが大声を挙げて笑い、マダムもクスクス笑い出し、自分も涙を流しながら赤面の態《てい》になり、苦笑しました。+「うん、そのほうがいい」+　とヒラメは、いつまでもだらし無く笑いながら、+「女のいないところに行ったほうがよい。女がいると、どうもいけない。女のいないところとは、いい思いつきです」+　女のいないところ。しかし、この自分の阿呆くさいうわごとは、のちに到って、非常に陰惨に実現せられました。+　ヨシ子は、何か、自分がヨシ子の身代りになって毒を飲んだとでも思い込んでいるらしく、以前よりも尚《なお》いっそう、自分に対して、おろおろして、自分が何を言っても笑わず、そうしてろくに口もきけないような有様なので、自分もアパートの部屋の中にいるのが、うっとうしく、つい外へ出て、相変らず安い酒をあおる事になるのでした。しかし、あのジアールの一件以来、自分のからだがめっきり痩《や》せ細って、手足がだるく、漫画の仕事も怠けがちになり、ヒラメがあの時、見舞いとして置いて行ったお金（ヒラメはそれを、渋田の志です、と言っていかにもご自身から出たお金のようにして差出しましたが、これも故郷の兄たちからのお金のようでした。自分もその頃には、ヒラメの家から逃げ出したあの時とちがって、ヒラメのそんなもったい振った芝居を、おぼろげながら見抜く事が出来るようになっていましたので、こちらもずるく、全く気づかぬ振りをして、神妙にそのお金のお礼をヒラメに向って申し上げたのでしたが、しかし、ヒラメたちが、なぜ、そんなややこしいカラクリをやらかすのか、わかるような、わからないような、どうしても自分には、へんな気がしてなりませんでした）そのお金で、思い切ってひとりで南伊豆の温泉に行ってみたりなどしましたが、とてもそんな悠長な温泉めぐりなど出来る柄《がら》ではなく、ヨシ子を思えば侘《わ》びしさ限りなく、宿の部屋から山を眺めるなどの落ちついた心境には甚だ遠く、ドテラにも着換えず、お湯にもはいらず、外へ飛び出しては薄汚い茶店みたいなところに飛び込んで、焼酎を、それこそ浴びるほど飲んで、からだ具合いを一そう悪くして帰京しただけの事でした。+　東京に大雪の降った夜でした。自分は酔って銀座裏を、ここはお国を何百里、ここはお国を何百里、と小声で繰り返し繰り返し呟くように歌いながら、なおも降りつもる雪を靴先で蹴散《けち》らして歩いて、突然、吐きました。それは自分の最初の喀血《かっけつ》でした。雪の上に、大きい日の丸の旗が出来ました。自分は、しばらくしゃがんで、それから、よごれていない個所の雪を両手で掬《すく》い取って、顔を洗いながら泣きました。+　こうこは、どうこの細道じゃ？+　こうこは、どうこの細道じゃ？+　哀れな童女の歌声が、幻聴のように、かすかに遠くから聞えます。不幸。この世には、さまざまの不幸な人が、いや、不幸な人ばかり、と言っても過言ではないでしょうが、しかし、その人たちの不幸は、所謂世間に対して堂々と抗議が出来、また「世間」もその人たちの抗議を容易に理解し同情します。しかし、自分の不幸は、すべて自分の罪悪からなので、誰にも抗議の仕様が無いし、また口ごもりながら一言でも抗議めいた事を言いかけると、ヒラメならずとも世間の人たち全部、よくもまあそんな口がきけたものだと呆《あき》れかえるに違いないし、自分はいったい俗にいう「わがままもの」なのか、またはその反対に、気が弱すぎるのか、自分でもわけがわからないけれども、とにかく罪悪のかたまりらしいので、どこまでも自《おのずか》らどんどん不幸になるばかりで、防ぎ止める具体策など無いのです。+　自分は立って、取り敢えず何か適当な薬をと思い、近くの薬屋にはいって、そこの奥さんと顔を見合せ、瞬間、奥さんは、フラッシュを浴びたみたいに首をあげ眼を見はり、棒立ちになりました。しかし、その見はった眼には、驚愕の色も嫌悪の色も無く、ほとんど救いを求めるような、慕うような色があらわれているのでした。ああ、このひとも、きっと不幸な人なのだ、不幸な人は、ひとの不幸にも敏感なものなのだから、と思った時、ふと、その奥さんが松葉杖《まつばづえ》をついて危かしく立っているのに気がつきました。駈け寄りたい思いを抑えて、なおもその奥さんと顔を見合せているうちに涙が出て来ました。すると、奥さんの大きい眼からも、涙がぽろぽろとあふれて出ました。+　それっきり、一言も口をきかずに、自分はその薬屋から出て、よろめいてアパートに帰り、ヨシ子に塩水を作らせて飲み、黙って寝て、翌る日も、風邪気味だと嘘をついて一日一ぱい寝て、夜、自分の秘密の喀血がどうにも不安でたまらず、起きて、あの薬屋に行き、こんどは笑いながら、奥さんに、実に素直に今迄のからだ具合いを告白し、相談しました。+「お酒をおよしにならなければ」+　自分たちは、肉身のようでした。+「アル中になっているかも知れないんです。いまでも飲みたい」+「いけません。私の主人も、テーベのくせに、菌を酒で殺すんだなんて言って、酒びたりになって、自分から寿命をちぢめました」+「不安でいけないんです。こわくて、とても、だめなんです」+「お薬を差し上げます。お酒だけは、およしなさい」+　奥さん（未亡人で、男の子がひとり、それは千葉だかどこだかの医大にはいって、間もなく父と同じ病いにかかり、休学入院中で、家には中風の舅《しゅうと》が寝ていて、奥さん自身は五歳の折、小児｜痲痺《まひ》で片方の脚が全然だめなのでした）は、松葉杖をコトコトと突きながら、自分のためにあっちの棚、こっちの引出し、いろいろと薬品を取そろえてくれるのでした。+　これは、造血剤。+　これは、ヴィタミンの注射液。注射器は、これ。+　これは、カルシウムの錠剤。胃腸をこわさないように、ジアスターゼ。+　これは、何。これは、何、と五、六種の薬品の説明を愛情こめてしてくれたのですが、しかし、この不幸な奥さんの愛情もまた、自分にとって深すぎました。最後に奥さんが、これは、どうしても、なんとしてもお酒を飲みたくて、たまらなくなった時のお薬、と言って素早く紙に包んだ小箱。+　モルヒネの注射液でした。+　酒よりは、害にならぬと奥さんも言い、自分もそれを信じて、また一つには、酒の酔いもさすがに不潔に感ぜられて来た矢先でもあったし、久し振りにアルコールというサタンからのがれる事の出来る喜びもあり、何の躊躇《ちゅうちょ》も無く、自分は自分の腕に、そのモルヒネを注射しました。不安も、焦燥《しょうそう》も、はにかみも、綺麗《きれい》に除去せられ、自分は甚だ陽気な能弁家になるのでした。そうして、その注射をすると自分は、からだの衰弱も忘れて、漫画の仕事に精が出て、自分で画きながら噴き出してしまうほど珍妙な趣向が生れるのでした。+　一日一本のつもりが、二本になり、四本になった頃には、自分はもうそれが無ければ、仕事が出来ないようになっていました。+「いけませんよ、中毒になったら、そりゃもう、たいへんです」+　薬屋の奥さんにそう言われると、自分はもう可成りの中毒患者になってしまったような気がして来て、（自分は、ひとの暗示に実にもろくひっかかるたちなのです。このお金は使っちゃいけないよ、と言っても、お前の事だものなあ、なんて言われると、何だか使わないと悪いような、期待にそむくような、へんな錯覚が起って、必ずすぐにそのお金を使ってしまうのでした）その中毒の不安のため、かえって薬品をたくさん求めるようになったのでした。+「たのむ！　もう一箱。勘定は月末にきっと払いますから」+「勘定なんて、いつでもかまいませんけど、警察のほうが、うるさいのでねえ」+　ああ、いつでも自分の周囲には、何やら、濁って暗く、うさん臭い日蔭者の気配がつきまとうのです。+「そこを何とか、ごまかして、たのむよ、奥さん。キスしてあげよう」+　奥さんは、顔を赤らめます。+　自分は、いよいよつけ込み、+「薬が無いと仕事がちっとも、はかどらないんだよ。僕には、あれは強精剤みたいなものなんだ」+「それじゃ、いっそ、ホルモン注射がいいでしょう」+「ばかにしちゃいけません。お酒か、そうでなければ、あの薬か、どっちかで無ければ仕事が出来ないんだ」+「お酒は、いけません」+「そうでしょう？　僕はね、あの薬を使うようになってから、お酒は一滴も飲まなかった。おかげで、からだの調子が、とてもいいんだ。僕だって、いつまでも、下手くそな漫画などをかいているつもりは無い、これから、酒をやめて、からだを直して、勉強して、きっと偉い絵画きになって見せる。いまが大事なところなんだ。だからさ、ね、おねがい。キスしてあげようか」+　奥さんは笑い出し、+「困るわねえ。中毒になっても知りませんよ」+　コトコトと松葉杖の音をさせて、その薬品を棚から取り出し、+「一箱は、あげられませんよ。すぐ使ってしまうのだもの。半分ね」+「ケチだなあ、まあ、仕方が無いや」+　家へ帰って、すぐに一本、注射をします。+「痛くないんですか？」+　ヨシ子は、おどおど自分にたずねます。+「それあ痛いさ。でも、仕事の能率をあげるためには、いやでもこれをやらなければいけないんだ。僕はこの頃、とても元気だろう？　さあ、仕事だ。仕事、仕事」+　とはしゃぐのです。+　深夜、薬屋の戸をたたいた事もありました。寝巻姿で、コトコト松葉杖をついて出て来た奥さんに、いきなり抱きついてキスして、泣く真似をしました。+　奥さんは、黙って自分に一箱、手渡しました。+　薬品もまた、焼酎同様、いや、それ以上に、いまわしく不潔なものだと、つくづく思い知った時には、既に自分は完全な中毒患者になっていました。真に、恥知らずの極《きわみ》でした。自分はその薬品を得たいばかりに、またも春画のコピイをはじめ、そうして、あの薬屋の不具の奥さんと文字どおりの醜関係をさえ結びました。+　死にたい、いっそ、死にたい、もう取返しがつかないんだ、どんな事をしても、何をしても、駄目になるだけなんだ、恥の上塗りをするだけなんだ、自転車で青葉の滝など、自分には望むべくも無いんだ、ただけがらわしい罪にあさましい罪が重なり、苦悩が増大し強烈になるだけなんだ、死にたい、死ななければならぬ、生きているのが罪の種なのだ、などと思いつめても、やっぱり、アパートと薬屋の間を半狂乱の姿で往復しているばかりなのでした。+　いくら仕事をしても、薬の使用量もしたがってふえているので、薬代の借りがおそろしいほどの額にのぼり、奥さんは、自分の顔を見ると涙を浮べ、自分も涙を流しました。+　地獄。+　この地獄からのがれるための最後の手段、これが失敗したら、あとはもう首をくくるばかりだ、という神の存在を賭《か》けるほどの決意を以《もっ》て、自分は、故郷の父あてに長い手紙を書いて、自分の実情一さいを（女の事は、さすがに書けませんでしたが）告白する事にしました。+　しかし、結果は一そう悪く、待てど暮せど何の返事も無く、自分はその焦燥と不安のために、かえって薬の量をふやしてしまいました。+　今夜、十本、一気に注射し、そうして大川に飛び込もうと、ひそかに覚悟を極めたその日の午後、ヒラメが、悪魔の勘で嗅《か》ぎつけたみたいに、堀木を連れてあらわれました。+「お前は、喀血したんだってな」+　堀木は、自分の前にあぐらをかいてそう言い、いままで見た事も無いくらいに優しく微笑《ほほえ》みました。その優しい微笑が、ありがたくて、うれしくて、自分はつい顔をそむけて涙を流しました。そうして彼のその優しい微笑一つで、自分は完全に打ち破られ、葬り去られてしまったのです。+　自分は自動車に乗せられました。とにかく入院しなければならぬ、あとは自分たちにまかせなさい、とヒラメも、しんみりした口調で、（それは慈悲深いとでも形容したいほど、もの静かな口調でした）自分にすすめ、自分は意志も判断も何も無い者の如く、ただメソメソ泣きながら唯々諾々と二人の言いつけに従うのでした。ヨシ子もいれて四人、自分たちは、ずいぶん永いこと自動車にゆられ、あたりが薄暗くなった頃、森の中の大きい病院の、玄関に到着しました。+　サナトリアムとばかり思っていました。+　自分は若い医師のいやに物やわらかな、鄭重《ていちょう》な診察を受け、それから医師は、+「まあ、しばらくここで静養するんですね」+　と、まるで、はにかむように微笑して言い、ヒラメと堀木とヨシ子は、自分ひとりを置いて帰ることになりましたが、ヨシ子は着換の衣類をいれてある風呂敷包を自分に手渡し、それから黙って帯の間から注射器と使い残りのあの薬品を差し出しました。やはり、強精剤だとばかり思っていたのでしょうか。+「いや、もう要らない」+　実に、珍らしい事でした。すすめられて、それを拒否したのは、自分のそれまでの生涯に於いて、その時ただ一度、といっても過言でないくらいなのです。自分の不幸は、拒否の能力の無い者の不幸でした。すすめられて拒否すると、相手の心にも自分の心にも、永遠に修繕し得ない白々しいひび割れが出来るような恐怖におびやかされているのでした。けれども、自分はその時、あれほど半狂乱になって求めていたモルヒネを、実に自然に拒否しました。ヨシ子の謂わば「神の如き無智」に撃たれたのでしょうか。自分は、あの瞬間、すでに中毒でなくなっていたのではないでしょうか。+　けれども、自分はそれからすぐに、あのはにかむような微笑をする若い医師に案内せられ、或る病棟にいれられて、ガチャンと鍵《かぎ》をおろされました。脳病院でした。+　女のいないところへ行くという、あのジアールを飲んだ時の自分の愚かなうわごとが、まことに奇妙に実現せられたわけでした。その病棟には、男の狂人ばかりで、看護人も男でしたし、女はひとりもいませんでした。+　いまはもう自分は、罪人どころではなく、狂人でした。いいえ、断じて自分は狂ってなどいなかったのです。一瞬間といえども、狂った事は無いんです。けれども、ああ、狂人は、たいてい自分の事をそう言うものだそうです。つまり、この病院にいれられた者は気違い、いれられなかった者は、ノーマルという事になるようです。+　神に問う。無抵抗は罪なりや？+　堀木のあの不思議な美しい微笑に自分は泣き、判断も抵抗も忘れて自動車に乗り、そうしてここに連れて来られて、狂人という事になりました。いまに、ここから出ても、自分はやっぱり狂人、いや、癈人《はいじん》という刻印を額に打たれる事でしょう。+　人間、失格。+　もはや、自分は、完全に、人間で無くなりました。+　ここへ来たのは初夏の頃で、鉄の格子の窓から病院の庭の小さい池に紅《あか》い睡蓮の花が咲いているのが見えましたが、それから三つき経ち、庭にコスモスが咲きはじめ、思いがけなく故郷の長兄が、ヒラメを連れて自分を引き取りにやって来て、父が先月末に胃潰瘍《いかいよう》でなくなったこと、自分たちはもうお前の過去は問わぬ、生活の心配もかけないつもり、何もしなくていい、その代り、いろいろ未練もあるだろうがすぐに東京から離れて、田舎で療養生活をはじめてくれ、お前が東京でしでかした事の後仕末は、だいたい渋田がやってくれた筈だから、それは気にしないでいい、とれいの生真面目な緊張したような口調で言うのでした。+　故郷の山河が眼前に見えるような気がして来て、自分は幽かにうなずきました。+　まさに癈人。+　父が死んだ事を知ってから、自分はいよいよ腑抜《ふぬ》けたようになりました。父が、もういない、自分の胸中から一刻も離れなかったあの懐しくおそろしい存在が、もういない、自分の苦悩の壺がからっぽになったような気がしました。自分の苦悩の壺がやけに重かったのも、あの父のせいだったのではなかろうかとさえ思われました。まるで、張合いが抜けました。苦悩する能力をさえ失いました。+　長兄は自分に対する約束を正確に実行してくれました。自分の生れて育った町から汽車で四、五時間、南下したところに、東北には珍らしいほど暖かい海辺の温泉地があって、その村はずれの、間数は五つもあるのですが、かなり古い家らしく壁は剥《は》げ落ち、柱は虫に食われ、ほとんど修理の仕様も無いほどの茅屋《ぼうおく》を買いとって自分に与え、六十に近いひどい赤毛の醜い女中をひとり附けてくれました。+　それから三年と少し経ち、自分はその間にそのテツという老女中に数度へんな犯され方をして、時たま夫婦｜喧嘩《げんか》みたいな事をはじめ、胸の病気のほうは一進一退、痩せたりふとったり、血痰《けったん》が出たり、きのう、テツにカルモチンを買っておいで、と言って、村の薬屋にお使いにやったら、いつもの箱と違う形の箱のカルモチンを買って来て、べつに自分も気にとめず、寝る前に十錠のんでも一向に眠くならないので、おかしいなと思っているうちに、おなかの具合がへんになり急いで便所へ行ったら猛烈な下痢で、しかも、それから引続き三度も便所にかよったのでした。不審に堪えず、薬の箱をよく見ると、それはヘノモチンという下剤でした。+　自分は仰向けに寝て、おなかに湯たんぽを載せながら、テツにこごとを言ってやろうと思いました。+「これは、お前、カルモチンじゃない。ヘノモチン、という」+　と言いかけて、うふふふと笑ってしまいました。「癈人」は、どうやらこれは、喜劇名詞のようです。眠ろうとして下剤を飲み、しかも、その下剤の名前は、ヘノモチン。+　いまは自分には、幸福も不幸もありません。+　ただ、一さいは過ぎて行きます。+　自分がいままで阿鼻叫喚で生きて来た所謂「人間」の世界に於いて、たった一つ、真理［＃「真理」に傍点］らしく思われたのは、それだけでした。+　ただ、一さいは過ぎて行きます。+　自分はことし、二十七になります。白髪がめっきりふえたので、たいていの人から、四十以上に見られます。+［＃改頁］++++［＃３字下げ］あとがき［＃「あとがき」は大見出し］+++　この手記を書き綴った狂人を、私は、直接には知らない。けれども、この手記に出て来る京橋のスタンド・バアのマダムともおぼしき人物を、私はちょっと知っているのである。小柄で、顔色のよくない、眼が細く吊《つ》り上っていて、鼻の高い、美人というよりは、美青年といったほうがいいくらいの固い感じのひとであった。この手記には、どうやら、昭和五、六、七年、あの頃の東京の風景がおもに写されているように思われるが、私が、その京橋のスタンド・バアに、友人に連れられて二、三度、立ち寄り、ハイボールなど飲んだのは、れいの日本の「軍部」がそろそろ露骨にあばれはじめた昭和十年前後の事であったから、この手記を書いた男には、おめにかかる事が出来なかったわけである。+　然るに、ことしの二月、私は千葉県船橋市に疎開している或る友人をたずねた。その友人は、私の大学時代の謂わば学友で、いまは某女子大の講師をしているのであるが、実は私はこの友人に私の身内の者の縁談を依頼していたので、その用事もあり、かたがた何か新鮮な海産物でも仕入れて私の家の者たちに食わせてやろうと思い、リュックサックを背負って船橋市へ出かけて行ったのである。+　船橋市は、泥海に臨んだかなり大きいまちであった。新住民たるその友人の家は、その土地の人に所番地を告げてたずねても、なかなかわからないのである。寒い上に、リュックサックを背負った肩が痛くなり、私はレコードの提琴の音にひかれて、或る喫茶店のドアを押した。+　そこのマダムに見覚えがあり、たずねてみたら、まさに、十年前のあの京橋の小さいバアのマダムであった。マダムも、私をすぐに思い出してくれた様子で、互いに大袈裟《おおげさ》に驚き、笑い、それからこんな時のおきまりの、れいの、空襲で焼け出されたお互いの経験を問われもせぬのに、いかにも自慢らしく語り合い、+「あなたは、しかし、かわらない」+「いいえ、もうお婆さん。からだが、がたぴしです。あなたこそ、お若いわ」+「とんでもない、子供がもう三人もあるんだよ。きょうはそいつらのために買い出し」+　などと、これもまた久し振りで逢った者同志のおきまりの挨拶を交し、それから、二人に共通の知人のその後の消息をたずね合ったりして、そのうちに、ふとマダムは口調を改め、あなたは葉ちゃんを知っていたかしら、と言う。それは知らない、と答えると、マダムは、奥へ行って、三冊のノートブックと、三葉の写真を持って来て私に手渡し、+「何か、小説の材料になるかも知れませんわ」+　と言った。+　私は、ひとから押しつけられた材料でものを書けないたちなので、すぐにその場でかえそうかと思ったが、（三葉の写真、その奇怪さに就いては、はしがきにも書いて置いた）その写真に心をひかれ、とにかくノートをあずかる事にして、帰りにはまたここへ立ち寄りますが、何町何番地の何さん、女子大の先生をしているひとの家をご存じないか、と尋ねると、やはり新住民同志、知っていた。時たま、この喫茶店にもお見えになるという。すぐ近所であった。+　その夜、友人とわずかなお酒を汲《く》み交し、泊めてもらう事にして、私は朝まで一睡もせずに、れいのノートに読みふけった。+　その手記に書かれてあるのは、昔の話ではあったが、しかし、現代の人たちが読んでも、かなりの興味を持つに違いない。下手に私の筆を加えるよりは、これはこのまま、どこかの雑誌社にたのんで発表してもらったほうが、なお、有意義な事のように思われた。+　子供たちへの土産の海産物は、干物《ひもの》だけ。私は、リュックサックを背負って友人の許《もと》を辞し、れいの喫茶店に立ち寄り、+「きのうは、どうも。ところで、……」+　とすぐに切り出し、+「このノートは、しばらく貸していただけませんか」+「ええ、どうぞ」+「このひとは、まだ生きているのですか？」+「さあ、それが、さっぱりわからないんです。十年ほど前に、京橋のお店あてに、そのノートと写真の小包が送られて来て、差し出し人は葉ちゃんにきまっているのですが、その小包には、葉ちゃんの住所も、名前さえも書いていなかったんです。空襲の時、ほかのものにまぎれて、これも不思議にたすかって、私はこないだはじめて、全部読んでみて、……」+「泣きましたか？」+「いいえ、泣くというより、……だめね、人間も、ああなっては、もう駄目ね」+「それから十年、とすると、もう亡くなっているかも知れないね。これは、あなたへのお礼のつもりで送ってよこしたのでしょう。多少、誇張して書いているようなところもあるけど、しかし、あなたも、相当ひどい被害をこうむったようですね。もし、これが全部事実だったら、そうして僕がこのひとの友人だったら、やっぱり脳病院に連れて行きたくなったかも知れない」+「あのひとのお父さんが悪いのですよ」+　何気なさそうに、そう言った。+「私たちの知っている葉ちゃんは、とても素直で、よく気がきいて、あれでお酒さえ飲まなければ、いいえ、飲んでも、……神様みたいないい子でした」
+ benchmark/Streamly/Benchmark/Unicode/data/Korean.txt view
@@ -0,0 +1,493 @@+야구+위키백과, 우리 모두의 백과사전. + 이동: 둘러보기, 찾기 ++야구+일리노이 주 시카고의 리글리 필드 경기 장면+최고 기구	국제 야구 연맹+별칭	하드볼+기원	18세기 중반 잉글랜드 (초기 형태)+ 1846년 6월 19일 미국+뉴저지 주 호보컨 (공식 경기)+특징+팀 인원수	9명+분류	실외, 필드, 구기+장비	야구공, 야구 방망이, 글러브+경기장	야구장+올림픽	1992년~2008년+ 야구 경기+야구(野球, baseball)는 각각 아홉 또는 열 명으로 구성된 두 팀이 방망이와 공을 사용해 겨루는 구기 종목이다. 야구의 목표는 공을 방망이(배트)로 맞추어, 한 변이 27.432 미터(90 피트)인 정사각형의 각 꼭지점에 놓여 있는 루(壘, Base)를 밟은 뒤 마지막으로 본루(本壘, Home Plate)를 밟아서 득점하는 것이다.[1] [2]공격 팀은 아홉 타자가 순서대로 나와서 수비 팀의 투수가 던지는 공을 쳐서 다이아몬드의 각 루를 밟은 뒤 홈에 들어와야 하며, 동시에 수비 팀은 공격 팀의 타자들이나 주자들을 여러 가지 방법을 통해 아웃시켜서 공격 팀이 득점을 못 하도록 막아야 한다. 공격 팀의 타자들은 동료가 안타(간혹 2루타, 3루타를 치는 경우가 있으며 외야 펜스를 넘기거나 아웃 당하기 전에 홈으로 돌아오면 홈런이 된다)를 쳤을 경우 원하는 루에 멈춰서거나 홈으로 들어와 득점할 수 있다. 공격 팀이 아웃 세 번을 기록할 경우 수비 팀은 공격 팀으로, 공격 팀은 수비 팀으로 바뀐다. 이 세 번의 아웃을 이닝(Inning, 회)이라고 부르며, 프로 게임에서 한 경기는 아홉 개의 이닝으로 구성된다. 마지막 이닝이 끝날 때 더 많은 득점을 한 팀이 이기게 된다. 공격과 수비가 완전히 분리된 스포츠이다.+프로 야구, 아마추어 야구, 청소년 야구는 북아메리카, 중앙아메리카, 남아메리카, 카리브 제도의 여러 국가들, 동아시아, 동남아시아 국가들에서 인기가 있다. 야구의 근대적인 틀은 19세기 북아메리카에서 만들어졌다. 역사학자들은 야구의 원형은 북미 대륙에 건너 온 영국, 아일랜드 이민자들이 가지고 들어 온, 크리켓이나 라운더스와 같이 공과 방망이를 사용하는 구기 경기에서 시작되었다는 데 의견을 함께한다. 19세기 후반 야구는 미국의 국기(國技)로 널리 인정받게 되었다.목차  [숨기기] +1 야구의 명칭+2 야구의 역사 +2.1 야구의 기원+2.2 미국에서의 발전+2.3 세계의 야구 +2.3.1 한국+3 야구 규칙과 경기 진행 +3.1 경기 용구+3.2 포지션+3.3 아웃+3.4 진루+4 야구의 인원 +4.1 선수 명단+4.2 그 외+5 야구의 기본기와 전술 +5.1 기본기+5.2 전술+6 야구의 고유한 스타일 +6.1 시간적 요소+6.2 개인과 팀+7 경기장+8 기록+9 야구 단체 및 주요 대회 +9.1 국제 야구 단체+9.2 야구 대회+9.3 야구 리그+10 같이 보기+11 참고 문헌+12 주석+13 바깥 고리++[편집]+야구의 명칭+ + 주만 가나에++야구의 명칭의 유래는 1894년 일본 제일고등중학교(현 도쿄 대학 교양학부)에서 재학중이던 주만 가나에가 'baseball'을 일본어 '野球(や-きゅう)'로 번역한 것이 대한민국으로 들어와 사용되고 있는 것이다. 그 외에도 일본의 문학가 마사오카 시키가 '배터(batter)', '러너(runner)', '베이스 온 볼스(base on balls)', '스트레이트(straight)', '쇼트스톱(shortstop)' 등의 미국식 야구용어를 '타자', '주자', '사구 (四球)대한민국에선 사구 대신 볼넷으로 사용)', '직구'(대한민국에서는 포심 속구, 투심, 컷 패스트볼로 부름.) '유격수'로 번역한 것이 대한민국에 들어와 쓰이고 있다.[3] 때때로 야구를 비슷한 경기인 소프트볼(softball)에 대비하여 하드볼(hardball)로 부르기도 한다.+[편집]+야구의 역사+ 이 부분의 본문은 야구의 역사입니다.+[편집]+야구의 기원++야구의 기원은 확실하게 짚어내기가 힘들다. 1344년에 출간된 프랑스의 한 책에 성직자들이 야구와 흡사한 라 술(La soule)이라는 게임을 즐기는 모습을 담은 삽화가 실려있다.[4] 원래 야구는 미국의 애브너 더블데이라는 군인 출신의 인물이 1839년에 쿠퍼스타운에서 창안했다고 알려졌다. 하지만 그가 직접 야구를 창안했다는 구체적인 증거가 없으며, 광산 기술자 출신의 애브너 그레이브스의 증언이 있었으나 별로 신뢰하기 어렵기 때문에 야구는 유럽에서 미국으로 전해진 것으로 추측된다.[5]++방망이와 공을 이용한 경기는 이미 오래 전부터 리디아인, 페르시아인, 인도인, 이집트인, 그리스인, 로마인 등에 의해 의식이나 오락으로 행해졌다. 이런 경기들은 정해진 규칙없이 여러 지역에서 행해졌다. 이런 여러가지 배트와 공을 이용하는 경기를 통해서 야구는 두드러진 발전을 할 수 있었다. 이런 발전을 통해서 1774년에 독일에서 프리드리히 구츠무츠가 존 뉴베리에서 출간한 《작고 귀여운 포켓북》(A Little Pretty Pocket-book)이라는 시집에서는 최초로 'Base-ball'이라는 단어가 들어가기도 했다.[6]++방망이와 공을 이용해 하는 경기는 영국에서 여러 가지 종류로 발전하는데, 영국 동남부에서는 크리켓으로, 남서부에서는 원홀 캣(또는 원 오캣)의 이름으로 발전했으며, 야구와 흡사한 경기인 라운더스도 있었다. 이런 종류의 경기들은 아메리카 대륙으로 옮겨와 두가지 형태로 진화했는데, 뉴욕 주변에서 행해진 타운볼은 각각 9명의 선수로 이루어진 두 팀이 하는 경기로 정비되었다.+ + 알렉산더 카트라이트++루셔스 애덤스등은 야구의 기본적인 규칙을 확립했다. 특히 1845년에는, 미국 뉴욕의 알렉산더 카트라이트가 니커보커 규칙을 만들었으며, 이 규칙은 오늘날 현대 야구의 규칙으로 진화하게 된다.[7] 그는 또한 라운더스에서 사용되었던 말랑말랑한 공을 더 작지만 딱딱한 공으로 교체했다.[8] 1953년 6월 3일, 미국 의회는 공식적으로 카트라이트가 근대 야구의 발명가임을 인정했다.++카트라이트가 소속된 구단인 뉴욕 니커보커스 팀이 1845년에 경기를 했다는 기록이 있기는 하지만, 미국의 역사상 공식적인 첫 경기로 현재 알려지고 있는 것은 1846년 6월 19일 뉴저지 주의 '호보켄'에서,[9] '뉴욕 나인'[10]이 '니커보커스' 팀을 4이닝 동안 23 대 1로 이긴 경기이다.[11]+[편집]+미국에서의 발전++1860년대 이미 미국에서는 야구가 대중적인 스포츠로 자리 잡았으며 선수들은 연봉을 받고 생활하는 프로 선수였으나 아마추어 선수처럼 생활해야 했다. 아마추어 시대는 1871년 3월 17일, 전미프로야구선수협회가 창설됨으로써 그 막을 내렸다. 1869년, 최초의 프로 야구 팀 신시내티 레드 스타킹스(Cincinnati Red Stockings)가 창단 되었으며 1875년에는 내셔널 리그(연봉 상한제 있음)가 창설되었다. 1882년에는 아메리칸 어소시에이션(American Association)이 창설되었고 1901년에는 이를 전신으로 하는 아메리칸 리그(연봉이 무제한임)가 창설되어 양대 리그체제를 갖추게 되었다. 1903년에는 양 리그의 우승 팀간의 승자를 겨루는 월드 시리즈(여기에서 월드(World)는 "월드신문사"의 이름으로써 신문사에서 스폰서를 해주기 때문에 월드시리즈라는 이름이 쓰인다고 한다)가 처음으로 치러졌으며, 1933년에는 올스타전이 처음으로 치러졌다.[12]++이후 많은 제도의 발전이 있었다. 브랜치 리키는 1920년에 대규모의 팜 시스템(Farm System)을 도입했다[13] 1975년에는 커드 플러드 등 여러 선수들의 희생으로 자유 계약 제도가 도입 되었다. 1980년에는 선수협 위원들이 구단주를 상대로 고소를 함으로써 연봉 상한선이 폐지되는 등 선수들의 권익이 향상되었다.[14]+ + 재키 로빈슨++메이저 리그 야구에서는 1947년 이전까지 흑인이 선수로 활동하지 못했다. 그 대신 흑인들은 1920년에 설립된 니그로 리그에서 선수로 뛰었고, 1924년에는 최초의 니그로 월드 시리즈가 치러졌다. 메이저 리그 야구에서 흑인이 최초로 선수로 뛴 것은 1947년으로, 재키 로빈슨은 로스앤젤레스 다저스에 입단해 10년간 팀에 몸담았으며, 1962년에는 명예의 전당에 헌액된 최초의 흑인이 되었다.[15]++투수는 1960년대에서 1970년대 초반까지 경기에서 타석에 섰다. 1970년대 초반, 지명타자(designated hitter, DH) 규칙이 제안되었으며,[16] 아메리칸 리그에서는 1973년 이 규칙이 적용되기 시작해 투수가 타석에 서지 않게 되었고 지명타자는 타석에만 서면서 수비는 하지 않았다. 내셔널 리그에서는 지금도 투수가 타석에 선다.++메이저 리그 야구는 1980년대 초반까지 불법이었던 약물 복용이 흔했고, 이 시기가 되어서야 알려졌다. 또한 여러 선수들이 약물로 인해 사망했다. 1990년대 초반부터는 선수들이 근육강화제를 사용했으며, 이 때문에 2005년 3월 17일, 미국 의회는 스테로이드 사용에 관한 청문회가 열렸다. 이 때문에 메이저 리그 야구는 2006년부터 약물 복용이 처음 발각 되었을 때에는 50경기, 두 번째에는 100경기, 세 번째로 발각이 되면 영구 제명이 된다는 '삼진 아웃' 제도를 적용하기 시작했다.[17]++메이저 리그 야구는 점점 미국 전역으로 확대 되었는데, 팀이 미국 동부에서 서부로 많이 옮겨갔으며, 캐나다에서도 1969년 몬트리올 엑스포스(현 워싱턴 내셔널스)가, 1977년 토론토 블루제이스가 리그에 참가했다.[18] 현재는 내셔널 리그 16팀, 아메리칸 리그 14팀으로 팀 수 (목표는 모든 리그 16팀씩 32팀)가 유지가 되고 있으며, 경기 수는 한 시즌 당 162경기로 치러진다.+[편집]+세계의 야구+ + 야구의 픽토그램.++야구는 미국의 대표적인 스포츠 중 하나며, 다른 여러 나라에서도 팬들의 지지에 기반한 야구 체계가 갖추어져 있다. 캐나다 야구의 역사는 미국과 밀접하게 관련이 있는데, 1877년 프로리그와 국제 협회에서 두 나라로 이루어진 특색있는 팀을 만들기도 했었다.++세계적으로 미국과 캐나다가 아닌 다른 공식적 첫 야구 리그는 쿠바의 야구 리그이다. 쿠바는 오랜 전통을 유지하며 1930년대 후반부터 국제 경기에서 막강한 전력을 자랑하는 팀이라는 명예를 얻게 된다.++쿠바의 야구 리그가 만들어진 후 프로 리그가 생긴 국가는 다음과 같다. 제1차 세계 대전 후에 프로 리그가 만들어진 국가는 1922년 네덜란드, 1934년 오스트레일리아, 1936년 일본, 1938년 푸에르토 리코이며, 제2차 세계대전 이후에 프로 리그가 만들어진 국가는 1948년 이탈리아, 많은 라틴 아메리카의 나라들 중 가장 두드러진 나라, 1945년 베네수엘라, 1945년 멕시코, 1951년 도미니카 공화국과 1982년 대한민국, 1990년 타이완, 2003년 중국 순으로 만들어졌다. 2009년 현재, 국제 야구 연맹에는 현재 117개국이 가입했다.[19]++현재 야구는 미국, 일본, 대한민국 의 국가에서 가장 인기있는 스포츠 중 하나이다. MLB의 겨울 리그 프로그램으로 푸에르토 리코, 베네수엘라, 도미니카 공화국, 오스트레일리아에 겨울 리그가 존재하고, 멕시코는 MLB 하위 Triple-A 에서 리그 참여를 하고있다. MLB 는 푸에르토 리코, 베네수엘라, 도미니카 공화국,멕시코 가 참여하는 캐러비언 시리즈를 4년에 한번씩 개최하고 있다. 또한 이탈리아, 네덜란드, 중국, 타이완, 니카라과 에도 대회가 존재한다.++공식적 첫 야구 리그 였던 쿠바의 야구 리그는 1961년 쿠바 혁명으로 폐지 되었다. 자세한 내용은 하위항목 야구 리그 참조.++한편 2005년 7월 싱가포르에서 열린 2012년 하계 올림픽에 관한 117번째 회의에서 야구, 소프트볼 종목 삭제에 관한 투표가 진행되어 2012년 하계 올림픽에서 야구, 소프트볼 종목을 제외시키기로 결정했다. 이는 메이저 리거들이 출전하지 않기 때문이다.[20]. 또한 2009년 8월 회의에서 2016년 하계 올림픽 에도 야구 종목을 제외하기로 결정했다. 이 회의에서는 빅스타 선수가 참여하는 8팀, 짧은 5일 간의 경기 방식으로 바꾸라고 요구했다.[21]+[편집]+한국++한국에 야구가 처음 들어온 것은 1905년으로, 당시 선교사로 온 미국인 질레트(P. L. Gillett)가 황성기독교청년회 회원들에게 야구를 가르친 것이 그 시초이다. 1906년 2월 11일 훈련원 터에서 YMCA팀 대 덕어(독일어)학교팀 사이에 최초의 야구경기가 열렸다. 《황성신문》1909년 3월 21일자엔 이러한 〈야구단 운동가〉라는 노래가 소개돼 있을 정도로 야구는 큰 인기를 누렸다: "무쇠 골격 돌 근육 소년 남아야/애국의 정신을 분발하여라/다달았네 다달았네 우리나라에/소년의 활동 시대 다달았네 /(후렴) 만인 대적(對敵) 연습하여 후일 전공 세우세/절세 영웅 대사업이 우리 목적이 아닌가" [22]+[편집]+야구 규칙과 경기 진행+ + 야구 경기장의 구조+ 이 부분의 본문은 야구 규칙입니다.++야구 경기는 두 팀이 서로 겨루는데, 경기가 진행되는 동안에 두 팀은 공격과 수비를 번갈아 가면서 진행한다. 그리고 공격 팀이 공격을 진행하면서 세 번의 아웃을 기록하면 공격 팀은 수비 팀으로, 수비 팀은 공격 팀으로 바뀐다. 그리고 이 세 번의 아웃을 이닝(inning, 회)이라고 하며, 일반적인 경기는 9이닝으로 구성되어 진행된다. 그리고 한 이닝은 초(初, 선공)와 말(末, 후공)로 구성된다. 그리고 한 이닝에 두 팀은 공격과 수비를 번갈아 가면서 경기를 진행하는데, 한 팀, 주로 홈팀이 말에 공격하며, 다른 한 팀, 주로 원정팀이 초에 공격한다. 야구 경기의 목표는 경기를 치르면서 상대 팀보다 더 많은 점수(득점)를 얻어 승리하는 것이다. 공격하는 팀의 선수들은 사각형 형태의 내야 다이아몬드 꼭지점에 있는 네 개의 베이스를 돌면 득점을 할 수 있다. 타자는 홈플레이트에서 타격을 하며 누상에 출루하고서는 반드시 시계반대방향으로 1루, 2루, 3루, 그리고 홈플레이트를 거쳐야 하며, 홈을 밟으면 득점이 된다. 반면 필드에서 수비를 보는 다른 팀은 아웃을 잡고 공격 팀이 점수를 내는 것을 막아야 한다. 아웃을 잡힌 선수는 배팅 오더에 따라 자신의 차례가 돌아올 때까지 공격을 할 수 없다. 세 개의 아웃카운트가 채워지면, 양 팀은 공격과 수비 역할을 교대하는 공수교대를 하며, 경기는 초에서 말로, 말에서 초로 바뀌게 된다. 9이닝동안 경기가 진행되다가 9회가 다 끝나도 점수가 같을 경우에는 연장전을 치뤄 승부를 낸다. 어린이 야구에서는 9이닝보다 적은 이닝으로 경기가 이루어지는게 보통이다.[23]+[편집]+경기 용구+ 이 부분의 본문은 야구의 경기 용구입니다.++야구를 하기 위해서 기본적으로 필요한 것은 방망이, 야구공, 글러브, 야구 경기를 치를 수 있는 경기장이 필요하다.+방망이는 공격을 할 때 필요한 도구로, 보통 알루미늄이나 목재로 만든다. 배트는 길고 딱딱한 나무 막대기이고, 손잡이 부분을 제외하고 지름은 약 2인치(5 센티미터)이다. 손잡이 부분은 지름이 약 1인치(2.5 센티미터)이다.+야구공은 한 주먹 정도의 크기이고 빨간색 실이 들어간 흰색(다른 색일 수도 있다) 공이다. 소프트볼의 경우, 보통 주먹 두 개 정도 크기의 흰색 줄무늬가 있는 흰색이나 노랑색 공을 사용한다.+글러브 또는 미트는 수비할 때 필요한 도구로, 가죽으로 만들어졌으며, 선수의 손에 착용한다. 글러브의 모양은 사용하는 선수의 포지션에 따라 조금씩 다르다.+야구의 경기장은 선수의 나이, 능력에 따라서 크기가 달라진다. 하지만 모든 야구장은 다이아몬드와 모서리, 베이스(루) + 야구공+가 있으며, 같은 방식의 경기를 진행한다. 경기장은 크게 내야와 외야로 구별된다.  + 야구공+[편집]+포지션+ 이 부분의 본문은 야구의 포지션입니다.+ + 야구의 포지션++이닝에서, 수비를 할 때 9명의 수비수들은 각자의 수비 위치에 선다. 다이아몬드의 중심의 투수판에 서 있는 선수를 투수라고 하며, 그리고 홈 플레이트 뒤에 앉아 있는 선수를 포수라고 하는데 이 둘을 배터리라고 부른다. 나머지 수비수들은 야수라고 부르는데 야수는 위치에 따라 내야수와 외야수로 분류되며 내야 안에 있는 4명의 수비수들을 내야수라고 한다. 내야수 중 3명은 1, 2, 3루에 서 있는데 이들은 각각 1루수, 2루수, 3루수라고 말하며 각 루와 그 주변을 수비하는 역할을 한다. 나머지 한명은 유격수로, 2루와 3루 사이의 서면서 그 사이를 수비한다. 그리고 나머지 3명의 선수는 외야에 서는데, 이들을 외야수라고 하며, 위치에 따라 좌익수(왼쪽), 중견수(가운데), 우익수(오른쪽)로 구분해서 부른다.++지명타자는 공격만 하고 수비는 하지 않는데, 이는 투수를 보호하기 위해 고안된 규칙으로 지명타자는 투수 대신 공격을 한다.++경기에서 홈플레이트 옆에 있는 타석에 서 공격을 하려는 선수를 '타자'라고 부르며, 타자는 배트를 잡고 있으며, 투수가 투수판에서 홈플레이트 쪽으로 공을 던지면 타자는 배트로 공을 쳐서 점수를 내려고 한다. 타자가 공을 치고 난 후에 타자는 배트를 놓고 1루를 향해 달려간다. 그리고 상황에 따라 2, 3루, 홈까지 갈 수 있다. 아웃이 된 경우에는 덕아웃으로 돌아간다.++투수는 타자가 베이스에 나가지 못하게 막기 위해 투수판에서 공을 던지는데, 공을 어디에 던지느냐에 따라 '스트라이크'(strike)와 '볼'(ball)로 구별된다. 타자는 스트라이크가 3개가 되면 아웃되지만, 볼이 4개가 되면 1루로 나갈 수 있다.++스트라이크를 던지는 방법은 다음과 같다.+투수가 공을 던졌는데 스트라이크 존(strike zone)을 통과한 경우.+타자가 공을 보고 방망이를 휘둘렀으나 맞지 않은 경우.(헛스윙)+타자가 공을 쳤으나 파울 라인이나 파울 폴(foul pole)을 기준으로 필드 바깥쪽으로 공이 날아간 경우. 이 경우를 파울(foul) 이라고 한다. 하지만 2 스트라이크 상태에서 파울이 된 경우에는 스트라이크가 추가되지 않는다.+[편집]+아웃+타자가 친 공이 노바운드(친 공이 땅에 떨어지지 않는상태)로 야수들의 글러브나 미트에 들어간 경우.+스트라이크를 3번 허용한 경우(스윙이나 그냥 보거만 있거나 스트라이크 존 안에서 몸에 맞거나).+2스트라이크 상황에서 번트가 파울이 된 경우(스리번트 아웃).+타자가 친 공을 야수가 잡은 후 타자가 1루에 닿기 전에 1루수에게 던진 후 잡은 경우.+타자가 친 공을 야수가 잡은 후 타자가 1루에 닿기 전에 1루수에게 던진 후 잡은 공으로 타자를 태그 하는 경우.+타자가 친 공을 야수가 잡은 후 주자를 태그한 경우.+타자가 친 공을 야수가 잡은 후 주자가 진루할 루로 가서 포스아웃 하는 경우 +(단, 포스아웃 당할 주자의 원래의 루로 다음 주자 혹은 타자가 주루해야 하는 경우.).+타자가 친 공에 주자가 맞은 경우.+타자가 2루타 이상의 장타를 쳤는데 베이스를 밟지 않고 진루한 때 수비측이 그에 대해 어필(항의)을 한 경우(누의 공과).+2스트라이크 상황에서 타자가 공에 맞았지만 배트를 휘두른 경우.+타자가 친 공을 노바운드로 야수가 잡은 후, 주자가 원래의 루에 귀루하여 터치하지 않고 진루했을 때 주자나 베이스를 공으로 터치한 경우 +(이 경우 포스아웃이 아닌 어필아웃이다).+타자가 친 공이 야수가 충분히 노바운드로 잡을 수 있다고 판단한 경우에 관중들이 공을 잡은 경우.+노아웃이나 1아웃 주자 1,2루나 만루일때, 타자가 친 공이 내야수들이 충분히 잡을 수 있는 내야안의 경우라 판단 될 경우 (인필드 플라이).+타자가 공을 쳤고 수비수가 충분히 잡을 수 있는데 주자 혹은 타자가 쳐서 수비방해한 경우.+타순이 엉켜서 상대편이 어필한 경우.(예를들어 3번타자가 나와야 할 때 4번타자가 나와서 타격을 해서 안타 등이 나왔는데 어필하면 3번타자는 아웃이고 4번타자는 다시 쳐야 한다.)+2스트라이크 이후에 투수가 던진 공이 스트라이크 선언되거나 타자가 헛스윙을 하였는데 포수가 노바운드로 잡지 못하여 공을 타자에게 태그하거나 타자가 1루 베이스를 밟기 전에 1루에 던진 경우. (스트라이크 아웃 낫아웃)+노아웃 혹은 1아웃에서 1루 주자가 있을때 제3스트라이크가 선언되었으면 스트라이크 아웃 낫아웃이 적용되지 않고 그대로 스트라이크 아웃이 된다.+주자가 선행주자를 추월한 경우+주자나 타자가 태그를 피하기 위해 루와 루사이를 연결하는 가상의 직선에서 91.4cm 이상 떨어져 주루했을때 (타구를 처리하는 야수를 피해 달린것은 상관없다.) (스리피트라인 아웃)+2스트라이크 상황에서 주자가 번트를 시도하여 친공이 파울라인밖으로 나갈경우+[편집]+진루++타자 또는 주자가 자신의 다음 베이스(타자의 경우에는 1루) 또는 그 이상에서 세이프되는 것을 진루라고 한다.+안타 : 히트(Hit)라고도 한다. 인플레이 상황에서 타구가 수비수가 잡을 수 없는 곳으로 갔을 때 안타라고 하며, 잡을 수 있는 공을 놓칠 때는 실책이라고 한다. 타자가 친 공이 땅바닥에 튀기지 않고 담장을 넘어가면 전광판에 안타라고 표시되지만, 주로 홈런이라고 하며, 모든 루를 돌아 홈플레이트를 밟고 득점할 수 있다.+볼넷 : 몸쪽에서 나간 공(볼)이 4개일 경우 진루하는 것을 말한다.+야수 선택 (필더스 초이스) : 야수의 기술적 실책이 아니라 두뇌적 실책에 의해서 주자가 진루하는 경우이다. 평범한 땅볼이 된 공을 잡은 야수가 1루에 타자 주자를 아웃시키는 대신, 선행주자를 아웃시키려고 다른 루에 송구하여 타자 주자가 1개 또는 그이상을 진루한 경우에 타자에게 주어지는 기록을 말한다.+실책 : 에러(Error)라고도 한다. 수비수가 잡아서 타자를 아웃을 시킬 수 있는 타구를 놓칠 때 쓰이는 말이다. 폭투, 도루 견제 때는 실책으로 인정하지 않는다. 2 스트라이크에서 헛스윙 삼진이 될 때, 그 공을 포수가 놓쳐서 그 사이에 타자가 1루에 무사히 갈 때는 스트라이크아웃 낫아웃이라고 한다.+몸에 맞은 볼 (힛바이피치드볼) : 타자의 몸에 공이 맞았을 때 1루로 진출할 수 있다.(스윙을 하지 않았을 경우) 정식 명칭은 '몸에 맞은 볼'이나 '힛바이피치드볼'이지만 보통 '데드볼'이라고 부른다.+[편집]+야구의 인원+[편집]+선수 명단+ +구원 투수가 몸을 풀고 있으며, 투수 코치가 그들을 살펴보고 있다.++최대 선수 명단 수는 리그 또는 수준에 따라 다르다. 메이저 리그 야구 팀은 선수 명단을 25명으로 유지하고 있다.+8명의 포지션 선수(position players)는 포수, 4명의 내야수, 3명의 외야수로 구성 된다.+5명의 선발 투수(starting pitchers)는 선발 로테이션을 구성한다.(6인도 있다.)+6명의 구원 투수(relief pitcher)에는 마무리 투수가 포함되며, 팀의 불펜을 구성한다.+1명의 백업 포수+2명의 백업 내야수+2명의 백업 외야수+1명의 지명타자, 또는 2번째의 백업 포수, 또는 7번째 구원 투수(seventh reliever)+[편집]+그 외++팀의 감독 또는 수석 코치는 선수 명단, 타순, 선발 투수를 정하고, 특히 구원 투수의 경기 중의 등판 시점과 같은 선수교체 등과 같은 팀의 중요한 전술을 구상한다. 감독은 2명 또는 그 이상의 코치들의 도움을 받는다. 코치들은 타격 코치, 야수 코치, 투수 코치, 트레이닝 코치로 전문적인 책임을 가지고 있다. 대부분의 경기에선 팀이 공격을 할 때 1루 코치와 3루 코치가 경기장에 서 있는데 그들은 파울선의 밖에 정해진 장소에 서서 경기 중에 주자의 방향에 조언하고 경기 중단시에 감독의 지시를 타자와 주자에게 전달한다.[24]+ 이 부분의 본문은 야구 심판입니다.+ + 야구의 주심++야구 경기에서 심판은 4명인데, 주심, 1루심, 2루심, 3루심으로 구성되어 있다. 먼저 주심은 포수 뒤에 서 있는데, 스트라이크 존을 통해서 스트라이크와 볼을 판정한다. 주심은 본루에서 아웃인지 세이프인지 판단하기도 한다. 그리고 나머지 1루심, 2루심, 3루심은 루 근처에서 서 있으며, 아웃인지 세이프인지 판정한다. 또한 타자가 하프 스윙 시에 주심이 스트라이크를 선고하지 않았을 경우에는 감독 또는 포수는 누심에게 조언을 받을 것을 요청할 수 있다. 좌우측 선심이 없는 경우 1, 3루심은 타자가 친 공이 외야에서 파울인지 아닌지 판단하기도 한다. 보크나 타임의 선언은 4심이 모두 동등한 권한을 갖는다.++메이저리그 야구에서는 보통 4명의 심판을 두는데, 올스타전이나 포스트 시즌 경기와 같이 중요한 시합의 경우 좌측 선심과 우측 선심을 추가하여 6명의 심판을 둔다. 그리고 2008년 8월부터는 비디오 판독제를 도입하기로 했다.[25]+[편집]+야구의 기본기와 전술+[편집]+기본기++야구는 기본적으로 야구공을 통해 이루어지는 경기인데, 공을 처리하는 것은 투구, 타격, 주루, 포구, 생각과 같은 동작으로 이루어진다.[26] 이에 따른 신체의 동작도 손(어깨), 발(다리), 눈, 입, 귀, 머리를 통해서 행해진다.[26] 손과 발은 투구, 타격, 주루, 포구에 필요한 수단이며, 눈은 잘볼 수 있는 수단이다.[26] 또한 야구는 단체스포츠이기 때문에 서로의 기분을 이해하고 동료의 플레이가 쉽게 되도록 서로 협조하는 팀워크가 필요하다.[27]++투구는 투수가 투수판을 밟고 타자에게 공을 던지는 행위를 뜻한다.[28] 투수는 좋은 투구를 위해서는 스피드와 제구가 좋은 공을 던져야 하고, 기본적인 속구 이외에도 커브, 포크볼과 같은 변화구를 던질줄 알아야 한다.[29] 또한 투수는 일반적인 와인드업 포지션과 주자 견제를 위한 세트 포지션을 사용한다.[28]++타격은 타자가 투수가 던진 공을 쳐내는 행위를 뜻한다. 스윙의 각도에 따라서 다운 스윙, 레벨 스윙, 어퍼 스윙으로 나뉜다.[28] 다운 스윙은 위에서 밑으로 내려치는 타법이며,[30] 레벨 스윙은 수평으로 휘두르는 타법으로 가장 이상적이며,[31] 어퍼 스윙은 밑에서 위로 올려치는 타법으로 가장 비효율적이다.[31]++주루는 루 상에 나간 주자의 플레이를 말한다. 일반적으로, 주루는 득점을 위해 홈으로 들어오기 위한 하나의 전략이다. 주루를 위해서는 주루 감각과 도루, 투수의 견제시 대비가 중요하다.+[편집]+전술++야구 경기에서 팀은 승리하기 위해서 여러가지 전술을 사용한다. 예컨대, 일반적으로 우타자는 좌완 투수에게 강하며, 좌타자는 우완 투수에게 강하다.[32] 만약 상대 팀의 선발 투수가 좌완 투수일 때, 보통 좌타자 대신 우타자를 많이 기용하며, 좌타자는 기용되지 않거나 하위타선에 배치된다. 이런 점 때문에 우완 투수일 때는 좌타석, 좌완 투수일 때는 우타석에 서서 양손을 사용하는 스위치 히터가 생겨났다.[33]+ + 타자가 번트를 시도하고 있다.++희생 번트는 루 상에 나가 있는 주자의 진루를 목표로 하는 전술으로, 주로 아웃 카운트가 유리한 무사 1루, 무사 2루, 무사 1·2루일 때 시도한다.[34] 스퀴즈 플레이는 주자가 3루에 있을 때, 번트를 대서 3루 주자가 득점하기 위한 전술이다.[35] 희생 플라이(일명 태그업)은 주자가 3루에 있을 때, 타자가 뜬공을 쳐 내면, 야수가 뜬공을 잡았을 때 3루주자는 득점하는 전술이다.[36] 도루는 투수가 투구를 하는 사이에 주자가 다음 루로 가려고 시도하는 것으로, 주로 발이 빠른 주자가 시도한다. 히트 앤 런(Hit and run)은 투수가 투구를 하는 사이 주자는 다음 루로 주루하며, 타자는 투수가 던진 공을 무조건 쳐서 최대한 많이 진루하려는 것이다. 런 앤 히트(Run and hit)는 투수가 투구를 하는 사이 주자가 다음 루로 주루하는 것은 같지만, 타자는 투수가 던진 공을 원하면 타격하는 전술이다. 런 앤 히트 작전이 시도됐을 때 타자가 타격하지 않았을 경우 주자의 도루 시도가 된다.++고의사구는 경기의 승부처(클러치)일 때, 잘 치는 타자가 나왔을 경우 그 타자를 볼넷으로 거르고 다음 타자와 상대해 더 큰 실점을 막으려는 전술이다. 루 상에 발이 빠르고 도루 가능성이 높은 주자가 나가있을 경우에는 투수가 포수에게 공을 하나 완전히 빼서 투구를 하는데, 도루를 대비해 주자를 견제하기 위한 것이다. 투수가 투구 전 또는 포수가 투구 후에 주자를 견제하기 위해서 주자가 있는 루의 야수에게 견제구를 던지기도 한다. 주자가 3루에 있을 때 내야 땅볼을 홈에 송구하기 위해서, 또는 타자가 번트한 공을 효율적으로 처리하기 위해서 야수들이 홈플레이트 쪽으로 이동해 수비를 한다.[37] 수비 위치는 타자의 타격 성향의 따라서 이동될 수 있다. 타자가 장타를 쳤을 때, 외야수는 잡은 공을 베이스에 있는 야수에게 송구하지 않고 보통 2루수 또는 유격수에게 송구를 하는데, 이를 중계 플레이라고 하며, 주자의 득점이나 진루를 방지하는 플레이이다.++전술의 지시는 보통 감독, 코칭스태프, 또는 선수간의 사인으로 전달되는데, 대부분 손짓으로 이루어진다. 사인의 종류에는 플래시 사인, 블록 사인, 키 사인 등이 있다.[38] 메이저 리그 야구에서는 9이닝을 기준으로 한 경기에 오가는 사인이 평균 1000여건 정도이다.[39]++경기는 모두 전술대로 진행하는 것은 아니며, 선수가 혼자서 독단적으로 플레이하는 경우도 있다. 예를 들어, 발이 빠른 주자들은 덕아웃 에서의 사인 지시 없이 자신의 판단으로 도루를 시도하는데, 이를 '그린라이트'(green light)라고 한다.[40]+[편집]+야구의 고유한 스타일++야구는 미국의 스포츠 중에서 여러가지 면에서 독특한 특징을 갖는 스포츠이다. 이러한 독특함이 오랜기간 지속해 올 수 있었던 매력이자 미국인의 정신에 강한 연대감을 갖게 하는 큰 요인이다. 또한 많은 미국인들은 야구가 기술과 타이밍 그리고 열정, 전략의 최상의 조합이라고 생각한다. 철학자였던 모리스 라파엘 코언은 야구를 국민적 종교라고 묘사하기도 했다.[41] 이 점에서, 야구는 그의 사촌격인 크리켓과 유사한데, 많은 영연방 국가에서 크리켓과 그것과 관련된 문화는 미국 문화에서의 야구의 역할과 비슷한 지위와 영향력을 가진다.+[편집]+시간적 요소++농구, 아이스하키, 미식축구, 그리고 축구는 모두 경기 시간이 정해져 있고, 보통 상대 팀에 직접적으로 저항해서 경쟁하는 것보다 정해져 있는 시간에서 공격에서 많은 시간을 차지한 팀에 의해 끝난다. 이와 반대로 야구는 경기 시간이 정해져 있지 않다. 팀은 마지막 타자가 나가기 전까지는 이길 수 없고 반격은 시간 제한을 받지 않는다. 비록 단체 종목과 반대되는 개인 종목들 중에서 경기 시간제한이 없어서 미국의 전문직들에게 인기가 많은 다른 스포츠로는 테니스와 골프가 있다.++최근 수십 년간, 관찰자들은 매년 야구 경기를 하는 데에 걸리는 시간이 꾸준히 증가한 것에 대한 정당성을 들어 프로 야구의 게임 길이를 비판해 왔다. 20세기에 들어서면서 게임 시간은 전형적으로 1시간 반 정도였다(1시간 반으로 정해졌다). 1920년대에는 평균 2시간 미만으로 변한 것이 1960년대에는 결국 2시간 38분으로 늘어났다.[42] 1975년에는 평균 2시간 25분으로 줄어 들었지만,[43] 21세기에 들어서면서 2003년 시즌 종료 직후 조사한 결과 평균 2시간 46분대가 되는 것으로 밝혀져 경기 시간이 더욱 길어지게 된 것으로 판명되었다.[42]++경기 시간이 늘어나는 것은 하프 이닝(half inning; 공수교대시간) 사이의 TV 광고, 늘어나는 반칙과 투구 인터벌, 그리고 느린 경기 흐름 때문이었다. 결국 메이저 리그는 하프 이닝 사이의 쉬는 시간의 최대 시간을 정하는 반면 심판이 더욱 엄격하게 스트라이크 존과 시간 규칙을 선수들이 지키게 강요하도록 교육했다.[42] [43] 2008년, 일본의 프로 야구는 2007년부터 과거 10년간의 평균 경기 시간이었던 3시간 18분의 6%(교토 의정서의 온실가스 배출량 감축 목표에서 따온 것이다)인 12분 줄이는 것을 목표로 삼았다.[44]++이러한 제한 시간이 없는 특징 때문에 야구계 일각에서는 승부가 연장으로 이어질 시에 빠르게 승부를 낼 수 있는 규칙으로서 이른바 승부치기를 도입하는 것이 논의되고 있기도 하다. 실제 베이징 올림픽에서는 승부치기 제도가 실시된 바 있으나, 승부치기 제도가 일반적인 것은 아니며 전 세계 거의 대부분의 프로 야구 리그에서는 아직 승부치기 제도를 도입하지 않고 있다.++공식적인 규칙에 명기되어 있기는 하지만 루(Base) 상에 주자가 없을 경우 투수는 12초 안에 투구해야 하며 이를 어길 시 그 투구는 '볼(Ball)'로 판정이 된다는 경기 촉진룰의 적용은 매우 드물고 아주 만약의 상황에만 시행 된다. 그러나 2010년도 프로야구에서는 이 12초룰을 적용키로 하여 투수에 유리한 룰이 아니냐며 타자들이 반발하고 있는 추세다. 심판은 또한 주자가 있을 경우에도 투수의 투구 지연 행위를 볼(Ball)로 판정할 수 있는 권리도 가지고 있는데 이 규칙 또한 매우 드물고 만약의 상황에만 시행된다. 공식 규칙 중에는 또한 주심이 타자에게 타격행위가 끝나지 않았을 경우 타자석을 벗어나지 않도록 요청할 수 있는 규칙이 있다. 그 이외의 다른 규칙으로는 '규칙위반을 하는지 주시하라'가 있다.+[편집]+개인과 팀++야구는 근본적으로 팀 스포츠이다. 명예의 전당에 들어갈 정도로 훌륭한 실력을 가졌으며 높은 연봉을 받는 두, 세 명 정도의 선수를 보유할 정도로 재정이 좋은 지역 연고 구단이라 하더라도 기량이 우수한 선수들이 반드시 성공을 기대할 수는 없으며, 여전히 선수 개인들은 강한 압박과 시험에 놓이게 된다. 투수는 반드시 훌륭한 투구를 해야하며 만약 그렇지 못할 경우 시합에 질 위험이 크고, 타자는 극히 짧은 순간에 어떤 구질인지, 스윙을 해야 할지, 말아야 할지를 결정해야 한다. 감독과 코치가 어떤 작전을 수행할지를 선수들에게 사인을 줄 수는 있지만, 그 어느 누구도 투수가 투구하는 것을, 타자가 타격하는 것을 도와 줄 수는 없다. 타자가 직선타구를 치게 되면, 최종 수비자인 외야수들은 볼을 잡아야 할지, 바운드 볼로 처리해야 할지를 혼자서 결정한다. 야구의 역사에서는 영웅적 대접을 받는 선수와 비난을 받는 선수들이 많다 - 시합의 승부처(클러치)에서 한 선수가 적시 안타를 치거나 또는 공을 잡아 플라이 아웃 시킬 수도 있지만, 또는 그 반대로 예상치 못한 삼진 아웃을 당하거나 수비에서 실책을 해서 모두에게 뚜렷이 각인되는 결과를 낳았다.++또한 야구에서 모든 선수들이 주자로 뛸 수 있으며 이 때문에 야구에서는 단거리 달리기가 매우 중요하다. 굳이 주자가 아니더라도 포수를 제외한 모든 포지션에서 뛰어난 단거리 달리기 능력이 요구된다. 단거리를 빠른 속도로 달리는 능력이야말로 야구의 기본기이다.+[편집]+경기장+ 이 부분의 본문은 야구장입니다.+ +리글리 필드의 득점판. 2005년 7월 27일, 시카고 컵스 - 플로리다 말린스의 경기.++야구 규칙에 따르면 경기장에 대한 규정은 다음과 같다.[1][45]+본루에서 1루, 1루에서 2루, 2루에서 3루, 3루에서 본루까지의 거리는 각각 27.432m(90피트)이다. 내야의 중앙 부근에 본루로부터 25.4cm(10인치)의 높이가 되도록 흙을 쌓아 올려 그곳에 투수판을 놓고 투수판 앞 15.2cm(6인치)되는 지점으로부터 본루를 향해 182.8cm(6피트)되는 지점까지, 경사도는 12:1이여야한다. 본루로부터 백 스톱까지의 거리 및 루선으로부터 파울지역에 있는 펜스, 스탠드 또는 플레이에 방해가 되는 시설까지의 거리는 18.288m(60피트) 이상이 되어야 한다. 내야는 한 변이 27.432m(90피트)인 정사각형이고 외야는 1루선과 3루선을 연장한 파울 라인 사이의 지역이다. 본루부터 페어지역에 있는 펜스, 스탠드 또는 플레이에 방해가 되는 시설까지의 거리는 76.199m(250피트) 이상이어야 한다. 경계선을 포함한 내야 및 외야는 페어지역이고 다른 지역은 파울지역이다. +1958년 6월 1일 이후 프로야구를 위해 건설하는 경기장은 본부로부터 좌우의 펜스, 스탠드 또는 좌우의 페어지역 위에 있는 플레이에 방해가 되는 시설까지의 거리는 99.058m(325피트) 이상, 중견의 펜스까지의 거리는 121.918m(400피트) 이상이여야한다.+본루는 오각형의 흰색 고무판으로 표시한다. 이 오각형을 만들 때에는 먼저 한 변이 43.2cm(17인치)인 정사각형을 그려, 이 중 한 변을 골라 이에 이웃한 양쪽의 변을 21.6cm(8½인치)로 줄인다. 이 변에서 밑변의 중심으로 각 30.5cm(12인치)의 변을 2개 만든다. 30.5cm(12인치)의 두 변이 만나는 곳을 1루선과 3루선의 교차점에 두고, 43.2cm(17인치)의 변을 투수판 쪽으로 해서 그 표면이 지면과 수평이 되도록 고정시킨다.+1루, 2루, 3루는 흰색 캔버스 백으로 표시하고 땅에 올바르게 고정시킨다. 1루와 3루의 캔버스 백은 완전히 내야 안쪽으로 들어가게 설치하고, 2루의 캔버스 백은 2루지점에 그 중심이 놓이도록 설치한다. 캔버스 백은 그 속에 부드러운 재료를 넣어서 만들고 그 크기는 38.1cm(15인치) 평방, 두께는 7.6cm(3인치)에서 12.7cm(5인치)까지 허용된다.+투수판은 가로 61cm(24인치), 세로 15.2cm(6인치)의 직사각형 흰색 고무 평판으로 만든다. 투수판은 그 앞쪽면 중앙으로부터 본루까지의 거리가 18.44m(60피트 6인치)가 되게 한다.+본거지 구단은 1루선과 3루선으로부터 적어도 7.62m(25피트) 떨어진 곳에 본거지 구단 및 방문 구단용으로 각 1개씩의 선수용 벤치를 설치하여야 하며, 이 벤치는 양 옆과 뒷 쪽을 둘러싸고 지붕을 씌워야 한다.+[편집]+기록+ 이 부분의 본문은 야구의 기록입니다.++많은 스포츠 중에서 혹은 그보다 휠씬 더, 야구에서의 기록은 대단히 중요한 의미를 갖는다. 야구 기록은 미국 프로 야구인 메이저 리그의 태동과 함께 유지되어 왔으며 생각컨대 이전보다 더 일반적인 것이 되었다. 단장, 스카우터, 감독 그리고 선수들은 자신이 속한 팀의 승리를 위한 다양한 전략선택에 도움을 주기 위해 기록을 연구한다.++야구에서의 기록은 여러 가지 이유로 다른 스포츠들보다 더 중요한 의미를 갖는 가장 중요한 이유는 다른 운동 경기들에서의 플레이는 유동적이고 다양한 결과를 보여주지만, 야구에서의 플레이는 제한된 결과만을 갖기 때문이다.++모든 세대의 야구팬은 다음과 같은 전통적인 야구 기록에 대해 알고 있으며 또한 그 내용에 관해 의견을 교환한다.+'타수'(打數, At-bats, AB)는 타자가 타석에서 타격행위를 완료한 총 횟수를 의미한다. 타수에는 타자가 타격행위를 완료하지 않은 타석은 제외하는데 볼넷과 몸에 맞는 볼이 그러한 경우이다.+타자의 '타율'(打率, Batting Average, AVG)은 '안타'의 수를 '타수'로 나눈 값이다.[46] 이것은 타자의 타격능력을 보여주는 가장 기본적인 통계수치이다.+투수의 '평균자책점'(Earned Run Average, ERA, 일본 야구에서는 '방어율'(防禦率)이란 용어를 사용)은 투수가 투구한 총 이닝과 허용한 자책점을 평균적으로 환산하여 9 이닝당 자책점(투구와 관련없는 수비행위로 인한 실점은 제외)으로 보여주는 통계수치이다. 약어로는 'ERA'로 표기한다.+투수의 '이닝'(Inning, IP(Inning Pitched))은 투구행동의 기본단위이다. 보통 양팀의 공수교대를 1이닝으로 표현하기도 하지만, 투수가 얼마나 던졌는지를 가늠하는 것도 이닝이다. 투구수와는 상관없이 1-아웃카운트를 잡았을 경우 ⅓(0.1)이닝 2-아웃카운트를 잡았을 경우 ⅔(0.2)이닝이라 표현, 3명의 타자를 아웃시키면 1이닝으로 표현된다. (또는 0.3, 0.7, 1로 표현) 연속성은 상관이 없이 기록된다. 투구에 의한 아웃이 아니라, 견제사에 의한 아웃도 인정되므로 투구수 없이 이닝을 기록할 수도 있다. 이것은 주로 투수의 내구력과, 지구력에 대한 척도가 되곤 한다.+'도루'(Stolen Bases, SB)는 투수의 투구행동시 다음 루로의 진루를 하는 행위이다. 얼마나 빠른지에 대한 수치적인 기준이 되며, 도루가 많을수록 공격의 효율성이 좋아진다.+세이버매트릭스(Sabermetrics)++미국 야구 연구 협회(The Society for American Baseball Research, SABR)는 야구 선수의 성과와 팀 기여도를 보다 더 잘 측정하고 상대적 가치에 관한 좀 더 추상적인 질문에 대한 답을 제공하기 위해 혁신적인 통계 수치를 개발해왔다('세이버매트릭스'란 용어는 학문의 분야와 고안된 특정 통계수치를 의미한다).++몇몇 세이버매트릭스 신봉자들이 야구계의 주류로 편입함에 따라 '세이버매트릭스'의 통계기록은 일반적으로 사용되기 시작했으며, 내용은 다음과 같다.+'OPS'(출루율과 장타율을 합한 것)는 타율보다 타자들의 성과를 더 잘 측정한다고 세이버매트릭스를 믿는 사람들이 말하는 다소 복잡한 공식이다. 타자의 '출루율 : (안타 + 볼넷 + 사구) / (타수+볼넷 +사구 + 희생플라이)'[46] 과 '장타율 : 총루타수 / 타수'[47]를 더한 값이다.[48]+'WHIP'(투구이닝 당 허용한 볼넷과 안타의 합)[49]은 투수의 능력을 잘 보여주는 통계수치이다.+특정 상황에 따른 통계기록++특정 상황에서 좀 더 세밀한 통계수치는 더욱 중요해진다. 예를 들어, 좌완 투수의 공을 잘 치는 타자의 경우 감독은 왼손 투수를 상대하기 위해 그 선수에게 좀 더 많은 기회를 줄 것이다. 득점상황에서 더 잘 치는 타자들이 나왔을 경우 상대팀 감독은 득점권 타율이 낮은 타자와 승부하기 위해 그 타자를 고의사구로 내보내려고 할 것이다.++다른 통계 기록들도 있는데 위에서 언급한 통계수치들보다 덜 중요할지도 모른다. 타자의 경우 타수, 안타수, 장타수 그리고 타점이고 투수의 경우는 투구 이닝수, 9이닝 당 삼진수, 볼넷, 투구 수 등이다.+[편집]+야구 단체 및 주요 대회+[편집]+국제 야구 단체+ +국제 야구 연맹에 가입된 국가.++국제 야구 연맹은 1938년에 설립되었으며, 117개국이 가맹하고 있다.[19] 그리고 대륙별로도 연맹이 조직되어 있어 있으며, 다음과 같이 소속되어 있다.++     아프리카 야구·소프트볼 협회(ABSA) - 16개국++     팬아메리칸 야구 연맹(COPABE, 스페인어: Confederación Panamericana de Béisbol) - 26개국++     아시아 야구 연맹 (BFA) - 20개국++     유럽 야구 연맹 (CEB, 프랑스어: Confédération Européenne de Baseball) - 40개국++     오세아니아 야구 연맹 (BCO) - 15개국+[편집]+야구 대회++세계의 주요 야구 대회에는 야구 월드컵, 대륙간컵 등이 있다. 하지만 이런 대회들은 아마추어 선수들만 참가하고 메이저 리그 야구 선수는 참여하지 않는다. 올림픽 야구 또한 메이저 리그 야구 선수들은 참여하지 않는데, 이 때문에 2012년 하계 올림픽에서 야구와 소프트볼이 제외된 이유가 되기도 한다. 유니버시아드 야구, 세계 청소년 야구 선수권 대회, 유스 베이스볼 월드 챔피언십은 대학, 청소년을 위한 대회이다. 여자 야구 대회로는 여자 야구 월드컵이 있다.++메이저 리그 야구 사무국은 야구의 열기 확대를 위해서 메이저 리그 야구 선수들도 참가하는 프로 야구 대회인 WBC(월드 베이스볼 클래식)을 2006년에 개최했다. 이 대회는 2009년에 열린 후 그 이후로는 4년마다 열릴 예정이다.[50]++각 대륙별 대회는 다음과 같다.+아프리카 - 올아프리카 게임 야구+아메리카 - 팬아메리칸 게임 야구+아시아 - 아시아 야구 선수권 대회+유럽 - 유럽 야구 선수권 대회+오세아니아 - 오세아니아 야구 선수권 대회+[편집]+야구 리그++세계 야구에서 가장 큰 규모의 프로 야구 리그는 미국의 메이저 리그 야구로, 내셔널 리그 16팀, 아메리칸 리그 14팀, 총 30개의 팀으로 각각 서부, 중부, 동부 지구로 나뉘어 있다.++메이저 리그 야구 밑으로는 트리플A, 더블A, 싱글A, 루키 등의 하위 리그들이 각 연고지마다 분포되있다. 그리고 메이저리그와는 별개로 독립리그들이 북중미권에 여럿 있다.++또한 네덜란드, 이탈리아, 오스트레일리아, 푸에르토리코, 도미니카 공화국, 파나마, 콜롬비아, 베네수엘라, 니카라과, 캐나다 등에도 리그가 있으며, 특히 카리브해 국가들의 리그는 기후상 겨울에도 리그를 연다. 쿠바는 공산국가 특유상 프로리그는 없지만 아마추어 국제대회에서는 상당한 실력을 보인다.++아시아에선 일본의 센트럴 리그와 퍼시픽 리그와 독립리그들이 있으며, 그 외에 대한민국, 타이완, 필리핀 등이 대표적이다.++또한 야구 리그는 난이도에 따라, 예를 들어서 아마추어, 프로에 따라서, 또는 성별에 따라, 나이에 따라서 리그가 다르다. 어린이 프로그램은 야구 규칙에 보다 더 쉬운 규칙을 적용하고 더 작은 구장에서 경기를 치르며, 코치나 기계로부터 보다 더 쉬운 투구를 한다. 또한 아마추어, 논-프로도 공식 야구 규칙에서 변형된 규칙을 사용한다.++야구 리그는 아메리카, 아시아, 유럽, 오세아니아 등에 존재한다. 특히 아시아의 경우 일본에서는 센트럴 리그와 퍼시픽 리그라는 양대 리그가 있다.++대한민국에서는 1982년 한국야구위원회 창설로 프로야구가 설립되었으며 롯데 자이언츠, 삼성 라이온즈, 해태 타이거즈, MBC 청룡, OB 베어스, 삼미 슈퍼스타즈 등 6개 팀으로 시작 2013년 현재는 삼성 라이온즈, SK 와이번스, 롯데 자이언츠, 두산 베어스, KIA 타이거즈. 넥센 히어로즈, LG 트윈스, 한화 이글스, NC 다이노스 등 9개 팀으로 리그가 진행중이다. 현재 대한민국 프로야구는 10구단 창설 논의가 진행중이며, 2013년에 10구단의 모기업이 결정될 예정이다. 10구단에 관심이 있는 지역과 모기업은 수원시와 KT의 연합과 전라북도와 부영의 연합이다.+[편집]+같이 보기야구 규칙/경기 진행+야구의 경기 용구+야구의 포지션+야구의 기록+야구의 점수 기록+야구장	야구 문화+분류:야구 문화+분류:야구 영화+분류:야구 게임+분류:야구상+야구 은어+야구 카드+야구 명예의 전당+스피드건(en:Speed gun)++	야구 관련 스포츠+방망이와 공을 이용하는 경기+마운드볼+오이나+소프트볼+크리켓+스틱볼+원 홀캣+타운볼+라프타+스툴볼+티볼++[편집]+참고 문헌+조지 벡시. 《야구의 역사》. 을유문화사. 8932430799+설리번 딘. 《Early Innings: A Documentary History of Baseball, 1825-1908》. U of Nebraska Press. 0803292449+설리번 딘. 《Late Innings: A Documentary History of Baseball, 1945-1972》. U of Nebraska Press. 0803292856+잭 스탈링스, 밥 베넷 (2003). 《Baseball Strategies: Your Guide to the Game Within the Game》. American Baseball Coaches Association/Human Kinetics. ISBN 0-7360-4218-0, OCLC 50203866+하일성. 《최신 야구교실》. 국일미디어. ISBN 978-89-7425-228-1+[편집]+주석+↑ 가 나 한국야구위원회. 한국야구위원회 : 경기규칙. 2012년 2월 23일에 확인.+↑ Major League Baseball. Major League Baseball: Official Baseball Rules. 2012년 2월 23일에 확인.+↑ 박동희. “SK 와이번스의 ‘야큐(野球)’ 실험”, 《스포츠 2.0》, 2007년 3월 23일 작성. 2009년 1월 1일 확인.+↑ Block (2005년), p.106~108.+↑ 야구의 역사, 조지 벡시 p. 59+↑ 야구의 역사, 조지 벡시 p.36+↑ Early Innings: A Documentary History of Baseball, 1825-1908, 설리번 p.292+↑ 쥘 티곌 (2002년). Past Time: Baseball as History. 《NINE: a Journal of Baseball History and Culture》 10: 170–171. doi:10.1353/nin.2002.0012. 2008년 6월 25일에 확인.+↑ Early Innings: A Documentary History of Baseball, 1825-1908, 설리번 p.80+↑ 야구의 역사, 조지 벡시 p. 32+↑ Early Innings: A Documentary History of Baseball, 1825-1908, 설리번 p.95+↑ “메이저리그”. 두산백과사전. 2008년 12월 14일에 읽어봄.+↑ 야구의 역사, 조지 벡시 p. 106+↑ 야구의 역사, 조지 벡시 p. 249+↑ Late Innings: A Documentary History of Baseball, 1945-1972, 설리번 p.162+↑ Late Innings: A Documentary History of Baseball, 1945-1972, 설리번 p.239+↑ 야구의 역사, 조지 벡시 p. 257+↑ “토론토 블루 제이스”. 두산백과사전. 2009년 4월 23일에 읽어봄.+↑ 가 나 국제 야구 연맹 (대륙 연맹/회원국 연맹). IBAF. 2009년 2월 3일에 확인.+↑ “They'rrre out! Baseball, softball out of Olympics”, 《NBCSports.com》, 2005년 7월 9일 작성.+↑ “IOC: Add golf, rugby to 2016 Olympics”, 《NBCSports.com》, 2009년 8월 13일 작성.+↑ 강준만 (2007). 《한국 근대사 산책4(러일전쟁에서 한국군 해산까지)》. 인물과사상사, 198쪽. ISBN 978-89-5906-074-0 “한국에 야구가 처음 들어온 것은 1905년으로, 당시 선교사로 온 미국인 질레트(P. L. Gillett)가 황성기독청년회 회원들에게 야구를 가르친 것이 그 시초이다. 1906년 2월 11일 훈련원 터에서 YMCA팀 대 덕어(독일어)학교팀 사이에 최초의 야구경기가 열렸다. 20) 『황성신문』1909년 3월 21일자엔 다음과 같은 〈야구단 운동가〉라는 노래가 소개돼 있을 정도로 야구는 큰 인기를 누렸다. "무쇠 골격 돌 근육 소년 남아야/애국의 정신을 분발하여라/다달았네 다달았네 우리나라에/소년의 활동 시대 다달았네 /(후렴) 만인 대적(對敵) 연습하여 후일 전공 세우세/절세 영웅 대사업이 우리 목적이 아닌가"21)”+↑ Thurston (2000), p. 15; Official Rules/Foreword. Major League Baseball. 2009년 2월 2일에 확인. Official Rules/1.00—Objectives of the Game (Rules 1.01–1.03). Major League Baseball. 2009년 2월 2일에 확인. Official Rules/2.00—Definitions of Terms. Major League Baseball. 2009년 2월 2일에 확인. Official Rules/4.00—Starting and Ending a Game (Rule 4.10). Major League Baseball. 2009년 2월 2일에 확인.+↑ 클레온 왈푸드 "Most 'Signs' Given by Coaches Are Merely Camouflage", Baseball Digest, 1960년 12월 ~ 1961년 1월, pp. 47–49.+↑ 허진우. “메이저리그, 오는 8월 비디오 판독제 도입 추진”, 《일간스포츠》, 2008년 6월 15일 작성.+↑ 가 나 다 하일성 (1995년 5월 1일). 《최신 야구교실》. 국일미디어, 19쪽. ISBN 978-89-7425-228-1+↑ 야구교실, 하일성 p.23+↑ 가 나 다 “전진수비”. 두산백과사전. 2010년 11월 30일에 읽어봄.+↑ 야구교실, 하일성 p.46+↑ “다운스윙”. 두산백과사전. 2010년 11월 30일에 읽어봄.+↑ 가 나 (한국어) 조해연 (2007). 《조해연의 우리말 야구용어 풀이》. 지성사, 49쪽. ISBN 8978891489+↑ 앤드류 배스트 (2008년 7월 18일). Southpaw’s Revenge. 2009년 2월 8일에 확인.+↑ 이상주. “'내 맘대로 타격' 스위치 타자의 세계”, 《스포츠서울》, 2008년 9월 26일 작성. 2009년 2월 24일 확인.+↑ 최민규. “무사 1루, 희생 번트 대지 말라”, 《스포츠 2.0》, 2006년 12월 27일 작성. 2009년 2월 24일 확인.+↑ Baseball Strategies: Your Guide to the Game Within the Game, 스탤링스, 베넷, 42–43, 47–48.+↑ Baseball Strategies: Your Guide to the Game Within the Game, 스탤링스, 베넷, p. 45.+↑ “전진수비”. 두산백과사전. 2009년 2월 24일에 읽어봄.+↑ 야구교실, 하일성 p.306+↑ 송재우. “사인, 또 하나의 야구 묘미”, 《송재우 칼럼》, 2007년 6월 1일 작성. 2009년 2월 24일 확인.+↑ “그린라이트”. 표준국어대사전. 2009년 2월 23일에 읽어봄.+↑ Cohen, Morris Raphael, "Baseball as a National Religion" (1919), in Cohen, The Faith of a Liberal (Transaction, 1993 [1946]), pp. 334–336: p. 334.+↑ 가 나 다 할 보드레이, "Baseball wants just a few more minutes", USA투데이, 2004년 2월 26일+↑ 가 나 제프 그린필드, "Midnight Baseball", 타임, 1998년 7월 13일+↑ 신인하. “경기시간 단축운동을 벌이고 있는 일본 야구계”, 《야큐 리포트》, 2008년 5월 8일 작성. 2009년 2월 26일 확인.+↑ MLB 공식 웹사이트.+↑ 가 나 문상열. “타율 〉출루율 진기록 나왔다”, 《동아일보》, 2008년 5월 16일 작성. 2008년 1월 2일 확인.+↑ “장타율”. 두산백과사전. 2009년 1월 3일에 읽어봄.+↑ 김형준. “마이리그 Tip - 타율 대비 최고 생산성의 타자는?”, 《김형준 칼럼》, 2008년 9월 3일 작성. 2009년 1월 3일 확인.+↑ 이호영. “롯데 자이언츠, 가을에도 야구한다”, 《스포츠 2.0》, 2008년 12월 16일 작성. 2009년 1월 2일 확인.+↑ 유해길. “WBC '파란 태풍' 야구 세계화 초석되다”, 《세계일보》, 2006년 3월 20일 작성.+[편집]+바깥 고리	위키미디어 공용에 관련 미디어 분류가 있습니다. +야구+	위키낱말사전에 이 문서와 관련된 글이 있습니다. +야구++야구 조직/리그+(영어) 메이저 리그 야구 공식 홈페이지+(영어) 마이너 리그 야구 공식 홈페이지+(영어) 국제 야구 연맹+(영어) 영국 야구 연맹+(한국어) 대한 야구 협회+야구 기록+(영어) 위키아 야구+(영어) 베이스볼-레퍼런스 공식 홈페이지+(영어) 더베이스볼큐브 공식 홈페이지+(영어) 야구-연감 공식 홈페이지+야구 뉴스/그 외+(영어) 초기 야구 온라인 박물관 홈페이지+(영어) 스팔딩 가이드 회의 도서관 공식 홈페이지+(영어) 야구 신문 기록 홈페이지+(영어) 중국의 야구+(영어) 온라인 야구 뉴스/잡지+(영어) 야구 경기장 구조, 설계+(영어) 유럽 야구 및 소프트볼 뉴스·정보[보이기]+ 야구와 관련된 항목+++분류: 야구+둘러보기 메뉴+계정 만들기+로그인+연습장+문서+토론+읽기+편집+역사++대문+사용자 모임+요즘 화제+최근 바뀜+모든 문서 보기+임의 문서로+도움말+기부+도구모음+여기를 가리키는 문서+가리키는 글의 바뀜+공용에 올리기+특수 문서 목록+고유링크+문서 정보+이 문서 인용하기+인쇄/내보내기+다른 언어++ 이 문서는 2013년 1월 9일 (수) 14:40에 마지막으로 바뀌었습니다.+모든 문서는 크리에이티브 커먼즈 저작자표시-동일조건변경허락 3.0에 따라 사용할 수 있습니다. 추가적인 조건이 적용될 수 있습니다. 자세한 내용은 이용 규약을 참고하십시오.+Wikipedia®는 미국 및 다른 국가에 등록되어 있는, Wikimedia Foundation, Inc. 소유의 등록 상표입니다.+개인정보 정책+위키백과 소개+면책 조항+모바일판에서 보기
+ benchmark/Streamly/Benchmark/Unicode/data/Vietnamese.txt view
@@ -0,0 +1,402 @@+Mời bạn tham gia bình chọn giao diện mới cho trang chính Wikipedia tiếng Việt.+Thành phố Hồ Chí Minh+Bách khoa toàn thư mở Wikipedia + Bước tới: menu, tìm kiếm Thành phố Hồ Chí Minh+Thành phố trực thuộc trung ương++Bến Bạch Đằng  · UBND TP Hồ Chí Minh  · Nhà thờ Đức Bà Sài Gòn  · Cảng Sài Gòn  · Tòa nhà Bitexco Financial  · Chợ Bến Thành  · Nhà hát Thành phố+Biệt danh: Hòn ngọc Viễn Đông+Địa lý+Tọa độ: 10°46′10″B 106°40′55″Đ+Diện tích 	2.095,6 km²+Dân số 2011+ Tổng cộng	7.521.100 người[1]+ Mật độ 	3.589 người/km²+Múi giờ 	UTC+7+[hiện]+Vị trí thành phố trên bản đồ Việt Nam++Hành chính+Quốc gia 	Việt Nam+Thành lập 	1698: Nguyễn Hữu Cảnh lập phủ Gia Định+Tên khác 	Sài Gòn+Chính quyền 	 + Chủ tịch UBND 	Lê Hoàng Quân+ Chủ tịch HĐND 	Nguyễn Thị Quyết Tâm+ Bí thư Thành ủy 	Lê Thanh Hải+Phân chia hành chính 	19 quận và 5 huyện+Mã hành chính 	VN-65+Mã bưu chính 	70xxxx-76xxxx+Mã điện thoại 	8+Biển số xe 	50 → 59+Web: hochiminhcity.gov.vn+++Tọa độ: 10°46′10″B 106°40′55″Đ++Thành phố Hồ Chí Minh là thành phố đông dân nhất, đồng thời cũng là trung tâm kinh tế, văn hóa, giáo dục quan trọng của Việt Nam.++Vùng đất này ban đầu được gọi là Prey Nokor, thành phố sau đó hình thành nhờ công cuộc khai phá miền Nam của nhà Nguyễn. Năm 1698, Nguyễn Hữu Cảnh cho lập phủ Gia Định, đánh dấu sự ra đời thành phố. Khi người Pháp vào Đông Dương, để phục vụ công cuộc khai thác thuộc địa, thành phố Sài Gòn được thành lập và nhanh chóng phát triển, trở thành một trong hai đô thị quan trọng nhất Việt Nam, được mệnh danh Hòn ngọc Viễn Đông hay Paris Phương Đông. Sài Gòn là thủ đô của Liên Bang Đông Dương giai đoạn 1887-1901. Năm 1954, Sài Gòn trở thành thủ đô của Việt Nam Cộng hòa và thành phố hoa lệ này trở thành một trong những đô thị quan trọng của vùng Đông Nam Á. Việt Nam Cộng hòa sụp đổ năm 1975, lãnh thổ Việt Nam hoàn toàn thống nhất. Ngày 2 tháng 7 năm 1976, Quốc hội nước Việt Nam thống nhất quyết định đổi tên Sài Gòn thành "Thành phố Hồ Chí Minh", theo tên vị Chủ tịch nước đầu tiên của Việt Nam Dân chủ Cộng hòa.++Nằm trong vùng chuyển tiếp giữa miền Đông Nam Bộ và Tây Nam Bộ, Thành phố Hồ Chí Minh ngày nay bao gồm 19 quận và 5 huyện, tổng diện tích 2.095,01 km². Theo kết quả điều tra dân số chính thức vào thời điểm 0 giờ ngày 1 tháng 4 năm 2009 thì dân số thành phố là 7.162.864 người (chiếm 8,34% dân số Việt Nam), mật độ trung bình 3.419 người/km². Đến ngày 1/4/2010 theo số liệu của Tổng cục Thống kê, dân dố thành phố tăng lên 7.382.287 người. Tuy nhiên nếu tính những người cư trú không đăng ký thì dân số thực tế của thành phố vượt trên 8 triệu người. Giữ vai trò quan trọng trong nền kinh tế Việt Nam, Thành phố Hồ Chí Minh chiếm 21,3% tổng sản phẩm (GDP) và 29,38% tổng thu ngân sách của cả nước[2][3]. Nhờ điều kiện tự nhiên thuận lợi, Thành phố Hồ Chí Minh trở thành một đầu mối giao thông quan trọng của Việt Nam và Đông Nam Á, bao gồm cả đường bộ, đường sắt, đường thủy và đường không. Vào năm 2007, thành phố đón khoảng 3 triệu khách du lịch quốc tế, tức 70% lượng khách vào Việt Nam. Các lĩnh vực giáo dục, truyền thông, thể thao, giải trí, Thành phố Hồ Chí Minh đều giữ vai trò quan trọng bậc nhất.++Tuy vậy, Thành phố Hồ Chí Minh đang phải đối diện với những vấn đề của một đô thị lớn có dân số tăng quá nhanh. Trong nội ô thành phố, đường sá trở nên quá tải, thường xuyên ùn tắc. Hệ thống giao thông công cộng kém hiệu quả. Môi trường thành phố cũng đang bị ô nhiễm do phương tiện giao thông, các công trường xây dựng và công nghiệp sản xuất.Mục lục  [ẩn] +1 Địa lý +1.1 Vị trí, địa hình+1.2 Địa chất, thủy văn+1.3 Khí hậu, thời tiết+1.4 Môi trường+2 Lịch sử +2.1 Thời kỳ hoang sơ+2.2 Khai phá+2.3 Từ Gia Định tới Sài Gòn+2.4 Thủ đô Sài Gòn+2.5 Thành phố Hồ Chí Minh+3 Hành chính+4 Kinh tế+5 Xã hội +5.1 Dân cư+5.2 Y tế+5.3 Giáo dục+6 Giao thông vận tải+7 Quy hoạch và kết cấu đô thị+8 Du lịch+9 Văn hóa +9.1 Truyền thông+9.2 Thể dục, thể thao+9.3 Trung tâm văn hóa, giải trí+10 Thành phố kết nghĩa+11 Chú thích+12 Liên kết ngoài++Địa lý+Vị trí, địa hình++Thành phố Hồ Chí Minh có tọa độ 10°10' – 10°38' Bắc và 106°22' – 106°54' Đông, phía Bắc giáp tỉnh Bình Dương, Tây Bắc giáp tỉnh Tây Ninh, Đông và Đông Bắc giáp tỉnh Đồng Nai, Đông Nam giáp tỉnh Bà Rịa - Vũng Tàu, Tây và Tây Nam giáp tỉnh Long An và Tiền Giang. Nằm ở miền Nam Việt Nam, Thành phố Hồ Chí Minh cách Hà Nội 1.730 km theo đường bộ, trung tâm thành phố cách bờ biển Đông 50 km theo đường chim bay. Với vị trí tâm điểm của khu vực Đông Nam Á, Thành phố Hồ Chí Minh là một đầu mối giao thông quan trọng về cả đường bộ, đường thủy và đường không, nối liền các tỉnh trong vùng và còn là một cửa ngõ quốc tế[4].++Nằm trong vùng chuyển tiếp giữa miền Đông Nam Bộ và đồng bằng sông Cửu Long, địa hình thành phố thấp dần từ Bắc xuống Nam và từ Tây sang Đông. Vùng cao nằm ở phía Bắc - Đông Bắc và một phần Tây Bắc, trung bình 10 đến 25 mét. Xen kẽ có một số gò đồi, cao nhất lên tới 32 mét như đồi Long Bình ở quận 9. Ngược lại, vùng trũng nằm ở phía Nam - Tây Nam và Ðông Nam thành phố, có độ cao trung bình trên dưới 1 mét, nơi thấp nhất 0,5 mét. Các khu vực trung tâm, một phần các quận Thủ Đức, quận 2, toàn bộ huyện Hóc Môn và quận 12 có độ cao trung bình, khoảng 5 tới 10 mét[5].++Thành phố Hồ Chí Minh gồm có bốn điểm cực:+Cực Bắc là xã Phú Mỹ Hưng, huyện Củ Chi.+Cực Tây là xã Thái Mỹ, huyện Củ Chi.+Cực Nam là xã Long Hòa, huyện Cần Giờ.+Cực Đông là xã Thạnh An, huyện Cần Giờ.+Địa chất, thủy văn+ +Sông Sài Gòn đoạn qua trung tâm thành phố và bán đảo Thủ Thiêm++Địa chất Thành phố Hồ Chí Minh bao gồm chủ yếu là hai tướng trầm tích Pleistocen và Holocen lộ ra trên bề mặt. Trầm tích Pleistocen chiếm hầu hết phần Bắc, Tây Bắc và Đông Bắc thành phố. Dưới tác động của các yếu tố tự nhiên và hoạt động của con người, trầm tích phù sa cổ hình thành nhóm đất đặc trưng riêng: đất xám. Với hơn 45 nghìn hecta, tức khoảng 23,4% diện tích thành phố, đất xám ở Thành phố Hồ Chí Minh có ba loại: đất xám cao, đất xám có tầng loang lổ đỏ vàng và hiếm hơn là đất xám gley. Trầm tích Holocen ở Thành phố Hồ Chí Minh có nhiều nguồn gốc: biển, vũng vịnh, sông biển, bãi bồi... hình thành nhiều loại đất khác nhau: nhóm đất phù sa biển với 15.100 ha, nhóm đất phèn với 40.800 ha và đất phèn mặn với 45.500 ha. Ngoài ra còn có một diện tích khoảng hơn 400 ha là "giồng" cát gần biển và đất feralite vàng nâu bị xói mòn trơ sỏi đá ở vùng đồi gò[6].++Về thủy văn, nằm ở vùng hạ lưu hệ thống sông Ðồng Nai - Sài Gòn, Thành phố Hồ Chí Minh có mạng lưới sông ngòi kênh rạch rất đa dạng. Sông Ðồng Nai Bắt nguồn từ cao nguyên Lâm Viên, hợp lưu bởi nhiều sông khác, có lưu vực lớn, khoảng 45.000 km². Với lưu lượng bình quân 20–500 m³/s, hàng năm cung cấp 15 tỷ m³ nước, sông Đồng Nai trở thành nguồn nước ngọt chính của thành phố. Sông Sài Gòn bắt nguồn từ vùng Hớn Quản, chảy qua Thủ Dầu Một đến Thành phố Hồ Chí Minh, với chiều dài 200 km và chảy dọc trên địa phận thành phố dài 80 km. Sông Sài Gòn có lưu lượng trung bình vào khoảng 54 m³/s, bề rộng tại thành phố khoảng 225 m đến 370 m, độ sâu tới 20 m. Nhờ hệ thống kênh Rạch Chiếc, hai con sông Đồng Nai và Sài Gòn nối thông ở phần nội thành mở rộng. Một con sông nữa của Thành phố Hồ Chí Minh là sông Nhà Bè, hình thành ở nơi hợp lưu hai sông Đồng Nai và Sài Gòn, chảy ra biển Đông bởi hai ngả chính Soài Rạp và Gành Rái. Trong đó, ngả Gành Rái chính là đường thủy chính cho tàu ra vào bến cảng Sài Gòn. Ngoài các con sông chính, Thành phố Hồ Chí Minh còn có một hệ thống kênh rạch chằng chịt: Láng The, Bàu Nông, rạch Tra, Bến Cát, An Hạ, Tham Lương, Cầu Bông, Nhiêu Lộc-Thị Nghè, Bến Nghé, Lò Gốm, Kênh Tẻ, Tàu Hũ, Kênh Ðôi...Hệ thống sông, kênh rạch giúp Thành phố Hồ Chí Minh trong việc tưới tiêu, nhưng do chịu ảnh hưởng dao động triều bán nhật của biển Ðông, thủy triều thâm nhập sâu đã gây nên những tác động xấu tới sản xuất nông nghiệp và hạn chế việc tiêu thoát nước ở khu vực nội thành[7].++Nhờ trầm tích Pleistocen, khu vực phía Bắc Thành phố Hồ Chí Minh có được lượng nước ngầm khá phong phú. Nhưng về phía Nam, trên trầm tích Holocen, nước ngầm thường bị nhiễm phèn, nhiễm mặn. Khu vực nội thành cũ có lượng nước ngầm đáng kể, tuy chất lượng không thực sự tốt, vẫn được khai thác chủ yếu ở ba tầng: 0–20 m, 60–90 m và 170–200 m (tầng trầm tích Miocen). Tại Quận 12, các huyện Hóc Môn và Củ Chi, chất lượng nước tốt, trữ lượng dồi dào, thường được khai thác ở tầng 60–90 m, trở thành nguồn nước bổ sung quan trọng.[7]+Khí hậu, thời tiết++Nằm trong vùng nhiệt đới xavan, Thành phố Hồ Chí Mình có nhiệt độ cao đều trong năm và hai mùa mưa – khô rõ rệt. Mùa mưa được bắt đầu từ tháng 5 tới tháng 11, còn mùa khô từ tháng 12 tới tháng 4 năm sau. Trung bình, Thành phố Hồ Chí Minh có 160 tới 270 giờ nắng một tháng, nhiệt độ trung bình 27 °C, cao nhất lên tới 40 °C, thấp nhất xuống 13,8 °C. Hàng năm, thành phố có 330 ngày nhiệt độ trung bình 25 tới 28 °C. Lượng mưa trung bình của thành phố đạt 1.949 mm/năm, trong đó năm 1908 đạt cao nhất 2.718 mm, thấp nhất xuống 1.392 mm vào năm 1958. Một năm, ở thành phố có trung bình 159 ngày mưa, tập trung nhiều nhất vào các tháng từ 5 tới 11, chiếm khoảng 90%, đặc biệt hai tháng 6 và 9. Trên phạm vi không gian thành phố, lượng mưa phân bố không đều, khuynh hướng tăng theo trục Tây Nam – Ðông Bắc. Các quận nội thành và các huyện phía Bắc có lượng mưa cao hơn khu vực còn lại[8].++Thành phố Hồ Chí Minh chịu ảnh hưởng bởi hai hướng gió chính là gió mùa Tây – Tây Nam và Bắc – Ðông Bắc. Gió Tây – Tây Nam từ Ấn Độ Dương, tốc độ trung bình 3,6 m/s, vào mùa mưa. Gió Gió Bắc – Ðông Bắc từ biển Đông, tốc độ trung bình 2,4 m/s, vào mùa khô. Ngoài ra còn có gió tín phong theo hướng Nam – Đông Nam vào khoảng tháng 3 tới tháng 5, trung bình 3,7 m/s. Có thể nói Thành phố Hồ Chí Minh thuộc vùng không có gió bão. Cũng như lượng mưa, độ ẩm không khí ở thành phố lên cao vào mùa mưa (80%), và xuống thấp vào mùa khô (74,5%). Bình quân độ ẩm không khí đạt 79,5%/năm[8].+ Khí hậu Thành phố Hồ Chí MinhTháng	1	2	3	4	5	6	7	8	9	10	11	12+Trung bình tối cao °C (°F)	32 (90)	33 (91)	34 (93)	34 (93)	33 (91)	32 (90)	31 (88)	32 (90)	31 (88)	31 (88)	30 (86)	31 (88)+Trung bình tối thấp °C (°F)	21 (70)	22 (72)	23 (73)	24 (75)	25 (77)	24 (75)	25 (77)	24 (75)	23 (73)	23 (73)	22 (72)	22 (72)+Lượng mưa mm (inch)	14 (0.6)	4 (0.2)	12 (0.5)	42 (1.7)	220 (8.7)	331 (13)	313 (12.3)	267 (10.5)	334 (13.1)	268 (10.6)	115 (4.5)	56 (2.2)++Nguồn: Đại sứ quán Việt Nam tại London[9] 26 tháng 2 năm 2008.+Môi trường++Với tốc độ gia tăng dân số quá nhanh, cơ sở hạ tầng chưa kịp quy hoạch nâng cấp tổng thể, ý thức một số người dân lại quá kém trong nhận thức và bảo vệ môi trường chung... Vì vậy, Thành phố Hồ Chí Minh hiện nay đang phải đối mặt với vấn đề ô nhiễm môi trường quá lớn. Hiện trạng nước thải không được xử lý đổ thẳng vào hệ thống sông ngòi còn rất phổ biến. Nhiều cơ sở sản xuất, bệnh viện và cơ sở y tế chưa có hệ thống xử lý nước thải là một thực trạng đáng báo động[10]. Tại cụm công nghiệp Tham Lương, nguồn nước bị nhiễm bẩn bởi chất thải công nghiệp với tổng lượng nước thải ước tính 500.000 m³/ngày[11]. Sông Sài Gòn, mức độ ô nhiễm vi sinh chủ yếu do hoạt động nuôi trồng thuỷ sản gây ra vượt tiêu chuẩn cho phép đến 220 lần. Cho tới 2008, vẫn chưa có giải pháp cụ thể nào để chấm dứt tình trạng ô nhiễm này[12].++Lượng rác thải ở Thành phố Hồ Chí Minh lên tới 6.000 tấn/ngày, trong đó một phần lượng rác thải rắn không được thu gom hết. Kết quả quan trắc năm 2007 cho thấy, so với năm 2006, sự ô nhiễm hữu cơ tăng 2 đến 4 lần. Các phương tiện giao thông, hoạt động xây dựng, sản xuất... còn góp phần gây ô nhiễm không khí. Khu vực ngoại thành, đất cũng bị ô nhiễm do tồn đọng thuốc bảo vệ thực vật từ sản xuất nông nghiệp gây nên[13].++Tình trạng ngập lụt trong trung tâm thành phố đang ở mức báo động cao, xảy ra cả trong mùa khô. Diện tích khu vực ngập lụt khoảng 140 km2 với 85% điểm ngập nước nằm ở khu vực trung tâm. Thiệt hại do ngập nước gây ra ước tính 8 tỷ đồng mỗi năm. Nguyên nhân là do hệ thống cống thoát nước được xây cách đây 50 năm đã xuống cấp. Ngoài ra, việc xây dựng các khu công nghiệp và đô thị ở khu vực phía nam – khu vực thoát nước của thành phố này đã làm cho tình hình ngập càng nghiêm trọng hơn[14].++Trước những bức xúc về thực trạng môi trường, Thành phố Hồ Chí Minh đang khẩn trương tìm mọi cách nâng cao chất lượng cuộc sống của người dân trên địa bàn. Việc trích ra một nguồn vốn lớn nhiều tỷ đồng đầu tư xây dựng hồ sinh học cải tạo nước kênh Ba Bò là một ví dụ[15].+Lịch sử+Bài chi tiết: Lịch sử Thành phố Hồ Chí Minh+Thời kỳ hoang sơ++Con người xuất hiện ở khu vực Sài Gòn từ khá sớm. Các cuộc khai quật khảo cổ trên địa phận Sài Gòn và khu vực lân cận cho thấy ở đây đã tồn tại nhiều nền văn hóa từ thời kỳ đồ đá cho tới thời kim khí. Những cư dân cổ từ nhiều thiên niên kỷ về trước đã biết đến kỹ thuật canh tác nông nghiệp. Văn hóa Sa Huỳnh từng tồn tại trên khu vực này với những nét rất riêng. Thời kỳ văn hóa Óc Eo, từ đầu Công Nguyên cho tới thế kỷ 7, khu vực miền Nam Đông Dương có nhiều tiểu quốc và Sài Gòn khi đó là miền đất có quan hệ với những vương quốc này.++Cho đến trước thế kỷ 16, vị trí tiếp giáp với các quốc gia cổ cũng khiến Sài Gòn trở thành nơi gặp gỡ của nhiều cộng đồng dân cư. Nhưng những cuộc tranh chấp đã khiến vùng đất Sài Gòn - Gia Định vẫn là miền đất hoang, vô chủ, địa bàn của vài nhóm dân cư cổ cho tới khi người Việt xuất hiện[16].+Khai phá+ + Sơ đồ Thành Bát Quái, công trình được xây dựng năm 1790++Những người Việt đầu tiên tự động vượt biển tới khai vùng đất này hoàn toàn không có sự tổ chức của nhà Nguyễn. Nhờ cuộc hôn nhân giữa công nữ Ngọc Vạn với vua Chân Lạp Chey Chetta II từ năm 1620, mối quan hệ giữa Đại Việt và Chân Lạp trở nên êm đẹp, dân cư hai nước có thể tự do qua lại sinh sống. Khu vực Sài Gòn, Đồng Nai bắt đầu xuất hiện những người Việt định cư. Trước đó, người Chăm, người Man cũng sinh sống rải rác ở đây từ xa xưa[17].++Giai đoạn từ 1623 tới 1698 được xem như thời kỳ hình thành của Sài Gòn sau này[18]. Năm 1623, chúa Nguyễn sai một phái bộ tới yêu cầu vua Chey Chettha II cho lập đồn thu thuế tại Prei Nokor (Sài Gòn) và Kas Krobei (Bến Nghé). Tuy đây là vùng rừng rậm hoang vắng nhưng lại nằm trên đường giao thông của các thương nhân Việt Nam qua Campuchia và Xiêm. Hai sự kiện quạn trọng tiếp theo của thời kỳ này là lập doanh trại và dinh thự của Phó vương Nặc Nộn và lập đồn dinh ở Tân Mỹ (gần ngã tư Cống Quỳnh - Nguyễn Trãi ngày nay). Có thể nói Sài Gòn hình thành từ ba cơ quan chính quyền này[18].++Năm 1679, chúa Nguyễn Phúc Tần cho một nhóm người Hoa "phản Thanh phục Minh" tới Mỹ Tho, Biên Hòa và Sài Gòn để lánh nạn. Đến năm 1698, chúa Nguyễn sai Nguyễn Hữu Cảnh kinh lý vào miền Nam. Trên cơ sở những lưu dân Việt đã tự phát tới khu vực này trước đó, Nguyễn Hữu Cảnh cho lập phủ Gia Định và hai huyện Phước Long, Tân Bình. Vùng Nam Bộ được sát nhập vào cương vực Việt Nam[19].++Thời điểm ban đầu này, khu vực Biên Hòa, Gia Định có khoảng 10.000 hộ với 200.000 khẩu. Công cuộc khai hoang được tiến hành theo những phương thức mới, mang lại hiệu quả hơn. Năm 1802, sau khi chiến thắng Tây Sơn, Nguyễn Ánh lên ngôi và đẩy mạnh công cuộc khai khẩn miền Nam. Các công trình kênh đào Rạch Giá - Hà Tiên, Vĩnh Tế... được thực hiện. Qua 300 năm, các trung tâm nông nghiệp phát triển bao quanh những đô thị sầm uất được hình thành[20].+Từ Gia Định tới Sài Gòn++Năm 1788, Nguyễn Ánh tái chiếm Sài Gòn, lấy nơi đây làm cơ sở để chống lại Tây Sơn. Năm 1790, với sự giúp đỡ của hai sĩ quan công binh người Pháp, Theodore Lebrun và Victor Olivier de Puymanel, Nguyễn Ánh cho xây dựng Thành Bát Quái làm trụ sở của chính quyền mới. "Gia Định thành" khi đó được đổi thành "Gia Định kinh"[21]. Tới năm 1802, Nguyễn Ánh lên ngôi ở Huế, miền Nam được chia thành 5 trấn. Sáu năm sau, 1808, "Gia Định trấn" lại được đổi thành "Gia Định thành". Trong khoảng thời gian 1833 đến 1835, Lê Văn Khôi khởi binh chống lại nhà Nguyễn, Thành Bát Quái trở thành địa điểm căn cứ. Sau khi trấn áp cuộc nổi dậy, năm 1835, vua Minh Mạng cho phá Thành Bát Quái, xây dựng Phụng Thành thay thế[22].+ +Chợ Bến Thành, Sài Gòn thời thuộc địa với những cột Morris đặc trưng của Pháp.++Ngay sau khi chiếm được thành Gia Định vào năm 1859, người Pháp gấp rút quy hoạch lại Sài Gòn thành một đô thị lớn phục vụ mục đích khai thác thuộc địa. Theo thiết kế ban đầu, Sài Gòn bao gồm cả khu vực Chợ Lớn. Nhưng đến 1864, nhận thấy diện tích dự kiến của thành phố quá rộng, khó bảo đảm về an ninh, chính quyền Pháp quyết định tách Chợ Lớn khỏi Sài Gòn. Rất nhanh chóng, các công trình quan trọng của thành phố, như Dinh Thống đốc Nam Kỳ, Dinh Toàn quyền, được thực hiện. Sau hai năm xây dựng và cải tạo, bộ mặt Sài Gòn hoàn toàn thay đổi[23].++Thành phố Sài Gòn khi đó được thiết kế theo mô hình châu Âu, nơi đặt văn phòng nhiều cơ quan công vụ như: dinh thống đốc, nha giám đốc nội vụ, tòa án, tòa thượng thẩm, tòa sơ thẩm, tòa án thương mại, tòa giám mục... Lục tỉnh Nam Kỳ là thuộc địa của Pháp và Sài Gòn nằm trong tỉnh Gia Định. Vào năm 1861, địa phận Sài Gòn được giới hạn bởi một bên là rạch Thị Nghè và rạch Bến Nghé với một bên là sông Sài Gòn cùng con đường nối liền chùa Cây Mai với những phòng tuyến cũ của đồn Kỳ Hòa. Đến năm 1867, việc quản lý Sài Gòn được giao cho Ủy ban thành phố gồm 1 ủy viên và 12 hội viên. Cho tới nửa đầu thập niên 1870, thành phố Sài Gòn vẫn nằm trong địa hạt hành chính tỉnh Gia Định[23]. Ngày 15 tháng 3 năm 1874, Tổng thống Pháp Jules Grévy ký sắc lệnh thành lập thành phố Sài Gòn[22]. Đứng đầu là viên Thị trưởng người Pháp. Đến năm 1879 thì chính quyền cho lập thêm Hội đồng thành phố Sài Gòn (hay đúng ra là Ủy hội thành phố - Commission municipale).[24]++Trong suốt thời kỳ Pháp thuộc, Sài Gòn trở thành trung tâm quan trọng, không chỉ hành chính mà còn kinh tế, văn hóa, giáo dục của cả Liên bang Đông Dương, được mệnh danh là Hòn ngọc Viễn Đông" ("the Pearl of the Far East") hoặc "Paris Phương Đông" ("Paris in the Orient")[cần dẫn nguồn].++Tính đến năm 1945 thì thành phố Sài Gòn-Chợ Lớn có dân số là 500.000. Chiến tranh Đông Dương tác động cuộc di dân từ nông thôn lên thành thị khiến bốn năm sau, 1949 thì dân số tăng hơn gấp đôi thành 1.200.000 và sang năm 1954 với hàng trăm nghìn người di cư vào Nam từ phía bắc vĩ tuyến 17 thì dân số Sài Gòn leo cao, đạt 2.000.000.[25]+Thủ đô Sài Gòn+ + Tòa đô chánh Saigon 1966++Từ năm 1949, Sài Gòn đã là thủ đô của Quốc gia Việt Nam. Đến năm 1955, Việt Nam Cộng hòa được thành lập, Sài Gòn trở thành thủ đô và cũng là thành phố lớn nhất của quốc gia non trẻ này với tên gọi chính thức "Thành đô Sài Gòn" (lưu ý, cách viết thông dụng là "Saigon"). Cũng năm 1954, thành phố tiếp nhận một lượng di dân mới từ miền Bắc Việt Nam (phần đông là người Công Giáo, còn gọi là dân Bắc Kỳ Công giáo) tập trung tại các khu vực như Xóm Mới-Gò Vấp, Bình An-quận 8, và rải rác tại các quận khác. Với nghị định số 110-NV ngày 27 tháng 3 năm 1959 của Tổng thống Ngô Đình Diệm, từ 6 quận, Sài Gòn được chia thành 8 quận với tổng cộng 45 phường.++Vào nửa cuối thập niên 1950, nhờ sự phát triển của kinh tế Việt Nam Cộng hòa và viện trợ của Chính phủ Hoa Kỳ và các nước đồng minh, Sài Gòn trở thành một thành phố hoa lệ với mệnh danh "Hòn ngọc Viễn Đông".[26] Từ giữa thập niên 1960 đến những năm đầu thập niên 1970, việc Quân đội Hoa Kỳ vào tham chiến tại miền Nam cũng gây nên những xáo trộn đối với thành phố. Nhiều cao ốc, công trình quân sự mọc lên[27]. Lối sống của giới trẻ Sài Gòn cũng chịu ảnh hưởng bởi văn hóa Âu Mỹ. Thành phố trở thành một trung tâm về chính trị, kinh tế, văn hóa, giải trí.++Nhưng tới những năm cuối của cuộc Chiến tranh Việt Nam, nền kinh tế miền Nam đi xuống do Mỹ cắt giảm viện trợ, nạn lạm phát trở nên nghiêm trọng. Hệ lụy và hậu quả trực tiếp của cuộc chiến gây ảnh hưởng xấu tới đô thị Sài Gòn. Sự kiện 30 tháng 4 năm 1975 đã khiến nhiều người dân Sài Gòn rời bỏ thành phố ra nước ngoài định cư.[28] Cũng trong thời gian này, ước tính 700.000 người khác được vận động đi kinh tế mới; nền văn hóa có ảnh hưởng phương Tây bị lu mờ rồi tàn lụi.[29]+Thành phố Hồ Chí Minh++Từ 30/04/1975, Chính quyền Việt Nam Cộng hòa bị xóa bỏ và Chính phủ Cách mạng lâm thời Cộng Hòa miền Nam Việt Nam - nằm dưới sự chỉ đạo của Đảng Cộng sản Việt Nam - quản lý miền Nam. Thành Đô Sài Gòn, tỉnh Gia Định và 2 quận Củ Chi và Phú Hòa kế cận dưới thời chính quyền Việt Nam Cộng hòa, được hợp nhất thành 1 đơn vị hành chính gọi là thành phố Sài Gòn - Gia Định. Đầu năm 1976, Đảng bộ và Ủy ban Nhân dân thành phố bắt đầu hoạt động. Ngày 2 tháng 7 năm 1976, Quốc hội đầu tiên của nước Việt Nam thống nhất quyết định đổi tên nước thành Cộng hòa Xã hội Chủ nghĩa Việt Nam, đồng thời đổi tên thành phố Sài Gòn - Gia Định thành "Thành phố Hồ Chí Minh", theo tên cuối cùng của chủ tịch nước đầu tiên, Hồ Chí Minh[30].+ +Dinh Độc Lập, công trình tiêu biểu của Sài Gòn trước 1975++Với tổng diện tích 2.095 km², Thành phố Hồ Chí Minh trở thành đô thị lớn nhất Việt Nam. 11 quận nội thành của Sài Gòn trước đây được chia lại thành 8 quận. Bốn quận Gò Vấp, Phú Nhuận, Bình Thạnh, Tân Bình được thành lập. Khu vực ngoại thành gồm 5 huyện: Thủ Đức, Hóc Môn, Củ Chi, Bình Chánh, Nhà Bè. Năm 1978, thành phố nhận thêm huyện Duyên Hải của tỉnh Đồng Nai. Năm 1979, các đơn vị hành chính cơ sở được phân chia lại, toàn thành phố có 261 phường, 86 xã. Sau đợt điều chỉnh tiếp theo vào năm 1989, thành phố còn 182 phường và 100 xã, thị trấn. Đến năm 1997, phân chia hành chính của thành phố lại thay đổi, gồm 17 quận, 5 huyện với 303 phường xã, thị trấn. Hiện nay, Thành phố Hồ Chí Minh gồm 19 quận nội thành và 5 huyện ngoại thành với 322 phường, xã và thị trấn[31].+Hành chính+Bài chi tiết: Tổ chức hành chính tại Thành phố Hồ Chí Minh+ +Trụ sở Ủy ban Nhân dân Thành phố++Thành phố Hồ Chí Minh hiện nay là một trong 5 thành phố trực thuộc Trung ương của Việt Nam. Về mặt hành chính, thành phố được chia thành 19 quận và 5 huyện.+Quận (19): 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, Bình Tân, Bình Thạnh, Gò Vấp, Phú Nhuận, Tân Bình, Tân Phú, Thủ Đức.+Huyện (5): Bình Chánh, Cần Giờ, Củ Chi, Hóc Môn, Nhà Bè.++Toàn thành phố có 322 đơn vị hành chính cấp xã, bao gồm: 259 phường, 58 xã và 5 thị trấn.. Với tổng diện tích 2.095,01 km², theo kết quả chính thức điều tra dân số ngày 01/04/2009 dân số thành phố là 7.162.864 người, mật độ 3.419 người/km². Lượng dân cư này tập trung chủ yếu trong nội thành, gồm 5.881.511 người, mật độ lên tới 11.906 người/km². Trong khi đó các huyện ngoại thành chỉ có 1.281.353 người, đạt 801 người/km².++Về hành chính, Hội đồng Nhân dân thành phố, với các đại biểu được bầu cử trực tiếp nhiệm kỳ 5 năm, có quyền quyết định các kế hoạch phát triển dài hạn về kinh tế, văn hóa, giáo dục... của thành phố. Đứng đầu Hội đồng Nhân dân gồm một Chủ tịch, một Phó chủ tịch và một Uỷ viên thường trực. Hội đồng Nhân dân chịu sự giám sát và hướng dẫn hoạt động của Ủy ban Thường vụ Quốc hội, chịu sự hướng dẫn và kiểm tra của Chính phủ trong việc thực hiện các văn bản của cơ quan nhà nước cấp trên theo quy định của Uỷ ban Thường vụ Quốc hội[32].++Hội đồng Nhân dân thành phố bầu nên Ủy ban Nhân dân, cơ quan trực tiếp chịu trách nhiệm quản lý về mọi hoạt động chính trị, an ninh, kinh tế và văn hóa trên địa bàn thành phố. Đứng đầu Ủy Ban Nhân dân gồm một Chủ tịch và các Phó chủ tịch. Các sở, ngành của Ủy ban Nhân dân sẽ quản lý về các lĩnh vực cụ thể, như y tế, giáo dục, đầu tư, tư pháp, tài chính. Tương tự, cấp quận, huyện cũng có Hội đồng Nhân dân và Ủy ban Nhân dân chịu sự chỉ đạo chung của cấp thành phố. Ngoài ra, Ủy ban Nhân dân còn quản lý một số tổng công ty trên địa bàn thành phố[33].++Bên cạnh Chủ tịch Hội đồng Nhân dân và Chủ tịch Ủy ban Nhân dân, đảng bộ Đảng Cộng sản Việt Nam tại thành phố còn bầu ra Bí thư Thành ủy. Quyền hạn và trách nhiệm của Bí thư Thành ủy được quy định theo Điều lệ Đảng Cộng sản Việt Nam. Vào năm 1995, hệ thống quản lý hành chính nhà nước trên địa bàn Thành phố Hồ Chí Minh có 976 địa chỉ, trong đó 47 thuộc trung ương, 73 thuộc thành phố, 549 thuộc các quận, huyện và 307 thuộc cấp phường xã. Các tổ chức đoàn thể, chính trị bao gồm cấp trung ương và thành phố có 291 địa chỉ, các đơn vị sự nghiệp có 2.719 địa chỉ.+Kinh tế+Bài chi tiết: Kinh tế Thành phố Hồ Chí Minh+ + Trung tâm thương mại Diamond Plaza++Thành phố Hồ Chí Minh giữ vai trò đầu tàu kinh tế của cả Việt Nam. Thành phố chiếm 0,6% diện tích và 8,34% dân số của Việt Nam nhưng chiếm tới 20,2% tổng sản phẩm, 27,9% giá trị sản xuất công nghiệp và 34,9% dự án nước ngoài[34]. Vào năm 2005, Thành phố Hồ Chí Minh có 4.344.000 lao động, trong đó 139 nghìn người ngoài độ tuổi lao động nhưng vẫn đang tham gia làm việc[35]. Năm 2010, thu nhập bình quân đầu người ở thành phố đạt 2.800 USD/năm, cao hơn nhiều so với trung bình cả nước, 1168 USD/năm.[36]. Tổng GDP cả năm 2010 đạt 418.053 tỷ đồng (tính theo gía thực tế khoảng 20,902 tỷ USD), tốc độ tăng trưởng đạt 11.8%[37].+ +Tòa nhà Bitexco Financial tại trung tâm Thành Phố vào ban đêm++Nền kinh tế của Thành phố Hồ Chí Minh đa dạng về lĩnh vực, từ khai thác mỏ, thủy sản, nông nghiệp, công nghiệp chế biến, xây dựng đến du lịch, tài chính... Cơ cấu kinh tế của thành phố, khu vực nhà nước chiếm 33,3%, ngoài quốc doanh chiếm 44,6%, phần còn lại là khu vực có vốn đầu tư nước ngoài. Về các ngành kinh tế, dịch vụ chiếm tỷ trọng cao nhất: 51,1%. Phần còn lại, công nghiệp và xây dựng chiếm 47,7%, nông nghiệp, lâm nghiệp và thủy sản chỉ chiếm 1,2%[38].++Tính đến giữa năm 2006, 3 khu chế xuất và 12 khu công nghiệp Thành phố Hồ Chí Minh đã thu hút được 1.092 dự án đầu tư, trong đó có 452 dự án có vốn đầu tư nước ngoài với tổng vốn đầu tư hơn 1,9 tỉ USD và 19,5 nghìn tỉ VND[39]. Thành phố cũng đứng đầu Việt Nam tổng lượng vốn đầu tư trực tiếp nước ngoài với 2.530 dự án FDI, tổng vốn 16,6 tỷ USD vào cuối năm 2007[40]. Riêng trong năm 2007, thành phố thu hút hơn 400 dự án với gần 3 tỷ USD[41]. Trong bảng xếp hạng về Chỉ số năng lực cạnh tranh cấp tỉnh của Việt Nam năm 2011, thành phố Hồ Chí Minh xếp ở vị trí thứ 20/63 tỉnh thành.[42]++Về thương mại, Thành phố Hồ Chí Minh có một hệ thống trung tâm mua sắm, siêu thị, chợ đa dạng. Chợ Bến Thành là biểu tượng về giao lưu thương mại từ xa xưa của thành phố, hiện nay vẫn giữ một vai trò quan trọng. Những thập niên gần đây, nhiều trung tâm thương mại hiện đại xuất hiện như Saigon Trade Centre, Diamond Plaza... Mức tiêu thụ của Thành phố Hồ Chí Minh cũng cao hơn nhiều so với các tỉnh khác của Việt Nam và gấp 1,5 lần thủ đô Hà Nội[43]. Sở Giao dịch Chứng khoán Thành phố Hồ Chí Minh, có mã giao dịch là VN-Index, được thành lập vào tháng 7 năm 1998. Tính đến ngày 31 tháng 12 năm 2007, toàn thị trường đã có 507 loại chứng khoán được niêm yết, trong đó có 138 cổ phiếu với tổng giá trị vốn hóa đạt 365 nghìn tỷ đồng[44].++Tuy vậy, nền kinh tế của Thành phố Hồ Chí Minh vẫn phải đối mặt với nhiều khó khăn. Toàn thành phố chỉ có 10% cơ sở công nghiệp có trình độ công nghệ hiện đại. Trong đó, có 21/212 cơ sở ngành dệt may, 4/40 cơ sở ngành da giày, 6/68 cơ sở ngành hóa chất, 14/144 cơ sở chế biến thực phẩm, 18/96 cơ sở cao su nhựa, 5/46 cơ sở chế tạo máy... có trình độ công nghệ, kỹ thuật sản xuất tiên tiến[45]. Cơ sở hạ tầng của thành phố lạc hậu, quá tải, chỉ giá tiêu dùng cao, tệ nạn xã hội, hành chính phức tạp... cũng gây khó khăn cho nền kinh tế[41]. Ngành công nghiệp thành phố hiện đang hướng tới các lĩnh vực cao, đem lại hiệu quả kinh tế hơn.+Xã hội+Dân cư+Vào tháng 05/1975 dân số thành phố Sài Gòn - Gia Định (đến tháng 07/1976 đổi tên thành Thành phố Hồ Chí Minh) là 3.498.120 người (thống kê của chính quyền thành phố).+Dân số Thành phố Hồ Chí Minh theo các kết quả điều tra dân số chính thức như sau: +Ngày 1/10/1979 (Điều tra toàn quốc): 3.419.977 người.[46]+Ngày 1/4/1989 (Điều tra toàn quốc): 3.988.124 người.+Ngày 1/4/1999 (Điều tra toàn quốc): 5.037.155 người.+Ngày 1/10/2004 (Điều tra của thành phố): 6.117.251 người.+Ngày 1/4/2009 (Điều tra toàn quốc): 7.162.864 người.+Theo số liệu điều tra của Tổng cục Thống kê ngày 1/4/2010, dân số thành phố là 7.382.287 người.[47]+Theo số liệu của Cục Thống kê Thành phố Hồ Chí Minh, dân số thành phố vào giữa năm 2010 là 7.396.446 người, mật độ 3.531 người/km2[48]+Theo số liệu điều tra của Tổng cục Thống kê ngày 1/4/2011, dân số thành phố là 7.549.341 người.[1]+Theo kết quả điều tra dân số ngày 01/04/2009 Thành phố Hồ Chí Minh có dân số 7.162.864 người, gồm 1.824.822 hộ dân trong đó: 1.509.930 hộ tại thành thị và 314.892 hộ tại nông thôn, bình quân 3,93 người/hộ. Phân theo giới tính: Nam có 3.435.734 người chiếm 47,97%, nữ có 3.727.130 người chiếm 52,03%. Những năm gần đây dân số thành phố tăng nhanh; trong 10 năm từ 1999-2009 dân số thành phố tăng thêm 2.125.709 người, bính quân tăng hơn 212.000 người/năm, tốc độ tăng 3,54%/năm, chiếm 22,32% số dân tăng thêm của cả nước trong vòng 10 năm. Với 572.132 người, tương đương với dân số một số tỉnh như: Quảng Trị, Ninh Thuận, quận Bình Tân có dân số lớn nhất trong số các quận cả nước. Tương tự, huyện Bình Chánh với 420.109 dân là huyện có dân số lớn nhất trong số các huyện cả nước. Trong khi đó huyện Cần Giờ với 68.846 người, có dân số thấp nhất trong số các quận, huyện của thành phố [49]. Không chỉ là thành phố đông dân nhất Việt Nam, quy mô dân số của Thành phố Hồ Chí Minh còn hơn phần lớn các thủ đô ở châu Âu ngoại trừ Moscow và London. Theo số liệu thống kê năm 2009, 83,32% dân cư sống trong khu vực thành thị. Thành phố Hồ Chí Minh có gần một phần ba là dân nhập cư từ các tỉnh khác.+Phân tích theo cơ cấu dân tộc: Người Việt (người Kinh) 6.699.124 người chiếm 93,52% dân số thành phố, tiếp theo tới người Hoa với 414.045 người chiếm 5,78%, còn lại là các dân tộc: Khmer 24.268 người, Chăm 7.819 người... Tổng cộng có đến 52/54 dân tộc được công nhận tại Việt Nam có người cư trú tại thành phố (chỉ thiếu dân tộc Bố Y và Cống), ít nhất là người La Hủ chỉ có 01 người. Ngoài ra còn 1.128 người được phân loại là người nước ngoài, có nguồn gốc từ các quốc gia khác (India, Pakistan, Indonesia, France...). Cộng đồng người Hoa ở Thành phố Hồ Chí Minh là cộng đồng người Hoa lớn nhất Việt Nam (bằng 50,3% tổng số người Hoa cả nước), cư trú khắp các quận, huyện, nhưng tập trung nhiều nhất tại Quận 5, 6, 8, 10, 11 và có những đóng góp đáng kể cho nền kinh tế thành phố[50].+Phân tích dân số theo tôn giáo: Căn cứ theo số liệu điều tra dân số năm 2009, 1.983.048 người (27,68% tổng số dân thành phố) kê khai có tôn giáo. Trong đó những tôn giáo có nhiều tín đồ là: Phật giáo 1.164.930 người chiếm 16,26%, Công giáo 745.283 người chiếm 10,4%, Cao đài 31.633 người chiếm 0,44%, Tin lành 27.016 người chiếm 0,37%, Hồi giáo 6.580 người chiếm 0,09%.++Sự phân bố dân cư ở Thành phố Hồ Chí Minh không đồng đều. Trong khi một số quận như: 3, 4, 10 và 11 có mật độ lên tới trên 40.000 người/km², thì huyện ngoại thành Cần Giờ có mật độ tương đối thấp 98 người/km²[51]. Về mức độ gia tăng dân số, trong khi tỷ lệ tăng tự nhiên khoảng 1,07% thì tỷ lệ tăng cơ học lên tới 2,5%[52]. Những năm gần đây dân số các quận trung tâm có xu hướng giảm; trong khi dân số các quận mới lập vùng ven tăng nhanh, do đón nhận dân từ trung tâm chuyển ra và người nhập cư từ các tỉnh đến sinh sống. Theo ước tính năm 2005, trung bình mỗi ngày có khoảng 1 triệu khách vãng lai tại Thành phố Hồ Chí Minh. Đến năm 2010, con số này còn có thể tăng lên tới 2 triệu[53].++Mặc dù Thành phố Hồ Chí Minh có thu nhập bình quân đầu người rất cao so với mức bình quân của cả Việt Nam, nhưng khoảng cách giàu nghèo ngày các lớn do những tác động của nền kinh tế thị trường. Những người hoạt động trong lĩnh vực thương mại cao hơn nhiều so với ngành sản xuất. Sự khác biệt xã hội vẫn còn thể hiện rõ giữa các quận nội ô so với các huyện ở ngoại thành.+Y tế+ + Bệnh viện tim Tâm Đức tại Quận 7++Thành phố Hồ Chí Minh, với dân số đông, mật độ cao trong nội thành, cộng thêm một lượng lớn dân vãng lai, đã phát sinh nhu cầu lớn về y tế và chăm sóc sức khỏe. Các tệ nạn xã hội, như mại dâm, ma túy, tình trạng ô nhiễm môi trường... gây ảnh hưởng lớn tới sức khỏe dân cư thành phố. Những bệnh truyền nhiễm phổ biến ở các nước đang phát triển như sốt rét, sốt xuất huyết, tả, thương hàn... hay các bệnh của những quốc gia công nghiệp phát triển, như tim mạch, tăng huyết áp, ung thư, tâm thần, bệnh nghề nghiệp... đều xuất hiện ở Thành phố Hồ Chí Minh[54]. Tuổi thọ trung bình của nam giới ở thành phố là 71,19, con số ở nữ giới là 75,00[55].++Vào năm 2005, Thành phố Hồ Chí Minh có 21.780 nhân viên y tế, trong đó có 3.399 bác sĩ. Tỷ lệ bác sĩ đạt 5.45 trên 10 nghìn dân, giảm so với con số 7.31 của năm 2002[56]. Toàn thành phố có 19.442 giường bệnh, 56 bệnh viện, 317 trạm y tế và 5 nhà hộ sinh[57]. Thế nhưng mạng lưới bệnh viện chưa được phân bổ hợp lý, tập trung chủ yếu trong nội ô. Theo con số năm 1994, chỉ riêng Quận 5 có tới 13 bệnh viện với 5.290 giường, chiếm 37% số giường bệnh toàn thành phố[58]. Bù lại, hệ thống y tế cộng đồng tương đối hoàn chỉnh, tất cả các xã, phường đều có trạm y tế. Bên cạnh hệ thống nhà nước, thành phố cũng có 2.303 cơ sở y tế tư nhân và 1.472 cơ sở dược tư nhân, góp phần giảm áp lực cho các bệnh viện lớn. Cũng tương tự hệ thống y tế nhà nước, các cơ sở này tập trung chủ yếu trong nội ô và việc đảm bảo các nguyên tắc chuyên môn chưa được chặt chẽ[54].++Sở Y tế thành phố hiện nay quản lý 8 bệnh viện đa khoa và 20 bệnh viện chuyên khoa. Nhiều bệnh viện của thành phố đã liên doanh với nước ngoài để tăng chất lượng phục vụ.+Giáo dục+ + Trụ sở Đại học Quốc gia Thành phố Hồ Chí Minh++Về mặt hành chính, Sở Giáo dục Thành phố Hồ Chí Minh chỉ quản lý các cơ sở giáo dục từ bậc mầm non tới phổ thông. Các trường đại học, cao đẳng phần lớn thuộc Bộ Giáo dục và Đào tạo Việt Nam. Trong năm học 2008–2009, toàn thành phố có 638 cơ sở giáo dục mầm non, 467 trường cấp I, 239 trường cấp II, 81 trường cấp III và 55 trường cấp II, III[59]. Ngoài ra, theo con số từ 1994, Thành phố Hồ Chí Minh còn có 20 trung tâm xóa mù chữ, 139 trung tâm tin học, ngoại ngữ và 12 cơ sở giáo dục đặc biệt. Tổng cộng 1.308 cơ sở giáo dục của thành phố có 1.169 cơ sở công lập và bán công, còn lại là các cơ sở dân lập, tư thục[60].++Hệ thống các trường từ bậc mầm non tới trung học trải đều khắp thành phố. Trong khi đó, những cơ sở xóa mù chữ, phổ cập giáo dục tập trung chủ yếu vào bốn huyện ngoại thành Củ Chi, Bình Chánh, Nhà Bè, Cần Giờ. Các trường ngoại ngữ ở Thành phố Hồ Chí Minh không chỉ giảng dạy những ngôn ngữ phổ biến mà còn một trường dạy quốc tế ngữ, một trường dạy Hán Nôm, bốn trường dạy tiếng Việt cho người nước ngoài. Thành phố Hồ Chí Minh hiện nay cũng có 40 trường quốc tế do các lãnh sự quán, công ty giáo dục đầu tư[61].+Bài chi tiết: Danh sách trường đại học tại Thành phố Hồ Chí Minh++Giáo dục bậc đại học, trên địa bàn thành phố có trên 80 trường, đa số do Bộ Giáo dục và Đào tạo quản lý, trong đó chỉ có 2 trường đại học công lập (Trường đại học Sài Gòn và Trường Đại học Y khoa Phạm Ngọc Thạch) do thành phố quản lý. Là thành phố lớn nhất Việt Nam, Thành phố Hồ Chí Minh cũng là trung tâm giáo dục bậc đại học lớn bậc nhất, cùng với Hà Nội. Đại học Quốc gia Thành phố Hồ Chí Minh với 6 trường đại học thành viên[62]. Nhiều đại học lớn khác của thành phố như Đại học Kiến trúc, Đại học Y Dược, Đại học Ngân hàng, Đại học Luật, Đại học Kinh tế... đều là các đại học quan trọng của Việt Nam. Trong số học sinh, sinh viên đang theo học tại các trường đại học, cao đẳng của thành phố, 40% đến từ các tỉnh khác của quốc gia[63].++Mặc dù đạt được những bước tiến quan trọng trong thời gian gần đây nhưng giáo dục Thành phố Hồ Chí Minh vẫn còn nhiều khiếm khuyết. Trình độ dân trí chưa cao và chênh lệch giữa các thành phần dân cư, đặc biệt là ngoại ô so với nội ô. Tỷ lệ trẻ em người Hoa không biết chữ vẫn còn nhiều, gấp 13 lần trẻ em người Kinh. Giáo dục đào tạo vẫn chưa tương xứng với nhu cầu của xã hội. Hệ thống cơ sở vật chất ngành giáo dục thành phố còn kém. Nhiều trường học sinh phải học ba ca. Thu nhập của giáo viên chưa cao, đặc biệt ở các huyện ngoại thành[63].+Giao thông vận tải+Bài chi tiết: Giao thông Thành phố Hồ Chí Minh+ +Bến Nhà Rồng, thương cảng cũ của Sài Gòn+ + Hầm Thủ Thiêm, hầm vượt sông dài nhất Đông Nam Á+ + Sân bay Quốc tế Tân Sơn Nhất++Nhờ điều kiện tự nhiên thuận lợi, Thành phố Hồ Chí Minh trở thành một đầu mối giao thông quan trọng của Việt Nam và khu vực Đông Nam Á. Khác với Hà Nội, vận tải thủy ở Thành phố Hồ Chí Minh chiếm một tỷ lệ quan trọng. Tính riêng vận tải hàng hóa, đường biển chiếm khoảng 29% và đường sông khoảng chiếm 20% tổng khối lượng thông qua đầu mối thành phố. Đường bộ chỉ chiếm 44% vận tại hàng hóa nhưng chiếm tới 85,6% vận tải hành khách[64]. Về giao thông đường không, Sân bay quốc tế Tân Sơn Nhất là phi trường lớn nhất Việt Nam về cả diện tích và công suất nhà ga[65]. Năm 2006, vận tải thành phố đã vận chuyển tổng cộng 73.743 tấn hàng hóa, 239 triệu lượt người và bốc xếp 44.341 tấn hàng[66]. Toàn thành phố hiện nay có khoảng 340.000 xe hơi và 3,5 triệu xe máy, gần gấp đôi so với Hà Nội[67].++Giao thông đường sắt của thành phố gồm tuyến nội ô và khu vực phụ cận - do Xí nghiệp Liên hiệp đường sắt 3 quản lý, tuyến Bắc - Nam và một vài đoạn đường chuyên dụng, hiện hầu như đã ngưng khai thác. Trong thành phố có hai nhà ga chính: Sóng Thần và Sài Gòn. Bên cạnh đó còn có một số nhà ga nhỏ như Dĩ An, Thủ Đức, Bình Triệu, Gò Vấp. Do mạng lưới đường sắt không được nối trực tiếp với các cảng, cơ sở đã cũ kỹ nên giao thông đường sắt Thành phố Hồ Chí Minh không phát triển, chỉ chiếm khoảng 6% khối lượng hàng hóa và 0,6% khối lượng hành khách[64].++Giao thông đường bộ, thành phố có 6 bến xe khách liên tỉnh được phân bố ở các cửa ngõ ra vào: Miền Đông, Văn Thánh, Miền Tây, Chợ Lớn, Tân Bình - Tây Ninh, Ký Thủ Ôn. Mạng lưới khả năng tiếp nhận trên 1.200 xe/ngày, vận chuyển gần 41.000 khách/ngày đi các tỉnh Nam Trung Bộ, Tây Nguyên, Đông Nam Bộ, Đồng bằng sông Cửu Long. Cũng theo số liệu từ 1994, tổng lượng hành khách liên tỉnh qua thành phố khoảng 106,4 triệu lượt người/năm, nhiều nhất qua quốc lộ 1A[64].++Khu vực Thành phố Hồ Chí Minh có bốn cảng biển chính: Sài Gòn, Bến Nghé, Nhà Bè, Tân Cảng cùng các cảng sông Bình Đông, Tân Thuận, Tôn Thất Thuyết, Bình Lợi, Bình Phước... Ngoài ra còn có khoảng 50 bến đò phục vụ giao thông hành khách. Cảng Sài Gòn là một trong những cảng lớn nhất Việt Nam, chiếm 25% trong tổng khối lượng hàng hóa thông qua các cảng biển cả nước. Cảng Bến Nghé nằm phía hạ lưu sông Sài Gòn, rộng 32 ha, tổng chiều dài cầu cảng 528 m, có thể cho tàu có tải trọng từ 15.000 - 20.000 tấn cập bến. Tuy năng lực của các cảng của Thành phố Hồ Chí Minh lớn nhưng việc chuyển tiếp giữa giao thông đường bộ, đường biển và đường sông gặp khó khăn. Tại hầu hết các cảng đường sông, do thiết bị thiếu, vẫn phải bốc dỡ thủ công[64].++Giao thông trong nội ô, do tốc độ tăng dân số nhanh, quy hoạch yếu, hệ thống đường xá nhỏ... khiến thành phố luôn phải đối mặt với vấn đề ùn tắc. Thành phố có 239 cây cầu nhưng phần lớn chiều rộng nhỏ hơn chiều rộng của đường nên gây khó khăn cho các phương tiện giao thông. Không những thế, một phần các cây cầu có trọng tải thấp hay đang trong tình trạng xuống cấp. Tại các huyện ngoại thành, hệ thống đường vẫn phần nhiều là đường đất đá. Trong khi đó, hệ thống đường trải nhựa còn lại cũng trở nên quá tải, cần sửa chữa.[64] Để giải quyết vấn đề giao thông đô thị, Thành phố Hồ Chí Minh đang đầu tư cho hệ thống giao thông công cộng. Hiện nay thành phố có 3.250 xe buýt và 8.000 xe taxi, mỗi năm chỉ đáp ứng khoảng 6,2% nhu cầu đi lại. Hệ thống xe buýt chưa đem lại hiệu quả cao, 65% tuyến trùng lặp[68]. Cùng mạng lưới xe buýt, dự án tàu điện ngầm Thành phố Hồ Chí Minh cũng được đang tiến hành. Theo dự kiến, thành phố sẽ có bốn tuyến, tổng chiều dài 54 km, 6 đường rày và 22 nhà ga. Cuối 2010, hai tuyến đầu tiên sẽ đi vào hoạt động[69].+Quy hoạch và kết cấu đô thị++Theo thiết kế đô thị ban đầu của người Pháp vào năm 1860, thành phố Sài Gòn sẽ là nơi sinh sống cho 500.000 dân. Chính quyền Việt Nam Cộng hòa đã tăng qui mô của thành phố lên đến 3 triệu dân. Tuy nhiên hiện nay thành phố này có dân số kể cả số lượng khách vãng lai là 10 triệu người, kết cấu đô thị đã quá tải[70]. Sài Gòn từng là thành phố của cây xanh với không gian kiến trúc theo quy hoạch của Pháp trước đây đã thay đổi với việc thu hẹp không gian xanh để xây dựng nhà cửa, không gian kiến trúc thành phố này trở nên chật chội với nhiều công trình xây dựng hỗn độn thiếu tính thống nhất[71].++Công tác quy hoạch có nhiều bất cập và yếu kém. Đến thời điểm đầu năm 2008 mới chỉ có 23% khối lượng công tác quy hoạch 1/2000 được thực hiện. Quy hoạch cho hệ thống công trình ngầm vẫn chưa được thực hiện xong[72]. Công tác xây quy họach và xây dựng đô thị mới vẫn mang nặng tư duy thời kỳ bao cấp. Trong 10 năm gần đây, khu vực đô thị mới để lại dấu ấn lớn trong quá trình phát triển thành phố này là khu đô thị mới Phú Mỹ Hưng do nước ngoài đầu tư xây dựng, không phải là những quận, huyện được chính quyền địa phương thành lập[73].++Quy hoạch thành phố Hồ Chí Minh tính tới thời điểm 2010 có khoảng trên dưới 600 dự án quy hoạch tại 13 quận huyện.++Chiến lược quy hoạch của Thành phố hiện nay là tránh dồn ứ dân cư về nội thành, đồng thời phát triển một số khu đô thị mới góp phần làm giảm mật độ dân số vốn đã quá cao như hiện nay.+Du lịch+Bài chi tiết: Du lịch Thành phố Hồ Chí Minh+ +Nhà hát lớn nằm tại khu vực trung tâm thành phố++Trong khoảng 4,3 triệu khách quốc tế đến Việt Nam vào năm 2007, 3 triệu khách đã tới thăm Thành phố Hồ Chí Minh, tức khoảng 70%[41]. Năm 2007 cũng là năm thành phố có được bước tiến mạnh mẽ, lượng khách tăng khoảng 12% so với 2006, doanh thu ngành du lịch đạt 19.500 tỷ VND, tăng 20%[74]. Là một thành phố trẻ chỉ với 300 năm lịch sử, nhưng Thành phố Hồ Chí Minh đã xây dựng được không ít công trình kiến trúc và sở hữu một nền văn hóa đa dạng.++Hiện nay Thành phố Hồ Chí Minh có 641 khách sạn với 17.646 phòng[75]. Phục vụ những khách cao cấp, thành phố có 11 khách sạn 5 sao, gồm: Caravelle, Sheraton, Moevenpick (Omni cũ), New World, Equatorial, Legend, Renaissance Riverside, Windsor Plaza, Sofitel Plaza, Park Hyatt, Majestic với tổng cộng 3.592 phòng[76]. Hầu hết các khách sạn này đều do những tập đoàn quốc tế như Accor, Furama, Mariot hay Sheraton quản lý và tập trung nhiều nhất tại Quận 1. Bên cạnh đó thành phố còn 8 khách sạn 4 sao với 1.281 phòng, 20 khách sạn 3 sao với 1.621 phòng. Do sự phát triển của du lịch, số phòng cao cấp tại thành phố hiện đang thiếu trầm trọng. Mặc dù nhiều nhà đầu tư có ý định xây dựng tiếp các khách sạn sạng trọng tại Thành phố Hồ Chí Minh nhưng họ lại gặp khó khăn trong việc tìm địa điểm. Theo dự kiến, đến năm 2020, thành phố sẽ có thêm 10 nghìn phòng 4 hoặc 5 sao[76].++Các địa điểm du lịch của thành phố tương đối đa dạng. Với hệ thống 11 viện bảo tàng, chủ yếu về đề tài lịch sử, Thành phố Hồ Chí Minh đứng đầu Việt Nam về số lượng bảo tàng. Bảo tàng lớn nhất và cổ nhất thành phố là Bảo tàng Lịch sử Việt Nam với 30 nghìn hiện vật. Trong khi phần lớn khách thăm Bảo tàng Chứng tích chiến tranh là người nước ngoài[77] thì bảo tàng thu hút nhiều khách nội địa nhất là Bảo tàng Hồ Chí Minh[78]. Thành phố Hồ Chí Minh cũng là một đô thị đa dạng về tôn giáo. Trên địa phận thành phố hiện nay có hơn một nghìn ngôi chùa, đình, miếu được xây dựng qua nhiều thời kỳ. Còn các nhà thờ xuất hiện chủ yếu trong thế kỷ 19 theo các phong cách Roman, Gothic. Nhà thờ lớn và nổi tiếng nhất của thành phố là nhà thờ Đức Bà, nằm ở Quận 1, hoàn thành năm 1880. Thời kỳ thuộc địa đã để lại cho thành phố nhiều công trình kiến trúc quan trọng, như Trụ sở Ủy ban Nhân dân Thành phố, Nhà hát lớn, Bưu điện trung tâm, Bến Nhà Rồng... Dinh Độc Lập và Thư viện Khoa học Tổng hợp được xây dựng dưới thời Việt Nam Cộng hòa. Kiến trúc hiện đại ghi dấu ấn ở thành phố bằng các cao ốc, khách sạn, trung tâm thương mại như Diamond Plaza, Saigon Trade Centre... Khu vực ngoài trung tâm, Địa đạo Củ Chi, Rừng ngập mặn Cần Giờ, Vườn cò Thủ Đức cũng là những địa điểm du lịch quan trọng.++Thành phố Hồ Chí Minh còn là một trung tâm mua sắm và giải trí. Bên cạnh các phòng trà ca nhạc, quán bar, vũ trường, sân khấu, thành phố có khá nhiều khu vui chơi như Công viên Đầm Sen, Suối Tiên, Thảo Cầm Viên. Các khu mua sắm, như Chợ Bến Thành, Diamond Plaza... hệ thống các nhà hàng, quán ăn cũng là một thế mạnh của du lịch thành phố.+Văn hóa+Truyền thông+ +Bưu điện trung tâm Thành phố++Là một trong hai trung tâm truyền thông của Việt Nam, Thành phố Hồ Chí Minh hiện nay có 38 đơn vị báo chí thành phố và 113 văn phòng đại diện báo chí trung ương và các tỉnh, 3 nhà xuất bản của thành phố và 21 chi nhánh nhà xuất bản trung ương cùng mạng lưới thông tấn xã, các đài phát thanh, truyền hình địa phương và trung ương. Tổng cộng, trên địa bàn thành phố hiện nay có trên một nghìn người hoạt động trong lĩnh vực báo chí[79].++Trong lĩnh vực xuất bản, từ năm 1995 tới nay, ba nhà xuất bản của thành phố chiếm 1/7 số đầu sách xuất bản của cả Việt Nam. Ước tính khoảng 60 đến 70% số lượng sách của cả nước được phát hành tại Thành phố Hồ Chí Minh[79]. Những năm gần đây, nhiều trung tâm sách, cửa hàng sách hiện đại xuất hiện. Sài Gòn cũng là nơi ra đời tờ Gia Định báo, tờ báo quốc ngữ đầu tiên. Sài Gòn giải phóng, Thanh Niên, Tuổi Trẻ nằm trong số những tờ báo lớn nhất Việt Nam hiện nay. Ngoài ra còn có thể kể đến những báo và tạp chí lớn khác như Công an thành phố, Người lao động, Thời báo kinh tế Sài Gòn, Thời trang, Thế giới mới, Kiến thức ngày nay... Ngoài báo chí tiếng Việt, Thành phố Hồ Chí Minh còn có Saigon Times daily, Thanhniennews bằng tiếng Anh, một ấn bản Sài Gòn giải phóng bằng tiếng Hoa.++Truyền hình đã xuất hiện tại Sài Gòn từ trước năm 1975, khi miền Bắc còn đang trong giai đoạn thử nghiệm. Ngay sau ngày chính quyền Việt Nam Cộng hòa sụp đổ, Đài truyền hình Giải phóng đã bắt đầu phát sóng. Đến nay, Đài Truyền hình Thành phố Hồ Chí Minh – HTV trở thành đài truyền hình địa phương quan trọng bậc nhất Việt Nam. Ngoài sáu kênh phát trên sóng analogue, HTV còn một số kênh truyền hình kỹ thuật số và truyền hình cáp. Đối tượng chính của HTV là dân cư thành phố và một số tỉnh lân cận.+Thể dục, thể thao+ + Sân vận động Thống Nhất++Theo số liệu thống kê vào năm 1994, toàn Thành phố Hồ Chí Minh có 492,7 hecta dành cho hoạt động thể thao, tức trung bình 1,02 m²/người, trong đó nội thành là 0,26 m²/người. Với sự gia tăng dân số, con số thực tế hiện nay thấp hơn[80]. Vào năm 2005, toàn thành phố có 91 sân bóng đá, 86 bể bơi, 256 phòng tập thể thao[81]. Sân vận động lớn nhất thành phố hiện nay là sân Thống Nhất, với 25 nghìn chỗ ngồi. Sân vận động lớn thứ hai là sân Quân khu 7, nằm ở quận Tân Bình. Không chỉ dành cho thi đấu thể thao, đây còn là địa điểm tổ chức nhiều chương trình ca nhạc quy mô lớn. Một địa điểm thể thao quan trọng khác của thành phố là Trường đua Phú Thọ. Xuất hiện từ thời thuộc địa, Trường đua Phú Thọ hiện nay là trường đua ngựa duy nhất của Việt Nam. Sở Thể dục - Thể thao thành phố cũng quản lý một số câu lạc bộ như Phan Đình Phùng, Thanh Đa, Yết Kiêu.++Thành phố Hồ Chí Minh cũng có những câu lạc bộ thể thao giàu thành tích. Môn bóng đá, Câu lạc Thép Miền Nam - Cảng Sài Gòn, có sân nhà là sân Thống Nhất, từng 4 lần vô định V League. Đội Công an Thành phố cũng từng một lần vô địch vào năm 1995. Các bộ môn thể thao khác có thể kể đến Câu lạc bộ Bưu điện Thành phố Hồ Chí Minh môn bóng chuyền, các câu lạc bộ bóng rổ, cờ, điền kinh, bóng bàn... của thành phố.+Trung tâm văn hóa, giải trí+ + Khách sạn Park Hyatt Saigon tại Quận 1++Những lý do lịch sử và địa lý đã khiến Sài Gòn luôn là một thành phố đa dạng về văn hóa. Ngay từ giai đoạn thành lập, dân cư của Sài Gòn đã thuộc nhiều dân tộc khác nhau: Kinh, Hoa, Chăm... Thời kỳ thuộc địa rồi chiến tranh Việt Nam, Sài Gòn hấp thụ thêm nền văn hóa Âu Mỹ. Cho tới những thập niên gần đây, những hoạt động kinh tế, du lịch tiếp tục giúp thành phố có một nền văn hóa đa dạng hơn.++Với vai trò một trung tâm văn hóa của Việt Nam, Thành phố Hồ Chí Minh hiện nay có 22 đơn vị nghệ thuật, 9 rạp hát, 11 bảo tàng, 22 rạp chiếu phim, 25 thư viện[82][83]. Hoạt động của ngành giải trí ở Thành phố Hồ Chí Minh nhộn nhịp hơn bất cứ thành phố nào ở Việt Nam. Hầu hết các hãng phim tư nhân lớn của Việt Nam hiện nay, như Phước Sang, Thiên Ngân, HKFilm, Việt Phim... đều có trụ sở chính ở Thành phố Hồ Chí Minh. Doanh thu các rạp của thành phố chiếm khoảng 60-70% doanh thu chiếu phim của cả nước[84]. Thành phố Hồ Chí Minh cũng sở hữu những sân khấu đa dạng. Nhà hát kịch Sân khấu nhỏ tại Quận 3 với những vở kịch thử nghiệm, những vở thư giãn ở Sân khấu Hài 135 Quận 1, Sân khấu kịch IDECAF với những vở lấy từ tuồng tích cổ hoặc tái hiện các danh tác trên thế giới. Lĩnh vực ca nhạc, Thành phố Hồ Chí Minh là thị trường sôi động nhất, điểm đến của phần lớn các ca sĩ nổi tiếng. Ngoài những sân khấu lớn như Nhà hát Thành phố, Nhà hát Bến Thành, Nhà hát Hòa Bình, Sân khấu Trống Đồng... hoạt động âm nhạc hoạt động âm nhạc ở thành phố ở những phòng trà, quán cà phê đa dạng: Tiếng Tơ Đồng, M&T, Catinat, ATB, Bodega, Carmen...+Thành phố kết nghĩa++Đến thời điểm năm 2008, Thành phố Hồ Chí Minh kết nghĩa với các thành phố sau[85]: Busan, Hàn Quốc+ Champasak, Lào+ Ekaterinburg, Nga+ Manila, Philippines+ Moskva, Nga	 Lyon, Pháp+ Quảng Châu, Trung Quốc+ Osaka, Nhật Bản+ Rhône-Alpes, Pháp+ Phnôm Pênh, Campuchia	 Viêng Chăn, Lào+ Thẩm Dương, Trung Quốc+ Toronto, Canada+ San Francisco, Hoa Kỳ+ Thượng Hải, Trung Quốc+ Yokohama, Nhật Bản.++Chú thích+^ a b “Diện tích, dân số và mật độ dân số năm 2011 phân theo địa phương”. Tổng cục Thống kê Việt Nam. Truy cập 30 tháng 9 năm 2012.+^ http://baodientu.chinhphu.vn/Home/Ban-hanh-Nghi-quyet-moi-cua-Bo-Chinh-tri-ve-phat-trien-TPHo-Chi-Minh/20127/142861.vgp+^ http://www.sggp.org.vn/chinhtri/2012/7/293239/+^ Thành phố với vẻ đẹp trời cho[liên kết hỏng] trên trang của Thành phố.+^ Ðịa hình[liên kết hỏng] trên trang của Thành phố.+^ Ðịa chất - đất đai[liên kết hỏng] trên trang của Thành phố.+^ a b Nguồn nước và thủy văn[liên kết hỏng] trên trang của Thành phố.+^ a b Khí hậu, thời tiết[liên kết hỏng] trên trang của Thành phố.+^ “Weather for Ho Chi Minh City”. Đại sứ quán Việt Nam tại London. Truy cập 26 tháng 2 năm 2008.+^ Cần một nghị quyết về môi trường Tin tức, truy cập 23 tháng 8 năm 2010.+^ Ô nhiễm môi trường và tình trạng ô nhiễm môi trường nước ở Việt Nam trên trang Viện Kinh tế Thành phố Hồ Chí Minh.+^ "Chưa có giải pháp cụ thể hạn chế ô nhiễm sông Sài Gòn[liên kết hỏng]". Báo Lao Động, 21 tháng 6, 2008.+^ Kiều Anh, "Thành phố Hồ Chí Minh: Đối mặt với ô nhiễm môi trường". Báo Khoa học và Phát triển, 25 tháng 7, 2008.+^ “Tp. Hồ Chí Minh: Giải pháp nào chống ngập nước?”. Báo Giao thông Vận tải (30 tháng 3 năm 2006).+^ Ô nhiễm môi trường tại TPHCM: Hiểm họa mới SGGP Online, truy cập ngày 23 tháng 8 năm 2010.+^ Vùng Sài Gòn thời hoang sơ[liên kết hỏng] trên trang của Thành phố.+^ Con đường lập nghiệp của cha ông để có Sài Gòn - Gia Định[liên kết hỏng] trên trang của Thành phố.+^ a b Lập đồn thu thuế đầu tiên[liên kết hỏng] trên trang của Thành phố.+^ Lịch sử hình thành đất Sài Gòn[liên kết hỏng] trên trang của Thành phố.+^ Công cuộc khai hoang ở Nam Bộ vào thời các chúa Nguyễn[liên kết hỏng] trên trang của Thành phố.+^ Lê Quỳnh, Chuyển giao quân sự: Trường hợp nhà Nguyễn. BBC Việt ngữ, 19 tháng 2, 2004.+^ a b Niên biểu 300 năm Sài Gòn[liên kết hỏng] trên trang của Thành phố.+^ a b Sài Gòn biến đổi và hình thành một thành phố theo kiểu phương Tây[liên kết hỏng] trên trang của Thành phố.+^ Goodman, Allan E. Politics in War. Cambridge, MA: Havard University Press, 1973. tr 14+^ Pierre Brocheux và Daniel Hémery. Indochina, An Ambiguous Colonization 1858-1954. Berkeley, CA: University of California Press, 2009. tr 336-374.+^ Metzner, Edward. Reeducation in Postwar Vietnam. College Station, TX: Tẽas A&M University Press, 2001. tr 5-9.+^ BBCVietnamese.com | Diễn đàn | 'Kỳ tích xây dựng của thập kỷ'+^ Sài Gòn dưới thời Mỹ Ngụy[liên kết hỏng] trên trang của Thành phố.+^ Nigel Cawthorne, Chiến Tranh Việt Nam Được Và Mất, Nhà xuất bản Đà Nẵng, năm xuất bản 2007, tr. 396+^ Nghị quyết của Quốc hội năm 1976[liên kết hỏng] trên trang của Thành phố.+^ Sài Gòn xưa - Lịch sử vùng đất[liên kết hỏng] trên trang của Liên minh hợp tác xã Thành phố Hồ Chí Minh.+^ Quy định của luật tổ chức Hội đồng Nhân dân trên trang của Hội đồng Nhân dân thành phố+^ Thông tin tổ chức hành chính Thành phố Hồ Chí Minh[liên kết hỏng] trên trang của Thành phố.+^ Số liệu 2005[liên kết hỏng] trên trang của Thành phố.+^ Nguồn lao động trên trang Viện Kinh tế Thành phố Hồ Chí Minh.+^ Kinh Te Vi Mo - Dau Tu tren trang cafef.vn+^ 10 điểm nổi bật trong tình hình kinh tế-xã hội của thành phố Hồ Chí Minh trog năm 2010+^ Chỉ tiêu tổng hợp giai đoạn 2001 - 2006[liên kết hỏng], trên trang của Thành phố.+^ Trang[liên kết hỏng] của Ban quản lý các khu chế xuất và công nghiệp Thành phố Hồ Chí Minh.+^ Hàn Ni, "TPHCM dẫn đầu thu hút vốn FDI vì biết cách bứt phá". Sài Gòn giải phóng, 3 tháng 11, 2007.+^ a b c "TPHCM sau 1 năm gia nhập WTO - Vượt lên chính mình...[liên kết hỏng]", Trung tâm thông tin thương mại.+^ “PCI 2011: Lào Cai và Bắc Ninh 'vượt vũ môn' ngoạn mục”. Phòng thương mại và Công nghiệp Việt Nam. Truy cập 23 tháng 2 năm 2012.+^ Minh Anh, "Quy mô tiêu dùng 41,5 tỉ USD: Đầu kéo phát triển!". Tuổi Trẻ, 20 tháng 8, 2007.+^ Hình thành và phát triển, trên trang Sở Giao dịch Chứng khoán Thành phố Hồ Chí Minh.+^ Thành phố Hồ Chí Minh: Chỉ có 10% cơ sở công nghiệp có trình độ công nghệ hiện đại, Mạng thông tin Khoa học và Công nghệ Việt Nam.+^ http://www.pso.hochiminhcity.gov.vn/an_pham/sltkcytphcm/30_so_lieu_thong_ke_chu_yeu+^ http://www.gso.gov.vn/default.aspx?tabid=512&idmid=5&ItemID=11010+^ http://www.pso.hochiminhcity.gov.vn/c/document_library/get_file?uuid=5fdc62bc-0523-453a-b596-57ad36af9831&groupId=18+^ Dang Bo Thanh Pho Ho Chi Minh+^ Kết quả điều tra dân số 1999 - 2004, trang của Cục thống kê Thành phố Hồ Chí Minh.+^ Kết quả toàn bộ Tổng điều tra Dân số và Nhà ở Việt Nam năm 2009, Tổng cục Thống kê Việt Nam+^ Dân số lao động[liên kết hỏng] trên trang của Thành phố.+^ Dự báo số khách vãng lai có mặt trung bình mỗi ngày trên trang Viện Kinh tế Thành phố Hồ Chí Minh.+^ a b Y tế và chăm sóc sức khỏe trên trang Viện Kinh tế Thành phố Hồ Chí Minh.+^ Các chỉ tiêu về thể lực trên trang Viện Kinh tế Thành phố Hồ Chí Minh.+^ Số liệu nhân lực y tế năm 1996 - 2005 trên trang của Sở Y tế thành phố.+^ Thống kê về y tế năm 2005 trên trang của Cục thống kê Thành phố Hồ Chí Minh.+^ Mạng lưới y tế trên địa bàn TP.HCM trên trang Viện Kinh tế Thành phố Hồ Chí Minh.+^ Các thông kê về giáo dục năm 2008, trên trang của Cục Thống kê Thành phố Hồ Chí Minh.+^ Số trường, lớp, học sinh, giáo viên hệ mầm non... trên trang Viện Kinh tế Thành phố Hồ Chí Minh.+^ Danh sách các trường quốc tế trên trang Sở Giáo dục Thành phố Hồ Chí Minh.+^ [1]+^ a b Giáo dục và đào tạo I trên trang Viện Kinh tế Thành phố Hồ Chí Minh.+^ a b c d e Giao thông vận tải I trên trang Viện Kinh tế Thành phố Hồ Chí Minh.+^ "Có nên xây sân bay quốc tế mới ở tỉnh Hải Dương", Tạp chí Hàng không, số tháng 10 năm 2007 của Cục hàng không dân dụng Việt Nam.+^ Vận tải - Bưu điện[liên kết hỏng] trên trang của Thành phố.+^ Ngô Lực Tải, Tìm lời giải chung cho giao thông ở Hà Nội và TP. HCM. Bộ Giao thông Vận tải, 29 tháng 5, 2008.+^ Duy Anh, Bình Minh, "TP.Hồ Chí Minh: Đi xe buýt lãng phí nhiều, hiệu quả thấp[liên kết hỏng]". Đời sống và Pháp luật, 14 tháng 9, 2007.+^ Phan Anh, "3 năm nữa TP HCM có tàu điện ngầm". VnExpress 30 tháng 4, 2007.+^ “Giải pháp giao thông TP.HCM: Chỉ là đối phó”. VietnamNet (27 tháng 11 năm 2007).+^ “Không gian đô thị thành phố Hồ Chí Minh (Phần 2)”. Đài truyền hình Việt Nam (25 tháng 5 năm 2005).+^ “TP. Hồ Chí Minh – Ngán ngẩm với quy hoạch”. Báo Lao Động (8 tháng 1 năm 2008).[liên kết hỏng]+^ “Quy hoạch TP.HCM chưa xứng tầm”. Thư viện pháp luật (2 tháng 5 năm 2008).+^ Đổng Thị Kim Vui, "Du lịch Thành phố Hồ Chí Minh: Chuyển biến rõ rệt sau 1 năm gia nhập WTO[liên kết hỏng]". Kinh tế và Đô thị, 13 tháng 12, 2007.+^ Khách sạn[liên kết hỏng] trên trang của Thành phố.+^ a b Văn Thân, "Thành phố Hồ Chí Minh: “Khát” đất xây khách sạn cao cấp!". Báo Công an Thành Phố Hồ Chí Minh, 21 tháng 2, 2008.+^ Lê Trần Phương, "Cảm nhận từ bảo tàng chứng tích chiến tranh[liên kết hỏng]". Báo Bình Dương, 1 tháng 11, 2006.+^ Hệ thống bảo tàng[liên kết hỏng] trên trang của Thành phố.+^ a b Báo chí - xuất bản[liên kết hỏng] trên trang của Thành phố.+^ Văn hóa thông tin - thể dục thể thao trên trang Viện Kinh tế Thành phố Hồ Chí Minh.+^ Thể dục thể thao, trang của Cục thống kê Thành phố Hồ Chí Minh.+^ Văn hóa – Xã hội Thành phố Hồ Chí Minh[liên kết hỏng], trên trang của Thành phố.+^ Văn hóa nghệ thuật, trên trang của Cục thống kê Thành phố Hồ Chí Minh.+^ Trần Đình, "Rạp chiếu phim ở Thành phố Hồ Chí Minh: Trở lại đúng vị trí “công nghệ giải trí”[liên kết hỏng]". Tổng cục Tiêu chuẩn Đo lường Chất lượng, tháng 1, 2006.+^ Nguồn: Trang chính thức của Thành phố Hồ Chí Minh+Liên kết ngoài	Wikimedia Commons có thêm thể loại hình ảnh và tài liệu về: Thành phố Hồ Chí Minh.++Trang chính thức của Thành phố Hồ Chí Minh+Trang của Viện Kinh tế Thành phố Hồ Chí Minh+Hình chụp chi tiết độ phân giải cao một góc trung tâm TP.HCM
benchmark/bench-report/BenchReport.hs view
@@ -4,13 +4,15 @@ module Main where  import Control.Exception (catch, ErrorCall(..))-import Control.Monad.Trans.State+import Control.Monad (mzero)+import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Maybe+import Control.Monad.Trans.State import Data.Char (toLower) import Data.List+import GHC.Real (infinity) import System.Environment (getArgs)-import Control.Monad.IO.Class (liftIO)-import Control.Monad (mzero)+import Text.Read (readMaybe)  import BenchShow @@ -26,12 +28,15 @@ data Options = Options     { genGraphs :: Bool     , sortByName :: Bool+    , useGauge :: Bool     , benchType :: Maybe BenchType     , fields :: [String]+    , diffStyle :: GroupStyle+    , cutOffPercent :: Double     } deriving Show  defaultOptions :: Options-defaultOptions = Options False False Nothing ["time"]+defaultOptions = Options False False False Nothing ["time"] PercentDiff 0  setGenGraphs :: Monad m => Bool -> StateT (a, Options) m () setGenGraphs val = do@@ -43,6 +48,11 @@     (args, opts) <- get     put (args, opts { sortByName = val }) +setUseGauge :: Monad m => Bool -> StateT (a, Options) m ()+setUseGauge val = do+    (args, opts) <- get+    put (args, opts { useGauge = val })+ setBenchType :: Monad m => BenchType -> StateT (a, Options) m () setBenchType val = do     (args, opts) <- get@@ -53,6 +63,24 @@     (args, opts) <- get     put (args, opts { fields = val }) +setDiff :: Monad m => String -> StateT (a, Options) m ()+setDiff val = do+    (args, opts) <- get+    let cmpStyle =+            case val of+                "absolute" -> Absolute+                "multiples" -> Multiples+                "percent" -> PercentDiff+                x -> error $ "Unknown diff option: " ++ show x+     in put (args, opts { diffStyle = cmpStyle })++setCutOff :: Monad m => String -> StateT (a, Options) m ()+setCutOff val = do+    (args, opts) <- get+    case readMaybe val of+        Just x -> put (args, opts { cutOffPercent = x })+        Nothing -> error $ "Invalid cutoff value: " ++ show val+ -- Like the shell "shift" to shift the command line arguments shift :: StateT ([String], Options) (MaybeT IO) (Maybe String) shift = do@@ -81,6 +109,24 @@                     "please provide a list of fields after --fields"                 mzero +parseDiff :: StateT ([String], Options) (MaybeT IO) ()+parseDiff = do+    x <- shift+    case x of+        Just str -> setDiff str+        Nothing -> do+                liftIO $ putStrLn "please provide a diff type"+                mzero++parseCutOff :: StateT ([String], Options) (MaybeT IO) ()+parseCutOff = do+    x <- shift+    case x of+        Just str -> setCutOff str+        Nothing -> do+                liftIO $ putStrLn "please provide a cutoff percent"+                mzero+ -- totally imperative style option parsing parseOptions :: IO (Maybe Options) parseOptions = do@@ -93,10 +139,13 @@      parseOpt opt =         case opt of-            "--graphs"    -> setGenGraphs True+            "--graphs" -> setGenGraphs True             "--sort-by-name" -> setSortByName True+            "--use-gauge" -> setUseGauge True             "--benchmark" -> parseBench-            "--fields"    -> parseFields+            "--fields" -> parseFields+            "--diff-style" -> parseDiff+            "--diff-cutoff-percent" -> parseCutOff             str -> do                 liftIO $ putStrLn $ "Unrecognized option " <> str                 mzero@@ -135,24 +184,34 @@      where -    dropComponent = dropWhile (== '/') . dropWhile (/= '/')+    separator = if useGauge then '/' else '.'+    dropComponent sep = dropWhile (== sep) . dropWhile (/= sep) -    classifyComparison b = Just-        ( takeWhile (/= '/') b-        , dropComponent b-        )+    -- In case of tasty-bench the names could be like+    -- All.Data.Array.Prim.Pinned/o-1-space.generation.show+    -- All.Data.Array.Foreign/o-1-space.generation.show+    classifyComparison b =+        let b1 =+                if useGauge+                then b+                else dropComponent separator b --- drop "All." at the beginning+         in Just+            ( takeWhile (/= '/') b1+            , dropComponent '/' b1 -- for tasty-bench drop up to "/"+            )  ------------------------------------------------------------------------------ -- text reports ------------------------------------------------------------------------------  selectBench-    :: Bool+    :: Options     -> (SortColumn -> Maybe GroupStyle -> Either String [(String, Double)])     -> [String]-selectBench sortName f =+selectBench Options{..} f =     reverse     $ fmap fst+    $ filter (\(_,y) -> filterPred y)     $ either       (const $ either error sortFunc $ f (ColumnIndex 0) (Just PercentDiff))       sortFunc@@ -160,8 +219,16 @@      where -    sortFunc = if sortName then sortOn fst else sortOn snd+    sortFunc = if sortByName then sortOn fst else sortOn snd +    cutOffMultiples = 1 + cutOffPercent / 100++    filterPred x =+        case benchType of+            Just (Compare _) ->+                x <= negate cutOffPercent || x >= cutOffPercent+            _ -> True+ benchShow ::        Options     -> Config@@ -183,8 +250,8 @@             return ()         Just opts@Options{fields = fs, benchType = btype} ->             let cfg = defaultConfig-                    { presentation = Groups PercentDiff-                    , selectBenchmarks = selectBench (sortByName opts)+                    { presentation = Groups (diffStyle opts)+                    , selectBenchmarks = selectBench opts                     , selectFields = filter                         ( flip elem (fmap (fmap toLower) fs)                         . fmap toLower
+ benchmark/bench-report/bin/bench-runner.sh view
@@ -0,0 +1,667 @@+#!/usr/bin/env bash++# Note that this script is used in the "streamly" package as well as+# in "streaming-benchmarks" package. Any changes to the script should be+# generic enough so that it works in both the cases.++#------------------------------------------------------------------------------++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 "       [--compare]"+  echo "       [--diff-style <absolute|percent|multiples>]"+  echo "       [--cutoff-percent <percent-value>]"+  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 "       [--commit-compare] [--base <commit>] [--candidate <commit>]"+  #echo "       -- <gauge options or benchmarks>"+  echo+  echo "--benchmarks: benchmarks to run, use 'help' for list of benchmarks"+  echo "--compare: compare the specified benchmarks with each other"+  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 --commit-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+}++build_report_prog() {+    local prog_path=$BENCH_REPORT_DIR/bin/bench-report++    hash -r+    if test ! -x "$prog_path" -a "$BUILD_ONCE" = "0"+    then+      echo "Building bench-report executables"+      BUILD_ONCE=1+      pushd $BENCH_REPORT_DIR+      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=$BENCH_REPORT_DIR/bin/bench-report+      test -x $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"+}++#------------------------------------------------------------------------------+# Speed options+#------------------------------------------------------------------------------++# 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+}++#------------------------------------------------------------------------------+# Determine options from benchmark name+#------------------------------------------------------------------------------++# Global 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++# $1: bench name+bench_exec_one() {+  local BENCH_NAME_ORIG+  BENCH_NAME_ORIG="$1"+  shift++  local SUPER_QUICK_OPTIONS+  local QUICKER_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++  local BENCH_NAME0+  local BENCH_NAME1+  local BENCH_NAME2+  local BENCH_NAME+  # 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 "/" and are prefixed by "All".+  #+  # For example, All.Prelude.Serial/x.y.z => Prelude.Serial/x/y/z+  if test "$USE_GAUGE" -eq 0+  then+    # Remove the prefix "All."+    BENCH_NAME0=$(echo $BENCH_NAME_ORIG | sed -e s/^All\.//)++    # Module names could contain dots e.g. "Prelude.Serial". So we insert+    # an explicit "/" to separate the module name part and the rest of+    # the benchmark name. For example, Prelude.Serial/elimination.drain+    BENCH_NAME1=$(echo $BENCH_NAME0 | cut -f1 -d '/')++    if test "$BENCH_NAME1" = "$BENCH_NAME0"+    then+      # There is no "/" separator+      BENCH_NAME1=$(echo $BENCH_NAME0 | sed -e 's/\./\//g')+      BENCH_NAME2=""+    else+      BENCH_NAME2=/$(echo $BENCH_NAME0 | cut -f2- -d '/' | sed -e 's/\./\//g')+    fi+    BENCH_NAME="${BENCH_NAME1}${BENCH_NAME2}"+  else+    BENCH_NAME=$BENCH_NAME_ORIG+  fi++  local RTS_OPTIONS1+  RTS_OPTIONS1="\++RTS -T \+$(bench_rts_options $(basename $BENCH_EXEC_PATH) $BENCH_NAME) \+$RTS_OPTIONS \+-RTS"++  local QUICK_MODE_TYPE+  QUICK_MODE_TYPE="\+  $(if test "$QUICK_MODE" -ne 0; then set_super_quick_mode; fi) \+  $(bench_speed_options $(basename $BENCH_EXEC_PATH) $BENCH_NAME)"++  local QUICK_BENCH_OPTIONS+  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++  local STREAM_SIZE+  local STREAM_LEN+  local STREAM_SIZE_OPT+  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_OPTIONS1 \+  $STREAM_LEN \+  $QUICK_BENCH_OPTIONS" \+  "$@"++  #------------------------------------------------------------------------------+  # Run benchmark with options and collect results+  #------------------------------------------------------------------------------++  local output_file+  output_file=$(bench_output_file $(basename $BENCH_EXEC_PATH))+  mkdir -p `dirname $output_file`+  rm -f ${output_file}.tmp++  local BENCH_NAME_ESC+  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_OPTIONS1 \+      $STREAM_SIZE_OPT \+      $QUICK_BENCH_OPTIONS \+      "$@" \+      --csv=${output_file}.tmp \+      -p '$0 == "'"$BENCH_NAME_ESC"'"' || die "Benchmark execution failed."++    # 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_OPTIONS1 \+      $STREAM_SIZE_OPT \+      $QUICK_BENCH_OPTIONS \+      "$@" \+      --csvraw=${output_file}.tmp \+      -m exact "$BENCH_NAME" || die "Benchmark execution failed."+    tail -n +2 ${output_file}.tmp \+      >> $output_file+  fi+}++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 bench_exec_one "$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,maxrss" >> $output_file+    $target_prog -l $MATCH \+      | grep "^All" \+      | while read -r name; \+          do bench_exec_one "$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+  if test -z "$BENCHMARK_PACKAGE_VERSION"+  then+    echo "Please set BENCHMARK_PACKAGE_VERSION in bench_config"+    exit 1+  fi+  target_prog=$(cabal_target_prog $package_name-$BENCHMARK_PACKAGE_VERSION $component $target_name) || \+    die "Cannot find executable for target $target_name"++  echo "Running executable $target_name ..."++  # Needed by bench_exec_one+  BENCH_EXEC_PATH=$target_prog++  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 $BENCHMARK_PACKAGE_NAME 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 $BENCHMARK_PACKAGE_NAME 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 "$COMMIT_COMPARE" = "0"+  then+    run_bench_targets $BENCHMARK_PACKAGE_NAME b "$bench_list" target_exe_extra_args+  else+    run_benches_comparing "$bench_list"+  fi+}++run_reports() {+    local prog+    prog=$BENCH_REPORT_DIR/bin/bench-report+    test -x $prog || die "Cannot find bench-report executable"+    echo++    for i in $1+    do+        echo "Generating reports for ${i}..."+        $prog \+            --benchmark $i \+            $(test "$USE_GAUGE" = 1 && echo "--use-gauge") \+            $(test "$GRAPH" = 1 && echo "--graphs") \+            $(test "$SORT_BY_NAME" = 1 && echo "--sort-by-name") \+            $(test -n "$BENCH_DIFF_STYLE" && echo "--diff-style $BENCH_DIFF_STYLE") \+            $(test -n "$BENCH_CUTOFF_PERCENT" && echo "--diff-cutoff-percent $BENCH_CUTOFF_PERCENT") \+            --fields "$FIELDS"+    done+}++#-----------------------------------------------------------------------------+# Execution starts here+#-----------------------------------------------------------------------------++USE_GIT_CABAL=1 # This is used by set_common_vars+set_common_vars++USE_NIX=0+COMPARE=0+COMMIT_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 --flag limit-build-mem"++#-----------------------------------------------------------------------------+# 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 ;;+    --config) shift; BENCH_CONFIG_FILE=$1; shift ;;+    --diff-style) shift; BENCH_DIFF_STYLE=$1; shift ;;+    --diff-cutoff-percent) shift; BENCH_CUTOFF_PERCENT=$1; shift ;;+    # flags+    --slow) SLOW=1; shift ;;+    --quick) QUICK_MODE=1; shift ;;+    --compare) COMPARE=1; shift ;;+    --commit-compare) COMMIT_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=("$@")++if test -z "$BENCH_CONFIG_FILE"+then+  die "Please use --config to specify config file"+fi++source "$BENCH_CONFIG_FILE" || \+  die "Failed to source config file $BENCH_CONFIG_FILE"++# Defined in $BENCH_CONFIG_FILE+bench_config++if test -z "$FIELDS"+then+  FIELDS=$DEFAULT_FIELDS+fi++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+}++# defined in $BENCH_CONFIG_FILE+bench_targets++if test "$(has_item "$TARGETS" help)" = "help"+then+  list_target_groups+  list_comparisons+  list_targets+  exit+fi++COMMON_FIELDS="allocated bytescopied cputime maxrss"+if test "$USE_GAUGE" -eq 1+then+  ALL_FIELDS="$COMMON_FIELDS time cycles utime stime minflt majflt nvcsw nivcsw"+else+  ALL_FIELDS="$COMMON_FIELDS"+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" $BENCHMARK_PACKAGE_NAME bench "$TARGETS"+  run_measurements "$TARGETS"+fi++#-----------------------------------------------------------------------------+# Run reports+#-----------------------------------------------------------------------------++# $1: var name+build_comparison_results () {+    local name+    local constituents++    name=$1+    constituents=$(eval "echo -n \$${name}")+    mkdir -p "charts/$name"+    dest_file="charts/$name/results.csv"+    : > $dest_file+    for j in $constituents+    do+      cat "charts/$j/results.csv" >> $dest_file+    done+}++if test "$COMPARE" -eq 1+then+  DYN_CMP_GRP="$(echo "$TARGETS" | sed -e 's/ /_/g')_cmp"+  eval "$DYN_CMP_GRP=\"$TARGETS\""+  COMPARISON_REPORTS=$DYN_CMP_GRP+  build_comparison_results $DYN_CMP_GRP+else+  COMPARISON_REPORTS=""+fi++for i in $COMPARISONS+do+  if test "$(has_item "$TARGETS_ORIG" $i)" = $i+  then+    COMPARISON_REPORTS="$COMPARISON_REPORTS $i"+    build_comparison_results $i+  fi+done++if test "$RAW" = "0"+then+  run_reports "$TARGETS"+  run_reports "$COMPARISON_REPORTS"+  if test -n "$DYN_CMP_GRP"+  then+    rm -rf "charts/$DYN_CMP_GRP"+  fi+fi
+ benchmark/bench-report/bin/build-lib.sh view
@@ -0,0 +1,213 @@+# $1: message+die () {+  >&2 echo -e "Error: $1"+  exit 1+}++warn () {+  >&2 echo -e "Warning: $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+}++# XXX cabal issue "cabal v2-exec which" cannot find benchmark/test executables++# $1: builddir+# $2: package name with version+# $3: component ("" (lib), t (test), b (benchmark), x (executable))+# $4: command to find+cabal_which_builddir() {+  local noopt=""+  if test "$TEST_QUICK_MODE" = "1"+  then+    noopt="/noopt"+  fi++  local path=$(echo $1/build/*/ghc-${GHC_VERSION}/${2}/$3/$4$noopt/build/$4/$4)+  echo "[cabal_which $path]" 1>&2+  test -f "$path" && echo $path+}++# $1: package name with version+# $2: component+# $3: command to find+cabal_which() {+  cabal_which_builddir $BUILD_DIR $1 $2 $3+}++# 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 with version+# $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)+}++# $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"+}
− benchmark/bench-report/default.nix 
@@ -1,50 +0,0 @@-{-  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/Prelude.hs view
@@ -26,6 +26,7 @@ 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.Stream.IsStream.Type as IsStream import qualified Streamly.Internal.Data.Pipe as Pipe import qualified Streamly.Internal.Data.Stream.Serial as Serial @@ -89,7 +90,8 @@  {-# INLINE sourceUnfoldrMSerial #-} sourceUnfoldrMSerial :: (S.IsStream t, Monad m) => Int -> Int -> t m Int-sourceUnfoldrMSerial count start = Serial.unfoldrM step start+sourceUnfoldrMSerial count start =+    IsStream.fromSerial $ Serial.unfoldrM step start     where     step cnt =         if cnt > start + count@@ -344,7 +346,7 @@  {-# INLINE concatStreamsWith #-} concatStreamsWith-    :: (forall c. S.SerialT IO c -> S.SerialT IO c -> S.SerialT IO c)+    :: (S.SerialT IO Int -> S.SerialT IO Int -> S.SerialT IO Int)     -> Int     -> Int     -> Int@@ -356,7 +358,7 @@  {-# INLINE concatPairsWith #-} concatPairsWith-    :: (forall c. S.SerialT IO c -> S.SerialT IO c -> S.SerialT IO c)+    :: (S.SerialT IO Int -> S.SerialT IO Int -> S.SerialT IO Int)     -> Int     -> Int     -> Int
benchmark/streamly-benchmarks.cabal view
@@ -39,6 +39,11 @@   manual: True   default: False +flag include-strict-utf8+  description: Include strict utf8 input benchmarks+  manual: True+  default: False+ flag has-llvm   description: Use llvm backend for better performance   manual: True@@ -64,6 +69,9 @@     if flag(dev)       cpp-options:    -DDEVBUILD +    if flag(include-strict-utf8)+      cpp-options:    -DINCLUDE_STRICT_UTF8+     if flag(inspection)       cpp-options:    -DINSPECTION @@ -113,17 +121,18 @@     -- other libraries     , streamly            >= 0.7.0     , random              >= 1.0   && < 2.0-    , transformers        >= 0.4   && < 0.6+    , transformers        >= 0.4   && < 0.7     , containers          >= 0.5   && < 0.7     , typed-process     >= 0.2.3 && < 0.3     , directory         >= 1.2.2 && < 1.4-    , ghc-prim          >= 0.4   && < 0.8+    , filepath          >= 1.4.1 && < 1.5+    , ghc-prim          >= 0.4   && < 0.9    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+    build-depends:    tasty-bench >= 0.3 && < 0.4+                    , tasty     >= 1.4.1 && < 1.5     mixins: tasty-bench       (Test.Tasty.Bench as Gauge       , Test.Tasty.Bench as Gauge.Main@@ -135,7 +144,7 @@   if flag(inspection)     build-depends:     template-haskell   >= 2.14  && < 2.17                      , inspection-testing >= 0.4   && < 0.5-                     , ghc-prim           >= 0.2   && < 0.7+                     , ghc-prim           >= 0.2   && < 0.9   -- Array uses a Storable constraint in dev build making several inspection   -- tests fail   if flag(dev) && flag(inspection)@@ -185,18 +194,21 @@   other-modules:         Serial.Generation       , Serial.Elimination-      , Serial.Transformation1-      , Serial.Transformation2-      , Serial.Transformation3-      , Serial.Nested-      , Serial.Exceptions+      , Serial.Transformation+      , Serial.NestedStream+      , Serial.NestedFold       , Serial.Split+      , Serial.Exceptions+      , Serial.Lift   if impl(ghcjs)     buildable: False   else     buildable: True   if flag(limit-build-mem)-    ghc-options: +RTS -M2000M -RTS+    if flag(dev)+      ghc-options: +RTS -M3500M -RTS+    else+      ghc-options: +RTS -M2000M -RTS   benchmark Prelude.WSerial@@ -209,6 +221,16 @@   else     buildable: True +benchmark Prelude.Merge+  import: bench-options+  type: exitcode-stdio-1.0+  hs-source-dirs: Streamly/Benchmark/Prelude+  main-is: Merge.hs+  if impl(ghcjs)+    buildable: False+  else+    buildable: True+ benchmark Prelude.ZipSerial   import: bench-options   type: exitcode-stdio-1.0@@ -306,7 +328,10 @@     buildable: True     build-depends: exceptions >= 0.8   && < 0.11   if flag(limit-build-mem)-    ghc-options: +RTS -M750M -RTS+    if flag(dev)+      ghc-options: +RTS -M3000M -RTS+    else+      ghc-options: +RTS -M750M -RTS  benchmark Data.Parser.ParserK   import: bench-options@@ -346,7 +371,10 @@     buildable: True     build-depends: exceptions >= 0.8   && < 0.11   if flag(limit-build-mem)-    ghc-options: +RTS -M1000M -RTS+    if flag(dev)+      ghc-options: +RTS -M3000M -RTS+    else+      ghc-options: +RTS -M1000M -RTS  ------------------------------------------------------------------------------- -- Raw Streams@@ -465,6 +493,8 @@   main-is: Streamly/Benchmark/Data/Array.hs   other-modules: Streamly.Benchmark.Data.ArrayOps   cpp-options: -DMEMORY_ARRAY+  if flag(limit-build-mem)+    ghc-options: +RTS -M1000M -RTS  ------------------------------------------------------------------------------- -- Array Stream Benchmarks@@ -497,8 +527,24 @@ ------------------------------------------------------------------------------- -- Unicode Benchmarks -------------------------------------------------------------------------------+ benchmark Unicode.Stream   import: bench-options   type: exitcode-stdio-1.0   hs-source-dirs: Streamly/Benchmark/Unicode   main-is: Stream.hs++benchmark Unicode.Char+  import: bench-options+  type: exitcode-stdio-1.0+  hs-source-dirs: Streamly/Benchmark/Unicode+  main-is: Char.hs+  -- Takes too much memory for ghcjs+  if impl(ghcjs)+    buildable: False++benchmark Unicode.Utf8+  import: bench-options+  type: exitcode-stdio-1.0+  hs-source-dirs: Streamly/Benchmark/Unicode+  main-is: Utf8.hs
+ bin/bench-config.sh view
@@ -0,0 +1,160 @@+#!/usr/bin/env bash++BENCH_CONFIG_DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")" &> /dev/null && pwd)"+source $BENCH_CONFIG_DIR/targets.sh \+  || { echo "Cannot source $BENCH_CONFIG_DIR/targets.sh"; exit 1; }++# Customization options+bench_config () {+  BENCH_REPORT_DIR=benchmark/bench-report+  BENCHMARK_PACKAGE_NAME=streamly-benchmarks+  BENCHMARK_PACKAGE_VERSION=0.0.0++  USE_GAUGE=0+  DEFAULT_FIELDS="allocated cputime bytescopied"+}++#------------------------------------------------------------------------------+# benchmark groups+#------------------------------------------------------------------------------++bench_targets () {+  targets+}++#------------------------------------------------------------------------------+# RTS options based on the benchmark executable name and benchmark name+#------------------------------------------------------------------------------++bench_rts_options () {+  local exe_name+  local bench_name++  exe_name="$1"+  bench_name="$2"++  # Based on benchmark class+  case "$bench_name" 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++  echo -n " "+  case "$exe_name" in+    Prelude.Concurrent*) echo -n "-K256K -M384M" ;;+    *) echo -n "" ;;+  esac++  echo -n " "+  # Based on specific benchmark+  # 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 ".".+  case "$bench_name" 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/o-n-heap/choice) echo -n "-K16M -M32M" ;;+    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+#------------------------------------------------------------------------------++bench_speed_options () {+  local exe_name+  local bench_name++  exe_name="$1"+  bench_name="$2"++  case "$exe_name" 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+  case "$bench_name" 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+}
− bin/bench-exec-one.sh 
@@ -1,275 +0,0 @@-#!/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
@@ -1,475 +1,15 @@ #!/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+source $SCRIPT_DIR/bench-config.sh \+  || { echo "Cannot source $SCRIPT_DIR/bench-config.sh"; exit 1; } -BUILD_BENCH="$CABAL_EXECUTABLE v2-build $BUILD_FLAGS $CABAL_BUILD_OPTIONS --enable-benchmarks"-if test "$MEASURE" = "1"+bench_config+if test -z "$BENCH_REPORT_DIR" then-  run_build "$BUILD_BENCH" streamly-benchmarks bench "$TARGETS"-  run_measurements "$TARGETS"+  echo "BENCH_REPORT_DIR variable not defined by bench-config() in $SCRIPT_DIR/bench-config.sh"+  exit 1 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+cd $SCRIPT_DIR/..+$BENCH_REPORT_DIR/bin/bench-runner.sh --config $SCRIPT_DIR/bench-config.sh "$@"
− bin/build-lib.sh 
@@ -1,246 +0,0 @@-# $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 
@@ -1,45 +0,0 @@-#!/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
@@ -1,7 +1,7 @@ #!/usr/bin/env bash  GHC_VERSION=8.10.4-STREAMLY_VERSION=0.8.0+STREAMLY_VERSION=0.8.1  case `uname` in   Darwin) SYSTEM=x86_64-osx;;
− bin/run-ci.sh 
@@ -1,250 +0,0 @@-#!/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
@@ -2,111 +2,119 @@ # test and benchmark groups #------------------------------------------------------------------------------ +# Depends on RUNNING_TESTS, RUNNING_BENCHMARKS, RUNNING_DEVBUILD variables+# being set for dev_build, test_only, bench_only functions to work. So the+# "targets" fucntion should be called only after these are set.+ # 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"+targets () {+  base_stream_grp="\+    `bench_only Data.Stream.StreamD` \+    `bench_only Data.Stream.StreamK` \+    `bench_only Data.Stream.StreamDK`" -prelude_concurrent_grp="\-  Prelude.Async \-  Prelude.WAsync \-  Prelude.Ahead \-  Prelude.Parallel \-  Prelude.ZipAsync"+  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`"+  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"+  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`"+  base_parser_grp="\+    Data.Parser.ParserD \+    `bench_only Data.Parser.ParserK`" -parser_grp="\-  Data.Fold \-  Data.Parser"+  parser_grp="\+    Data.Fold \+    Data.Parser" -list_grp="\-  `test_only Data.List.Base` \-  `test_only Data.List`"+  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.+  #------------------------------------------------------------------------------+  # 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`"+  infinite_grp="\+    $prelude_serial_grp \+    $prelude_concurrent_grp \+    `bench_only Prelude.Rate`" -#-------------------------------------------------------------------------------# Benchmark comparison groups-#------------------------------------------------------------------------------+  #------------------------------------------------------------------------------+  # 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+  # *_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="Data.Array.Foreign Data.Array.Prim Data.Array Data.Array.Prim.Pinned"+  pinned_array_cmp="Data.Array.Foreign 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"+  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 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"+  # 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`"+  # Not in any groups+  INDIVIDUAL_TARGETS="\+      Data.Unfold \+      Unicode.Stream \+      $(test_only $(dev_build Unicode.Char)) \+      `bench_only Unicode.Char` \+      `bench_only Unicode.Utf8` \+      FileSystem.Handle \+      `test_only FileSystem.Event` \+      `test_only Network.Socket` \+      `test_only Network.Inet.TCP` \+      `test_only version-bounds`"+}
bin/test.sh view
@@ -1,35 +1,44 @@ #!/usr/bin/env bash -STREAMLY_VERSION=0.8.0+SCRIPT_DIR=$(dirname $0) +STREAMLY_VERSION=0.8.1+BENCH_REPORT_DIR=benchmark/bench-report+source $SCRIPT_DIR/targets.sh+ #------------------------------------------------------------------------------ # Script #------------------------------------------------------------------------------ -SCRIPT_DIR=$(dirname $0)- print_help () {   echo "Usage: $0 "   echo "       [--targets <"target1 target2 ..." | help>]"+  echo+  echo "       [--quick]"   echo "       [--with-compiler <compiler exe name>]"   echo "       [--cabal-build-options <option>]"   echo "       [--dev-build]"+  echo   echo "       [--coverage]"   echo "       [--hpc-report-options <option>]"   echo "       [--no-measure]"   echo "       [--raw]"+  echo   echo "       [--rtsopts <option>]"   echo "       -- <hspec options or test names>"   echo   echo "--targets: targets to run, use 'help' for list of targets"+  echo+  echo "--quick: disable optimizations to build quickly"   echo "--cabal-build-options: Pass any cabal build options to be used for build"   echo "--dev-build: runs some additional tests"+  echo   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 "--rtsopts: pass GHC RTS options to the test executable"   echo "Any arguments after a '--' are passed directly to hspec"   exit }@@ -39,7 +48,7 @@ #-----------------------------------------------------------------------------  RUNNING_TESTS=y-source $SCRIPT_DIR/build-lib.sh+source $BENCH_REPORT_DIR/bin/build-lib.sh  USE_GIT_CABAL=1 set_common_vars@@ -47,6 +56,8 @@ MEASURE=1 HPC_REPORT_OPTIONS= RAW=0+CABAL_BUILD_OPTIONS="--flag limit-build-mem"+TEST_QUICK_MODE=0  # XXX add a bisect option while test -n "$1"@@ -56,14 +67,14 @@     # 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 ;;+    --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 ;;+    --quick) TEST_QUICK_MODE=1; shift ;;+    --dev-build) RUNNING_DEVBUILD=1 CABAL_BUILD_OPTIONS+=" --flag dev"; shift ;;     --coverage) COVERAGE=1; shift ;;     --no-measure) MEASURE=0; shift ;;     --) shift; break ;;@@ -75,12 +86,17 @@  set_derived_vars +if test $TEST_QUICK_MODE -eq 1+then+  CABAL_BUILD_OPTIONS+=" --disable-optimization --flags -opt"+fi+ #----------------------------------------------------------------------------- # Determine targets #----------------------------------------------------------------------------- -# Requires RUNNING_DEVBUILD var-source $SCRIPT_DIR/targets.sh+# Defined in targets.sh+targets  if test "$(has_item "$TARGETS" help)" = "help" then@@ -104,6 +120,7 @@     Data.Array.Foreign) echo -n "-M128M" ;;     Data.Array.Prim) echo -n "-M128M" ;;     Data.Array.Prim.Pinned) echo -n "-M128M" ;;+    Prelude.Rate) echo -n "-M512M" ;;     # For -O0 case writeChunks test fails, maybe we should have a separate flag     # for O0 case?     FileSystem.Handle) echo -n "-K16M" ;;@@ -154,9 +171,52 @@ # Run targets #----------------------------------------------------------------------------- +# $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 ..."++  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 with version+# $2: component+# $3: targets+# $4: args generator func+run_targets() {+    for i in $3+    do+      run_target $1 $2 $i $4+    done+}+ if test "$MEASURE" -eq "1" then-run_targets streamly-tests t "$TARGETS" target_exe_extra_args+run_targets "streamly-tests-0.0.0" t "$TARGETS" target_exe_extra_args 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.8.0.+# Generated by GNU Autoconf 2.71 for streamly 0.8.1. # # Report bugs to <streamly@composewell.com>. #@@ -610,8 +610,8 @@ # Identity of this package. PACKAGE_NAME='streamly' PACKAGE_TARNAME='streamly'-PACKAGE_VERSION='0.8.0'-PACKAGE_STRING='streamly 0.8.0'+PACKAGE_VERSION='0.8.1'+PACKAGE_STRING='streamly 0.8.1' PACKAGE_BUGREPORT='streamly@composewell.com' PACKAGE_URL='https://streamly.composewell.com' @@ -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.8.0 to adapt to many kinds of systems.+\`configure' configures streamly 0.8.1 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.8.0:";;+     short | recursive ) echo "Configuration of streamly 0.8.1:";;    esac   cat <<\_ACEOF @@ -1404,7 +1404,7 @@ test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then   cat <<\_ACEOF-streamly configure 0.8.0+streamly configure 0.8.1 generated by GNU Autoconf 2.71  Copyright (C) 2021 Free Software Foundation, Inc.@@ -1674,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.8.0, which was+It was created by streamly $as_me 0.8.1, which was generated by GNU Autoconf 2.71.  Invocation command line was    $ $0$ac_configure_args_raw@@ -4028,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.8.0, which was+This file was extended by streamly $as_me 0.8.1, which was generated by GNU Autoconf 2.71.  Invocation command line was    CONFIG_FILES    = $CONFIG_FILES@@ -4084,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.8.0+streamly config.status 0.8.1 configured by $0, generated by GNU Autoconf 2.71,   with options \\"\$ac_cs_config\\"
configure.ac view
@@ -3,7 +3,7 @@ # See https://www.gnu.org/software/autoconf/manual/autoconf.html for help on # the macros used in this file. -AC_INIT([streamly], [0.8.0], [streamly@composewell.com], [streamly], [https://streamly.composewell.com])+AC_INIT([streamly], [0.8.1], [streamly@composewell.com], [streamly], [https://streamly.composewell.com])  # To suppress "WARNING: unrecognized options: --with-compiler" AC_ARG_WITH([compiler], [GHC])
− credits/CONTRIBUTORS.md 
@@ -1,127 +0,0 @@-This is a list of code contributors to this library. For issue contributors-please see https://github.com/composewell/streamly/issues.--Use `git shortlog -sn tag1...tag2` on the git repository to get a list of-contributors between two repository tags.--## 0.8.0--* 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--* Harendra Kumar-* Pranay Sashank-* Adithya Kumar-* Sanchayan Maity-* Julian Ospald-* Shlok Datye--## 0.7.1--* Harendra Kumar-* Pranay Sashank-* Adithya Kumar-* Sanchayan Maity-* Brian Wignall-* Julian Ospald-* Lucian Ursu--## 0.7.0--* Harendra Kumar-* Pranay Sashank-* Artyom Kazak-* David Feuer-* Adithya Kumar-* Aravind Gopal--## 0.6.1--* Harendra Kumar-* Mariusz Ryndzionek-* Luke Clifton-* Nicolas Henin--## 0.6.0--* Harendra Kumar-* Pranay Sashank-* Abhiroop Sarkar-* Michael Sloan--## 0.5.2--* Harendra Kumar-* Keith--## 0.5.1--* Harendra Kumar--## 0.5.0--* Harendra Kumar-* Veladus-* Tim Buckley--## 0.4.1--* Harendra Kumar--## 0.4.0--* Harendra Kumar--## 0.3.0--* Harendra Kumar-* Xiaokui Shu-* k0ral--## 0.2.1--* Harendra Kumar--## 0.2.0--* Harendra Kumar-* Abhiroop Sarkar-* Hussein Ait Lahcen--## 0.1.2--* Harendra Kumar-* Abhiroop Sarkar-* Hussein Ait Lahcen--## 0.1.1--* Harendra Kumar-* Veladus-* Abhiroop Sarkar-* Sibi Prabakaran--## 0.1.0--* Harendra Kumar-* Sibi Prabakaran
− credits/COPYRIGHTS.md 
@@ -1,77 +0,0 @@-This file contains a summary of the credits and copyrights for the code-currently shipped with the package.  To find parts of the code where the-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-  SmallArray code is taken from "primitive" package.-  * Copyright (c) 2009-2012 Roman Leshchinskiy-  * Copyright (c) 2015 Dan Doel-  * https://hackage.haskell.org/package/primitive-0.7.0.0-  * See primitive-0.7.0.0.txt for the original license.--## 0.7.0--* Composable folds include code from the "foldl" package.-   * Copyright (c) 2013 Gabriel Gonzalez-   * http://hackage.haskell.org/package/foldl-1.4.5-   * See foldl-1.4.5.txt for the original license.--* Portions of UTF8 encoding/decoding code taken from the "base" package-  * Copyright (c) The University of Glasgow, 2009-  * http://hackage.haskell.org/package/base-4.12.0.0-  * See base-4.12.0.0.txt for the original license.--* UTF8 decoding state machine-  * Copyright (c) 2008-2009 Bjoern Hoehrmann <bjoern@hoehrmann.de>-  * http://bjoern.hoehrmann.de/utf-8/decoder/dfa/-  * See bjoern-2008-2009.txt for original license--## 0.6.1--* The time related code includes portions from the "clock" package.-   * Copyright (c) 2009-2012, Cetin Sert-   * Copyright (c) 2010, Eugene Kirpichov-   * http://hackage.haskell.org/package/clock-0.7.2-   * See clock-0.7.2.txt for the original license.--## 0.4.0--* Implementation of direct style monadic streams includes code from the-   "vector" package.-   * Copyright (c) 2008-2012, Roman Leshchinskiy-   * http://hackage.haskell.org/package/vector-0.12.0.2-   * See vector-0.12.0.2.txt for the original license.--## 0.1.0--* The initial version of this release included code from the transient-   package, however it was completely rewritten later on.-  * Copyright © 2014-2016 Alberto G. Corona-  * http://hackage.haskell.org/package/transient-0.5.5-  * See transient-0.5.5.txt for the original license.--* The AcidRain example was adapted from the "pipes-concurrency" package.-  * Copyright (c) 2014 Gabriel Gonzalez-  * http://hackage.haskell.org/package/pipes-concurrency-2.0.8-  * See pipes-concurrency-2.0.8.txt for the original license.--* The circling square example was adapted from the "Yampa" package.-  * Copyright (c) 2003, Henrik Nilsson, Antony Courtney and Yale University.-  * http://hackage.haskell.org/package/Yampa-0.10.6.2-  * See Yampa-0.10.6.2.txt for the original license.
− credits/README.md 
@@ -1,43 +0,0 @@-# 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-give proper credits for it. Below, we have listed the copyright attributions-and contributions to this library.  We do due diligence in giving credit where-its due, if something got missed please do point out by [raising an issue on-github](https://github.com/composewell/streamly/issues) or [sending an email to-the maintainers](mailto:streamly@composewell.com).--## Attributions--See COPYRIGHTS.md for parts of other works included in this package.--## Contributions--See CONTRIBUTORS.md for a release wise list of contributors to this library.--## References--Some (among many others) of the Haskell packages that we looked at and might-have taken some ideas or inspiration from include:--* http://hackage.haskell.org/package/base--* https://hackage.haskell.org/package/logict-* https://hackage.haskell.org/package/list-transformer-* http://hackage.haskell.org/package/transient--* http://hackage.haskell.org/package/streaming-* http://hackage.haskell.org/package/machines-* https://hackage.haskell.org/package/simple-conduit-* http://hackage.haskell.org/package/pipes-* http://hackage.haskell.org/package/conduit--* http://hackage.haskell.org/package/vector-* http://hackage.haskell.org/package/bytestring-* http://hackage.haskell.org/package/text--* http://hackage.haskell.org/package/split-* https://hackage.haskell.org/package/foldl-* https://github.com/effectfully/prefolds
− credits/Yampa-0.10.6.2.txt 
@@ -1,29 +0,0 @@-Copyright (c) 2003, Henrik Nilsson, Antony Courtney and Yale University.-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions-are met:--- Redistributions of source code must retain the above copyright notice,-this list of conditions and the following disclaimer.--- Redistributions in binary form must reproduce the above copyright-notice, this list of conditions and the following disclaimer in the-documentation and/or other materials provided with the distribution.--- Neither name of the copyright holders nor the names of its-contributors may be used to endorse or promote products derived from-this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-HOLDERS OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,-INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,-BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS-OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND-ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR-TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE-USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
− credits/base-4.12.0.0.txt 
@@ -1,83 +0,0 @@-This library (libraries/base) is derived from code from several-sources: --  * Code from the GHC project which is largely (c) The University of-    Glasgow, and distributable under a BSD-style license (see below),--  * Code from the Haskell 98 Report which is (c) Simon Peyton Jones-    and freely redistributable (but see the full license for-    restrictions).--  * Code from the Haskell Foreign Function Interface specification,-    which is (c) Manuel M. T. Chakravarty and freely redistributable-    (but see the full license for restrictions).--The full text of these licenses is reproduced below.  All of the-licenses are BSD-style or compatible.---------------------------------------------------------------------------------The Glasgow Haskell Compiler License--Copyright 2004, The University Court of the University of Glasgow. -All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:--- Redistributions of source code must retain the above copyright notice,-this list of conditions and the following disclaimer.- -- Redistributions in binary form must reproduce the above copyright notice,-this list of conditions and the following disclaimer in the documentation-and/or other materials provided with the distribution.- -- Neither name of the University nor the names of its contributors may be-used to endorse or promote products derived from this software without-specific prior written permission. --THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF-GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,-INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND-FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE-UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE-FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL-DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR-SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER-CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT-LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY-OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH-DAMAGE.---------------------------------------------------------------------------------Code derived from the document "Report on the Programming Language-Haskell 98", is distributed under the following license:--  Copyright (c) 2002 Simon Peyton Jones--  The authors intend this Report to belong to the entire Haskell-  community, and so we grant permission to copy and distribute it for-  any purpose, provided that it is reproduced in its entirety,-  including this Notice.  Modified versions of this Report may also be-  copied and distributed for any purpose, provided that the modified-  version is clearly presented as such, and that it does not claim to-  be a definition of the Haskell 98 Language.---------------------------------------------------------------------------------Code derived from the document "The Haskell 98 Foreign Function-Interface, An Addendum to the Haskell 98 Report" is distributed under-the following license:--  Copyright (c) 2002 Manuel M. T. Chakravarty--  The authors intend this Report to belong to the entire Haskell-  community, and so we grant permission to copy and distribute it for-  any purpose, provided that it is reproduced in its entirety,-  including this Notice.  Modified versions of this Report may also be-  copied and distributed for any purpose, provided that the modified-  version is clearly presented as such, and that it does not claim to-  be a definition of the Haskell 98 Foreign Function Interface.-------------------------------------------------------------------------------
− credits/bjoern-2008-2009.txt 
@@ -1,19 +0,0 @@-Copyright (c) 2008-2009 Bjoern Hoehrmann <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.
− credits/clock-0.7.2.txt 
@@ -1,32 +0,0 @@-Copyright (c) 2009-2012, Cetin Sert-Copyright (c) 2010, Eugene Kirpichov--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * The names of contributors may not be used to endorse or promote-      products derived from this software without specific prior-      written permission. --THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
− credits/foldl-1.4.5.txt 
@@ -1,24 +0,0 @@-Copyright (c) 2013 Gabriel Gonzalez-All rights reserved.--Redistribution and use in source and binary forms, with or without modification,-are permitted provided that the following conditions are met:-    * Redistributions of source code must retain the above copyright notice,-      this list of conditions and the following disclaimer.-    * Redistributions in binary form must reproduce the above copyright notice,-      this list of conditions and the following disclaimer in the documentation-      and/or other materials provided with the distribution.-    * Neither the name of Gabriel Gonzalez nor the names of other contributors-      may be used to endorse or promote products derived from this software-      without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND-ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED-WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE-DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR-ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES-(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;-LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON-ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS-SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
− credits/fsnotify-0.3.0.1.txt 
@@ -1,30 +0,0 @@-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 
@@ -1,30 +0,0 @@-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.
− credits/pipes-concurrency-2.0.8.txt 
@@ -1,24 +0,0 @@-Copyright (c) 2014 Gabriel Gonzalez-All rights reserved.--Redistribution and use in source and binary forms, with or without modification,-are permitted provided that the following conditions are met:-    * Redistributions of source code must retain the above copyright notice,-      this list of conditions and the following disclaimer.-    * Redistributions in binary form must reproduce the above copyright notice,-      this list of conditions and the following disclaimer in the documentation-      and/or other materials provided with the distribution.-    * Neither the name of Gabriel Gonzalez nor the names of other contributors-      may be used to endorse or promote products derived from this software-      without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND-ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED-WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE-DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR-ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES-(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;-LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON-ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS-SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
− credits/primitive-0.7.0.0.txt 
@@ -1,30 +0,0 @@-Copyright (c) 2008-2009, Roman Leshchinskiy-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:--- Redistributions of source code must retain the above copyright notice,-this list of conditions and the following disclaimer.- -- Redistributions in binary form must reproduce the above copyright notice,-this list of conditions and the following disclaimer in the documentation-and/or other materials provided with the distribution.- -- Neither name of the University nor the names of its contributors may be-used to endorse or promote products derived from this software without-specific prior written permission. --THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF-GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,-INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND-FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE-UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE-FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL-DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR-SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER-CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT-LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY-OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH-DAMAGE.-
− credits/transient-0.5.5.txt 
@@ -1,18 +0,0 @@-Copyright © 2014-2016 Alberto G. Corona       <https://github.com/agocorona>
-
-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.
− credits/vector-0.12.0.2.txt 
@@ -1,30 +0,0 @@-Copyright (c) 2008-2012, Roman Leshchinskiy-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:--- Redistributions of source code must retain the above copyright notice,-this list of conditions and the following disclaimer.- -- Redistributions in binary form must reproduce the above copyright notice,-this list of conditions and the following disclaimer in the documentation-and/or other materials provided with the distribution.- -- Neither name of the University nor the names of its contributors may be-used to endorse or promote products derived from this software without-specific prior written permission. --THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF-GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,-INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND-FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE-UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE-FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL-DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR-SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER-CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT-LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY-OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH-DAMAGE.-
− default.nix 
@@ -1,138 +0,0 @@-# 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
dev/MAINTAINING.md view
@@ -81,8 +81,10 @@       [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:+      * streamly-bytestring+      * streamly-process+      * streamly-lz4  * _Update Package Metadata:_ @@ -90,6 +92,9 @@     * 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+    * Any docs linked inside haddock/cabal/changelog or any other such file+      should go in the extra-doc-files section instead of+      extra-source-files. Otherwise hackage shows the links as broken.     * 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@@ -98,25 +103,25 @@ * _Copyrights and Contibutors_      * Make sure contributors to the release are listed in-      `credits/CONTRIBUTORS.md`.-    * Bump the release version in `credits/CONTRIBUTORS.md`.+      `docs/CONTRIBUTORS.md`.+    * Bump the release version in `docs/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`.+      `docs/Credits.md` and the license is added to the repo.+    * Bump the release version in `docs/Credits.md`.  * _Update changelog & Version_: -    * Find API changes using `cabal-diff streamly 0.8.0 .` and record+    * Find API changes using `cabal-diff streamly 0.8.1 .` 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.+      release version number and the month/year of publishing.     * 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+      `rg '0\.8\.'|grep -v -i since` to find any remaining occurrences of the       old release.  Check `rg -i unreleased` for any remaining todos.  * _Upload_:
dev/container-api.md view
@@ -7,13 +7,22 @@ qualified with the module name e.g. Array.toBytes. This doc lists some conventions and guidelines to be followed. +## Bytes and Chunks++APIs that deal with streams of Word8 may have "bytes" in their names+while the ones dealing with "Array Word8" have "chunks" in their+names. Usually the default is bytes when there is no explicit mention in+the name.+ ## 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+## To and from Stream +### 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@@ -24,7 +33,7 @@   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+### To and Get  * Converting the complete object to an external representation is prefixed with   "to" (e.g. toBytes).@@ -32,18 +41,68 @@ * "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+### Append  * Use "append" prefix for appending data at the end of a mutable container +## With additional config++Sometimes we need to modify the behavior of a combinator using some additional+config. For example, combinators to read/write using a specified size of+buffer. For such cases we apply the "With" suffix to standard combinator names:++* readWith+* readChunksWith+* toBytesWith+* getBytesWith+ ## Random Access (Arrays) +### Single elements+ * getIndex (for arrays)-* getSlice/getRange/getIndices * putIndex (for mutable arrays)++### Ranges++* ...FromTo (e.g. readFromTo, readChunksFromTo, toBytesFromTo, getBytesFromTo)+* ...FromThenTo+* ...Indices++FromThenTo vs FromStepN:++We could use `fromThenTo` or `fromStepN` style APIs for stepwise+enumeration. The first one uses absolute numbers whereas the second one+uses relative positioning. We prefer FromThenTo style where possible for+the following reasons:++* It is the style used in base lists, and we are already using it in Enumerable+  type class.+* Both have their pros and cons. In `fromThenTo`, (1) it may be+  non-intuitive whether `To` is inclusive, (2) specifying an empty range+  is a bit awkward (e.g. fromThenTo 1 1 0). In `fromStepN`, if we know+  the first and the last element then we will have to compute the offset+  correctly. Ideally, when we know the elements then former is more+  suitable while if we know the count then the latter is more suitable.++Note that in case of floating point numbers `FromStep` style may have an+advantage over `FromThen` style. Here is a quote from the documentation of+`enumerateFromThenNum`:++```+Note that in the strange world of floating point numbers, using+@enumerateFromThenNum (from, from + 1)@ is almost exactly the same as+@enumerateFromStepNum (from, 1) but not precisely the same. Because @(from++ 1) - from@ is not exactly 1, it may lose some precision, the loss may+also be aggregated in each step, if you want that precision then use+'enumerateFromStepNum' instead.+```++### Appending+ * append (for mutable arrays) -## Key Access (Maps)+## Key-Value Store Access (Maps)  * getKey * findKey (test existence)
+ dev/overview.md view
@@ -0,0 +1,24 @@+# Streamly++This document is yet to be written. It is supposed to provide an overall+design overview for developers.++## 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.
docs/API-changelog.txt view
@@ -1,7 +1,18 @@-# Release 0.8.0 vs release 0.7.3-# API diff generated by cabal-diff with some edits.-# ~~~ deprecated module-# ~~ deprecated symbol+# API diff as generated by cabal-diff with minor edits.+# ~~~ means deprecated module+# ~~ means deprecated symbol++#----------------------------+# Changes from 0.8.0 to 0.8.1+#----------------------------++@@@ Streamly.FileSystem.Handle+++ getChunk :: MonadIO m => Int -> Handle -> m (Array Word8)+++ putChunk :: (MonadIO m, Storable a) => Handle -> Array a -> m ()++#----------------------------+# Changes from 0.7.3 to 0.8.0+#----------------------------  # Deprecated, merged into Streamly.Prelude ~~~ Streamly
+ docs/CONTRIBUTORS.md view
@@ -0,0 +1,135 @@+This is a list of code contributors to this library. For issue contributors+please see https://github.com/composewell/streamly/issues.++Use `git shortlog -sn tag1...tag2` on the git repository to get a list of+contributors between two repository tags.++## 0.8.1++* Harendra Kumar+* Adithya Kumar+* Ranjeet Kumar Ranjan+* Julian Ospald+* Sanchayan Maity++## 0.8.0++* 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++* Harendra Kumar+* Pranay Sashank+* Adithya Kumar+* Sanchayan Maity+* Julian Ospald+* Shlok Datye++## 0.7.1++* Harendra Kumar+* Pranay Sashank+* Adithya Kumar+* Sanchayan Maity+* Brian Wignall+* Julian Ospald+* Lucian Ursu++## 0.7.0++* Harendra Kumar+* Pranay Sashank+* Artyom Kazak+* David Feuer+* Adithya Kumar+* Aravind Gopal++## 0.6.1++* Harendra Kumar+* Mariusz Ryndzionek+* Luke Clifton+* Nicolas Henin++## 0.6.0++* Harendra Kumar+* Pranay Sashank+* Abhiroop Sarkar+* Michael Sloan++## 0.5.2++* Harendra Kumar+* Keith++## 0.5.1++* Harendra Kumar++## 0.5.0++* Harendra Kumar+* Veladus+* Tim Buckley++## 0.4.1++* Harendra Kumar++## 0.4.0++* Harendra Kumar++## 0.3.0++* Harendra Kumar+* Xiaokui Shu+* k0ral++## 0.2.1++* Harendra Kumar++## 0.2.0++* Harendra Kumar+* Abhiroop Sarkar+* Hussein Ait Lahcen++## 0.1.2++* Harendra Kumar+* Abhiroop Sarkar+* Hussein Ait Lahcen++## 0.1.1++* Harendra Kumar+* Veladus+* Abhiroop Sarkar+* Sibi Prabakaran++## 0.1.0++* Harendra Kumar+* Sibi Prabakaran
+ docs/Credits.md view
@@ -0,0 +1,43 @@+# 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+give proper credits for it. Below, we have listed the copyright attributions+and contributions to this library.  We do due diligence in giving credit where+its due, if something got missed please do point out by [raising an issue on+github](https://github.com/composewell/streamly/issues) or [sending an email to+the maintainers](mailto:streamly@composewell.com).++## Attributions++See LICENSE for parts of other works included in this package.++## Contributions++See CONTRIBUTORS.md for a release wise list of contributors to this library.++## References++Some (among many others) of the Haskell packages that we looked at and might+have taken some ideas or inspiration from include:++* http://hackage.haskell.org/package/base++* https://hackage.haskell.org/package/logict+* https://hackage.haskell.org/package/list-transformer+* http://hackage.haskell.org/package/transient++* http://hackage.haskell.org/package/streaming+* http://hackage.haskell.org/package/machines+* https://hackage.haskell.org/package/simple-conduit+* http://hackage.haskell.org/package/pipes+* http://hackage.haskell.org/package/conduit++* http://hackage.haskell.org/package/vector+* http://hackage.haskell.org/package/bytestring+* http://hackage.haskell.org/package/text++* http://hackage.haskell.org/package/split+* https://hackage.haskell.org/package/foldl+* https://github.com/effectfully/prefolds
@@ -0,0 +1,1 @@+https://github.com/composewell/streamly/issues/1046
docs/Tutorial.hs view
@@ -111,18 +111,7 @@ -- 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,+-- 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
docs/building.md view
@@ -8,13 +8,13 @@ 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+GHC 9.0 and GHC 9.2 have 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.+However, upcoming releases may fix some of these issues.  ### Distributions -Tested with stackage `lts-18.0` and `nix 21.05`.+Tested with stackage `lts-18.18` and `nix 21.05`.  ### Memory requirements @@ -99,11 +99,38 @@  ### Linux -* File system events notification module is supported only for kernel versions-  2.6.36 onwards.+File system events notification module is supported only for kernel versions+2.6.36 onwards. -### Mac OSX+### macOS -* 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.+File system events notification module supports macOS 10.7+ . You must+have the ``Cocoa`` framework installed which is supplied by the macOS+SDK.  If ``Cocoa`` is not installed, you may see an error like this:++```+error: ld: framework not found Cocoa+```++### Native build++Usually, if you have a working GHC you would already have the SDK+installed. See the documentation of `Xcode` or `xcode-select` tool for+more details.++### Nix build++Please note that cabal2nix may not always be able to generate a complete nix+expression on `macOS`. See [this+issue](https://github.com/NixOS/cabal2nix/issues/470).++You may need to add ``nixpkgs.darwin.apple_sdk.frameworks.Cocoa`` to+your ``buildInputs`` or ``executableFrameworkDepends``. Something like+this:++```+executableFrameworkDepends =+    if builtins.currentSystem == "x86_64-darwin"+    then [nixpkgs.darwin.apple_sdk.frameworks.Cocoa]+    else [];+```
+ docs/faq.md view
@@ -0,0 +1,70 @@+# Frequently Asked Questions++This document provides idioms or examples to solve common programming+problems using streamly. To start with please go through [Streamly Quick+Overview](README.md) and [`Streamly examples repository`][streamly-examples].+This document provides additional examples.++## Distribute and Zip Concurrently++Say, you have an input stream, and each element of the input stream is to be+transformed in multiple ways using monadic functions. Then you want to zip the+results together and consume the resulting stream concurrently.++First, distribute an item to multiple effectful consumer concurrently, for+example:++```haskell+import Data.Function ((&))+import qualified Streamly.Prelude as Stream++f1 x =+      Prelude.map ($ x) [return . (+ 1), return . (+ 2)]+    & Stream.fromListM+    & Stream.fromAhead+    & Stream.toList+```++Alternatively, if you want to concurrently zip different types of outputs, you+can use `Applicative` composition:++```haskell+import Data.Maybe (fromJust)+f2 x =+    (,,)+      <$> Stream.fromEffect (return $ show x)+      <*> Stream.fromEffect (return $ x + 1)+      <*> Stream.fromEffect (return $ fromIntegral x / 2)+  & Stream.fromAsync+  & Stream.head+  & fmap fromJust+```++Then apply the function `f` concurrently to your input stream:++```haskell+g f xs =+  Stream.fromList xs+    & Stream.mapM f+    & Stream.fromAhead+    & Stream.toList+```++```+>>> g f1 [1,2,3,4::Int]+[[2,3],[3,4],[4,5],[5,6]]++>>> g f2 [1,2,3,4::Int]+[("1",2,0.5),("2",3,1.0),("3",4,1.5),("4",5,2.0)]+```++## Sliding Window++```+>>> :{+  Stream.fromList [1,2,3,4,5::Int]+& Stream.scan (Array.writeLastN 2)+& Stream.toList+:}+[[],[1],[1,2],[2,3],[3,4],[4,5]]+```
docs/getting-started.md view
@@ -204,7 +204,7 @@ adding a version number constraint to the `--build-depends` flag:  ```-$ cabal repl --build-depends streamly==0.8.0+$ cabal repl --build-depends streamly==0.8.1 [1 of 1] Compiling Main             ( Main.hs, interpreted ) Ok, modules loaded: Main. *Main>
+ docs/streaming-pradigms.rst view
@@ -0,0 +1,117 @@+Streaming Paradigms+-------------------++There are two dual paradigms for stream processing in Haskell. In the first+paradigm we represent a stream as a data type and use functions to work on it.+In the second paradigm we represent *stream processors* as data types and+provide them individual data elements to process, there is no explicit+representation of the stream as a data type. In the first paradigm we work with+data representation and in the second paradigm we work with function+representations. Both of these paradigms have equal expressive power. The+latter uses the monadic composition for data flow whereas the former does not+need monadic composition for straight line stream processing and therefore can+use it for higher level composition e.g.  to compose streams in a product+style.++To see an example of the first paradigm, let us use the ``vector`` package to+represent a monadic stream of integers as ``Stream IO Int``. This data+representation of stream is passed explicitly to the stream processing+functions like ``filter`` and ``drop`` to manipulate it::++  import qualified Data.Vector.Fusion.Stream.Monadic as S++  stream :: S.Stream IO Int+  stream = S.fromList [1..100]++  main =  do+    let str = (S.filter even . S.drop 10) stream+    toList str >>= putStrLn . show++Pure lists and vectors are the most basic examples of streams in this paradigm.+The streaming IO libraries just extend the same paradigm to monadic streaming.+The API of these libraries is very much similar to lists with a monad parameter+added.++The second paradigm is direct opposite of the first one, there is no stream+representation in this paradigm, instead we represent *stream processors* as+data types. A stream processor represents a particular process rather than+data, and we compose them together to create composite processors. We can call+them stream transducers or simply pipes. Using the ``machines`` package::++  import qualified Data.Machine as S++  producer :: S.SourceT IO Int+  producer = S.enumerateFromTo 1 100++  main =  do+    let processor = producer S.~> S.dropping 10 S.~> S.filtered even+    S.runT processor >>= putStrLn . show++Both of these paradigms look almost the same, right? To see the difference+let's take a look at some types. In the first paradigm we have an explicit+stream type and the processing functions take the stream as input and produce+the transformed stream::++  stream :: S.Stream IO Int+  filter :: Monad m => (a -> Bool) -> Stream m a -> Stream m a++In the second paradigm, there is no stream data type, there are stream+processors, let's call them boxes that represent a process.  We have a+*SourceT* box that represents a singled ended producer and a *Process* box or a+pipe that has two ends, an input end and an output end, a ``MachineT``+represents any kind of box. We put these boxes together using the ``~>``+operator and then run the resulting machine using ``runT``::++  producer :: S.SourceT IO Int+  filtered :: (a -> Bool) -> Process a a+  dropping :: Int -> Process a a+  (~>) :: Monad m => MachineT m k b -> ProcessT m b c -> MachineT m k c++Custom pipes can be created using a Monadic composition and primitives to+receive and send data usually called ``await`` and ``yield``.++.. |str| replace:: `streamly <https://github.com/composewell/streamly>`__+++-----------------------------------------------------------------------------++| Streaming libraries using the direct paradigm.                              |++------------------------+----------------------------------------------------++| Library                | Remarks                                            |++========================+====================================================++| vector                 | The simplest in this category, provides            |+|                        | transformation and combining of monadic            |+|                        | streams but no monadic composition of streams.     |+|                        | Provides a very simple list like API.              |++------------------------+----------------------------------------------------++| streaming              | * Encodes a return value to be supplied when the   |+|                        |   stream ends. The monad instance passes on the    |+|                        |   streams and combines the return values.          |+|                        | * Functor general                                  |+|                        | * The API is more complicated than vector because  |+|                        |   of the return value and the functor layer.       |++------------------------+----------------------------------------------------++| list-t                 | Provides straight line composition of streams      |+|                        | as well as a list like monadic composition.        |+|                        | The API is simple, just like ``vector``.           |++------------------------+----------------------------------------------------++|                        | Like list-t, in addition to straight line          |+|                        | composition it provides a list like monadic        |+|                        | composition of streams, supports combining streams |+|                        | concurrently supports concurrent applicative and   |+|                        | monadic composition.                               |+| |str|                  | The basic API is very much like lists and          |+|                        | almost identical to ``vector`` streams.            |++------------------------+----------------------------------------------------++++-----------------------------------------------------------------------------++| Streaming libraries using the pipes paradigm.                               |++------------------------+----------------------------------------------------++| Library                | Remarks                                            |++========================+====================================================++| conduit                | ``await`` and ``yield`` data to upstream or        |+|                        | downstream pipes; supports pushing leftovers back. |++------------------------+----------------------------------------------------++| pipes                  | ``await`` and ``yield`` data to upstream or        |+|                        | downstream pipes                                   |++------------------------+----------------------------------------------------++| machines               | Can await from two sources, left and right.        |++------------------------+----------------------------------------------------+
docs/streamly-docs.cabal view
@@ -15,6 +15,9 @@ -- Library ------------------------------------------------------------------------------- +extra-doc-files:+  Roadmap.link+ library   default-language: Haskell2010   ghc-options:      -Wall
docs/unified-abstractions.md view
@@ -110,7 +110,7 @@ `logict` packages for free.  Here is an example of nested looping using the serial stream monad: -``` haskell+```haskell import qualified Streamly.Prelude as S  loops = do
− examples/README.md 
@@ -1,3 +0,0 @@-# Examples--Examples are available in [streamly-examples](https://github.com/composewell/streamly-examples) repo.
src/Streamly.hs view
@@ -210,19 +210,19 @@ where  import Data.Semigroup (Semigroup(..))-import Streamly.Internal.Data.SVar (MonadAsync, Rate(..))+import Streamly.Internal.Control.Concurrent (MonadAsync)+import Streamly.Internal.Data.SVar (Rate(..)) import Streamly.Internal.Data.Stream.Ahead-import Streamly.Internal.Data.Stream.Async hiding (mkAsync)+import Streamly.Internal.Data.Stream.Async 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.IsStream.Expand+import Streamly.Internal.Data.Stream.IsStream.Type+import Streamly.Internal.Data.Stream.Serial (StreamT, InterleavedT) import Streamly.Internal.Data.Stream.Zip  import qualified Streamly.Prelude as P 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+import qualified Streamly.Internal.Data.Stream.IsStream.Transform as Transform  -- XXX provide good succinct examples of pipelining, merging, splitting etc. -- below.@@ -363,7 +363,7 @@ -- @since 0.1.0 {-# DEPRECATED runStreaming "Please use runStream instead." #-} runStreaming :: (Monad m, IsStream t) => t m a -> m ()-runStreaming = P.drain . K.adapt+runStreaming = P.drain . adapt  -- | Same as @runStream@. --@@ -383,35 +383,35 @@ -- @since 0.1.0 {-# DEPRECATED runInterleavedT "Please use 'drain . interleaving' instead." #-} runInterleavedT :: Monad m => WSerialT m a -> m ()-runInterleavedT = P.drain . K.adapt+runInterleavedT = P.drain . adapt  -- | Same as @drain . fromParallel@. -- -- @since 0.1.0 {-# DEPRECATED runParallelT "Please use 'drain . fromParallel' instead." #-} runParallelT :: Monad m => ParallelT m a -> m ()-runParallelT = P.drain . K.adapt+runParallelT = P.drain . adapt  -- | Same as @drain . fromAsync@. -- -- @since 0.1.0 {-# DEPRECATED runAsyncT "Please use 'drain . fromAsync' instead." #-} runAsyncT :: Monad m => AsyncT m a -> m ()-runAsyncT = P.drain . K.adapt+runAsyncT = P.drain . adapt  -- | Same as @drain . zipping@. -- -- @since 0.1.0 {-# DEPRECATED runZipStream "Please use 'drain . fromZipSerial instead." #-} runZipStream :: Monad m => ZipSerialM m a -> m ()-runZipStream = P.drain . K.adapt+runZipStream = P.drain . adapt  -- | Same as @drain . zippingAsync@. -- -- @since 0.1.0 {-# DEPRECATED runZipAsync "Please use 'drain . fromZipAsync instead." #-} runZipAsync :: Monad m => ZipAsyncM m a -> m ()-runZipAsync = P.drain . K.adapt+runZipAsync = P.drain . adapt  {- -- | Same as "Streamly.Prelude.foldWith".@@ -450,7 +450,7 @@ -- @since 0.2.0 {-# INLINABLE mkAsync #-} mkAsync :: (IsStream t, MonadAsync m) => t m a -> m (t m a)-mkAsync = return . Async.mkAsync+mkAsync = return . Transform.mkAsync  ------------------------------------------------------------------------------ -- Documentation
src/Streamly/Data/Fold.hs view
@@ -10,6 +10,7 @@ -- consists of an accumulator and an effectful action that absorbs a value into -- the accumulator. --+-- >>> import Data.Function ((&)) -- >>> import qualified Streamly.Data.Fold as Fold -- >>> import qualified Streamly.Prelude as Stream --@@ -91,26 +92,39 @@ -- = 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').+-- are more efficient in composition of producers (e.g.+-- 'Streamly.Prelude.serial' or 'Streamly.Prelude.mergeBy') whereas folds are+-- more efficient in 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]+-- >>> :{+--  f stream =+--        Stream.filter odd stream+--      & Stream.map (+1)+--      & Stream.sum+-- :}+--+-- >>> f $ Stream.fromList [1..100 :: Int] -- 2550 -- -- Folds are stream consumers with an input stream and an output value, stream -- transformations on folds happen on the input side: ----- >>> f = Fold.filter odd $ Fold.lmap (+1) $ Fold.sum--- >>> Stream.fold f $ Stream.fromList [1..100]+-- >>> :{+-- f =+--        Fold.filter odd+--      $ Fold.lmap (+1)+--      $ Fold.sum+-- :}+--+-- >>> Stream.fold f $ Stream.fromList [1..100 :: Int] -- 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.+-- Notice the similiarity in the definition of @f@ in both cases, the only+-- difference is the composition by @&@ vs @$@ and the use @lmap@ vs @map@, the+-- difference is due to output vs input side transformations.  module Streamly.Data.Fold     (@@ -227,6 +241,8 @@     -- "Streamly.Internal.Data.Fold.Tee".      , teeWith+    --, teeWithFst+    --, teeWithMin     , tee     , distribute @@ -235,6 +251,10 @@     -- fold selector.      , partition+    --, partitionByM+    --, partitionByFstM+    --, partitionByMinM+    --, partitionBy      -- ** Unzipping     , unzip@@ -264,5 +284,6 @@ import Streamly.Internal.Data.Fold  -- $setup+-- >>> import Data.Function ((&)) -- >>> import qualified Streamly.Data.Fold as Fold -- >>> import qualified Streamly.Prelude as Stream
src/Streamly/FileSystem/Handle.hs view
@@ -9,49 +9,59 @@ -- Stability   : released -- Portability : GHC ----- Read and write streams and arrays to and from file handles. File handle 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.FileSystem.Handle as Handle ----- Control over file reading and writing behavior in terms of buffering,--- encoding, decoding is in the hands of the programmer, the 'TextEncoding',--- 'NewLineMode', and 'Buffering' options of the underlying handle provided by--- GHC are not needed and ignored.+-- Read and write byte streams and array streams to and from file handles+-- ('Handle'). ----- = Programmer Notes+-- The 'TextEncoding', 'NewLineMode', and 'Buffering' options of the underlying+-- GHC 'Handle' are ignored by these APIs. Please use @Streamly.Unicode.*@+-- modules for encoding and decoding a byte stream, use stream splitting+-- operations in "Streamly.Prelude" to create a stream of lines or to split the+-- input stream on any other type of boundaries. ----- > import qualified Streamly.FileSystem.Handle as Handle+-- To set the read or write start position use 'hSeek' on the 'Handle', the+-- 'Streamly.Prelude.before' combinator may be used to do that on a streaming+-- combinator.  To restrict the length of read or write use the stream trimming+-- operations like 'Streamly.Prelude.take'. --+-- Note that a 'Handle' is inherently stateful, therefore, we cannot use these+-- APIs from multiple threads without serialization; reading or writing in one+-- thread would affect the file position for other threads.+-- -- For additional, experimental APIs take a look at -- "Streamly.Internal.FileSystem.Handle" module.++-- Design notes: ----- = Performance Notes+-- By design, file handle 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. ----- In some cases the stream type based APIs in the--- "Streamly.Internal.FileSystem.Handle" module may be more efficient compared--- to the unfold/fold based APIs exposed from this module because of better--- fusion by GHC. However, with the streamly fusion GHC plugin (upcoming) these--- APIs would perform as well as the stream based APIs in all cases.---- IO APIs are divided into two categories, sequential streaming IO APIs and--- random access IO APIs.- module Streamly.FileSystem.Handle     (-    -- * Sequential/Streaming IO-    -- | Stream data to or from a file or device sequentially.  When reading,-    -- the stream is lazy and generated on-demand as the consumer consumes it.-    -- Read IO requests to the IO device are performed in chunks limited to a-    -- maximum size of 32KiB, this is referred to as-    -- '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.+    -- * Singleton IO+    -- | Read or write a single buffer.+      getChunk+    , putChunk++    -- * Streaming IO+    -- | Read or write a stream of data to or from a file or device+    -- sequentially.+    --+    -- Read requests to the IO device are performed in chunks limited to a+    -- maximum size of 'Streamly.Internal.System.IO.defaultChunkSize'.  Note+    -- that the size of the actual chunks in the resulting stream may be less+    -- than the @defaultChunkSize@ but it can never exceed it.  If the whole+    -- stream is not consumed, it is possible that we may have read slightly+    -- more from the IO device than what the consumer needed.+    --     -- Unless specified otherwise in the API, writes are collected into chunks-    -- of 'Streamly.Internal.Data.Array.Foreign.Type.defaultChunkSize' before they-    -- are written to the IO device.+    -- of 'Streamly.Internal.System.IO.defaultChunkSize' before they are+    -- written to the IO device. +    -- Internal notes:+    --     -- Streaming APIs work for all kind of devices, seekable or non-seekable;     -- including disks, files, memory devices, terminals, pipes, sockets and     -- fifos. While random access APIs work only for files or devices that have@@ -59,18 +69,18 @@     -- Devices like terminals, pipes, sockets and fifos do not have random     -- access capability. -    -- ** Read From Handle+    -- ** Reading     -- | 'TextEncoding', 'NewLineMode', and 'Buffering' options of the     -- underlying handle are ignored. The read occurs from the current seek     -- position of the file handle. The stream ends as soon as EOF is     -- encountered. -      read+    , read     , readWithBufferOf     , readChunks     , readChunksWithBufferOf -    -- ** Write to Handle+    -- ** Writing     -- | 'TextEncoding', 'NewLineMode', and 'Buffering' options of the     -- underlying handle are ignored. The write occurs from the current seek     -- position of the file handle.  The write behavior depends on the 'IOMode'
src/Streamly/Internal/Control/Concurrent.hs view
@@ -12,6 +12,7 @@     (       MonadAsync     , RunInIO(..)+    , captureMonadState     , doFork     , fork     , forkManaged@@ -42,6 +43,16 @@ type MonadAsync m = (MonadIO m, MonadBaseControl IO m, MonadThrow m)  newtype RunInIO m = RunInIO { runInIO :: forall b. m b -> IO (StM m b) }++-- | 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.+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).
src/Streamly/Internal/Data/Array.hs view
@@ -15,110 +15,101 @@ module Streamly.Internal.Data.Array     ( Array(..) -    , foldl'-    , foldr--    , length-+    -- * Construction+    , nil     , writeN     , write--    , toStreamD-    , toStreamDRev--    , toStream-    , toStreamRev-    , read+    , writeLastN -    , fromListN-    , fromList     , fromStreamDN     , fromStreamD-     , fromStreamN     , fromStream +    , fromListN+    , fromList++    -- * Elimination+    , length+    , read++    , toStreamD+    , toStreamDRev+    , toStream+    , toStreamRev++    , foldl'+    , foldr     , streamFold     , fold++    -- * Random Access+    , getIndexUnsafe+    , strip     ) where -import Prelude hiding (foldr, length, read) #if !MIN_VERSION_primitive(0,7,1) import Control.DeepSeq (NFData(..)) #endif import Control.Monad (when) import Control.Monad.IO.Class (liftIO, MonadIO) import Data.Functor.Identity (runIdentity)-import Data.Primitive.Array hiding (fromList, fromListN)+import Data.IORef import GHC.Base (Int(..)) import GHC.IO (unsafePerformIO)-import qualified GHC.Exts as Exts  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.Stream.Serial (SerialT(..)) import Streamly.Internal.Data.Tuple.Strict (Tuple'(..), Tuple3'(..)) import Streamly.Internal.Data.Unfold.Type (Unfold(..)) +import qualified GHC.Exts as Exts import qualified Streamly.Internal.Data.Fold.Type as FL+import qualified Streamly.Internal.Data.Ring as RB import qualified Streamly.Internal.Data.Stream.StreamD as D +import Data.Primitive.Array hiding (fromList, fromListN)+import Prelude hiding (foldr, length, read)+ {-# NOINLINE bottomElement #-} bottomElement :: a bottomElement = undefined -{-# INLINE_NORMAL toStreamD #-}-toStreamD :: 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# i) =-        return $-        case Exts.indexArray# (array# arr) i of-            (# x #) -> D.Yield x (I# i + 1)+{-# NOINLINE nil #-}+nil :: Array a+nil = unsafePerformIO $ do+    marr <- liftIO $ newArray 0 bottomElement+    liftIO $ freezeArray marr 0 0 -{-# INLINE length #-}-length :: Array a -> Int-length = sizeofArray+-------------------------------------------------------------------------------+-- Construction - Folds+------------------------------------------------------------------------------- -{-# INLINE_NORMAL toStreamDRev #-}-toStreamDRev :: 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# i) =-        return $-        case Exts.indexArray# (array# arr) i of-            (# x #) -> D.Yield x (I# i - 1)+{-# INLINE_NORMAL writeN #-}+writeN :: MonadIO m => Int -> Fold m a (Array a)+writeN len = Fold step initial extract -{-# INLINE_NORMAL foldl' #-}-foldl' :: (b -> a -> b) -> b -> Array a -> b-foldl' f z arr = runIdentity $ D.foldl' f z $ toStreamD arr+    where -{-# INLINE_NORMAL foldr #-}-foldr :: (a -> b -> b) -> b -> Array a -> b-foldr f z arr = runIdentity $ D.foldr f z $ toStreamD arr+    {-# INLINE next #-}+    next marr i = do+        let i1 = i + 1+            st = Tuple' marr i1+        if len > i1+        then return $ FL.Partial st+        else fmap FL.Done $ extract st --- writeN n = S.evertM (fromStreamDN n)-{-# INLINE_NORMAL writeN #-}-writeN :: MonadIO m => Int -> Fold m a (Array a)-writeN limit = Fold step initial extract-  where     initial = do-        marr <- liftIO $ newArray limit bottomElement-        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 $ FL.Partial $ Tuple' marr (i + 1)-    extract (Tuple' marr len) = liftIO $ freezeArray marr 0 len+        marr <- liftIO $ newArray len bottomElement+        next marr (-1) +    step (Tuple' marr i) x = do+        liftIO $ writeArray marr i x+        next marr i++    extract (Tuple' marr l) = liftIO $ freezeArray marr 0 l+ {-# INLINE_NORMAL write #-} write :: MonadIO m => Fold m a (Array a) write = Fold step initial extract@@ -138,6 +129,10 @@             return $ FL.Partial $ Tuple3' marr (i + 1) capacity     extract (Tuple3' marr len _) = liftIO $ freezeArray marr 0 len +-------------------------------------------------------------------------------+-- Construction - from streams+-------------------------------------------------------------------------------+ {-# INLINE_NORMAL fromStreamDN #-} fromStreamDN :: MonadIO m => Int -> D.Stream m a -> m (Array a) fromStreamDN limit str = do@@ -153,6 +148,16 @@ fromStreamD :: MonadIO m => D.Stream m a -> m (Array a) fromStreamD = D.fold write +{-# INLINE fromStreamN #-}+fromStreamN :: MonadIO m => Int -> SerialT m a -> m (Array a)+fromStreamN n (SerialT m) = do+    when (n < 0) $ error "fromStreamN: negative write count specified"+    fromStreamDN n $ D.fromStreamK m++{-# INLINE fromStream #-}+fromStream :: MonadIO m => SerialT m a -> m (Array a)+fromStream (SerialT m) = fromStreamD $ D.fromStreamK m+ {-# INLINABLE fromListN #-} fromListN :: Int -> [a] -> Array a fromListN n xs = unsafePerformIO $ fromStreamDN n $ D.fromList xs@@ -161,30 +166,80 @@ fromList :: [a] -> Array a fromList xs = unsafePerformIO $ fromStreamD $ D.fromList xs -#if !MIN_VERSION_primitive(0,7,1)-instance NFData a => NFData (Array a) where-    {-# INLINE rnf #-}-    rnf = foldl' (\_ x -> rnf x) ()-#endif+-------------------------------------------------------------------------------+-- Elimination - Unfolds+------------------------------------------------------------------------------- -{-# INLINE fromStreamN #-}-fromStreamN :: MonadIO m => Int -> SerialT m a -> m (Array a)-fromStreamN n m = do-    when (n < 0) $ error "fromStreamN: negative write count specified"-    fromStreamDN n $ D.toStreamD m+{-# INLINE length #-}+length :: Array a -> Int+length = sizeofArray -{-# INLINE fromStream #-}-fromStream :: MonadIO m => SerialT m a -> m (Array a)-fromStream m = fromStreamD $ D.toStreamD m+{-# INLINE_NORMAL read #-}+read :: Monad m => Unfold m (Array a) a+read = Unfold step inject+  where+    inject arr = return (arr, 0)+    step (arr, i)+        | i == length arr = return D.Stop+    step (arr, I# i) =+        return $+        case Exts.indexArray# (array# arr) i of+            (# x #) -> D.Yield x (arr, I# i + 1) +-------------------------------------------------------------------------------+-- Elimination - to streams+-------------------------------------------------------------------------------++{-# INLINE_NORMAL toStreamD #-}+toStreamD :: 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# i) =+        return $+        case Exts.indexArray# (array# arr) i of+            (# x #) -> D.Yield x (I# i + 1)++{-# INLINE_NORMAL toStreamDRev #-}+toStreamDRev :: 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# i) =+        return $+        case Exts.indexArray# (array# arr) i of+            (# x #) -> D.Yield x (I# i - 1)+ {-# INLINE_EARLY toStream #-}-toStream :: (Monad m, IsStream t) => Array a -> t m a-toStream = D.fromStreamD . toStreamD+toStream :: Monad m => Array a -> SerialT m a+toStream = SerialT . D.toStreamK . toStreamD  {-# INLINE_EARLY toStreamRev #-}-toStreamRev :: (Monad m, IsStream t) => Array a -> t m a-toStreamRev = D.fromStreamD . toStreamDRev+toStreamRev :: Monad m => Array a -> SerialT m a+toStreamRev = SerialT . D.toStreamK . toStreamDRev +-------------------------------------------------------------------------------+-- Elimination - using Folds+-------------------------------------------------------------------------------++{-# INLINE_NORMAL foldl' #-}+foldl' :: (b -> a -> b) -> b -> Array a -> b+foldl' f z arr = runIdentity $ D.foldl' f z $ toStreamD arr++{-# INLINE_NORMAL foldr #-}+foldr :: (a -> b -> b) -> b -> Array a -> b+foldr f z arr = runIdentity $ D.foldr f z $ toStreamD arr++#if !MIN_VERSION_primitive(0,7,1)+instance NFData a => NFData (Array a) where+    {-# INLINE rnf #-}+    rnf = foldl' (\_ x -> rnf x) ()+#endif+ {-# INLINE fold #-} fold :: Monad m => Fold m a b -> Array a -> m b fold f arr = D.fold f (toStreamD arr)@@ -193,14 +248,68 @@ streamFold :: Monad m => (SerialT m a -> m b) -> Array a -> m b streamFold f arr = f (toStream arr) -{-# INLINE_NORMAL read #-}-read :: Monad m => Unfold m (Array a) a-read = Unfold step inject-  where-    inject arr = return (arr, 0)-    step (arr, i)-        | i == length arr = return D.Stop-    step (arr, I# i) =-        return $-        case Exts.indexArray# (array# arr) i of-            (# x #) -> D.Yield x (arr, I# i + 1)+-------------------------------------------------------------------------------+-- Random reads and writes+-------------------------------------------------------------------------------++-- | /O(1)/ Lookup the element at the given index. Index starts from 0. Does+-- not check the bounds.+--+-- @since 0.8.0+{-# INLINE getIndexUnsafe #-}+getIndexUnsafe :: Array a -> Int -> a+getIndexUnsafe = indexArray++{-# INLINE writeLastN #-}+writeLastN :: MonadIO m => Int -> Fold m a (Array a)+writeLastN n+    | n <= 0 = fmap (const mempty) FL.drain+    | otherwise = Fold step initial done++    where++    initial = do+        rb <- liftIO $ RB.createRing n+        return $ FL.Partial $ Tuple' rb (0 :: Int)++    step (Tuple' rb rh) x = do+        liftIO $ RB.unsafeInsertRing rb rh x+        return $ FL.Partial $ Tuple' rb (rh + 1)++    done (Tuple' rb rh) = do+        arr' <- liftIO $ newArray (min rh n) (undefined :: a)+        ref <- liftIO $ readIORef $ RB.ringHead rb+        if rh < n+        then+            liftIO $ copyMutableArray arr' 0 (RB.arr rb) 0 ref+        else do+            liftIO $ copyMutableArray arr' 0 (RB.arr rb) ref (n - ref)+            liftIO $ copyMutableArray arr' (n - ref) (RB.arr rb) 0 ref+        liftIO $ unsafeFreezeArray arr'++-- XXX This is not efficient as it copies the array. We should support array+-- slicing so that we can just refer to the underlying array memory instead of+-- copying.+--+-- | Truncate the array at the beginning and end as long as the predicate+-- holds true.+strip :: (a -> Bool) -> Array a -> Array a+strip p arr =+    let lastIndex = length arr - 1+        indexR = getIndexR lastIndex -- last predicate failing index+    in if indexR == -1+       then nil+       else+            let indexL = getIndexL 0 -- first predicate failing index+            in if indexL == 0 && indexR == lastIndex+               then arr+               else cloneArray arr indexL (indexR - indexL + 1)++    where++    getIndexR idx+        | idx < 0 = idx+        | otherwise =+            if p (indexArray arr idx) then getIndexR (idx - 1) else idx++    getIndexL idx = if p (indexArray arr idx) then getIndexL (idx + 1) else idx
src/Streamly/Internal/Data/Array/Foreign.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE UnboxedTuples #-}- #include "inline.hs"  -- |@@ -36,8 +34,6 @@     (       Array -    -- , defaultChunkSize-     -- * Construction      -- Pure, From Static Memory (Unsafe)@@ -55,136 +51,105 @@     , fromStreamN     , fromStream -    -- Monadic APIs-    -- , newArray+    -- Monadic Folds     , A.writeN      -- drop new     , A.writeNAligned     , A.write       -- full buffer     , writeLastN      -- * Elimination-     , A.toList     , A.toStream     , A.toStreamRev     , read-    , producer-    , unsafeRead+    , unsafeRead    -- XXX readUnsafe?     , A.readRev-    -- , readChunksOf+    , producer -- experimental      -- * 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-    -- , ...+    , A.unsafeIndex -- XXX Rename to getIndexUnsafe??+    , getIndexRev+    , last           -- XXX getIndexLast?+    , getIndices+    , getIndicesFromThenTo+    -- , getIndicesFrom    -- read from a given position to the end of file+    -- , getIndicesUpto    -- read from beginning up to the given position+    -- , getIndicesFromTo+    -- , getIndicesFromRev  -- read from a given position to the beginning of file+    -- , getIndicesUptoRev  -- read from end to the given position in file -    , writeIndex-    --, writeIndices-    --, writeRanges+    -- * Size+    , length+    , null -    -- -- * Search-    -- , bsearch-    -- , bsearchIndex+    -- * Search+    , binarySearch+    , findIndicesOf+    -- , findIndexOf     -- , find-    -- , findIndex-    -- , findIndices -    -- -- * In-pace mutation (for Mutable Array type)-    -- , partitionBy-    -- , shuffleBy-    -- , foldtWith-    -- , foldbWith--    , unsafeSlice--    -- * Immutable Transformations-    , streamTransform-     -- * Casting     , cast-    , unsafeCast-    , unsafeAsPtr     , asBytes-    , unsafeAsCString+    , unsafeCast   -- castUnsafe?+    , unsafeAsPtr  -- asPtrUnsafe?+    , unsafeAsCString -- asCStringUnsafe?+    , A.unsafeFreeze -- asImmutableUnsafe?+    , A.unsafeThaw   -- asMutableUnsafe? -    -- * Folding Arrays+    -- * Subarrays+    , getSliceUnsafe+    -- , getSlice+    , genSlicesFromLen+    , getSlicesFromLen+    , splitOn++    -- * Streaming Operations+    , streamTransform++    -- ** Folding     , streamFold     , fold     ) where +import Control.Exception (assert) import Control.Monad (when) import Control.Monad.IO.Class (MonadIO(..))+import Data.Functor.Identity (Identity) #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.Mut.Type (ReadUState(..), touch) 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.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 Streamly.Internal.System.IO (unsafeInlineIO)  import qualified Streamly.Internal.Data.Array.Foreign.Mut.Type as MA+import qualified Streamly.Internal.Data.Array.Foreign.Mut 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.Producer as Producer+import qualified Streamly.Internal.Data.Stream.IsStream.Type as 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.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 -------------------------------------------------------------------------------@@ -196,9 +161,9 @@ -- /Pre-release/ {-# INLINE fromStreamN #-} fromStreamN :: (MonadIO m, Storable a) => Int -> SerialT m a -> m (Array a)-fromStreamN n m = do+fromStreamN n (SerialT m) = do     when (n < 0) $ error "writeN: negative write count specified"-    A.fromStreamDN n $ D.toStreamD m+    A.fromStreamDN n $ D.fromStreamK 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@@ -211,13 +176,39 @@ -- /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+fromStream (SerialT m) = P.fold A.write m+-- write m = A.fromStreamD $ D.fromStreamK m  ------------------------------------------------------------------------------- -- Elimination ------------------------------------------------------------------------------- +{-# INLINE_NORMAL producer #-}+producer :: forall m a. (Monad m, Storable a) => Producer m (Array a) a+producer = Producer step inject extract+    where++    {-# INLINE inject #-}+    inject (Array contents start end) = return $ ReadUState contents end start++    {-# INLINE_LATE step #-}+    step (ReadUState contents end cur)+        | assert (cur <= end) (cur == end) =+            let x = unsafeInlineIO $ touch contents+            in x `seq` return D.Stop+    step (ReadUState contents end cur) = 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 cur+                cur1 = cur `plusPtr` sizeOf (undefined :: a)+            return $ D.Yield x (ReadUState contents end cur1)++    extract (ReadUState contents end cur) = return $ Array contents cur end+ -- | Unfold an array into a stream. -- -- /Since 0.7.0 (Streamly.Memory.Array)/@@ -225,11 +216,7 @@ -- @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+read = Producer.simplify producer  -- | Unfold an array into a stream, does not check the end of the array, the -- user is responsible for terminating the stream within the array bounds. For@@ -247,38 +234,58 @@ unsafeRead = Unfold step inject     where -    inject (Array fp _) = return fp+    inject (Array contents start end) =+        return (ReadUState contents end start)      {-# INLINE_LATE step #-}-    step (ForeignPtr p contents) = do+    step (ReadUState contents end p) = do             -- unsafeInlineIO allows us to run this in Identity monad for pure             -- toList/foldr case which makes them much faster due to not             -- accumulating the list and fusing better with the pure consumers.             --             -- This should be safe as the array contents are guaranteed to be             -- evaluated/written to before we peek at them.-            let !x = A.unsafeInlineIO $ do-                        r <- peek (Ptr p)+            let !x = unsafeInlineIO $ do+                        r <- peek 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', () #)+            let !p1 = p `plusPtr` sizeOf (undefined :: a)+            return $ D.Yield x (ReadUState contents end p1) --- | > null arr = length arr == 0+-- | --+-- >>> import qualified Streamly.Internal.Data.Array.Foreign.Type as Array+-- >>> null arr = Array.byteLength arr == 0+-- -- /Pre-release/ {-# INLINE null #-}-null :: Storable a => Array a -> Bool-null arr = length arr == 0+null :: Array a -> Bool+null arr = A.byteLength arr == 0 --- | > last arr = getIndex arr (length arr - 1)+-- | Like 'getIndex' but indexes the array in reverse from the end. -- -- /Pre-release/+{-# INLINE getIndexRev #-}+getIndexRev :: forall a. Storable a => Array a -> Int -> Maybe a+getIndexRev arr i =+    unsafeInlineIO+        $ MA.unsafeWithArrayContents (arrContents arr) (arrStart arr)+            $ \ptr -> do+                let elemSize = sizeOf (undefined :: a)+                    elemPtr = aEnd arr `plusPtr` negate (elemSize * (i + 1))+                if i >= 0 && elemPtr >= ptr+                then Just <$> peek elemPtr+                else return Nothing++-- |+--+-- >>> import qualified Streamly.Internal.Data.Array.Foreign as Array+-- >>> last arr = Array.getIndexRev arr 0+--+-- /Pre-release/ {-# INLINE last #-} last :: Storable a => Array a -> Maybe a-last arr = getIndex arr (length arr - 1)+last arr = getIndexRev arr 0  ------------------------------------------------------------------------------- -- Folds with Array as the container@@ -308,7 +315,8 @@         arr <- liftIO $ MA.newArray n         foldFunc i rh snoc' arr rb -    snoc' b a = liftIO $ MA.unsafeSnoc b a+    -- XXX We should write a read unfold for ring.+    snoc' b a = liftIO $ MA.snocUnsafe b a      foldFunc i         | i < n = RB.unsafeFoldRingM@@ -322,27 +330,31 @@ -- 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+-- | Given a sorted array, perform a binary search to find the given element.+-- Returns the index of the element if found.+--+-- /Unimplemented/+{-# INLINE binarySearch #-}+binarySearch :: a -> Array a -> Maybe Int+binarySearch = undefined  -- find/findIndex etc can potentially be implemented more efficiently on arrays -- compared to streams by using SIMD instructions.+-- We can also return a bit array instead. -find :: (a -> Bool) -> Array a -> Bool-find = undefined+-- | Perform a linear search to find all the indices where a given element is+-- present in an array.+--+-- /Unimplemented/+findIndicesOf :: (a -> Bool) -> Unfold Identity (Array a) Int+findIndicesOf = undefined -findIndex :: (a -> Bool) -> Array a -> Maybe Int-findIndex = undefined+{-+findIndexOf :: (a -> Bool) -> Array a -> Maybe Int+findIndexOf p = Unfold.fold Fold.head . Stream.unfold (findIndicesOf p) -findIndices :: (a -> Bool) -> Array a -> Array Int-findIndices = undefined+find :: (a -> Bool) -> Array a -> Bool+find = Unfold.fold Fold.null . Stream.unfold (findIndicesOf p) -}  -------------------------------------------------------------------------------@@ -352,7 +364,7 @@ -- XXX We can potentially use SIMD instructions on arrays to fold faster.  ---------------------------------------------------------------------------------- Slice and splice+-- Slice -------------------------------------------------------------------------------  -- | /O(1)/ Slice an array in constant time.@@ -362,147 +374,113 @@ -- /Unsafe/ -- -- /Pre-release/-{-# INLINE unsafeSlice #-}-unsafeSlice ::+{-# INLINE getSliceUnsafe #-}+getSliceUnsafe ::        forall a. Storable a     => Int -- ^ starting index     -> Int -- ^ length of the slice     -> Array a     -> Array a-unsafeSlice start len (Array fp _) =+getSliceUnsafe index len (Array contents start e) =     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+        fp1 = start `plusPtr` (index * size)+        end = fp1 `plusPtr` (len * size)+     in assert (end <= e) (Array contents fp1 end) --- 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)'.+-- | Split the array into a stream of slices using a predicate. The element+-- matching the predicate is dropped. ----- @since 0.7.0-{-# INLINABLE foldtWith #-}-foldtWith :: Int -> (Array a -> Array a -> m (Array a)) -> Array a -> m (Array a)-foldtWith level f = undefined+-- /Pre-release/+{-# INLINE splitOn #-}+splitOn :: (Monad m, Storable a) =>+    (a -> Bool) -> Array a -> SerialT m (Array a)+splitOn predicate arr =+    IsStream.fromStreamD+        $ fmap (\(i, len) -> getSliceUnsafe i len arr)+        $ D.sliceOnSuffix predicate (A.toStreamD arr) --- | 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--}+{-# INLINE genSlicesFromLen #-}+genSlicesFromLen :: forall m a. (Monad m, Storable a)+    => Int -- ^ from index+    -> Int -- ^ length of the slice+    -> Unfold m (Array a) (Int, Int)+genSlicesFromLen from len =+    Unfold.lmap A.unsafeThaw (MA.genSlicesFromLen from len) --- XXX consider the bulk update/accumulation/permutation APIs from vector.+-- | Generate a stream of slices of specified length from an array, starting+-- from the supplied array index. The last slice may be shorter than the+-- requested length.+--+-- /Pre-release//+{-# INLINE getSlicesFromLen #-}+getSlicesFromLen :: forall m a. (Monad m, Storable a)+    => Int -- ^ from index+    -> Int -- ^ length of the slice+    -> Unfold m (Array a) (Array a)+getSlicesFromLen from len =+    fmap A.unsafeFreeze+        $ Unfold.lmap A.unsafeThaw (MA.getSlicesFromLen from len)  ------------------------------------------------------------------------------- -- Random reads and writes ------------------------------------------------------------------------------- --- | /O(1)/ Lookup the element at the given index, starting from 0.+-- XXX Change this to a partial function instead of a Maybe type? And use+-- MA.getIndex instead. --+-- | /O(1)/ Lookup the element at the given index. Index starts from 0.+-- -- @since 0.8.0 {-# INLINE getIndex #-}-getIndex :: Storable a => Array a -> Int -> Maybe a+getIndex :: forall a. 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+    unsafeInlineIO+        $ MA.unsafeWithArrayContents (arrContents arr) (arrStart arr)+            $ \ptr -> do+                let elemSize = sizeOf (undefined :: a)+                    elemPtr = ptr `plusPtr` (elemSize * i)+                if i >= 0 && elemPtr `plusPtr` elemSize <= aEnd arr+                then Just <$> peek elemPtr+                else return Nothing -{---- | @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@.+-- | Given a stream of array indices, read the elements on those indices from+-- the supplied Array. An exception is thrown if an index is out of bounds. ----- @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@.+-- This is the most general operation. We can implement other operations in+-- terms of this: ----- @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.+-- @+-- read =+--      let u = lmap (\arr -> (0, length arr - 1)) Unfold.enumerateFromTo+--       in Unfold.lmap f (getIndices arr) ----- /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@.+-- readRev =+--      let i = length arr - 1+--       in Unfold.lmap f (getIndicesFromThenTo i (i - 1) 0)+-- @ ----- @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+-- /Unimplemented/+{-# INLINE getIndices #-}+getIndices :: Unfold m (Array a) Int -> Unfold m (Array a) a+getIndices = 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@.+-- | Unfolds @(from, then, to, array)@ generating a finite stream whose first+-- element is the array value from the index @from@ and the successive elements+-- are from the indices in increments of @then@ up to @to@. Index enumeration+-- can occur downwards or upwards depending on whether @then@ comes before or+-- after @from@. ----- @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--}+-- @+-- getIndicesFromThenTo =+--     let f (from, next, to, arr) =+--             (Stream.enumerateFromThenTo from next to, arr)+--      in Unfold.lmap f getIndices+-- @+--+-- /Unimplemented/+{-# INLINE getIndicesFromThenTo #-}+getIndicesFromThenTo :: Unfold m (Int, Int, Int, Array a) a+getIndicesFromThenTo = undefined  ------------------------------------------------------------------------------- -- Transform via stream operations@@ -523,6 +501,9 @@ runPipe f arr = P.runPipe (toArrayMinChunk (length arr)) $ f (A.read arr) -} +-- XXX For transformations that cannot change the number of elements e.g. "map"+-- we can use a predetermined array length.+-- -- | Transform an array into another array using a stream transformation -- operation. --@@ -531,8 +512,7 @@ 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)+    P.fold (A.writeWith (length arr)) $ getSerialT $ f (A.toStream arr)  ------------------------------------------------------------------------------- -- Casts@@ -550,7 +530,8 @@     Storable b => #endif     Array a -> Array b-unsafeCast (Array start end) = Array (castForeignPtr start) (castPtr end)+unsafeCast (Array contents start end) =+    Array contents (castPtr start) (castPtr end)  -- | Cast an @Array a@ into an @Array Word8@. --@@ -581,7 +562,7 @@ -- unsafeAsPtr :: Array a -> (Ptr b -> IO c) -> IO c unsafeAsPtr Array{..} act = do-    unsafeWithForeignPtr aStart $ \ptr -> act (castPtr ptr)+    MA.unsafeWithArrayContents arrContents arrStart $ \ptr -> act (castPtr ptr)  -- | Convert an array of any type into a null terminated CString Ptr. --@@ -594,7 +575,7 @@ 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)+    MA.unsafeWithArrayContents arrContents arrStart $ \ptr -> act (castPtr ptr)  ------------------------------------------------------------------------------- -- Folds@@ -605,7 +586,7 @@ -- /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 f arr = P.fold f (getSerialT (A.toStream arr))  -- | Fold an array using a stream fold operation. --
+ src/Streamly/Internal/Data/Array/Foreign/Mut.hs view
@@ -0,0 +1,86 @@+#include "inline.hs"++-- |+-- Module      : Streamly.Internal.Data.Array.Foreign.Mut+-- Copyright   : (c) 2020 Composewell Technologies+-- License     : BSD-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+    (+      module Streamly.Internal.Data.Array.Foreign.Mut.Type+    , splitOn+    , genSlicesFromLen+    , getSlicesFromLen+    )+where++import Prelude hiding (foldr, length, read, splitAt)++import Streamly.Internal.Data.Array.Foreign.Mut.Type+import qualified Streamly.Internal.Data.Stream.StreamD as D+import Foreign.Storable (Storable)+import Streamly.Internal.Data.Stream.IsStream.Type (SerialT)+import qualified Streamly.Internal.Data.Stream.IsStream.Type as IsStream+import qualified Streamly.Internal.Data.Unfold as Unfold+import Streamly.Internal.Data.Unfold.Type (Unfold(..))+import Control.Monad.IO.Class (MonadIO(..))++-- | Split the array into a stream of slices using a predicate. The element+-- matching the predicate is dropped.+--+-- /Pre-release/+{-# INLINE splitOn #-}+splitOn :: (MonadIO m, Storable a) =>+    (a -> Bool) -> Array a -> SerialT m (Array a)+splitOn predicate arr =+    IsStream.fromStreamD+        $ fmap (\(i, len) -> getSliceUnsafe i len arr)+        $ D.sliceOnSuffix predicate (toStreamD arr)++-- | Generate a stream of array slice descriptors ((index, len)) of specified+-- length from an array, starting from the supplied array index. The last slice+-- may be shorter than the requested length depending on the array length.+--+-- /Pre-release/+{-# INLINE genSlicesFromLen #-}+genSlicesFromLen :: forall m a. (Monad m, Storable a)+    => Int -- ^ from index+    -> Int -- ^ length of the slice+    -> Unfold m (Array a) (Int, Int)+genSlicesFromLen from len =+    let fromThenTo n = (from, from + len, n - 1)+        mkSlice n i = return (i, min len (n - i))+     in Unfold.lmap length+        $ Unfold.mapMWithInput mkSlice+        $ Unfold.lmap fromThenTo Unfold.enumerateFromThenTo++-- | Generate a stream of slices of specified length from an array, starting+-- from the supplied array index. The last slice may be shorter than the+-- requested length depending on the array length.+--+-- /Pre-release/+{-# INLINE getSlicesFromLen #-}+getSlicesFromLen :: forall m a. (Monad m, Storable a)+    => Int -- ^ from index+    -> Int -- ^ length of the slice+    -> Unfold m (Array a) (Array a)+getSlicesFromLen from len =+    let mkSlice arr (i, n) = return $ getSliceUnsafe i n arr+     in Unfold.mapMWithInput mkSlice (genSlicesFromLen from len)
src/Streamly/Internal/Data/Array/Foreign/Mut/Type.hs view
@@ -1,1267 +1,2147 @@ {-# 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 = (<>)+-- |+-- 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+--+-- Mutable arrays and file system files are quite similar, they can grow and+-- their content is mutable. Therefore, both have similar APIs as well. We+-- strive to keep the API consistent for both. Ideally, you should be able to+-- replace one with another with little changes to the code.++module Streamly.Internal.Data.Array.Foreign.Mut.Type+    (+    -- * Type+    -- $arrayNotes+      Array (..)+    , ArrayContents+    , arrayToFptrContents+    , fptrToArrayContents+    , unsafeWithArrayContents+    , nilArrayContents+    , touch++    -- * Constructing and Writing+    -- ** Construction+    -- , nil++    -- *** Uninitialized Arrays+    , newArray+    , newArrayAligned+    , newArrayAlignedUnmanaged+    , newArrayWith++    -- *** Initialized Arrays+    , withNewArrayUnsafe++    -- *** From streams+    , ArrayUnsafe (..)+    , writeNWithUnsafe+    , writeNWith+    , writeNUnsafe+    , writeN+    , writeNAligned+    , writeNAlignedUnmanaged++    , writeWith+    , write++    -- , writeRevN+    -- , writeRev++    -- ** From containers+    , fromForeignPtrUnsafe+    , fromListN+    , fromList+    , fromStreamDN+    , fromStreamD++    -- * Random writes+    , putIndex+    , putIndexUnsafe+    , putIndices+    -- , putFromThenTo+    -- , putFrom -- start writing at the given position+    -- , putUpto -- write from beginning up to the given position+    -- , putFromTo+    -- , putFromRev+    -- , putUptoRev+    , modifyIndexUnsafe+    , modifyIndex+    , modifyIndices+    , modify+    , swapIndices++    -- * Growing and Shrinking+    -- Arrays grow only at the end, though it is possible to grow on both sides+    -- and therefore have a cons as well as snoc. But that will require two+    -- bounds in the array representation.++    -- ** Appending elements+    , snocWith+    , snoc+    , snocLinear+    , snocMay+    , snocUnsafe++    -- ** Appending streams+    , appendNUnsafe+    , appendN+    , appendWith+    , append++    -- ** Truncation+    -- These are not the same as slicing the array at the beginning, they may+    -- reduce the length as well as the capacity of the array.+    , truncateWith+    , truncate+    , truncateExp++    -- * Eliminating and Reading++    -- ** To streams+    , ReadUState(..)+    , read+    , readRev++    -- ** To containers+    , toStreamD+    , toStreamDRev+    , toStreamK+    , toStreamKRev+    , toList++    -- experimental+    , producer++    -- ** Random reads+    , getIndex+    , getIndexUnsafe+    , getIndices+    -- , getFromThenTo+    , getIndexRev++    -- * Memory Management+    , blockSize+    , arrayChunkBytes+    , allocBytesToElemCount+    , realloc+    , resize+    , resizeExp+    , rightSize++    -- * Size+    , length+    , byteLength+    -- , capacity+    , byteCapacity+    , bytesFree++    -- * In-place Mutation Algorithms+    , reverse+    , permute+    , partitionBy+    , shuffleBy+    , divideBy+    , mergeBy++    -- * Casting+    , cast+    , castUnsafe+    , asBytes+    , asPtrUnsafe++    -- * Folding+    , foldl'+    , foldr+    , cmp++    -- * Arrays of arrays+    --  We can add dimensionality parameter to the array type to get+    --  multidimensional arrays. Multidimensional arrays would just be a+    --  convenience wrapper on top of single dimensional arrays.++    -- | Operations dealing with multiple arrays, streams of arrays or+    -- multidimensional array representations.++    -- ** Construct from streams+    , arraysOf+    , arrayStreamKFromStreamD+    , writeChunks++    -- ** Eliminate to streams+    , flattenArrays+    , flattenArraysRev+    , fromArrayStreamK++    -- ** Construct from arrays+    -- get chunks without copying+    , getSliceUnsafe+    , getSlice+    -- , getSlicesFromLenN+    , splitAt -- XXX should be able to express using getSlice+    , breakOn++    -- ** Appending arrays+    , spliceCopy+    , spliceWith+    , splice+    , spliceExp+    -- , putSlice+    -- , appendSlice+    -- , appendSliceFrom++    -- * Utilities+    , memcpy+    , memcmp+    , c_memchr+    )+where++#include "inline.hs"++#ifdef USE_C_MALLOC+#define USE_FOREIGN_PTR+#endif++import Control.Exception (assert)+import Control.DeepSeq (NFData(..))+import Control.Monad (when, void)+import Control.Monad.IO.Class (MonadIO(..))+import Data.Bits ((.&.))+#if __GLASGOW_HASKELL__ < 808+import Data.Semigroup (Semigroup(..))+#endif+import Data.Word (Word8)+import Foreign.C.Types (CSize(..), CInt(..))+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)+#ifndef USE_FOREIGN_PTR+import Foreign.Marshal.Alloc (mallocBytes)+#endif+import Foreign.Ptr (plusPtr, minusPtr, castPtr, nullPtr)+import Foreign.Storable (Storable(..))+import GHC.Base+    ( touch#, IO(..), byteArrayContents#+    , Int(..), newAlignedPinnedByteArray#+    )+#ifndef USE_FOREIGN_PTR+import GHC.Base (RealWorld, MutableByteArray#)+#endif+#if __GLASGOW_HASKELL__ < 802+#define noinline+#else+import GHC.Base (noinline)+#endif+import GHC.Exts (unsafeCoerce#)+import GHC.ForeignPtr (ForeignPtr(..), ForeignPtrContents(..))+#ifdef USE_C_MALLOC+import GHC.ForeignPtr (mallocForeignPtrAlignedBytes)+#endif+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.Type (adaptState)+import Streamly.Internal.Data.Unfold.Type (Unfold(..))+import Streamly.Internal.System.IO (arrayPayloadSize, defaultChunkSize)+import System.IO.Unsafe (unsafePerformIO)++#ifdef DEVBUILD+import qualified Data.Foldable as F+#endif+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+#ifdef USE_FOREIGN_PTR+import qualified Streamly.Internal.Foreign.Malloc as Malloc+#endif++import Prelude hiding+    (length, foldr, read, unlines, splitAt, reverse, truncate)++-- $setup+-- >>> :m+-- >>> import qualified Streamly.Internal.Data.Array.Foreign.Mut.Type as Array+-- >>> import qualified Streamly.Internal.Data.Stream.IsStream as Stream+-- >>> import qualified Streamly.Internal.Data.Stream.StreamD as StreamD+-- >>> import qualified Streamly.Internal.Data.Fold as Fold+-- >>> import qualified Streamly.Internal.Data.Fold.Type as Fold++-------------------------------------------------------------------------------+-- Array Data Type+-------------------------------------------------------------------------------++foreign import ccall unsafe "string.h memcpy" c_memcpy+    :: Ptr Word8 -> Ptr Word8 -> CSize -> IO (Ptr Word8)++foreign import ccall unsafe "string.h memchr" c_memchr+    :: Ptr Word8 -> Word8 -> CSize -> IO (Ptr Word8)++foreign import ccall unsafe "string.h memcmp" c_memcmp+    :: Ptr Word8 -> Ptr Word8 -> CSize -> IO CInt++-- | Given a 'Storable' type (unused first arg) and a number of bytes, return+-- how many elements of that type will completely fit in those bytes.+--+{-# INLINE bytesToElemCount #-}+bytesToElemCount :: Storable a => a -> Int -> Int+bytesToElemCount x n =+    let elemSize = sizeOf x+    in n `div` elemSize++-- XXX we are converting Int to CSize+memcpy :: Ptr Word8 -> Ptr Word8 -> Int -> IO ()+memcpy dst src len = void (c_memcpy dst src (fromIntegral len))++-- XXX we are converting Int to CSize+-- return True if the memory locations have identical contents+{-# INLINE memcmp #-}+memcmp :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool+memcmp p1 p2 len = do+    r <- c_memcmp p1 p2 (fromIntegral len)+    return $ r == 0++-------------------------------------------------------------------------------+-- Array Contents+-------------------------------------------------------------------------------++-- We support using ForeignPtrContents or MutableByteArray.++#ifdef USE_FOREIGN_PTR+newtype ArrayContents = ArrayContents ForeignPtrContents+#define UNPACKIF+#else+-- XXX can use UnliftedNewtypes+data ArrayContents = ArrayContents !(MutableByteArray# RealWorld)+#define UNPACKIF {-# UNPACK #-}+#endif++{-# INLINE touch #-}+touch :: ArrayContents -> IO ()+touch (ArrayContents contents) =+    IO $ \s -> case touch# contents s of s' -> (# s', () #)++fptrToArrayContents :: ForeignPtrContents -> ArrayContents+arrayToFptrContents :: ArrayContents -> ForeignPtrContents+#ifdef USE_FOREIGN_PTR+fptrToArrayContents = ArrayContents+arrayToFptrContents (ArrayContents contents) = contents+#else+fptrToArrayContents (PlainPtr mbarr) = ArrayContents mbarr+fptrToArrayContents _ = error "Unsupported foreign ptr"+arrayToFptrContents (ArrayContents contents) = PlainPtr contents+#endif++-- | Similar to unsafeWithForeignPtr.+{-# INLINE unsafeWithArrayContents #-}+unsafeWithArrayContents :: MonadIO m =>+    ArrayContents -> Ptr a -> (Ptr a -> m b) -> m b+unsafeWithArrayContents contents ptr f = do+  r <- f ptr+  liftIO $ touch contents+  return r++-------------------------------------------------------------------------------+-- 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.++-- | An unboxed, pinned mutable array. An array is created with a given length+-- and capacity. Length is the number of valid elements in the array.  Capacity+-- is the maximum number of elements that the array can be expanded to without+-- having to reallocate the memory.+--+-- The elements in the array can be mutated in-place without changing the+-- reference (constructor). However, the length of the array cannot be mutated+-- in-place.  A new array reference is generated when the length changes.  When+-- the length is increased (upto the maximum reserved capacity of the array),+-- the array is not reallocated and the new reference uses the same underlying+-- memory as the old one.+--+-- Several routines in this module allow the programmer to control the capacity+-- of the array. The programmer can control the trade-off between memory usage+-- and performance impact due to reallocations when growing or shrinking the+-- array.+--+data Array a =+#ifdef DEVBUILD+    Storable a =>+#endif+    Array+    { arrContents :: UNPACKIF !ArrayContents+    , arrStart :: {-# UNPACK #-} !(Ptr a)      -- ^ first address+    , aEnd   :: {-# UNPACK #-} !(Ptr a)        -- ^ first unused address+    , aBound :: {-# UNPACK #-} !(Ptr a)        -- ^ first address beyond allocated memory+    }++-- | @fromForeignPtrUnsafe foreignPtr end bound@ creates an 'Array' that starts+-- at the memory pointed by the @foreignPtr@, @end@ is the first unused+-- address, and @bound@ is the first address beyond the allocated memory.+--+-- Unsafe: Make sure that foreignPtr <= end <= bound and (end - start) is an+-- integral multiple of the element size. Only PlainPtr type ForeignPtr is+-- supported.+--+-- /Pre-release/+--+{-# INLINE fromForeignPtrUnsafe #-}+fromForeignPtrUnsafe ::+#ifdef DEVBUILD+    Storable a =>+#endif+    ForeignPtr a -> Ptr a -> Ptr a -> Array a+fromForeignPtrUnsafe fp@(ForeignPtr start contents) end bound =+    assert (unsafeForeignPtrToPtr fp <= end && end <= bound)+           (Array (fptrToArrayContents contents) (Ptr start) end bound)++-------------------------------------------------------------------------------+-- Construction+-------------------------------------------------------------------------------++-- XXX Change the names to use "new" instead of "newArray". That way we can use+-- the same names for managed file system objects as well. For unmanaged ones+-- we can use open/create etc as usual.+--+-- A new array is similar to "touch" creating a zero length file. An mmapped+-- array would be similar to a sparse file with holes. TBD: support mmapped+-- files and arrays.++-- GHC always guarantees word-aligned memory, alignment is important only when+-- we need more than that.  See stg_newAlignedPinnedByteArrayzh and+-- allocatePinned in GHC source.++-- | @newArrayWith allocator alignment count@ allocates a new array of zero+-- length and with a capacity to hold @count@ elements, using @allocator+-- size alignment@ as the memory allocator function.+--+-- Alignment must be greater than or equal to machine word size and a power of+-- 2.+--+-- /Pre-release/+{-# INLINE newArrayWith #-}+newArrayWith :: forall m a. (MonadIO m, Storable a)+    => (Int -> Int -> m (ArrayContents, Ptr a)) -> Int -> Int -> m (Array a)+newArrayWith alloc alignSize count = do+    let size = max (count * sizeOf (undefined :: a)) 0+    (contents, p) <- alloc size alignSize+    return $ Array+        { arrContents = contents+        , arrStart = p+        , aEnd   = p+        , aBound = p `plusPtr` size+        }++newAlignedArrayContents :: Int -> Int -> IO (ArrayContents, Ptr a)+#ifdef USE_C_MALLOC+newAlignedArrayContents size align = do+    (ForeignPtr addr contents) <- mallocForeignPtrAlignedBytes size align+    return (ArrayContents contents, Ptr addr)+#else+newAlignedArrayContents size _align | size < 0 =+  errorWithoutStackTrace "newAlignedArrayContents: size must be >= 0"+newAlignedArrayContents (I# size) (I# align) = IO $ \s ->+    case newAlignedPinnedByteArray# size align s of+        (# s', mbarr# #) ->+           let p = Ptr (byteArrayContents# (unsafeCoerce# mbarr#))+#ifdef USE_FOREIGN_PTR+               c = ArrayContents (PlainPtr mbarr#)+#else+               c = ArrayContents mbarr#+#endif+            in (# s', (c, p) #)+#endif++{-# NOINLINE nilArrayContents #-}+nilArrayContents :: ArrayContents+nilArrayContents =+    fst $ unsafePerformIO $ newAlignedArrayContents 0 0++-- | Like 'newArrayWith' but using an allocator that allocates unmanaged pinned+-- memory. The memory will never be freed by GHC.  This could be useful in+-- allocate-once global data structures. Use carefully as incorrect use can+-- lead to memory leak.+--+-- /Internal/+{-# INLINE newArrayAlignedUnmanaged #-}+newArrayAlignedUnmanaged :: forall m a. (MonadIO m, Storable a) =>+    Int -> Int -> m (Array a)+#ifdef USE_FOREIGN_PTR+newArrayAlignedUnmanaged = do+    newArrayWith mallocForeignPtrAlignedUnmanagedBytes++    where++    mallocForeignPtrAlignedUnmanagedBytes size align = do+        ForeignPtr addr contents <-+            liftIO $ Malloc.mallocForeignPtrAlignedUnmanagedBytes size align+        return (ArrayContents contents, Ptr addr)+#else+newArrayAlignedUnmanaged _align count = do+    let size = max (count * sizeOf (undefined :: a)) 0+    p <- liftIO $ mallocBytes size+    return $ Array+        { arrContents = nilArrayContents+        , arrStart = p+        , aEnd = p+        , aBound = p `plusPtr` size+        }+#endif++-- | Like 'newArrayWith' but using an allocator that aligns the memory to the+-- alignment dictated by the 'Storable' instance of the type.+--+-- /Internal/+{-# INLINE newArrayAligned #-}+newArrayAligned :: (MonadIO m, Storable a) => Int -> Int -> m (Array a)+newArrayAligned = newArrayWith (\s a -> liftIO $ newAlignedArrayContents s a)++-- XXX can unaligned allocation be more efficient when alignment is not needed?+--+-- | Allocates an empty array that can hold 'count' items.  The memory of the+-- array is uninitialized and the allocation is aligned as per the 'Storable'+-- instance of the type.+--+-- /Pre-release/+{-# INLINE newArray #-}+newArray :: forall m a. (MonadIO m, Storable a) => Int -> m (Array a)+newArray = newArrayAligned (alignment (undefined :: a))++-- | Allocate an Array of the given size and run an IO action passing the array+-- start pointer.+--+-- /Internal/+{-# INLINE withNewArrayUnsafe #-}+withNewArrayUnsafe ::+       (MonadIO m, Storable a) => Int -> (Ptr a -> m ()) -> m (Array a)+withNewArrayUnsafe count f = do+    arr <- newArray count+    unsafeWithArrayContents (arrContents arr) (arrStart arr)+        $ \p -> f p >> return arr++-------------------------------------------------------------------------------+-- Random writes+-------------------------------------------------------------------------------++-- | Write an input stream of (index, value) pairs to an array. Throws an+-- error if any index is out of bounds.+--+-- /Unimplemented/+{-# INLINE putIndices #-}+putIndices :: Array a -> Fold m (Int, a) ()+putIndices = undefined++-- | Write the given element to the given index of the array. Does not check if+-- the index is out of bounds of the array.+--+-- /Pre-release/+{-# INLINE putIndexUnsafe #-}+putIndexUnsafe :: forall m a. (MonadIO m, Storable a)+    => Array a -> Int -> a -> m ()+putIndexUnsafe Array{..} i x =+    unsafeWithArrayContents arrContents arrStart $ \ptr -> do+        let elemSize = sizeOf (undefined :: a)+            elemPtr = ptr `plusPtr` (elemSize * i)+        assert (i >= 0 && elemPtr `plusPtr` elemSize <= aEnd) (return ())+        liftIO $ poke elemPtr x++invalidIndex :: String -> Int -> a+invalidIndex label i =+    error $ label ++ ": invalid array index " ++ show i++{-# INLINE putIndexPtr #-}+putIndexPtr :: forall m a. (MonadIO m, Storable a) =>+    Ptr a -> Ptr a -> Int -> a -> m ()+putIndexPtr ptr end i x = do+    let elemSize = sizeOf (undefined :: a)+        elemPtr = ptr `plusPtr` (elemSize * i)+    if i >= 0 && elemPtr `plusPtr` elemSize <= end+    then liftIO $ poke elemPtr x+    else invalidIndex "putIndexPtr" i++-- | /O(1)/ Write the given element at the given index in the array.+-- Performs in-place mutation of the array.+--+-- >>> putIndex arr ix val = Array.modifyIndex arr ix (const (val, ()))+-- >>> f = Array.putIndices+-- >>> putIndex arr ix val = Stream.fold (f arr) (Stream.fromPure (ix, val))+--+-- /Pre-release/+{-# INLINE putIndex #-}+putIndex :: (MonadIO m, Storable a) => Array a -> Int -> a -> m ()+putIndex arr i x =+    unsafeWithArrayContents (arrContents arr) (arrStart arr)+        $ \p -> putIndexPtr p (aEnd arr) i x++-- | Modify a given index of an array using a modifier function.+--+-- /Pre-release/+modifyIndexUnsafe :: forall m a b. (MonadIO m, Storable a) =>+    Array a -> Int -> (a -> (a, b)) -> m b+modifyIndexUnsafe Array{..} i f = do+    liftIO $ unsafeWithArrayContents arrContents arrStart $ \ptr -> do+        let elemSize = sizeOf (undefined :: a)+            elemPtr = ptr `plusPtr` (elemSize * i)+        assert (i >= 0 && elemPtr `plusPtr` elemSize <= aEnd) (return ())+        r <- peek elemPtr+        let (x, res) = f r+        poke elemPtr x+        return res++-- | Modify a given index of an array using a modifier function.+--+-- /Pre-release/+modifyIndex :: forall m a b. (MonadIO m, Storable a) =>+    Array a -> Int -> (a -> (a, b)) -> m b+modifyIndex Array{..} i f = do+    liftIO $ unsafeWithArrayContents arrContents arrStart $ \ptr -> do+        let elemSize = sizeOf (undefined :: a)+            elemPtr = ptr `plusPtr` (elemSize * i)+        if i >= 0 && elemPtr `plusPtr` elemSize <= aEnd+        then do+            r <- peek elemPtr+            let (x, res) = f r+            poke elemPtr x+            return res+        else invalidIndex "modifyIndex" i++-- | Modify the array indices generated by the supplied unfold.+--+-- /Pre-release/+modifyIndices :: -- forall m a b. (MonadIO m, Storable a) =>+    Unfold m (Array a) Int -> Array a -> (a -> a) -> m ()+modifyIndices = undefined++-- | Modify each element of an array using the supplied modifier function.+--+-- /Unimplemented/+modify :: -- forall m a b. (MonadIO m, Storable a) =>+    Array a -> (a -> a) -> m ()+modify = undefined++-- | Swap the elements at two indices.+--+-- /Pre-release/+swapIndices :: -- (MonadIO m, Storable a) =>+    Array a -> Int -> Int -> m ()+swapIndices = undefined++-------------------------------------------------------------------------------+-- Rounding+-------------------------------------------------------------------------------++-- XXX Should we use bitshifts in calculations or it gets optimized by the+-- compiler/processor itself?+--+-- | The page or block size used by the GHC allocator. Allocator allocates at+-- least a block and then allocates smaller allocations from within a block.+blockSize :: Int+blockSize = 4 * 1024++-- | Allocations larger than 'largeObjectThreshold' are in multiples of block+-- size and are always pinned. The space beyond the end of a large object up to+-- the end of the block is unused.+largeObjectThreshold :: Int+largeObjectThreshold = (blockSize * 8) `div` 10++-- | Round up an array larger than 'largeObjectThreshold' to use the whole+-- block.+{-# INLINE roundUpLargeArray #-}+roundUpLargeArray :: Int -> Int+roundUpLargeArray size =+    if size >= largeObjectThreshold+    then+        assert+            (blockSize /= 0 && ((blockSize .&. (blockSize - 1)) == 0))+            ((size + blockSize - 1) .&. negate blockSize)+    else size++{-+roundUpToPower2 :: Int -> Int+roundUpToPower2 = undefined+-}++-- | @allocBytesToBytes elem allocatedBytes@ returns the array size in bytes+-- such that the real allocation is less than or equal to @allocatedBytes@,+-- unless @allocatedBytes@ is less than the size of one array element in which+-- case it returns one element's size.+--+{-# INLINE allocBytesToBytes #-}+allocBytesToBytes :: forall a. Storable a => a -> Int -> Int+allocBytesToBytes _ n =+    max (arrayPayloadSize n) (sizeOf (undefined :: a))++-- | Given a 'Storable' type (unused first arg) and real allocation size+-- (including overhead), return how many elements of that type will completely+-- fit in it, returns at least 1.+--+{-# INLINE allocBytesToElemCount #-}+allocBytesToElemCount :: Storable a => a -> Int -> Int+allocBytesToElemCount x bytes =+    let n = bytesToElemCount x (allocBytesToBytes x bytes)+     in assert (n >= 1) n++-- | The default chunk size by which the array creation routines increase the+-- size of the array when the array is grown linearly.+arrayChunkBytes :: Int+arrayChunkBytes = 1024++-------------------------------------------------------------------------------+-- Snoc+-------------------------------------------------------------------------------++-- XXX We can possibly use a smallMutableByteArray to hold the start, end,+-- bound pointers. Or we can use the first 16 bytes of the allocation to store+-- the end, bound pointers. Using fully mutable handle will ensure that we do+-- not have multiple references to the same array of different lengths lying+-- around and potentially misused. In that case "snoc" need not return a new+-- array (snoc :: Array a -> a -> m ()), it will just modify the old reference.+-- The array length will be mutable.  This means the length function would also+-- be monadic.  Mutable arrays would behave more like files that grow in that+-- case.++-- | Snoc using a 'Ptr'. Low level reusable function.+--+-- /Internal/+{-# INLINE snocNewEnd #-}+snocNewEnd :: (MonadIO m, Storable a) => Ptr a -> Array a -> a -> m (Array a)+snocNewEnd newEnd arr@Array{..} x = liftIO $ do+    assert (newEnd <= aBound) (return ())+    poke aEnd x+    touch arrContents+    return $ arr {aEnd = newEnd}++-- | Really really unsafe, appends the element into the first array, may+-- cause silent data corruption or if you are lucky a segfault if the first+-- array does not have enough space to append the element.+--+-- /Internal/+{-# INLINE snocUnsafe #-}+snocUnsafe :: forall m a. (MonadIO m, Storable a) =>+    Array a -> a -> m (Array a)+snocUnsafe arr@Array{..} =+    snocNewEnd (aEnd `plusPtr` sizeOf (undefined :: a)) arr++-- | Like 'snoc' but does not reallocate when pre-allocated array capacity+-- becomes full.+--+-- /Internal/+{-# INLINE snocMay #-}+snocMay :: forall m a. (MonadIO m, Storable a) =>+    Array a -> a -> m (Maybe (Array a))+snocMay arr@Array{..} x = liftIO $ do+    let newEnd = aEnd `plusPtr` sizeOf (undefined :: a)+    if newEnd <= aBound+    then Just <$> snocNewEnd newEnd arr x+    else return Nothing++reallocWith :: forall m a. (MonadIO m , Storable a) =>+       String+    -> (Int -> Int)+    -> Int+    -> Array a+    -> m (Array a)+reallocWith label sizer reqSize arr = do+    let oldSize = aEnd arr `minusPtr` arrStart arr+        newSize = sizer oldSize+        safeSize = max newSize (oldSize + reqSize)+        rounded = roundUpLargeArray safeSize+    assert (newSize >= oldSize + reqSize || error badSize) (return ())+    assert (rounded >= safeSize) (return ())+    realloc rounded arr++    where++    badSize = concat+        [ label+        , ": new array size is less than required size "+        , show reqSize+        , ". Please check the sizing function passed."+        ]++-- NOINLINE to move it out of the way and not pollute the instruction cache.+{-# NOINLINE snocWithRealloc #-}+snocWithRealloc :: forall m a. (MonadIO m, Storable a) =>+       (Int -> Int)+    -> Array a+    -> a+    -> m (Array a)+snocWithRealloc sizer arr x = do+    let elemSize = sizeOf (undefined :: a)+    arr1 <- liftIO $ reallocWith "snocWith" sizer elemSize arr+    snocUnsafe arr1 x++-- | @snocWith sizer arr elem@ mutates @arr@ to append @elem@. The length of+-- the array increases by 1.+--+-- If there is no reserved space available in @arr@ it is reallocated to a size+-- in bytes determined by the @sizer oldSizeBytes@ function, where+-- @oldSizeBytes@ is the original size of the array in bytes.+--+-- If the new array size is more than 'largeObjectThreshold' we automatically+-- round it up to 'blockSize'.+--+-- Note that the returned array may be a mutated version of the original array.+--+-- /Pre-release/+{-# INLINE snocWith #-}+snocWith :: forall m a. (MonadIO m, Storable a) =>+       (Int -> Int)+    -> Array a+    -> a+    -> m (Array a)+snocWith allocSize arr x = liftIO $ do+    let newEnd = aEnd arr `plusPtr` sizeOf (undefined :: a)+    if newEnd <= aBound arr+    then snocNewEnd newEnd arr x+    else snocWithRealloc allocSize arr x++-- | The array is mutated to append an additional element to it. If there+-- is no reserved space available in the array then it is reallocated to grow+-- it by 'arrayChunkBytes' rounded up to 'blockSize' when the size becomes more+-- than 'largeObjectThreshold'.+--+-- Note that the returned array may be a mutated version of the original array.+--+-- Performs O(n^2) copies to grow but is thrifty on memory.+--+-- /Pre-release/+{-# INLINE snocLinear #-}+snocLinear :: forall m a. (MonadIO m, Storable a) => Array a -> a -> m (Array a)+snocLinear = snocWith (+ allocBytesToBytes (undefined :: a) arrayChunkBytes)++-- XXX round it to next power of 2.+--+-- | The array is mutated to append an additional element to it. If there is no+-- reserved space available in the array then it is reallocated to double the+-- original size.+--+-- This is useful to reduce allocations when appending unknown number of+-- elements.+--+-- Note that the returned array may be a mutated version of the original array.+--+-- >>> snoc = Array.snocWith (* 2)+--+-- Performs O(n * log n) copies to grow, but is liberal with memory allocation.+--+-- /Pre-release/+{-# INLINE snoc #-}+snoc :: forall m a. (MonadIO m, Storable a) => Array a -> a -> m (Array a)+snoc = snocWith (* 2)++-------------------------------------------------------------------------------+-- Resizing+-------------------------------------------------------------------------------++-- | 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 -> Int -> Array a -> IO (Array a)+reallocAligned elemSize alignSize newSize Array{..} = do+    assert (aEnd <= aBound) (return ())+    let oldStart = arrStart+        oldSize = aEnd `minusPtr` oldStart+    assert (oldSize `mod` elemSize == 0) (return ())+    (contents, pNew) <- newAlignedArrayContents newSize alignSize+    let size = min oldSize newSize+    assert (size >= 0) (return ())+    assert (size `mod` elemSize == 0) (return ())+    memcpy (castPtr pNew) (castPtr oldStart) size+    touch arrContents+    return $ Array+        { arrStart = pNew+        , arrContents = contents+        , aEnd   = pNew `plusPtr` (size - (size `mod` elemSize))+        , aBound = pNew `plusPtr` newSize+        }++{-# INLINABLE realloc #-}+realloc :: forall m a. (MonadIO m, Storable a) => Int -> Array a -> m (Array a)+realloc i arr =+    liftIO+        $ reallocAligned+            (sizeOf (undefined :: a)) (alignment (undefined :: a)) i arr++-- | Change the reserved memory of the array so that it is enough to hold the+-- specified number of elements.  Nothing is done if the specified capacity is+-- less than the length of the array.+--+-- If the capacity is more than 'largeObjectThreshold' then it is rounded up to+-- the block size (4K).+--+-- /Unimplemented/+{-# INLINE resize #-}+resize :: -- (MonadIO m, Storable a) =>+    Int -> Array a -> m (Array a)+resize = undefined++-- | Like 'resize' but if the capacity is more than 'largeObjectThreshold' then+-- it is rounded up to the closest power of 2.+--+-- /Unimplemented/+{-# INLINE resizeExp #-}+resizeExp :: -- (MonadIO m, Storable a) =>+    Int -> Array a -> m (Array a)+resizeExp = undefined++-- | Resize the allocated memory to drop any reserved free space at the end of+-- the array and reallocate it to reduce wastage.+--+-- Up to 25% wastage is allowed to avoid reallocations.  If the capacity is+-- more than 'largeObjectThreshold' then free space up to the 'blockSize' is+-- retained.+--+-- /Pre-release/+{-# INLINE rightSize #-}+rightSize :: forall m a. (MonadIO m, Storable a) => Array a -> m (Array a)+rightSize arr@Array{..} = do+    assert (aEnd <= aBound) (return ())+    let start = arrStart+        len = aEnd `minusPtr` start+        capacity = aBound `minusPtr` start+        target = roundUpLargeArray len+        waste = aBound `minusPtr` aEnd+    assert (target >= len) (return ())+    assert (len `mod` sizeOf (undefined :: a) == 0) (return ())+    -- We trade off some wastage (25%) to avoid reallocations and copying.+    if target < capacity && len < 3 * waste+    then realloc target arr+    else return arr++-------------------------------------------------------------------------------+-- Reducing the length+-------------------------------------------------------------------------------++-- | Drop the last n elements of the array to reduce the length by n. The+-- capacity is reallocated using the user supplied function.+--+-- /Unimplemented/+{-# INLINE truncateWith #-}+truncateWith :: -- (MonadIO m, Storable a) =>+    Int -> (Int -> Int) -> Array a -> m (Array a)+truncateWith = undefined++-- | Drop the last n elements of the array to reduce the length by n.+--+-- The capacity is rounded to 1K or 4K if the length is more than the GHC large+-- block threshold.+--+-- /Unimplemented/+{-# INLINE truncate #-}+truncate :: -- (MonadIO m, Storable a) =>+    Int -> Array a -> m (Array a)+truncate = undefined++-- | Like 'truncate' but the capacity is rounded to the closest power of 2.+--+-- /Unimplemented/+{-# INLINE truncateExp #-}+truncateExp :: -- (MonadIO m, Storable a) =>+    Int -> Array a -> m (Array a)+truncateExp = undefined++-------------------------------------------------------------------------------+-- Random reads+-------------------------------------------------------------------------------++-- | Return the element at the specified index without checking the bounds.+--+-- Unsafe because it does not check the bounds of the array.+{-# INLINE_NORMAL getIndexUnsafe #-}+getIndexUnsafe :: forall m a. (MonadIO m, Storable a) => Array a -> Int -> m a+getIndexUnsafe Array {..} i =+    unsafeWithArrayContents arrContents arrStart $ \ptr -> do+        let elemSize = sizeOf (undefined :: a)+            elemPtr = ptr `plusPtr` (elemSize * i)+        assert (i >= 0 && elemPtr `plusPtr` elemSize <= aEnd) (return ())+        liftIO $ peek elemPtr++{-# INLINE getIndexPtr #-}+getIndexPtr :: forall m a. (MonadIO m, Storable a) =>+    Ptr a -> Ptr a -> Int -> m a+getIndexPtr ptr end i = do+    let elemSize = sizeOf (undefined :: a)+        elemPtr = ptr `plusPtr` (elemSize * i)+    if i >= 0 && elemPtr `plusPtr` elemSize <= end+    then liftIO $ peek elemPtr+    else invalidIndex "getIndexPtr" i++-- | /O(1)/ Lookup the element at the given index. Index starts from 0.+--+{-# INLINE getIndex #-}+getIndex :: (MonadIO m, Storable a) => Array a -> Int -> m a+getIndex arr i =+    unsafeWithArrayContents (arrContents arr) (arrStart arr)+        $ \p -> getIndexPtr p (aEnd arr) i++{-# INLINE getIndexPtrRev #-}+getIndexPtrRev :: forall m a. (MonadIO m, Storable a) =>+    Ptr a -> Ptr a -> Int -> m a+getIndexPtrRev ptr end i = do+    let elemSize = sizeOf (undefined :: a)+        elemPtr = end `plusPtr` negate (elemSize * (i + 1))+    if i >= 0 && elemPtr >= ptr+    then liftIO $ peek elemPtr+    else invalidIndex "getIndexPtrRev" i++-- | /O(1)/ Lookup the element at the given index from the end of the array.+-- Index starts from 0.+--+-- Slightly faster than computing the forward index and using getIndex.+--+{-# INLINE getIndexRev #-}+getIndexRev :: (MonadIO m, Storable a) => Array a -> Int -> m a+getIndexRev arr i =+    unsafeWithArrayContents (arrContents arr) (arrStart arr)+        $ \p -> getIndexPtrRev p (aEnd arr) i++data GetIndicesState contents start end st =+    GetIndicesState contents start end st++-- | Given an unfold that generates array indices, read the elements on those+-- indices from the supplied Array. An error is thrown if an index is out of+-- bounds.+--+-- /Pre-release/+{-# INLINE getIndices #-}+getIndices :: (MonadIO m, Storable a) =>+    Unfold m (Array a) Int -> Unfold m (Array a) a+getIndices (Unfold stepi injecti) = Unfold step inject++    where++    inject arr@(Array contents start (Ptr end) _) = do+        st <- injecti arr+        return $ GetIndicesState contents start (Ptr end) st++    {-# INLINE_LATE step #-}+    step (GetIndicesState contents start end st) = do+        r <- stepi st+        case r of+            D.Yield i s -> do+                x <- liftIO $ getIndexPtr start end i+                return $ D.Yield x (GetIndicesState contents start end s)+            D.Skip s -> return $ D.Skip (GetIndicesState contents start end s)+            D.Stop -> do+                liftIO $ touch contents+                return D.Stop++-------------------------------------------------------------------------------+-- Subarrays+-------------------------------------------------------------------------------++-- XXX We can also get immutable slices.++-- | /O(1)/ Slice an array in constant time.+--+-- Unsafe: The bounds of the slice are not checked.+--+-- /Unsafe/+--+-- /Pre-release/+{-# INLINE getSliceUnsafe #-}+getSliceUnsafe :: forall a. Storable a+    => Int -- ^ from index+    -> Int -- ^ length of the slice+    -> Array a+    -> Array a+getSliceUnsafe index len (Array contents start e _) =+    let size = sizeOf (undefined :: a)+        fp1 = start `plusPtr` (index * size)+        end = fp1 `plusPtr` (len * size)+     in assert+            (index >= 0 && len >= 0 && end <= e)+            (Array contents fp1 end end)++-- | /O(1)/ Slice an array in constant time. Throws an error if the slice+-- extends out of the array bounds.+--+-- /Pre-release/+{-# INLINE getSlice #-}+getSlice :: forall a. Storable a =>+       Int -- ^ from index+    -> Int -- ^ length of the slice+    -> Array a+    -> Array a+getSlice index len (Array contents start e _) =+    let size = sizeOf (undefined :: a)+        fp1 = start `plusPtr` (index * size)+        end = fp1 `plusPtr` (len * size)+     in if index >= 0 && len >= 0 && end <= e+        then Array contents fp1 end end+        else error+                $ "getSlice: invalid slice, index "+                ++ show index ++ " length " ++ show len++-------------------------------------------------------------------------------+-- In-place mutation algorithms+-------------------------------------------------------------------------------++-- XXX consider the bulk update/accumulation/permutation APIs from vector.++-- | You may not need to reverse an array because you can consume it in reverse+-- using 'readRev'. To reverse large arrays you can read in reverse and write+-- to another array. However, in-place reverse can be useful to take adavantage+-- of cache locality and when you do not want to allocate additional memory.+--+-- /Unimplemented/+{-# INLINE reverse #-}+reverse :: Array a -> m Bool+reverse = undefined++-- | Generate the next permutation of the sequence, returns False if this is+-- the last permutation.+--+-- /Unimplemented/+{-# INLINE permute #-}+permute :: Array a -> m Bool+permute = undefined++-- | Partition an array into two halves using a partitioning predicate. The+-- first half retains values where the predicate is 'False' and the second half+-- retains values where the predicate is 'True'.+--+-- /Unimplemented/+{-# INLINE partitionBy #-}+partitionBy :: (a -> Bool) -> Array a -> m (Array a, Array a)+partitionBy = 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.+--+-- /Unimplemented/+{-# INLINE shuffleBy #-}+shuffleBy :: (a -> a -> m Bool) -> Array a -> Array a -> m (Array a)+shuffleBy = undefined++-- XXX we can also make the folds partial by stopping at a certain level.+--+-- | @divideBy level partition array@  performs a top down hierarchical+-- recursive partitioning fold of items in the container using the given+-- function as the partition function.  Level indicates the level in the tree+-- where the fold would stop.+--+-- This performs a quick sort if the partition function is+-- 'partitionBy (< pivot)'.+--+-- /Unimplemented/+{-# INLINABLE divideBy #-}+divideBy ::+    Int -> (Array a -> Array a -> m (Array a)) -> Array a -> m (Array a)+divideBy = undefined++-- | @mergeBy level merge array@ performs a pairwise bottom up fold recursively+-- merging the pairs using the supplied merge function. Level indicates the+-- level in the tree where the fold would stop.+--+-- This performs a random shuffle if the shuffle function is random.  If we+-- stop at level 0 and repeatedly apply the function then we can do a bubble+-- sort.+--+-- /Unimplemented/+mergeBy :: Int -> (Array a -> Array a -> m (Array a)) -> Array a -> m (Array a)+mergeBy = undefined++-------------------------------------------------------------------------------+-- Size+-------------------------------------------------------------------------------++-- | /O(1)/ Get the byte length of the array.+--+-- @since 0.7.0+{-# INLINE byteLength #-}+byteLength :: Array a -> Int+byteLength Array{..} =+    let len = aEnd `minusPtr` arrStart+    in assert (len >= 0) len++-- Note: try to avoid the use of length in performance sensitive internal+-- routines as it involves a costly 'div' operation. Instead use the end ptr+-- int he array to check the bounds etc.+--+-- | /O(1)/ Get the length of the array i.e. the number of elements in the+-- array.+--+-- Note that 'byteLength' is less expensive than this operation, as 'length'+-- involves a costly division operation.+--+-- @since 0.7.0+{-# INLINE length #-}+length :: forall a. Storable a => Array a -> Int+length arr =+    let elemSize = sizeOf (undefined :: a)+        blen = byteLength arr+     in assert (blen `mod` elemSize == 0) (blen `div` elemSize)++-- | Get the total capacity of an array. An array may have space reserved+-- beyond the current used length of the array.+--+-- /Pre-release/+{-# INLINE byteCapacity #-}+byteCapacity :: Array a -> Int+byteCapacity Array{..} =+    let len = aBound `minusPtr` arrStart+    in assert (len >= 0) len++-- | The remaining capacity in the array for appending more elements without+-- reallocation.+--+-- /Pre-release/+{-# INLINE bytesFree #-}+bytesFree :: Array a -> Int+bytesFree Array{..} =+    let n = aBound `minusPtr` aEnd+    in assert (n >= 0) n++-------------------------------------------------------------------------------+-- Streams of arrays - Creation+-------------------------------------------------------------------------------++data GroupState s contents start end bound+    = GroupStart s+    | GroupBuffer s contents start end bound+    | GroupYield+        contents start end bound (GroupState s contents start end bound)+    | GroupFinish++-- | @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.arraysOf: "+                    ++ "the size of arrays [" ++ show n+                    ++ "] must be a natural number"+        Array contents start end bound <- liftIO $ newArray n+        return $ D.Skip (GroupBuffer st contents start end bound)++    step' gst (GroupBuffer st contents start end bound) = do+        r <- step (adaptState gst) st+        case r of+            D.Yield x s -> do+                liftIO $ poke end x >> touch contents+                let end' = end `plusPtr` sizeOf (undefined :: a)+                return $+                    if end' >= bound+                    then D.Skip+                            (GroupYield+                                contents start end' bound (GroupStart s))+                    else D.Skip (GroupBuffer s contents start end' bound)+            D.Skip s ->+                return $ D.Skip (GroupBuffer s contents start end bound)+            D.Stop ->+                return+                    $ D.Skip (GroupYield contents start end bound GroupFinish)++    step' _ (GroupYield contents start end bound next) =+        return $ D.Yield (Array contents start end bound) next++    step' _ GroupFinish = return D.Stop++-- XXX buffer to a list instead?+-- | Buffer the stream into arrays in memory.+{-# INLINE arrayStreamKFromStreamD #-}+arrayStreamKFromStreamD :: forall m a. (MonadIO m, Storable a) =>+    D.Stream m a -> m (K.Stream m (Array a))+arrayStreamKFromStreamD =+    let n = allocBytesToElemCount (undefined :: a) defaultChunkSize+     in D.foldr K.cons K.nil . arraysOf n++-------------------------------------------------------------------------------+-- Streams of arrays - Flattening+-------------------------------------------------------------------------------++data FlattenState s contents a =+      OuterLoop s+    | InnerLoop s contents !(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 ->+                D.Skip (InnerLoop s arrContents arrStart aEnd)+            D.Skip s -> D.Skip (OuterLoop s)+            D.Stop -> D.Stop++    step' _ (InnerLoop st _ p end) | assert (p <= end) (p == end) =+        return $ D.Skip $ OuterLoop st++    step' _ (InnerLoop st contents p end) = do+        x <- liftIO $ do+                    r <- peek p+                    touch contents+                    return r+        return $ D.Yield x (InnerLoop st contents+                            (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))+                 in D.Skip (InnerLoop s arrContents p arrStart)+            D.Skip s -> D.Skip (OuterLoop s)+            D.Stop -> D.Stop++    step' _ (InnerLoop st _ p start) | p < start =+        return $ D.Skip $ OuterLoop st++    step' _ (InnerLoop st contents p start) = do+        x <- liftIO $ do+                    r <- peek p+                    touch contents+                    return r+        let cur = p `plusPtr` negate (sizeOf (undefined :: a))+        return $ D.Yield x (InnerLoop st contents cur start)++-------------------------------------------------------------------------------+-- Unfolds+-------------------------------------------------------------------------------++data ReadUState a = ReadUState+    UNPACKIF !ArrayContents  -- contents+    !(Ptr a)           -- end address+    !(Ptr a)           -- current address++toReadUState :: Array a -> ReadUState a+toReadUState (Array contents start end _) = ReadUState contents end start++-- | Resumable unfold of an array.+--+{-# INLINE_NORMAL producer #-}+producer :: forall m a. (MonadIO m, Storable a) => Producer m (Array a) a+producer = Producer step (return . toReadUState) extract+    where++    {-# INLINE_LATE step #-}+    step (ReadUState contents end cur)+        | assert (cur <= end) (cur == end) = do+            liftIO $ touch contents+            return D.Stop+    step (ReadUState contents end cur) = do+            !x <- liftIO $ peek cur+            let cur1 = cur `plusPtr` sizeOf (undefined :: a)+            return $ D.Yield x (ReadUState contents end cur1)++    extract (ReadUState contents end cur) = return $ Array contents cur end end++-- | Unfold an array into a stream.+--+-- @since 0.7.0+{-# INLINE_NORMAL read #-}+read :: forall m a. (MonadIO 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. (MonadIO m, Storable a) => Unfold m (Array a) a+readRev = Unfold step inject+    where++    inject (Array contents start end _) =+        let p = end `plusPtr` negate (sizeOf (undefined :: a))+         in return $ ReadUState contents start p++    {-# INLINE_LATE step #-}+    step (ReadUState contents start p) | p < start = do+        liftIO $ touch contents+        return D.Stop+    step (ReadUState contents start p) = do+            x <- liftIO $ peek p+            let cur = p `plusPtr` negate (sizeOf (undefined :: a))+            return $ D.Yield x (ReadUState contents start cur)++-------------------------------------------------------------------------------+-- 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 arrStart+    where++    go p | assert (p <= aEnd) (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.+        -- XXX+        let !x = unsafeInlineIO $ do+                    r <- peek p+                    touch arrContents+                    return r+        in c x (go (p `plusPtr` sizeOf (undefined :: a)))+-}++-- XXX Monadic foldr/build fusion?+-- Reference: https://www.researchgate.net/publication/220676509_Monadic_augment_and_generalised_short_cut_fusion+-- | Convert an 'Array' into a list.+--+-- @since 0.7.0+{-# INLINE toList #-}+toList :: forall m a. (MonadIO m, Storable a) => Array a -> m [a]+toList Array{..} = liftIO $ go arrStart+    where++    go p | assert (p <= aEnd) (p == aEnd) = return []+    go p = do+        x <- peek p+        touch arrContents+        (:) x <$> go (p `plusPtr` sizeOf (undefined :: a))++-- | 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. (MonadIO m, Storable a) => Array a -> D.Stream m a+toStreamD Array{..} = D.Stream step arrStart++    where++    {-# INLINE_LATE step #-}+    step _ p | assert (p <= aEnd) (p == aEnd) = return D.Stop+    step _ p = liftIO $ do+        r <- peek p+        touch arrContents+        return $ D.Yield r (p `plusPtr` sizeOf (undefined :: a))++{-# INLINE toStreamK #-}+toStreamK :: forall m a. (MonadIO m, Storable a) => Array a -> K.Stream m a+toStreamK Array{..} = go arrStart++    where++    go p | assert (p <= aEnd) (p == aEnd) = K.nil+         | otherwise =+        let elemM = do+              r <- peek p+              touch arrContents+              return r+        in liftIO elemM `K.consM` 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. (MonadIO 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 < arrStart = return D.Stop+    step _ p = liftIO $ do+        r <- peek p+        touch arrContents+        return $ D.Yield r (p `plusPtr` negate (sizeOf (undefined :: a)))++{-# INLINE toStreamKRev #-}+toStreamKRev :: forall m a. (MonadIO m, Storable a) => Array a -> K.Stream m a+toStreamKRev Array {..} =+    let p = aEnd `plusPtr` negate (sizeOf (undefined :: a))+    in go p++    where++    go p | p < arrStart = K.nil+         | otherwise =+        let elemM = do+              r <- peek p+              touch arrContents+              return r+        in liftIO elemM `K.consM` go (p `plusPtr` negate (sizeOf (undefined :: a)))++-------------------------------------------------------------------------------+-- Folding+-------------------------------------------------------------------------------++-- XXX Need something like "Array m a" enforcing monadic action to avoid the+-- possibility of such APIs.+--+-- | Strict left fold of an array.+{-# INLINE_NORMAL foldl' #-}+foldl' :: (MonadIO m, Storable a) => (b -> a -> b) -> b -> Array a -> m b+foldl' f z arr = D.foldl' f z $ toStreamD arr++-- | Right fold of an array.+{-# INLINE_NORMAL foldr #-}+foldr :: (MonadIO m, Storable a) => (a -> b -> b) -> b -> Array a -> m b+foldr f z arr = D.foldr f z $ toStreamD arr++-------------------------------------------------------------------------------+-- Folds+-------------------------------------------------------------------------------++data ArrayUnsafe a = ArrayUnsafe+    UNPACKIF !ArrayContents  -- contents+    {-# UNPACK #-} !(Ptr a)  -- start address+    {-# UNPACK #-} !(Ptr a)  -- first unused address++toArrayUnsafe :: Array a -> ArrayUnsafe a+toArrayUnsafe (Array contents start end _) =+    ArrayUnsafe contents start end++fromArrayUnsafe ::+#ifdef DEVBUILD+    Storable a =>+#endif+    ArrayUnsafe a -> Array a+fromArrayUnsafe (ArrayUnsafe contents start end) =+         Array contents start end end++-- Note: Arrays may be allocated with a specific alignment at the beginning of+-- the array. If you need to maintain that alignment on reallocations then you+-- can resize the array manually before append, using an aligned resize+-- operation.++-- XXX Keep the bound intact to not lose any free space? Perf impact?++-- | Append up to @n@ input items to the supplied array.+--+-- Unsafe: Do not drive the fold beyond @n@ elements, it will lead to memory+-- corruption or segfault.+--+-- Any free space left in the array after appending @n@ elements is lost.+--+-- /Internal/+{-# INLINE_NORMAL appendNUnsafe #-}+appendNUnsafe :: forall m a. (MonadIO m, Storable a) =>+       m (Array a)+    -> Int+    -> Fold m a (Array a)+appendNUnsafe action n =+    fmap fromArrayUnsafe $ FL.foldlM' step initial++    where++    initial = do+        assert (n >= 0) (return ())+        arr@(Array _ _ end bound) <- action+        let free = bound `minusPtr` end+            elemSize = sizeOf (undefined :: a)+            needed = n * elemSize+        -- XXX We can also reallocate if the array has too much free space,+        -- otherwise we lose that space.+        arr1 <-+            if free < needed+            then noinline reallocWith "appendNUnsafeWith" (+ needed) needed arr+            else return arr+        return $ toArrayUnsafe arr1++    step (ArrayUnsafe contents start end) x = do+        liftIO $ poke end x >> touch contents+        let end1 = end `plusPtr` sizeOf (undefined :: a)+        return $ ArrayUnsafe contents start end1++-- | Append @n@ elements to an existing array. Any free space left in the array+-- after appending @n@ elements is lost.+--+-- >>> appendN initial n = Fold.take n (Array.appendNUnsafe initial n)+--+-- /Pre-release/+{-# INLINE_NORMAL appendN #-}+appendN :: forall m a. (MonadIO m, Storable a) =>+    m (Array a) -> Int -> Fold m a (Array a)+appendN initial n = FL.take n (appendNUnsafe initial n)++-- | @appendWith realloc action@ mutates the array generated by @action@ to+-- append the input stream. If there is no reserved space available in the+-- array it is reallocated to a size in bytes  determined by @realloc oldSize@,+-- where @oldSize@ is the current size of the array in bytes.+--+-- Note that the returned array may be a mutated version of original array.+--+-- >>> appendWith sizer = Fold.foldlM' (Array.snocWith sizer)+--+-- /Pre-release/+{-# INLINE appendWith #-}+appendWith :: forall m a. (MonadIO m, Storable a) =>+    (Int -> Int) -> m (Array a) -> Fold m a (Array a)+appendWith sizer = FL.foldlM' (snocWith sizer)++-- | @append action@ mutates the array generated by @action@ to append the+-- input stream. If there is no reserved space available in the array it is+-- reallocated to double the size.+--+-- Note that the returned array may be a mutated version of original array.+--+-- >>> append = Array.appendWith (* 2)+--+-- /Pre-release/+{-# INLINE append #-}+append :: forall m a. (MonadIO m, Storable a) =>+    m (Array a) -> Fold m a (Array a)+append = appendWith (* 2)++-- | @writeNWith alloc n@ folds a maximum of @n@ elements into an array+-- allocated using the @alloc@ function.+--+-- >>> writeNWith alloc n = Fold.take n (Array.writeNWithUnsafe alloc n)+-- >>> writeNWith alloc n = Array.appendN (alloc n) n+--+{-# INLINE_NORMAL writeNWith #-}+writeNWith :: forall m a. (MonadIO m, Storable a)+    => (Int -> m (Array a)) -> Int -> Fold m a (Array a)+writeNWith alloc n = FL.take n (writeNWithUnsafe alloc n)++-- | @writeN n@ folds a maximum of @n@ elements from the input stream to an+-- 'Array'.+--+-- >>> writeN = Array.writeNWith Array.newArray+-- >>> writeN n = Fold.take n (Array.writeNUnsafe n)+-- >>> writeN n = Array.appendN (Array.newArray n) n+--+-- @since 0.7.0+{-# INLINE_NORMAL writeN #-}+writeN :: forall m a. (MonadIO m, Storable a) => Int -> Fold m a (Array a)+writeN = writeNWith newArray++-- | @writeNAligned align n@ folds a maximum of @n@ elements from the input+-- stream to an 'Array' aligned to the given size.+--+-- >>> writeNAligned align = Array.writeNWith (Array.newArrayAligned align)+-- >>> writeNAligned align n = Array.appendN (Array.newArrayAligned align n) n+--+-- /Pre-release/+--+{-# INLINE_NORMAL writeNAligned #-}+writeNAligned :: forall m a. (MonadIO m, Storable a)+    => Int -> Int -> Fold m a (Array a)+writeNAligned align = writeNWith (newArrayAligned align)++-- | @writeNAlignedUnmanaged align n@ folds a maximum of @n@ elements from the+-- input stream to an 'Array' whose starting address is aligned to @align@+-- bytes and is allocated using unmanaged memory (never freed).  This could be+-- useful to allocate memory that we need to allocate only once in the lifetime+-- of the program.+--+-- >>> f = Array.newArrayAlignedUnmanaged+-- >>> writeNAlignedUnmanaged a = Array.writeNWith (f a)+-- >>> writeNAlignedUnmanaged a n = Array.appendN (f a n) n+--+-- /Pre-release/+--+{-# INLINE_NORMAL writeNAlignedUnmanaged #-}+writeNAlignedUnmanaged :: forall m a. (MonadIO m, Storable a)+    => Int -> Int -> Fold m a (Array a)+writeNAlignedUnmanaged align = writeNWith (newArrayAlignedUnmanaged align)++-- XXX We can carry bound as well in the state to make sure we do not lose the+-- remaining capacity. Need to check perf impact.+--+-- | Like 'writeNUnsafe' but takes a new array allocator @alloc size@ function+-- as argument.+--+-- >>> writeNWithUnsafe alloc n = Array.appendNUnsafe (alloc n) n+--+-- /Pre-release/+{-# INLINE_NORMAL writeNWithUnsafe #-}+writeNWithUnsafe :: forall m a. (MonadIO m, Storable a)+    => (Int -> m (Array a)) -> Int -> Fold m a (Array a)+writeNWithUnsafe alloc n = Fold step initial (return . fromArrayUnsafe)++    where++    initial = FL.Partial . toArrayUnsafe <$> alloc (max n 0)++    step (ArrayUnsafe contents start end) x = do+        liftIO $ poke end x >> touch contents+        return+          $ FL.Partial+          $ ArrayUnsafe contents start (end `plusPtr` sizeOf (undefined :: a))++-- | Like 'writeN' but does not check the array bounds when writing. The fold+-- driver must not call the step function more than 'n' times otherwise it will+-- corrupt the memory and crash. This function exists mainly because any+-- conditional in the step function blocks fusion causing 10x performance+-- slowdown.+--+-- >>> writeNUnsafe = Array.writeNWithUnsafe Array.newArray+--+-- @since 0.7.0+{-# INLINE_NORMAL writeNUnsafe #-}+writeNUnsafe :: forall m a. (MonadIO m, Storable a)+    => Int -> Fold m a (Array a)+writeNUnsafe = writeNWithUnsafe newArray++-- XXX Buffer to a list instead?+--+-- | Buffer a stream into a stream of arrays.+--+-- >>> writeChunks n = Fold.many (Array.writeN n) Fold.toStreamK+--+-- Breaking an array into an array stream  can be useful to consume a large+-- array sequentially such that memory of the array is released incrementatlly.+--+-- See also: 'arrayStreamKFromStreamD'.+--+-- /Unimplemented/+--+{-# INLINE_NORMAL writeChunks #-}+writeChunks :: (MonadIO m, Storable a) =>+    Int -> Fold m a (K.Stream n (Array a))+writeChunks n = FL.many (writeN n) FL.toStreamK++-- XXX Compare writeWith with fromStreamD which uses an array of streams+-- implementation. We can write this using writeChunks above if that is faster.+-- If writeWith is faster then we should use that to implement+-- fromStreamD.+--+-- XXX The realloc based implementation needs to make one extra copy if we use+-- shrinkToFit.  On the other hand, the stream of arrays implementation may+-- buffer the array chunk pointers in memory but it does not have to shrink as+-- we know the exact size in the end. However, memory copying does not seem to+-- be as expensive as the allocations. Therefore, we need to reduce the number+-- of allocations instead. Also, the size of allocations matters, right sizing+-- an allocation even at the cost of copying sems to help.  Should be measured+-- on a big stream with heavy calls to toArray to see the effect.+--+-- XXX check if GHC's memory allocator is efficient enough. We can try the C+-- malloc to compare against.++-- | @writeWith minCount@ folds the whole input to a single array. The array+-- starts at a size big enough to hold minCount elements, the size is doubled+-- every time the array needs to be grown.+--+-- /Caution! Do not use this on infinite streams./+--+-- >>> f n = Array.appendWith (* 2) (Array.newArray n)+-- >>> writeWith n = Fold.rmapM Array.rightSize (f n)+-- >>> writeWith n = Fold.rmapM Array.fromArrayStreamK (Array.writeChunks n)+--+-- /Pre-release/+{-# INLINE_NORMAL writeWith #-}+writeWith :: forall m a. (MonadIO m, Storable a)+    => Int -> Fold m a (Array a)+-- writeWith n = FL.rmapM rightSize $ appendWith (* 2) (newArray n)+writeWith elemCount =+    FL.rmapM extract $ FL.foldlM' step initial++    where++    insertElem (Array contents start end bound) x = do+        liftIO $ poke end x+        let end1 = end `plusPtr` sizeOf (undefined :: a)+        return $ Array contents start end1 bound++    initial = do+        when (elemCount < 0) $ error "writeWith: elemCount is negative"+        liftIO $ newArrayAligned (alignment (undefined :: a)) elemCount+    step arr@(Array _ start end bound) x+        | end `plusPtr` sizeOf (undefined :: a) > bound = do+        let oldSize = end `minusPtr` start+            newSize = max (oldSize * 2) 1+        arr1 <-+            liftIO+                $ reallocAligned+                    (sizeOf (undefined :: a))+                    (alignment (undefined :: a))+                    newSize+                    arr+        insertElem arr1 x+    step arr x = insertElem arr x+    extract = liftIO . rightSize++-- | Fold the whole input to a single array.+--+-- Same as 'writeWith' using an initial array size of 'arrayChunkBytes' bytes+-- rounded up to the element size.+--+-- /Caution! Do not use this on infinite streams./+--+-- @since 0.7.0+{-# INLINE write #-}+write :: forall m a. (MonadIO m, Storable a) => Fold m a (Array a)+write = writeWith (allocBytesToElemCount (undefined :: a) arrayChunkBytes)++-------------------------------------------------------------------------------+-- construct from streams, known size+-------------------------------------------------------------------------------++-- | Use the 'writeN' fold instead.+--+-- >>> fromStreamDN n = StreamD.fold (Array.writeN n)+--+{-# INLINE_NORMAL fromStreamDN #-}+fromStreamDN :: forall m a. (MonadIO m, Storable a)+    => Int -> D.Stream m a -> m (Array a)+-- fromStreamDN n = D.fold (writeN n)+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 :: (MonadIO m, Storable a) => Int -> [a] -> m (Array a)+fromListN n xs = fromStreamDN n $ D.fromList xs++-------------------------------------------------------------------------------+-- convert stream to a single array+-------------------------------------------------------------------------------++{-# INLINE arrayStreamKLength #-}+arrayStreamKLength :: (Monad m, Storable a) => K.Stream m (Array a) -> m Int+arrayStreamKLength as = K.foldl' (+) 0 (K.map length as)++-- | Convert an array stream to an array. Note that this requires peak memory+-- that is double the size of the array stream.+--+{-# INLINE fromArrayStreamK #-}+fromArrayStreamK :: (Storable a, MonadIO m) =>+    K.Stream m (Array a) -> m (Array a)+fromArrayStreamK as = do+    len <- arrayStreamKLength as+    fromStreamDN len $ D.unfoldMany read $ D.fromStreamK as++-- CAUTION: a very large number (millions) of arrays can degrade performance+-- due to GC overhead because we need to buffer the arrays before we flatten+-- all the arrays.+--+-- XXX Compare if this is faster or "fold write".+--+-- | We could take the approach of doubling the memory allocation on each+-- overflow. This would result in more or less the same amount of copying as in+-- the chunking approach. However, if we have to shrink in the end then it may+-- result in an extra copy of the entire data.+--+-- >>> fromStreamD = StreamD.fold Array.write+--+{-# INLINE fromStreamD #-}+fromStreamD :: (MonadIO m, Storable a) => D.Stream m a -> m (Array a)+fromStreamD m = arrayStreamKFromStreamD m >>= fromArrayStreamK++-- | Create an 'Array' from a list. The list must be of finite size.+--+-- @since 0.7.0+{-# INLINABLE fromList #-}+fromList :: (MonadIO m, Storable a) => [a] -> m (Array a)+fromList xs = fromStreamD $ D.fromList xs++-------------------------------------------------------------------------------+-- Combining+-------------------------------------------------------------------------------++-- | Copy two arrays into a newly allocated array.+{-# INLINE spliceCopy #-}+spliceCopy :: (MonadIO m, Storable a) => Array a -> Array a -> m (Array a)+spliceCopy arr1 arr2 = do+    let src1 = arrStart arr1+        src2 = arrStart arr2+        len1 = aEnd arr1 `minusPtr` src1+        len2 = aEnd arr2 `minusPtr` src2++    arr <- liftIO $ newArray (len1 + len2)+    let dst = arrStart arr++    -- XXX Should we use copyMutableByteArray# instead? Is there an overhead to+    -- ccall?+    liftIO $ do+        memcpy (castPtr dst) (castPtr src1) len1+        touch (arrContents arr1)+        memcpy (castPtr (dst `plusPtr` len1)) (castPtr src2) len2+        touch (arrContents arr2)+    return arr { aEnd = dst `plusPtr` (len1 + len2) }++-- | Really really unsafe, appends the second array into the first array. If+-- the first array does not have enough space it may cause silent data+-- corruption or if you are lucky a segfault.+{-# INLINE spliceUnsafe #-}+spliceUnsafe :: MonadIO m => Array a -> (Array a, Int) -> m (Array a)+spliceUnsafe dst (src, srcLen) =+    liftIO $ do+         let psrc = arrStart src+         let pdst = aEnd dst+         assert (pdst `plusPtr` srcLen <= aBound dst) (return ())+         memcpy (castPtr pdst) (castPtr psrc) srcLen+         touch (arrContents src)+         touch (arrContents dst)+         return $ dst {aEnd = pdst `plusPtr` srcLen}++-- | @spliceWith sizer dst src@ mutates @dst@ to append @src@. If there is no+-- reserved space available in @dst@ it is reallocated to a size determined by+-- the @sizer dstBytesn srcBytes@ function, where @dstBytes@ is the size of the+-- first array and @srcBytes@ is the size of the second array, in bytes.+--+-- Note that the returned array may be a mutated version of first array.+--+-- /Pre-release/+{-# INLINE spliceWith #-}+spliceWith :: forall m a. (MonadIO m, Storable a) =>+    (Int -> Int -> Int) -> Array a -> Array a -> m (Array a)+spliceWith sizer dst@(Array _ start end bound) src = do+{-+    let f = appendWith (`sizer` byteLength src) (return dst)+     in D.fold f (toStreamD src)+-}+    assert (end <= bound) (return ())+    let srcLen = aEnd src `minusPtr` arrStart src++    dst1 <-+        if end `plusPtr` srcLen >= bound+        then do+            let oldSize = end `minusPtr` start+                newSize = sizer oldSize srcLen+            when (newSize < oldSize + srcLen)+                $ error+                    $ "splice: newSize is less than the total size "+                    ++ "of arrays being appended. Please check the "+                    ++ "newSize function passed."+            liftIO $ realloc newSize dst+        else return dst+    spliceUnsafe dst1 (src, srcLen)++-- | The first array is mutated to append the second array. If there is no+-- reserved space available in the first array a new allocation of exact+-- required size is done.+--+-- Note that the returned array may be a mutated version of first array.+--+-- >>> splice = Array.spliceWith (+)+--+-- /Pre-release/+{-# INLINE splice #-}+splice :: (MonadIO m, Storable a) => Array a -> Array a -> m (Array a)+splice = spliceWith (+)++-- | Like 'append' but the growth of the array is exponential. Whenever a new+-- allocation is required the previous array size is at least doubled.+--+-- This is useful to reduce allocations when folding many arrays together.+--+-- Note that the returned array may be a mutated version of first array.+--+-- >>> spliceExp = Array.spliceWith (\l1 l2 -> max (l1 * 2) (l1 + l2))+--+-- /Pre-release/+{-# INLINE spliceExp #-}+spliceExp :: (MonadIO m, Storable a) => Array a -> Array a -> m (Array a)+spliceExp = spliceWith (\l1 l2 -> max (l1 * 2) (l1 + l2))++-------------------------------------------------------------------------------+-- 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 = arrStart+    loc <- c_memchr p sep (fromIntegral $ aEnd `minusPtr` p)+    return $+        if loc == nullPtr+        then (arr, Nothing)+        else+            ( Array+                { arrContents = arrContents+                , arrStart = arrStart+                , aEnd = loc+                , aBound = loc+                }+            , Just $ Array+                    { arrContents = arrContents+                    , arrStart = arrStart `plusPtr` (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 = arrStart `plusPtr` off+                in ( Array+                  { arrContents = arrContents+                  , arrStart = arrStart+                  , aEnd = p+                  , aBound = p+                  }+                , Array+                  { arrContents = arrContents+                  , arrStart = arrStart `plusPtr` off+                  , aEnd = aEnd+                  , aBound = aBound+                  }+                )++-------------------------------------------------------------------------------+-- Casting+-------------------------------------------------------------------------------++-- | Cast an array having elements of type @a@ into an array having elements of+-- type @b@. The array size must be a multiple of the size of type @b@+-- otherwise accessing the last element of the array may result into a crash or+-- a random value.+--+-- /Pre-release/+--+castUnsafe ::+#ifdef DEVBUILD+    Storable b =>+#endif+    Array a -> Array b+castUnsafe (Array contents start end bound) =+    Array contents (castPtr start) (castPtr end) (castPtr bound)++-- | Cast an @Array a@ into an @Array Word8@.+--+-- /Pre-release/+--+asBytes :: Array a -> Array Word8+asBytes = castUnsafe++-- | Cast an array having elements of type @a@ into an array having elements of+-- type @b@. The length of the array should be a multiple of the size of the+-- target element otherwise 'Nothing' is returned.+--+-- /Pre-release/+--+cast :: forall a b. Storable b => Array a -> Maybe (Array b)+cast arr =+    let len = byteLength arr+        r = len `mod` sizeOf (undefined :: b)+     in if r /= 0+        then Nothing+        else Just $ castUnsafe arr++-- | Use an @Array a@ as @Ptr b@.+--+-- /Unsafe/+--+-- /Pre-release/+--+asPtrUnsafe :: Array a -> (Ptr b -> IO c) -> IO c+asPtrUnsafe Array{..} act = do+    unsafeWithArrayContents arrContents arrStart $ \ptr -> act (castPtr ptr)++-------------------------------------------------------------------------------+-- Equality+-------------------------------------------------------------------------------++-- | Compare if two arrays are equal.+--+-- /Pre-release/+{-# INLINE cmp #-}+cmp :: MonadIO m => Array a -> Array a -> m Bool+cmp arr1 arr2 =+    liftIO $ do+        let ptr1 = arrStart arr1+        let ptr2 = arrStart arr2+        let len1 = aEnd arr1 `minusPtr` ptr1+        let len2 = aEnd arr2 `minusPtr` ptr2++        if len1 == len2+        then+            if ptr1 == ptr2+            then return True+            else do+                r <- memcmp (castPtr ptr1) (castPtr ptr2) len1+                touch (arrContents arr1)+                touch (arrContents arr2)+                return r+        else return False++-------------------------------------------------------------------------------+-- NFData+-------------------------------------------------------------------------------++-- This is a Storable array, we cannot have unevaluated data in it so this is+-- just a no op.+instance NFData (Array a) where+    {-# INLINE rnf #-}+    rnf Array {} = ()
src/Streamly/Internal/Data/Array/Foreign/Type.hs view
@@ -22,13 +22,15 @@     , unsafeThaw      -- * Construction-    , spliceTwo+    , splice      , fromPtr     , fromAddr#     , fromCString#     , fromList     , fromListN+    , fromListRev+    , fromListRevN     , fromStreamDN     , fromStreamD @@ -55,49 +57,40 @@     , toList      -- * Folds-    , toArrayMinChunk+    , writeWith     , 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.Exception (assert) import Control.DeepSeq (NFData(..)) import Control.Monad.IO.Class (MonadIO(..))+import Data.Functor.Identity (Identity(..)) 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.Base (Addr#, nullAddr#, build) 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.Array.Foreign.Mut.Type+    (ArrayContents, ReadUState(..), touch) import Streamly.Internal.Data.Fold.Type (Fold(..))+import Streamly.Internal.Data.Stream.Serial (SerialT(..)) import Streamly.Internal.Data.Unfold.Type (Unfold(..)) import Text.Read (readPrec, readListPrec, readListPrecDefault) @@ -106,9 +99,10 @@ 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 +import Streamly.Internal.System.IO (unsafeInlineIO, defaultChunkSize)+ #if __GLASGOW_HASKELL__ < 808 import Data.Semigroup (Semigroup(..)) #endif@@ -142,7 +136,12 @@     Storable a => #endif     Array-    { aStart :: {-# UNPACK #-} !(ForeignPtr a) -- first address+    { arrContents ::+#ifndef USE_FOREIGN_PTR+        {-# UNPACK #-}+#endif+            !ArrayContents -- ^ first address+    , arrStart :: {-# UNPACK #-} !(Ptr a) -- start address     , aEnd   :: {-# UNPACK #-} !(Ptr a)        -- first unused addres     } @@ -157,39 +156,52 @@ -- 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/.+-- XXX For debugging we can track slices/references through a weak IORef.  Then+-- trigger a GC after freeze/thaw and assert that there are no references+-- remaining.++-- | Makes an immutable array using the underlying memory of the mutable+-- array.+--+-- Please make sure that there are no other references to the mutable array+-- lying around, so that it is never used after freezing it using+-- /unsafeFreeze/.  If the underlying array is mutated, the immutable promise+-- is lost.+--+-- /Pre-release/ {-# INLINE unsafeFreeze #-} unsafeFreeze :: MA.Array a -> Array a-unsafeFreeze (MA.Array as ae _) = Array as ae+unsafeFreeze (MA.Array ac as ae _) = Array ac as ae --- | Similar to 'unsafeFreeze' but uses 'MA.shrinkToFit' on the mutable array+-- | Similar to 'unsafeFreeze' but uses 'MA.rightSize' 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+  MA.Array ac as ae _ <- MA.rightSize arr+  return $ Array ac 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/.+-- | Makes a mutable array using the underlying memory of the immutable array.+--+-- Please make sure that there are no other references to the immutable array+-- lying around, so that it is never used after thawing it using /unsafeThaw/.+-- If the resulting array is mutated, any references to the older immutable+-- array are mutated as well.+--+-- /Pre-release/ {-# INLINE unsafeThaw #-} unsafeThaw :: Array a -> MA.Array a-unsafeThaw (Array as ae) = MA.Array as ae ae+unsafeThaw (Array ac as ae) = MA.Array ac 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)+{-# INLINE splice #-}+splice :: (MonadIO m, Storable a) => Array a -> Array a -> m (Array a)+splice arr1 arr2 =+    unsafeFreeze <$> MA.splice (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@@ -211,12 +223,12 @@     Storable a => #endif     Int -> Ptr a -> Array a-fromPtr n ptr = MA.unsafeInlineIO $ do-    fptr <- newForeignPtr_ ptr+fromPtr n ptr = unsafeInlineIO $ do     let end = ptr `plusPtr` n     return $ Array-        { aStart = fptr-        , aEnd   = end+        { arrContents = MA.nilArrayContents+        , arrStart = ptr+        , aEnd = end         }  -- XXX when converting an array of Word8 from a literal string we can simply@@ -288,7 +300,7 @@ fromCString# :: Addr# -> Array Word8 fromCString# addr# = do     let cstr = Ptr addr#-        len = MA.unsafeInlineIO $ c_strlen cstr+        len = unsafeInlineIO $ c_strlen cstr     fromPtr (fromIntegral len) (castPtr cstr)  -- | Create an 'Array' from the first N elements of a list. The array is@@ -300,8 +312,22 @@ -- @since 0.8.0 {-# INLINABLE fromListN #-} fromListN :: Storable a => Int -> [a] -> Array a-fromListN n xs = unsafeFreeze $ MA.fromListN n xs+fromListN n xs = unsafePerformIO $ unsafeFreeze <$> MA.fromListN n xs +-- XXX We can possibly have a direction flag in the array to reverse it without+-- actually doing anything. With that we can just do "reverse . fromList". But+-- it may complicate all the APIs as all reads of the array will have to handle+-- the flag.+--+-- | Create an 'Array' from the first N elements of a list in reverse order.+-- The array is allocated to size N, if the list terminates before N elements+-- then the array may hold less than N elements.+--+-- /Unimplemented/+{-# INLINABLE fromListRevN #-}+fromListRevN :: {- Storable a => -} Int -> [a] -> Array a+fromListRevN _n _xs = undefined+ -- | Create an 'Array' from a list. The list must be of finite size. -- -- /Since 0.7.0 (Streamly.Memory.Array)/@@ -309,8 +335,16 @@ -- @since 0.8.0 {-# INLINABLE fromList #-} fromList :: Storable a => [a] -> Array a-fromList xs = unsafeFreeze $ MA.fromList xs+fromList xs = unsafePerformIO $ unsafeFreeze <$> MA.fromList xs +-- | Create an 'Array' from a list in reverse order. The list must be of finite+-- size.+--+-- /Unimplemented/+{-# INLINABLE fromListRev #-}+fromListRev :: {- Storable a => -} [a] -> Array a+fromListRev _xs = undefined+ {-# INLINE_NORMAL fromStreamDN #-} fromStreamDN :: forall m a. (MonadIO m, Storable a)     => Int -> D.Stream m a -> m (Array a)@@ -328,7 +362,7 @@ {-# 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+bufferChunks m = D.foldr K.cons K.nil $ arraysOf defaultChunkSize m  -- | @arraysOf n stream@ groups the input stream into a stream of -- arrays of size n.@@ -376,12 +410,12 @@ -- 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)+unsafeIndexIO arr = MA.getIndexUnsafe (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)+unsafeIndex arr i = let !r = unsafeInlineIO $ unsafeIndexIO arr i in r  -- | /O(1)/ Get the byte length of the array. --@@ -398,37 +432,113 @@ -- @since 0.8.0 {-# INLINE length #-} length :: forall a. Storable a => Array a -> Int-length arr =  MA.length (unsafeThaw arr)+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+readRev = Unfold step inject+    where +    inject (Array contents start end) =+        let p = end `plusPtr` negate (sizeOf (undefined :: a))+         in return $ ReadUState contents start p++    {-# INLINE_LATE step #-}+    step (ReadUState contents start p) | p < start =+        let x = unsafeInlineIO $ touch contents+        in x `seq` return D.Stop+    step (ReadUState contents start 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+            let cur = p `plusPtr` negate (sizeOf (undefined :: a))+            return $ D.Yield x (ReadUState contents start cur)++ {-# INLINE_NORMAL toStreamD #-} toStreamD :: forall m a. (Monad m, Storable a) => Array a -> D.Stream m a-toStreamD arr = MA.toStreamD (unsafeThaw arr)+toStreamD Array{..} = D.Stream step arrStart +    where++    {-# INLINE_LATE step #-}+    step _ p | assert (p <= aEnd) (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+                    touch arrContents+                    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 arr = MA.toStreamK (unsafeThaw arr)+toStreamK :: forall m a. Storable a => Array a -> K.Stream m a+toStreamK Array{..} = go arrStart +    where++    go p | assert (p <= aEnd) (p == aEnd) = K.nil+         | otherwise =+        -- See Note in toStreamD.+        let !x = unsafeInlineIO $ do+                    r <- peek p+                    touch arrContents+                    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 arr = MA.toStreamDRev (unsafeThaw arr)+toStreamDRev Array{..} =+    let p = aEnd `plusPtr` negate (sizeOf (undefined :: a))+    in D.Stream step p +    where++    {-# INLINE_LATE step #-}+    step _ p | p < arrStart = return D.Stop+    step _ p = do+        -- See comments in toStreamD for why we use unsafeInlineIO+        let !x = unsafeInlineIO $ do+                    r <- peek p+                    touch arrContents+                    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 arr = MA.toStreamKRev (unsafeThaw arr)+toStreamKRev :: forall m a. Storable a => Array a -> K.Stream m a+toStreamKRev Array {..} =+    let p = aEnd `plusPtr` negate (sizeOf (undefined :: a))+    in go p +    where++    go p | p < arrStart = K.nil+         | otherwise =+        let !x = unsafeInlineIO $ do+                    r <- peek p+                    touch arrContents+                    return r+        in x `K.cons` go (p `plusPtr` negate (sizeOf (undefined :: a)))+ -- | 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+toStream :: (Monad m, Storable a) => Array a -> SerialT m a+toStream = SerialT . D.toStreamK . toStreamD -- XXX add fallback to StreamK rule -- {-# RULES "Streamly.Array.read fallback to StreamK" [1] --     forall a. S.readK (read a) = K.fromArray a #-}@@ -437,8 +547,8 @@ -- -- /Pre-release/ {-# INLINE_EARLY toStreamRev #-}-toStreamRev :: (Monad m, K.IsStream t, Storable a) => Array a -> t m a-toStreamRev = D.fromStreamD . toStreamDRev+toStreamRev :: (Monad m, Storable a) => Array a -> SerialT m a+toStreamRev = SerialT . D.toStreamK . toStreamDRev  -- XXX add fallback to StreamK rule -- {-# RULES "Streamly.Array.readRev fallback to StreamK" [1]@@ -446,11 +556,11 @@  {-# 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)+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 = MA.foldr f z (unsafeThaw arr)+foldr f z arr = runIdentity $ D.foldr f z $ toStreamD arr  -- | Create two slices of an array without copying the original array. The -- specified index @i@ is the first index of the second slice.@@ -461,6 +571,27 @@   where     (a, b) = MA.splitAt i (unsafeThaw arr) +-- Use foldr/build fusion to fuse with list consumers+-- This can be useful when using the IsList instance+{-# INLINE_LATE toListFB #-}+toListFB :: forall a b. Storable a => (a -> b -> b) -> b -> Array a -> b+toListFB c n Array{..} = go arrStart+    where++    go p | assert (p <= aEnd) (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+                    touch arrContents+                    return r+        in c x (go (p `plusPtr` sizeOf (undefined :: a)))+ -- | Convert an 'Array' into a list. -- -- /Since 0.7.0 (Streamly.Memory.Array)/@@ -468,7 +599,7 @@ -- @since 0.8.0 {-# INLINE toList #-} toList :: Storable a => Array a -> [a]-toList = MA.toList . unsafeThaw+toList s = build (\c n -> toListFB c n s)  ------------------------------------------------------------------------------- -- Folds@@ -519,24 +650,11 @@     => 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+{-# INLINE_NORMAL writeWith #-}+writeWith :: forall m a. (MonadIO m, Storable a)+    => Int -> Fold m a (Array a)+-- writeWith n = FL.rmapM spliceArrays $ toArraysOf n+writeWith elemCount = unsafeFreeze <$> MA.writeWith elemCount  -- | Fold the whole input to a single array. --@@ -549,18 +667,6 @@ 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 -------------------------------------------------------------------------------@@ -592,16 +698,18 @@ -- 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)+    arr1 == arr2 = unsafeInlineIO $! unsafeThaw arr1 `MA.cmp` unsafeThaw arr2 -instance (Storable a, NFData a) => NFData (Array a) where+-- Since this is a Storable array we cannot have unevaluated data in it so+-- this is just a no op.+instance NFData (Array a) where     {-# INLINE rnf #-}-    rnf = foldl' (\_ x -> rnf x) ()+    rnf Array {} = ()  instance (Storable a, Ord a) => Ord (Array a) where     {-# INLINE compare #-}-    compare a b = compare (unsafeThaw a) (unsafeThaw b)+    compare arr1 arr2 = runIdentity $+        D.cmpBy compare (toStreamD arr1) (toStreamD arr2)      -- Default definitions defined in base do not have an INLINE on them, so we     -- replicate them here with an INLINE.@@ -631,24 +739,25 @@ -- {-# 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+toStreamD_ size Array{..} = D.Stream step arrStart      where      {-# INLINE_LATE step #-}     step _ p | p == aEnd = return D.Stop-    step _ p = do-        x <- liftIO $ do-                    r <- peek p-                    touchForeignPtr aStart-                    return r+    step _ p = liftIO $ do+        x <- peek p+        touch arrContents         return $ D.Yield x (p `plusPtr` size) +{-++XXX Why isn't Storable implicit? This does not compile unless I use the Storable+contraint.+ {-# INLINE_NORMAL _foldr #-} _foldr :: forall a b. (a -> b -> b) -> b -> Array a -> b-_foldr f z arr@Array {..} =+_foldr f z arr =     let !n = sizeOf (undefined :: a)     in unsafePerformIO $ D.foldr f z $ toStreamD_ n arr @@ -656,6 +765,8 @@ -- operations. instance Foldable Array where   foldr = _foldr++-} #endif  -------------------------------------------------------------------------------@@ -663,17 +774,14 @@ -------------------------------------------------------------------------------  instance Storable a => Semigroup (Array a) where-    arr1 <> arr2 = unsafePerformIO $ spliceTwo arr1 arr2--nullForeignPtr :: ForeignPtr a-nullForeignPtr = ForeignPtr nullAddr# (error "nullForeignPtr")+    arr1 <> arr2 = unsafePerformIO $ splice arr1 arr2  nil :: #ifdef DEVBUILD     Storable a => #endif     Array a-nil = Array nullForeignPtr (Ptr nullAddr#)+nil = Array MA.nilArrayContents (Ptr nullAddr#) (Ptr nullAddr#)  instance Storable a => Monoid (Array a) where     mempty = nil
src/Streamly/Internal/Data/Array/Prim/MutTypesInclude.hs view
@@ -163,21 +163,27 @@ -- /Pre-release/ {-# INLINE_NORMAL writeN #-} writeN :: (MonadIO m, Prim a) => Int -> Fold m a (Array a)-writeN limit = Fold step initial extract+writeN len = Fold step initial extract      where +    {-# INLINE next #-}+    next marr i = do+        let i1 = i + 1+            st = Tuple' marr i1+        if len > i1+        then return $ FL.Partial st+        else fmap FL.Done $ extract st+     initial = do-        marr <- newArray limit-        return $ FL.Partial $ Tuple' marr 0+        marr <- liftIO $ newArray len+        next marr (-1) -    extract (Tuple' marr len) = shrinkArray marr len >> return marr+    step (Tuple' marr i) x = do+        liftIO $ unsafeWriteIndex marr i x+        next marr i -    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)+    extract (Tuple' marr l) = shrinkArray marr l >> return marr  -- Use Tuple' instead? data ArrayUnsafe a = ArrayUnsafe
src/Streamly/Internal/Data/Array/Prim/TypesInclude.hs view
@@ -25,7 +25,7 @@ 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 qualified Streamly.Internal.Data.Stream.StreamK.Type as K  import GHC.Exts hiding (fromListN, fromList, toList) import Prelude hiding (length, unlines, foldr)@@ -398,7 +398,7 @@     step _ i = return $ D.Yield (unsafeIndex arr i) (i + 1)  {-# INLINE toStreamK #-}-toStreamK :: (K.IsStream t, Prim a) => Array a -> t m a+toStreamK :: Prim a => Array a -> K.Stream m a toStreamK arr = go 0      where@@ -423,7 +423,7 @@     step _ i = return $ D.Yield (unsafeIndex arr i) (i - 1)  {-# INLINE toStreamKRev #-}-toStreamKRev :: (K.IsStream t, Prim a) => Array a -> t m a+toStreamKRev :: Prim a => Array a -> K.Stream m a toStreamKRev arr = go (length arr - 1)      where
src/Streamly/Internal/Data/Array/PrimInclude.hs view
@@ -9,13 +9,10 @@ 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 Streamly.Internal.Data.Stream.Serial (SerialT(..))  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) @@ -30,9 +27,9 @@ -- /Pre-release/ {-# INLINE fromStreamN #-} fromStreamN :: (MonadIO m, Prim a) => Int -> SerialT m a -> m (Array a)-fromStreamN n m = do+fromStreamN n (SerialT m) = do     when (n < 0) $ error "writeN: negative write count specified"-    A.fromStreamDN n $ D.toStreamD m+    A.fromStreamDN n $ D.fromStreamK 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@@ -45,7 +42,7 @@ -- /Pre-release/ {-# INLINE fromStream #-} fromStream :: (MonadIO m, Prim a) => SerialT m a -> m (Array a)-fromStream = P.fold A.write+fromStream (SerialT m) = P.fold A.write m -- write m = A.fromStreamD $ D.toStreamD m  -------------------------------------------------------------------------------@@ -56,8 +53,8 @@ -- -- /Pre-release/ {-# INLINE_EARLY toStream #-}-toStream :: (MonadIO m, K.IsStream t, Prim a) => Array a -> t m a-toStream = D.fromStreamD . A.toStreamD+toStream :: (MonadIO m, Prim a) => Array a -> SerialT m a+toStream = SerialT . D.toStreamK . 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 #-}@@ -66,8 +63,8 @@ -- -- /Pre-release/ {-# INLINE_EARLY toStreamRev #-}-toStreamRev :: (MonadIO m, IsStream t, Prim a) => Array a -> t m a-toStreamRev = D.fromStreamD . A.toStreamDRev+toStreamRev :: (MonadIO m, Prim a) => Array a -> SerialT m a+toStreamRev = SerialT . D.toStreamK . 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 #-}@@ -128,7 +125,7 @@ -- /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 f arr = P.fold f (getSerialT (toStream arr))  -- | Fold an array using a stream fold operation. --@@ -170,10 +167,11 @@ -- -- /Pre-release/ {-# INLINE concat #-}-concat :: (IsStream t, MonadIO m, Prim a) => t m (Array a) -> t m a+concat :: (MonadIO m, Prim a) => SerialT m (Array a) -> SerialT 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)+concat (SerialT m) =+    SerialT $ D.toStreamK $ D.unfoldMany read (D.fromStreamK m)  -- | Coalesce adjacent arrays in incoming stream to form bigger arrays of a -- maximum specified size in bytes.@@ -182,4 +180,5 @@ {-# 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)+compact n (SerialT xs) =+    SerialT $ D.toStreamK $ A.packArraysChunksOf n (D.fromStreamK xs)
src/Streamly/Internal/Data/Array/Stream/Fold/Foreign.hs view
@@ -23,7 +23,7 @@ -- >>> 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"+-- >>> ArrayStream.foldArr (ArrayFold.fromFold (Fold.take 7 Fold.toList)) $ Stream.arraysOf 5 $ Stream.fromList "hello world" -- "hello w" -- module Streamly.Internal.Data.Array.Stream.Fold.Foreign@@ -55,12 +55,10 @@ 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.Mut.Type (touch) import Streamly.Internal.Data.Array.Foreign.Type (Array(..)) import Streamly.Internal.Data.Parser.ParserD (Initial(..), Step(..)) import Streamly.Internal.Data.Tuple.Strict (Tuple'(..))@@ -108,14 +106,14 @@                   Fold.Partial s1 -> IPartial s1                   Fold.Done b -> IDone b -    step s (Array fp@(ForeignPtr start _) end) = do-        goArray SPEC (Ptr start) s+    step s (Array contents start end) = do+        goArray SPEC start s          where          goArray !_ !cur !fs | cur >= end = do             assert (cur == end) (return ())-            liftIO $ touchForeignPtr fp+            liftIO $ touch contents             return $ Partial 0 fs         goArray !_ !cur !fs = do             x <- liftIO $ peek cur@@ -140,23 +138,23 @@      where -    step s (Array fp@(ForeignPtr start _) end) = do-        if Ptr start >= end+    step s (Array contents start end) = do+        if start >= end         then return $ Continue 0 s-        else goArray SPEC (Ptr start) s+        else goArray SPEC 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+            if next1 >= 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+            liftIO $ touch contents             res <- step1 fs x             let elemSize = sizeOf (undefined :: a)                 next = cur `plusPtr` elemSize@@ -321,10 +319,10 @@                 Done j b -> return $ Done j b                 Error err -> return $ Error err         else do-            let !(Array (ForeignPtr start contents) _) = arr+            let !(Array contents start _) = arr                 sz = sizeOf (undefined :: a)-                end = Ptr start `plusPtr` (i * sz)-                arr1 = Array (ForeignPtr start contents) end+                end = start `plusPtr` (i * sz)+                arr1 = Array contents start end                 remaining = negate i1             res <- step1 r arr1             case res of
src/Streamly/Internal/Data/Array/Stream/Foreign.hs view
@@ -22,18 +22,22 @@     , unlines      -- * Elimination+    -- ** Element Folds     , fold-    , fold_-    -- , parse+    , parse     , parseD-    , foldMany++    -- ** Array Folds+    , foldArr+    , foldArr_+    -- , parseArr+    , parseArrD+    , foldArrMany+     , toArray      -- * Compaction     , lpackArraysChunksOf-#if !defined(mingw32_HOST_OS)-    , groupIOVecsOf-#endif     , compact      -- * Splitting@@ -48,9 +52,11 @@ import Control.Exception (assert) import Control.Monad.Catch (MonadThrow, throwM) import Control.Monad.IO.Class (MonadIO(..))+#if __GLASGOW_HASKELL__ < 808+import Data.Semigroup (Semigroup(..))+#endif 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(..))@@ -60,17 +66,17 @@ 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.Mut.Type+    (arrayToFptrContents, fptrToArrayContents, touch) 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.Stream.IsStream.Type+    (IsStream, fromStreamD, toStreamD) import Streamly.Internal.Data.SVar (adaptState, defState)+import Streamly.Internal.Data.Array.Foreign.Mut.Type+    (memcpy, allocBytesToElemCount)  import qualified Streamly.Internal.Data.Array.Foreign as A import qualified Streamly.Internal.Data.Array.Foreign as Array@@ -97,7 +103,7 @@ {-# 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)+arraysOf n str = fromStreamD $ A.arraysOf n (toStreamD str)  ------------------------------------------------------------------------------- -- Append@@ -116,9 +122,9 @@ -- @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)+-- concat m = fromStreamD $ A.flattenArrays (toStreamD m)+-- concat m = fromStreamD $ D.concatMap A.toStreamD (toStreamD m)+concat m = fromStreamD $ D.unfoldMany A.read (toStreamD m)  -- | Convert a stream of arrays into a stream of their elements reversing the -- contents of each array before flattening.@@ -128,7 +134,7 @@ -- @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)+concatRev m = fromStreamD $ A.flattenArraysRev (toStreamD m)  ------------------------------------------------------------------------------- -- Intersperse and append@@ -154,12 +160,12 @@ {-# 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 = fromStreamD . A.unlines x . toStreamD interposeSuffix x = S.interposeSuffix x A.read  data FlattenState s a =       OuterLoop s-    | InnerLoop s !(ForeignPtr a) !(Ptr a) !(Ptr a)+    | InnerLoop s !MA.ArrayContents !(Ptr a) !(Ptr a)  {-# INLINE_NORMAL unlines #-} unlines :: forall m a. (MonadIO m, Storable a)@@ -171,26 +177,28 @@         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 (InnerLoop s arrContents arrStart 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+    step' _ (InnerLoop st contents p end) = do         x <- liftIO $ do                     r <- peek p-                    touchForeignPtr startf+                    touch contents                     return r-        return $ D.Yield x (InnerLoop st startf+        return $ D.Yield x (InnerLoop st contents                             (p `plusPtr` sizeOf (undefined :: a)) end)  ------------------------------------------------------------------------------- -- Compact ------------------------------------------------------------------------------- +-- XXX These would not be needed once we implement compactLEFold, see+-- module Streamly.Internal.Data.Array.Stream.Mut.Foreign+-- {-# INLINE_NORMAL packArraysChunksOf #-} packArraysChunksOf :: (MonadIO m, Storable a)     => Int -> D.Stream m (Array a) -> D.Stream m (Array a)@@ -203,23 +211,7 @@ 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+    FL.lmap A.unsafeThaw $ AS.lpackArraysChunksOf n (FL.lmap A.unsafeFreeze fld)  -- | Coalesce adjacent arrays in incoming stream to form bigger arrays of a -- maximum specified size in bytes.@@ -228,7 +220,7 @@ {-# 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)+compact n xs = fromStreamD $ packArraysChunksOf n (toStreamD xs)  ------------------------------------------------------------------------------- -- Split@@ -272,7 +264,7 @@         case r of             D.Yield arr s -> do                 (arr1, marr2) <- A.breakOn byte arr-                buf' <- A.spliceTwo buf arr1+                buf' <- A.splice buf arr1                 return $ case marr2 of                     Nothing -> D.Skip (Buffering s buf')                     Just x -> D.Skip (Yielding buf' (Splitting s x))@@ -302,7 +294,7 @@     -> t m (Array Word8)     -> t m (Array Word8) splitOn byte s =-    D.fromStreamD $ D.splitInnerBy (A.breakOn byte) A.spliceTwo $ D.toStreamD s+    fromStreamD $ D.splitInnerBy (A.breakOn byte) A.splice $ toStreamD s  {-# INLINE splitOnSuffix #-} splitOnSuffix@@ -310,14 +302,72 @@     => Word8     -> t m (Array Word8)     -> t m (Array Word8)--- splitOn byte s = D.fromStreamD $ A.splitOn byte $ D.toStreamD s+-- splitOn byte s = fromStreamD $ A.splitOn byte $ toStreamD s splitOnSuffix byte s =-    D.fromStreamD $ D.splitInnerBySuffix (A.breakOn byte) A.spliceTwo $ D.toStreamD s+    fromStreamD $ D.splitInnerBySuffix (A.breakOn byte) A.splice $ toStreamD s  ---------------------------------------------------------------------------------- Elimination+-- Elimination - Running folds ------------------------------------------------------------------------------- +-- XXX This should be written using CPS (as foldK) if we want it to scale wrt+-- to the number of times it can be called on the same stream.+--+{-# INLINE_NORMAL foldD #-}+foldD :: forall m a b. (MonadIO m, Storable a) =>+    Fold m a b -> D.Stream m (Array a) -> m (b, D.Stream m (Array a))+foldD (Fold fstep initial extract) stream@(D.Stream step state) = do+    res <- initial+    case res of+        FL.Partial fs -> go SPEC state fs+        FL.Done fb -> return $! (fb, stream)++    where++    {-# INLINE go #-}+    go !_ st !fs = do+        r <- step defState st+        case r of+            D.Yield (Array contents start (Ptr end)) s ->+                let fp = ForeignPtr end (arrayToFptrContents contents)+                 in goArray SPEC s fp start fs+            D.Skip s -> go SPEC s fs+            D.Stop -> do+                b <- extract fs+                return (b, D.nil)++    goArray !_ s fp@(ForeignPtr end _) !cur !fs+        | cur == Ptr end = do+            liftIO $ touchForeignPtr fp+            go SPEC s fs+    goArray !_ st fp@(ForeignPtr end contents) !cur !fs = do+        x <- liftIO $ peek cur+        res <- fstep fs x+        let elemSize = sizeOf (undefined :: a)+            next = cur `plusPtr` elemSize+        case res of+            FL.Done b -> do+                let arr = Array (fptrToArrayContents contents) next (Ptr end)+                return $! (b, D.cons arr (D.Stream step st))+            FL.Partial fs1 -> goArray SPEC st fp next fs1++-- | Fold an array stream using the supplied 'Fold'. Returns the fold result+-- and the unconsumed stream.+--+-- /Internal/+--+{-# INLINE_NORMAL fold #-}+fold ::+       (MonadIO m, Storable a)+    => FL.Fold m a b+    -> SerialT m (A.Array a)+    -> m (b, SerialT m (A.Array a))+fold f s = fmap fromStreamD <$> foldD f (toStreamD s)++-------------------------------------------------------------------------------+-- Fold to a single Array+-------------------------------------------------------------------------------+ -- When we have to take an array partially, take the last part of the array. {-# INLINE takeArrayListRev #-} takeArrayListRev :: forall a. Storable a => Int -> [Array a] -> [Array a]@@ -333,10 +383,10 @@            then x : go (n - len) xs            else if n == len            then [x]-           else let !(Array (ForeignPtr _ contents) end) = x+           else let !(Array contents _ end) = x                     sz = sizeOf (undefined :: a)-                    !(Ptr start) = end `plusPtr` negate (n * sz)-                 in [Array (ForeignPtr start contents) end]+                    !start = end `plusPtr` negate (n * sz)+                 in [Array contents start end]  -- When we have to take an array partially, take the last part of the array in -- the first split.@@ -356,12 +406,11 @@                 then (x:xs', xs'')                 else if m == len                 then ([x],xs)-                else let !(Array (ForeignPtr start contents) end) = x+                else let !(Array contents start 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+                         arr2 = Array contents start end1+                         arr1 = Array contents end1 end                       in ([arr1], arr2:xs)  -------------------------------------------------------------------------------@@ -383,11 +432,12 @@      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+    writeArr dst (MA.Array ac src ae _) =+        liftIO $ do+            let count = ae `minusPtr` src+            memcpy (castPtr dst) (castPtr src) count+            touch ac+            return $ dst `plusPtr` count  {-# INLINE _spliceArrays #-} _spliceArrays :: (MonadIO m, Storable a)@@ -401,11 +451,12 @@      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+    writeArr dst (Array ac src ae) =+        liftIO $ do+            let count = ae `minusPtr` src+            memcpy (castPtr dst) (castPtr src) count+            touch ac+            return $ dst `plusPtr` count  {-# INLINE _spliceArraysBuffered #-} _spliceArraysBuffered :: (MonadIO m, Storable a)@@ -419,11 +470,11 @@ 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))+    let n = allocBytesToElemCount (undefined :: a) (4 * 1024)+        idst = liftIO $ MA.newArray n -    arr <- S.foldlM' MA.spliceWithDoubling idst (S.map A.unsafeThaw s)-    liftIO $ A.unsafeFreeze <$> MA.shrinkToFit arr+    arr <- S.foldlM' MA.spliceExp idst (S.map A.unsafeThaw s)+    liftIO $ A.unsafeFreeze <$> MA.rightSize arr  -- XXX This should just be "fold A.write" --@@ -457,7 +508,7 @@ -}  ---------------------------------------------------------------------------------- Parsing+-- Elimination - running element parsers -------------------------------------------------------------------------------  -- GHC parser does not accept {-# ANN type [] NoSpecConstr #-}, so we need@@ -465,10 +516,15 @@ {-# ANN type List NoSpecConstr #-} newtype List a = List {getList :: [a]} +-- This can be generalized to any type provided it can be unfolded to a stream+-- and it can be combined using a semigroup operation.+--+-- XXX This should be written using CPS (as parseK) if we want it to scale wrt+-- to the number of times it can be called on the same stream. {-# INLINE_NORMAL parseD #-} parseD ::        forall m a b. (MonadIO m, MonadThrow m, Storable a)-    => PRD.Parser m (Array a) b+    => PRD.Parser m 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@@ -490,6 +546,104 @@     go !_ st backBuf !pst = do         r <- step defState st         case r of+            D.Yield (Array contents start (Ptr end)) s ->+                gobuf SPEC s backBuf+                    (ForeignPtr end (arrayToFptrContents contents)) start pst+            D.Skip s -> go SPEC s backBuf pst+            D.Stop -> do+                b <- extract pst+                return (b, D.nil)++    -- Use strictness on "cur" to keep it unboxed+    gobuf !_ s backBuf fp@(ForeignPtr end _) !cur !pst+        | cur == Ptr end = do+            liftIO $ touchForeignPtr fp+            go SPEC s backBuf pst+    gobuf !_ s backBuf fp@(ForeignPtr end contents) !cur !pst = do+        x <- liftIO $ peek cur+        pRes <- pstep pst x+        let elemSize = sizeOf (undefined :: a)+            next = cur `plusPtr` elemSize+        case pRes of+            PR.Partial 0 pst1 ->+                 gobuf SPEC s (List []) fp next pst1+            PR.Partial n pst1 -> do+                assert (n <= Prelude.length (x:getList backBuf)) (return ())+                let src0 = Prelude.take n (x:getList backBuf)+                    arr0 = A.fromListN n (Prelude.reverse src0)+                    arr1 = Array (fptrToArrayContents contents) next (Ptr end)+                    src = arr0 <> arr1+                let !(Array cont1 start (Ptr end1)) = src+                    fp1 = ForeignPtr end1 (arrayToFptrContents cont1)+                gobuf SPEC s (List []) fp1 start pst1+            PR.Continue 0 pst1 ->+                gobuf SPEC s (List (x:getList backBuf)) fp next pst1+            PR.Continue n pst1 -> do+                assert (n <= Prelude.length (x:getList backBuf)) (return ())+                let (src0, buf1) = splitAt n (x:getList backBuf)+                    arr0 = A.fromListN n (Prelude.reverse src0)+                    arr1 = Array (fptrToArrayContents contents) next (Ptr end)+                    src = arr0 <> arr1+                let !(Array cont1 start (Ptr end1)) = src+                    fp1 = ForeignPtr end1 (arrayToFptrContents cont1)+                gobuf SPEC s (List buf1) fp1 start pst1+            PR.Done 0 b -> do+                let arr = Array (fptrToArrayContents contents) next (Ptr end)+                return (b, D.cons arr (D.Stream step s))+            PR.Done n b -> do+                assert (n <= Prelude.length (x:getList backBuf)) (return ())+                let src0 = Prelude.take n (x:getList backBuf)+                    -- XXX create the array in reverse instead+                    arr0 = A.fromListN n (Prelude.reverse src0)+                    arr1 = Array (fptrToArrayContents contents) next (Ptr end)+                    -- XXX Use StreamK to avoid adding arbitrary layers of+                    -- constructors every time.+                    str = D.cons arr0 (D.cons arr1 (D.Stream step s))+                return (b, str)+            PR.Error err -> throwM $ ParseError err++-- | Parse an array stream using the supplied 'Parser'.  Returns the parse+-- result and the unconsumed stream. Throws 'ParseError' if the parse fails.+--+-- /Internal/+--+{-# INLINE_NORMAL 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 fromStreamD <$> parseD p (toStreamD s)++-------------------------------------------------------------------------------+-- Elimination - Running Array Folds and parsers+-------------------------------------------------------------------------------++{-# INLINE_NORMAL parseArrD #-}+parseArrD ::+       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))+parseArrD (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@@ -535,32 +689,32 @@ -- -- /Internal/ ---{-# INLINE parse #-}-parse ::+{-# INLINE parseArr #-}+parseArr ::        (MonadIO m, MonadThrow m, Storable a)-    => PRD.Parser m a b+    => ASF.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)+parseArr p s = fmap fromStreamD <$> parseD p (toStreamD s) -}  -- | Fold an array stream using the supplied array stream 'Fold'. -- -- /Pre-release/ ---{-# INLINE fold #-}-fold :: (MonadIO m, MonadThrow m, Storable a) =>+{-# INLINE foldArr #-}+foldArr :: (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)+foldArr (ASF.Fold p) s = fst <$> parseArrD p (toStreamD s)  -- | Like 'fold' but also returns the remaining stream. -- -- /Pre-release/ ---{-# INLINE fold_ #-}-fold_ :: (MonadIO m, MonadThrow m, Storable a) =>+{-# INLINE foldArr_ #-}+foldArr_ :: (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)+foldArr_ (ASF.Fold p) s = second fromStreamD <$> parseArrD p (toStreamD s)  {-# ANN type ParseChunksState Fuse #-} data ParseChunksState x inpBuf st pst =@@ -570,13 +724,13 @@     | ParseChunksBuf inpBuf st inpBuf !pst     | ParseChunksYield x (ParseChunksState x inpBuf st pst) -{-# INLINE_NORMAL foldManyD #-}-foldManyD+{-# INLINE_NORMAL foldArrManyD #-}+foldArrManyD     :: (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) =+foldArrManyD (ASF.Fold (PRD.Parser pstep initial extract)) (D.Stream step state) =     D.Stream stepOuter (ParseChunksInit [] state)      where@@ -696,10 +850,10 @@ -- See "Streamly.Prelude.foldMany" for more details. -- -- /Pre-release/-{-# INLINE foldMany #-}-foldMany+{-# INLINE foldArrMany #-}+foldArrMany     :: (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)+foldArrMany p m = fromStreamD $ foldArrManyD p (toStreamD m)
src/Streamly/Internal/Data/Array/Stream/Mut/Foreign.hs view
@@ -17,9 +17,6 @@     , packArraysChunksOf     , SpliceState (..)     , lpackArraysChunksOf-#if !defined(mingw32_HOST_OS)-    , groupIOVecsOf-#endif     , compact     , compactLE     , compactEQ@@ -33,25 +30,17 @@ 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.Stream.Serial (SerialT(..))+import Streamly.Internal.Data.Stream.IsStream.Type+    (IsStream, fromStreamD, toStreamD) 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. --@@ -63,7 +52,7 @@ {-# 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+arraysOf n = fromStreamD . MArray.arraysOf n . toStreamD  ------------------------------------------------------------------------------- -- Compact@@ -75,6 +64,8 @@     | SpliceYielding arr (SpliceState s arr)     | SpliceFinish +-- XXX This can be removed once compactLEFold/compactLE are implemented.+-- -- | This mutates the first array (if it has space) to append values from the -- second one. This would work for immutable arrays as well because an -- immutable array never has space so a new array is allocated instead of@@ -123,7 +114,7 @@                     buf' <- if MArray.byteCapacity buf < n                             then liftIO $ MArray.realloc n buf                             else return buf-                    buf'' <- MArray.spliceWith buf' arr+                    buf'' <- MArray.splice buf' arr                     return $ D.Skip (SpliceBuffering s buf'')             D.Skip s -> return $ D.Skip (SpliceBuffering s buf)             D.Stop -> return $ D.Skip (SpliceYielding buf SpliceFinish)@@ -132,6 +123,9 @@      step' _ (SpliceYielding arr next) = return $ D.Yield arr next +-- XXX Remove this once compactLEFold is implemented+-- lpackArraysChunksOf = Fold.many compactLEFold+-- {-# INLINE_NORMAL lpackArraysChunksOf #-} lpackArraysChunksOf :: (MonadIO m, Storable a)     => Int -> Fold m (Array a) () -> Fold m (Array a) ()@@ -174,7 +168,7 @@             buf' <- if MArray.byteCapacity buf < len                     then liftIO $ MArray.realloc (max n len) buf                     else return buf-            buf'' <- MArray.spliceWith buf' arr+            buf'' <- MArray.splice buf' arr              -- XXX this is common in both the equations of step             if len >= n@@ -188,18 +182,20 @@                         return $ first (Tuple' Nothing) res             else return $ FL.Partial $ Tuple' (Just buf'') r1 --- XXX replace by compactLE+-- XXX Same as compactLE, to be removed once that is implemented. -- -- | Coalesce adjacent arrays in incoming stream to form bigger arrays of a -- maximum specified size in bytes. ----- @since 0.7.0+-- /Internal/ {-# 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)+compact n (SerialT xs) =+    SerialT $ D.toStreamK $ packArraysChunksOf n (D.fromStreamK xs) --- XXX Replace the above functions by a compactLEFold+-- See lpackArraysChunksOf/packArraysChunksOf to implement 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@@ -212,21 +208,26 @@     Int -> Fold m (Array a) (Array a) compactLEFold = undefined +-- | Coalesce adjacent arrays in incoming stream to form bigger arrays of a+-- maximum specified size in bytes.+--+-- /Internal/ 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)+compactLE n (SerialT xs) =+    SerialT $ D.toStreamK $ D.foldMany (compactLEFold n) (D.fromStreamK 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.+-- | Like 'compactLE' but generates arrays of exactly equal to the size+-- specified except for the last array in the stream which could be shorter. -- -- /Unimplemented/ {-# INLINE compactEQ #-} compactEQ :: -- (MonadIO m, Storable a) =>     Int -> SerialT m (Array a) -> SerialT m (Array a) compactEQ _n _xs = undefined-    -- D.fromStreamD $ D.foldMany (compactEQFold n) (D.toStreamD xs)+    -- IsStream.fromStreamD $ D.foldMany (compactEQFold n) (IsStream.toStreamD xs) --- | Like 'compact' but generates arrays of size greater than or equal to the+-- | Like 'compactLE' but generates arrays of size greater than or equal to the -- specified except for the last array in the stream which could be shorter. -- -- /Unimplemented/@@ -234,78 +235,4 @@ 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+    -- IsStream.fromStreamD $ D.foldMany (compactGEFold n) (IsStream.toStreamD xs)
src/Streamly/Internal/Data/Fold.hs view
@@ -109,10 +109,10 @@      -- ** Mapping on Input     , transform-    , map     , lmap     --, lsequence     , lmapM+    , scan     , indexed      -- ** Filtering@@ -144,7 +144,6 @@      -- ** Trimming     , take-    , takeInterval      -- By elements     , takeEndBy@@ -158,6 +157,7 @@      -- ** Serial Append     , serialWith+    , serial_     -- , tail     -- , init     , splitAt -- spanN@@ -215,7 +215,6 @@      -- ** Splitting     , many-    , intervalsOf     , chunksOf     , chunksBetween @@ -223,13 +222,17 @@     , concatSequence     , concatMap -    -- * Running Partially+    -- * Running A Fold+    -- | Normally you would run a fold to completion by supplying it a stream,+    -- e.g. using 'Stream.fold'. However, you could also run a fold partially+    -- by using 'duplicate' on it and then running it with a stream.+    -- Alternatively, 'initialize', 'snoc' and 'finish' can be used to run a+    -- fold incrementally, however, that may not be the most efficient way to+    -- run a fold.     , initialize-    , runStep+    , snoc     , duplicate--    -- * Fold2-    , drainBy2+    , finish      -- * Deprecated     , sequence@@ -237,8 +240,8 @@     ) where -import Control.Monad (void) import Data.Bifunctor (first)+import Data.Either (isLeft, isRight) import Data.Functor.Identity (Identity(..)) import Data.Int (Int64) import Data.Map.Strict (Map)@@ -246,16 +249,16 @@ #if __GLASGOW_HASKELL__ < 804 import Data.Semigroup (Semigroup((<>))) #endif+import Streamly.Internal.BaseCompat (fromLeft, fromRight) 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 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 Streamly.Internal.Data.Stream.IsStream.Enumeration as Stream import qualified Prelude  import Prelude hiding@@ -274,7 +277,10 @@ -- >>> 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.Fold.Type as Fold -- >>> import qualified Streamly.Internal.Data.Parser as Parser+-- >>> import Streamly.Internal.Data.Stream.Serial (SerialT(..))+-- >>> import Data.IORef (newIORef, readIORef, writeIORef)  ------------------------------------------------------------------------------ -- hoist@@ -327,7 +333,7 @@ -- @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+mapMaybe f = lmap f . filter isJust . lmap fromJust  ------------------------------------------------------------------------------ -- Transformations on fold inputs@@ -374,6 +380,42 @@      extract (Tuple' _ fs) = fextract fs +-- | Scan the input of a 'Fold' to change it in a stateful manner using another+-- 'Fold'.+-- /Pre-release/+{-# INLINE scan #-}+scan :: Monad m => Fold m a b -> Fold m b c -> Fold m a c+scan (Fold stepL initialL extractL) (Fold stepR initialR extractR) =+    Fold step initial extract++    where++    runStep actionL sR = do+        rL <- actionL+        case rL of+            Done bL -> do+                rR <- stepR sR bL+                case rR of+                    Partial sR1 -> Done <$> extractR sR1+                    Done bR -> return $ Done bR+            Partial sL -> do+                !b <- extractL sL+                rR <- stepR sR b+                return+                    $ case rR of+                        Partial sR1 -> Partial (sL, sR1)+                        Done bR -> Done bR++    initial = do+        r <- initialR+        case r of+            Partial sR -> runStep initialL sR+            Done b -> return $ Done b++    step (sL, sR) x = runStep (stepL sL x) sR++    extract = extractR . snd+ ------------------------------------------------------------------------------ -- Left folds ------------------------------------------------------------------------------@@ -396,13 +438,6 @@ 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)@@ -1107,6 +1142,22 @@ -- Partitioning ------------------------------------------------------------------------------ +{-# INLINE partitionByMUsing #-}+partitionByMUsing :: Monad m =>+       (  (x -> y -> (x, y))+       -> Fold m (Either b c) x+       -> Fold m (Either b c) y+       -> Fold m (Either b c) (x, y)+       )+    -> (a -> m (Either b c))+    -> Fold m b x+    -> Fold m c y+    -> Fold m a (x, y)+partitionByMUsing t f fld1 fld2 =+    let l = lmap (fromLeft undefined) fld1  -- :: Fold m (Either b c) x+        r = lmap (fromRight undefined) fld2 -- :: Fold m (Either b c) y+     in lmapM f (t (,) (filter isLeft l) (filter isRight r))+ -- | Partition the input over two folds using an 'Either' partitioning -- predicate. --@@ -1128,24 +1179,26 @@ -- -- 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+--  return $ \a -> do --      r <- readIORef ref --      writeIORef ref $ tail r---      return $ head r a+--      return $ Prelude.head r a+-- :} --+-- >>> :{ -- main = do --  f <- proportionately 2 1---  r <- S.fold (FL.partitionByM f FL.length FL.length) (S.enumerateFromTo (1 :: Int) 100)+--  r <- Stream.fold (Fold.partitionByM f Fold.length Fold.length) (Stream.enumerateFromTo (1 :: Int) 100) --  print r--- @--- @+-- :}+--+-- >>> main -- (67,33)--- @ --+-- -- This is the consumer side dual of the producer side 'mergeBy' operation. -- -- When one fold is done, any input meant for it is ignored until the other@@ -1159,85 +1212,23 @@ {-# 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+partitionByM = partitionByMUsing teeWith  -- | 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+partitionByFstM :: Monad m+    => (a -> m (Either b c)) -> Fold m b x -> Fold m c y -> Fold m a (x, y)+partitionByFstM = partitionByMUsing teeWithFst  -- | Similar to 'partitionByM' but terminates when any fold terminates. ----- /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+partitionByMinM :: Monad m =>+    (a -> m (Either b c)) -> Fold m b x -> Fold m c y -> Fold m a (x, y)+partitionByMinM = partitionByMUsing teeWithMin  -- Note: we could use (a -> Bool) instead of (a -> Either b c), but the latter -- makes the signature clearer as to which case belongs to which fold.@@ -1547,17 +1538,33 @@ -- -- Same as: ----- > classify fld = Fold.classifyWith fst (map snd fld)+-- > classify fld = Fold.classifyWith fst (lmap 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)+classify fld = classifyWith fst (lmap snd fld)  ------------------------------------------------------------------------------ -- Unzipping ------------------------------------------------------------------------------ +{-# INLINE unzipWithMUsing #-}+unzipWithMUsing :: Monad m =>+       (  (x -> y -> (x, y))+       -> Fold m (b, c) x+       -> Fold m (b, c) y+       -> Fold m (b, c) (x, y)+       )+    -> (a -> m (b, c))+    -> Fold m b x+    -> Fold m c y+    -> Fold m a (x, y)+unzipWithMUsing t f fld1 fld2 =+    let f1 = lmap fst fld1  -- :: Fold m (b, c) b+        f2 = lmap snd fld2  -- :: Fold m (b, c) c+     in lmapM f (t (,) f1 f2)+ -- | Like 'unzipWith' but with a monadic splitter function. -- -- @unzipWithM k f1 f2 = lmapM k (unzip f1 f2)@@@ -1566,78 +1573,23 @@ {-# 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+unzipWithM = unzipWithMUsing teeWith  -- | 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+unzipWithFstM :: Monad m =>+    (a -> m (b, c)) -> Fold m b x -> Fold m c y -> Fold m a (x, y)+unzipWithFstM = unzipWithMUsing teeWithFst  -- | Similar to 'unzipWithM' but terminates when any fold terminates. ----- /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+unzipWithMinM :: Monad m =>+    (a -> m (b,c)) -> Fold m b x -> Fold m c y -> Fold m a (x,y)+unzipWithMinM = unzipWithMUsing teeWithMin  -- | Split elements in the input stream into two parts using a pure splitter -- function, direct each part to a different fold and zip the results.@@ -1697,8 +1649,9 @@ -- -- /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)+indexed :: -- forall m a b. Monad m =>+    Fold m (Int, a) b -> Fold m a b+indexed = undefined -- 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@@ -1716,7 +1669,7 @@        (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+with f comb g = f . comb g . lmap snd  -- | @sampleFromthen offset stride@ samples the element at @offset@ index and -- then every element at strides of @stride@.@@ -1764,12 +1717,12 @@ -- /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+-- >>> toStream = fmap SerialT Fold.toStreamK -- -- /Pre-release/ {-# INLINE toStream #-}-toStream :: Monad m => Fold m a (SerialT Identity a)-toStream = foldr K.cons K.nil+toStream :: Monad m => Fold m a (SerialT n a)+toStream = fmap SerialT toStreamK  -- This is more efficient than 'toStream'. toStream is exactly the same as -- reversing the stream after toStreamRev.@@ -1777,7 +1730,7 @@ -- | Buffers the input stream to a pure stream in the reverse order of the -- input. ----- > toStreamRev = foldl' (flip K.cons) K.nil+-- >>> toStreamRev = fmap SerialT Fold.toStreamKRev -- -- /Warning!/ working on large streams accumulated as buffers in memory could -- be very inefficient, consider using "Streamly.Data.Array" instead.@@ -1786,5 +1739,5 @@  --  xn : ... : x2 : x1 : [] {-# INLINABLE toStreamRev #-}-toStreamRev :: Monad m => Fold m a (SerialT Identity a)-toStreamRev = foldl' (flip K.cons) K.nil+toStreamRev :: Monad m => Fold m a (SerialT n a)+toStreamRev = fmap SerialT toStreamKRev
+ src/Streamly/Internal/Data/Fold/Async.hs view
@@ -0,0 +1,120 @@+-- |+-- Module      : Streamly.Internal.Data.Fold.Async+-- Copyright   : (c) 2019 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+module Streamly.Internal.Data.Fold.Async+    (+    -- * Trimming+      takeInterval++    -- * Splitting+    , intervalsOf+    )+where++import Control.Concurrent (threadDelay, forkIO, killThread)+import Control.Concurrent.MVar (MVar, newMVar, swapMVar, readMVar)+import Control.Exception (SomeException(..), catch, mask)+import Control.Monad (void)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.Control (control)+import Streamly.Internal.Control.Concurrent (MonadAsync)+import Streamly.Internal.Data.Tuple.Strict (Tuple3'(..))++import Streamly.Internal.Data.Fold.Type++-- $setup+-- >>> :m+-- >>> import qualified Streamly.Prelude as Stream+-- >>> import qualified Streamly.Data.Fold as Fold+-- >>> import qualified Streamly.Internal.Data.Fold.Async as Fold++-- 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.+--+-- >>> input = Stream.delay 0.1 $ Stream.fromList [1..]+-- >>> Stream.fold (Fold.takeInterval 1.0 Fold.toList) input+-- [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/SVar.hs view
@@ -0,0 +1,78 @@+-- |+-- Module      : Streamly.Internal.Data.Fold.SVar+-- Copyright   : (c) 2017 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+--+module Streamly.Internal.Data.Fold.SVar+    (+      write+    , writeLimited+    )+where++#include "inline.hs"++import Control.Monad (void)+import Control.Monad.IO.Class (MonadIO(liftIO))+import Streamly.Internal.Data.Fold.Type (Fold(..))++import qualified Streamly.Internal.Data.Fold.Type as FL++import Streamly.Internal.Data.SVar++-- | 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 ()
+ src/Streamly/Internal/Data/Fold/Step.hs view
@@ -0,0 +1,83 @@+-- |+-- Module      : Streamly.Internal.Data.Fold.Step+-- Copyright   : (c) 2019 Composewell Technologies+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+module Streamly.Internal.Data.Fold.Step+    (+    -- * Types+      Step (..)++    , mapMStep+    , chainStepM+    )+where++import Data.Bifunctor (Bifunctor(..))+import Fusion.Plugin.Types (Fuse(..))++------------------------------------------------------------------------------+-- Step of a fold+------------------------------------------------------------------------------++-- The Step functor around b allows expressing early termination like a right+-- fold. Traditional list right folds use function composition and laziness to+-- terminate early whereas we use data constructors. It allows stream fusion in+-- contrast to the foldr/build fusion when composing with functions.++-- | Represents the result of the @step@ of a 'Fold'.  'Partial' returns an+-- intermediate state of the fold, the fold step can be called again with the+-- state or the driver can use @extract@ on the state to get the result out.+-- 'Done' returns the final result and the fold cannot be driven further.+--+-- /Pre-release/+--+{-# ANN type Step Fuse #-}+data Step s b+    = Partial !s+    | Done !b++-- | 'first' maps over 'Partial' and 'second' maps over 'Done'.+--+instance Bifunctor Step where+    {-# INLINE bimap #-}+    bimap f _ (Partial a) = Partial (f a)+    bimap _ g (Done b) = Done (g b)++    {-# INLINE first #-}+    first f (Partial a) = Partial (f a)+    first _ (Done x) = Done x++    {-# INLINE second #-}+    second _ (Partial x) = Partial x+    second f (Done a) = Done (f a)++-- | 'fmap' maps over 'Done'.+--+-- @+-- fmap = 'second'+-- @+--+instance Functor (Step s) where+    {-# INLINE fmap #-}+    fmap = second++-- | Map a monadic function over the result @b@ in @Step s b@.+--+-- /Internal/+{-# INLINE mapMStep #-}+mapMStep :: Applicative m => (a -> m b) -> Step s a -> m (Step s b)+mapMStep f res =+    case res of+        Partial s -> pure $ Partial s+        Done b -> Done <$> f b++-- | If 'Partial' then map the state, if 'Done' then call the next step.+{-# INLINE chainStepM #-}+chainStepM :: Applicative m =>+    (s1 -> m s2) -> (a -> m (Step s2 b)) -> Step s1 a -> m (Step s2 b)+chainStepM f _ (Partial s) = Partial <$> f s+chainStepM _ g (Done b) = g b
src/Streamly/Internal/Data/Fold/Type.hs view
@@ -209,8 +209,11 @@     -- * Folds     , fromPure     , fromEffect+    , fromRefold     , drain     , toList+    , toStreamK+    , toStreamKRev      -- * Combinators @@ -218,7 +221,6 @@     , rmapM      -- ** Mapping Input-    , map     , lmap     , lmapM @@ -229,14 +231,12 @@      -- ** Trimming     , take-    , takeInterval      -- ** Serial Append-    , serialWith+    , serialWith -- rename to "append"     , serial_      -- ** Parallel Distribution-    , GenericRunner(..)     , teeWith     , teeWithFst     , teeWithMin@@ -250,106 +250,56 @@     , many     , manyPost     , chunksOf-    , intervalsOf+    , refoldMany+    , refoldMany1+    , refold      -- ** Nesting     , concatMap -    -- * Running Partially-    , duplicate+    -- * Running A Fold     , initialize-    , runStep--    -- * Fold2-    , Fold2 (..)-    , simplify-    , chunksOf2+    , snoc+    , duplicate+    , finish     ) 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 Control.Monad ((>=>)) import Data.Bifunctor (Bifunctor(..)) import Data.Maybe (isJust, fromJust) import Fusion.Plugin.Types (Fuse(..))+import Streamly.Internal.Data.Fold.Step (Step(..), mapMStep, chainStepM) import Streamly.Internal.Data.Maybe.Strict (Maybe'(..), toMaybe)-import Streamly.Internal.Data.Tuple.Strict (Tuple'(..), Tuple3'(..))-import Streamly.Internal.Data.SVar (MonadAsync)+import Streamly.Internal.Data.Tuple.Strict (Tuple'(..))+import Streamly.Internal.Data.Refold.Type (Refold(..)) +import qualified Streamly.Internal.Data.Stream.StreamK.Type as K+ import Prelude hiding (concatMap, filter, foldr, map, take)  -- $setup -- >>> :m -- >>> :set -XFlexibleContexts+-- >>> import Streamly.Data.Fold (Fold) -- >>> import Prelude hiding (concatMap, filter, map)+-- >>> import Streamly.Prelude (SerialT)+-- >>> import qualified Data.Foldable as Foldable -- >>> 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+-- >>> import qualified Streamly.Internal.Data.Fold.Type as Fold+-- >>> import qualified Streamly.Internal.Data.Stream.IsStream as Stream+-- >>> import qualified Streamly.Internal.Data.Stream.StreamK as StreamK  ------------------------------------------------------------------------------ -- The Fold type ------------------------------------------------------------------------------ +-- An fold is akin to a writer. It is the streaming equivalent of a writer.+-- The type @b@ is the accumulator of the writer. That's the reason the+-- default folds in various modules are called "write".+ -- | The type @Fold m a b@ having constructor @Fold step initial extract@ -- represents a fold over an input stream of values of type @a@ to a final -- value of type @b@ in 'Monad' @m@.@@ -555,25 +505,18 @@ mkFoldM_ step initial = mkFoldM step initial return  --------------------------------------------------------------------------------- Fold2+-- Refold ------------------------------------------------------------------------------ --- | 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'.+-- This is similar to how we run an Unfold to generate a Stream. A Fold is like+-- a Stream and a Fold2 is like an Unfold. ----- /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'+-- | Make a fold from a consumer. -- -- /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+fromRefold :: Refold m c a b -> c -> Fold m a b+fromRefold (Refold step inject extract) c =+    Fold step (inject c) extract  ------------------------------------------------------------------------------ -- Basic Folds@@ -602,6 +545,31 @@ toList :: Monad m => Fold m a [a] toList = foldr (:) [] +-- | Buffers the input stream to a pure stream in the reverse order of the+-- input.+--+-- >>> toStreamKRev = Foldable.foldl' (flip StreamK.cons) StreamK.nil+--+-- This is more efficient than 'toStreamK'. toStreamK has exactly the same+-- performance as reversing the stream after toStreamKRev.+--+-- /Pre-release/++--  xn : ... : x2 : x1 : []+{-# INLINABLE toStreamKRev #-}+toStreamKRev :: Monad m => Fold m a (K.Stream n a)+toStreamKRev = foldl' (flip K.cons) K.nil++-- | A fold that buffers its input to a pure stream.+--+-- >>> toStreamK = foldr StreamK.cons StreamK.nil+-- >>> toStreamK = fmap StreamK.reverse Fold.toStreamKRev+--+-- /Internal/+{-# INLINE toStreamK #-}+toStreamK :: Monad m => Fold m a (K.Stream n a)+toStreamK = foldr K.cons K.nil+ ------------------------------------------------------------------------------ -- Instances ------------------------------------------------------------------------------@@ -638,7 +606,7 @@ fromEffect :: Applicative m => m b -> Fold m a b fromEffect b = Fold undefined (Done <$> b) pure -{-# ANN type Step Fuse #-}+{-# ANN type SeqFoldState Fuse #-} data SeqFoldState sl f sr = SeqFoldL !sl | SeqFoldR !f !sr  -- | Sequential fold application. Apply two folds sequentially to an input@@ -664,60 +632,84 @@ -- @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 :: 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+    {-# INLINE runR #-}+    runR action f = bimap (SeqFoldR f) f <$> action -    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)+    {-# INLINE runL #-}+    runL action = do+        resL <- action+        chainStepM (return . SeqFoldL) (runR initialR . func) resL +    initial = runL initialL++    step (SeqFoldL st) a = runL (stepL st a)+    step (SeqFoldR f st) a = runR (stepR st a) f+     extract (SeqFoldR f sR) = fmap f (extractR sR)     extract (SeqFoldL sL) = do         rL <- extractL sL         res <- initialR-        case res of-            Partial sR -> do-                rR <- extractR sR-                return $ func rL rR-            Done rR -> return $ func rL rR+        fmap (func rL)+            $ case res of+                Partial sR -> extractR sR+                Done rR -> return rR +{-# ANN type SeqFoldState_ Fuse #-}+data SeqFoldState_ sl sr = SeqFoldL_ !sl | SeqFoldR_ !sr+ -- | Same as applicative '*>'. Run two folds serially one after the other -- discarding the result of the first. ----- /Unimplemented/+-- This was written in the hope that it might be faster than implementing it+-- using serialWith, but the current benchmarks show that it has the same+-- performance. So do not expose it unless some benchmark shows benefit. -- {-# INLINE serial_ #-}-serial_ :: -- Monad m =>-    Fold m x a -> Fold m x b -> Fold m x b-serial_ _f1 _f2 = undefined+serial_ :: Monad m => Fold m x a -> Fold m x b -> Fold m x b+serial_ (Fold stepL initialL _) (Fold stepR initialR extractR) =+    Fold step initial extract -{-# ANN type GenericRunner Fuse #-}-data GenericRunner sL sR bL bR-    = RunBoth !sL !sR-    | RunLeft !sL !bR-    | RunRight !bL !sR+    where +    initial = do+        resL <- initialL+        case resL of+            Partial sl -> return $ Partial $ SeqFoldL_ sl+            Done _ -> do+                resR <- initialR+                return $ first SeqFoldR_ resR++    step (SeqFoldL_ st) a = do+        r <- stepL st a+        case r of+            Partial s -> return $ Partial (SeqFoldL_ s)+            Done _ -> do+                resR <- initialR+                return $ first SeqFoldR_ resR+    step (SeqFoldR_ st) a = do+        resR <- stepR st a+        return $ first SeqFoldR_ resR++    extract (SeqFoldR_ sR) = extractR sR+    extract (SeqFoldL_ _) = do+        res <- initialR+        case res of+            Partial sR -> extractR sR+            Done rR -> return rR++{-# ANN type TeeState Fuse #-}+data TeeState sL sR bL bR+    = TeeBoth !sL !sR+    | TeeLeft !bR !sL+    | TeeRight !bL !sR+ -- | @teeWith k f1 f2@ distributes its input to both @f1@ and @f2@ until both -- of them terminate and combines their output using @k@. --@@ -736,101 +728,189 @@ -- {-# 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+teeWith f (Fold stepL initialL extractL) (Fold stepR initialR extractR) =+    Fold step initial extract      where -    begin = do-        resL <- beginL-        resR <- beginR+    {-# INLINE runBoth #-}+    runBoth actionL actionR = do+        resL <- actionL+        resR <- actionR         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+                                Partial sr -> TeeBoth sl sr+                                Done br -> TeeLeft br sl+                  Done bl -> bimap (TeeRight 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+    initial = runBoth initialL initialR -    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+    step (TeeBoth sL sR) a = runBoth (stepL sL a) (stepR sR a)+    step (TeeLeft bR sL) a = bimap (TeeLeft bR) (`f` bR) <$> stepL sL a+    step (TeeRight bL sR) a = bimap (TeeRight bL) (f bL) <$> stepR sR a +    extract (TeeBoth sL sR) = f <$> extractL sL <*> extractR sR+    extract (TeeLeft bR sL) = (`f` bR) <$> extractL sL+    extract (TeeRight bL sR) = f bL <$> extractR sR++{-# ANN type TeeFstState Fuse #-}+data TeeFstState sL sR b+    = TeeFstBoth !sL !sR+    | TeeFstLeft !b !sL+ -- | Like 'teeWith' but terminates as soon as the first fold terminates. ----- /Unimplemented/+-- /Pre-release/ -- {-# INLINE teeWithFst #-}-teeWithFst :: (b -> c -> d) -> Fold m a b -> Fold m a c -> Fold m a d-teeWithFst = undefined+teeWithFst :: Monad m =>+    (b -> c -> d) -> Fold m a b -> Fold m a c -> Fold m a d+teeWithFst f (Fold stepL initialL extractL) (Fold stepR initialR extractR) =+    Fold step initial extract +    where++    {-# INLINE runBoth #-}+    runBoth actionL actionR = do+        resL <- actionL+        resR <- actionR++        case resL of+            Partial sl ->+                return+                    $ Partial+                    $ case resR of+                        Partial sr -> TeeFstBoth sl sr+                        Done br -> TeeFstLeft br sl+            Done bl -> do+                Done . f bl <$>+                    case resR of+                        Partial sr -> extractR sr+                        Done br -> return br++    initial = runBoth initialL initialR++    step (TeeFstBoth sL sR) a = runBoth (stepL sL a) (stepR sR a)+    step (TeeFstLeft bR sL) a = bimap (TeeFstLeft bR) (`f` bR) <$> stepL sL a++    extract (TeeFstBoth sL sR) = f <$> extractL sL <*> extractR sR+    extract (TeeFstLeft bR sL) = (`f` bR) <$> extractL sL+ -- | Like 'teeWith' but terminates as soon as any one of the two folds -- terminates. ----- /Unimplemented/+-- /Pre-release/ -- {-# INLINE teeWithMin #-}-teeWithMin :: (b -> c -> d) -> Fold m a b -> Fold m a c -> Fold m a d-teeWithMin = undefined+teeWithMin :: Monad m =>+    (b -> c -> d) -> Fold m a b -> Fold m a c -> Fold m a d+teeWithMin f (Fold stepL initialL extractL) (Fold stepR initialR extractR) =+    Fold step initial extract +    where++    {-# INLINE runBoth #-}+    runBoth actionL actionR = do+        resL <- actionL+        resR <- actionR+        case resL of+            Partial sl -> do+                case resR of+                    Partial sr -> return $ Partial $ Tuple' sl sr+                    Done br -> Done . (`f` br) <$> extractL sl++            Done bl -> do+                Done . f bl <$>+                    case resR of+                        Partial sr -> extractR sr+                        Done br -> return br++    initial = runBoth initialL initialR++    step (Tuple' sL sR) a = runBoth (stepL sL a) (stepR sR a)++    extract (Tuple' sL sR) = f <$> extractL sL <*> extractR sR+ -- | Shortest alternative. Apply both folds in parallel but choose the result -- from the one which consumed least input i.e. take the shortest succeeding -- fold. ----- /Unimplemented/+-- If both the folds finish at the same time or if the result is extracted+-- before any of the folds could finish then the left one is taken. --+-- /Pre-release/+-- {-# INLINE shortest #-}-shortest :: -- Monad m =>-    Fold m x a -> Fold m x a -> Fold m x a-shortest _f1 _f2 = undefined+shortest :: Monad m => Fold m x a -> Fold m x b -> Fold m x (Either a b)+shortest (Fold stepL initialL extractL) (Fold stepR initialR _) =+    Fold step initial extract +    where++    {-# INLINE runBoth #-}+    runBoth actionL actionR = do+        resL <- actionL+        resR <- actionR+        return $+            case resL of+                Partial sL -> bimap (Tuple' sL) Right resR+                Done bL -> Done $ Left bL++    initial = runBoth initialL initialR++    step (Tuple' sL sR) a = runBoth (stepL sL a) (stepR sR a)++    extract (Tuple' sL _) = Left <$> extractL sL++{-# ANN type LongestState Fuse #-}+data LongestState sL sR+    = LongestBoth !sL !sR+    | LongestLeft !sL+    | LongestRight !sR+ -- | Longest alternative. Apply both folds in parallel but choose the result -- from the one which consumed more input i.e. take the longest succeeding -- fold. ----- /Unimplemented/+-- If both the folds finish at the same time or if the result is extracted+-- before any of the folds could finish then the left one is taken. --+-- /Pre-release/+-- {-# INLINE longest #-}-longest :: -- Monad m =>-    Fold m x a -> Fold m x a -> Fold m x a-longest _f1 _f2 = undefined+longest :: Monad m => Fold m x a -> Fold m x b -> Fold m x (Either a b)+longest (Fold stepL initialL extractL) (Fold stepR initialR extractR) =+    Fold step initial extract +    where++    {-# INLINE runBoth #-}+    runBoth actionL actionR = do+        resL <- actionL+        resR <- actionR+        return $+            case resL of+                Partial sL ->+                    Partial $+                        case resR of+                            Partial sR -> LongestBoth sL sR+                            Done _ -> LongestLeft sL+                Done bL -> bimap LongestRight (const (Left bL)) resR++    initial = runBoth initialL initialR++    step (LongestBoth sL sR) a = runBoth (stepL sL a) (stepR sR a)+    step (LongestLeft sL) a = bimap LongestLeft Left <$> stepL sL a+    step (LongestRight sR) a = bimap LongestRight Right <$> stepR sR a++    left sL = Left <$> extractL sL+    extract (LongestLeft sL) = left sL+    extract (LongestRight sR) = Right <$> extractR sR+    extract (LongestBoth sL _) = left sL+ data ConcatMapState m sa a c     = B !sa     | forall s. C (s -> a -> m (Step s c)) !s (s -> m c)@@ -913,13 +993,6 @@     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@@ -964,7 +1037,7 @@ -- @since 0.8.0 {-# INLINE catMaybes #-} catMaybes :: Monad m => Fold m a b -> Fold m (Maybe a) b-catMaybes = filter isJust . map fromJust+catMaybes = filter isJust . lmap fromJust  ------------------------------------------------------------------------------ -- Parsing@@ -987,46 +1060,50 @@      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+    {-# INLINE next #-}+    next i res =         case res of-            Partial sres -> do+            Partial s -> do                 let i1 = i + 1-                    s1 = Tuple'Fused i1 sres+                    s1 = Tuple'Fused i1 s                 if i1 < n                 then return $ Partial s1-                else Done <$> fextract sres-            Done bres -> return $ Done bres+                else Done <$> fextract s+            Done b -> return $ Done b +    initial = finitial >>= next (-1)++    step (Tuple'Fused i r) a = fstep r a >>= next i+     extract (Tuple'Fused _ r) = fextract r  ------------------------------------------------------------------------------ -- Nesting ------------------------------------------------------------------------------ --- | 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.+-- | 'duplicate' provides the ability to run a fold in parts.  The duplicated+-- fold consumes the input and returns the same fold as output instead of+-- returning the final result, the returned fold can be run later to consume+-- more input. --+-- We can append a stream to a fold as follows:+-- -- >>> :{+-- foldAppend :: Monad m => Fold m a b -> SerialT m a -> m (Fold m a b)+-- foldAppend f = Stream.fold (Fold.duplicate f)+-- :}+--+-- >>> :{ -- 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)+--  sum1 <- foldAppend Fold.sum (Stream.enumerateFromTo 1 10)+--  sum2 <- foldAppend sum1 (Stream.enumerateFromTo 11 20)+--  Stream.fold sum2 (Stream.enumerateFromTo 21 30) -- :} -- 465 --+-- 'duplicate' essentially appends a stream to the fold without finishing the+-- fold.  Compare with 'snoc' which appends a singleton value to the fold.+-- -- /Pre-release/ {-# INLINABLE duplicate #-} duplicate :: Monad m => Fold m a b -> Fold m a (Fold m a b)@@ -1049,19 +1126,38 @@     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.+-- | Append a singleton value to the fold. --+-- >>> import qualified Data.Foldable as Foldable+-- >>> Foldable.foldlM Fold.snoc Fold.toList [1..3] >>= Fold.finish+-- [1,2,3]+--+-- Compare with 'duplicate' which allows appending a stream to the 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+{-# INLINE snoc #-}+snoc :: Monad m => Fold m a b -> a -> m (Fold m a b)+snoc (Fold step initial extract) a = do     res <- initial     r <- case res of           Partial fs -> step fs a-          b@(Done _) -> return b+          Done _ -> return res     return $ Fold step (return r) extract +-- | Finish the fold to extract the current value of the fold.+--+-- >>> Fold.finish Fold.toList+-- []+--+-- /Pre-release/+{-# INLINE finish #-}+finish :: Monad m => Fold m a b -> m b+finish (Fold _ initial extract) = do+    res <- initial+    case res of+          Partial fs -> extract fs+          Done b -> return b+ ------------------------------------------------------------------------------ -- Parsing ------------------------------------------------------------------------------@@ -1107,38 +1203,38 @@     -- Caution! There is mutual recursion here, inlining the right functions is     -- important. -    {-# INLINE handleSplitStep #-}-    handleSplitStep branch cs sres =+    {-# INLINE split #-}+    split f cs sres =         case sres of-            Partial ss1 -> return $ Partial $ branch ss1 cs-            Done sb -> runCollector ManyFirst cs sb+            Partial ss -> return $ Partial $ f ss cs+            Done sb -> cstep cs sb >>= collect -    {-# INLINE handleCollectStep #-}-    handleCollectStep branch cres =+    {-# INLINE collect #-}+    collect cres =         case cres of-            Partial cs -> do-                sres <- sinitial-                handleSplitStep branch cs sres+            Partial cs -> sinitial >>= split ManyFirst cs             Done cb -> return $ Done cb -    -- Do not inline this-    runCollector branch cs sb = cstep cs sb >>= handleCollectStep branch--    initial = cinitial >>= handleCollectStep ManyFirst+    -- A fold may terminate even without accepting a single input.  So we run+    -- the split fold's initial action even if no input is received.  However,+    -- this means that if no input was ever received by "step" we discard the+    -- fold's initial result which could have generated an effect. However,+    -- note that if "sinitial" results in Done we do collect its output even+    -- though the fold may not have received any input. XXX Is this+    -- inconsistent?+    initial = cinitial >>= collect      {-# INLINE step_ #-}-    step_ ss cs a = do-        sres <- sstep ss a-        handleSplitStep ManyLoop cs sres+    step_ ss cs a = sstep ss a >>= split ManyLoop cs      {-# INLINE step #-}     step (ManyFirst ss cs) a = step_ ss cs a     step (ManyLoop ss cs) a = step_ ss cs a +    -- Do not extract the split fold if no item was consumed.     extract (ManyFirst _ cs) = cextract cs     extract (ManyLoop ss cs) = do-        sb <- sextract ss-        cres <- cstep cs sb+        cres <- sextract ss >>= cstep cs         case cres of             Partial s -> cextract s             Done b -> return b@@ -1167,33 +1263,25 @@     -- Caution! There is mutual recursion here, inlining the right functions is     -- important. -    {-# INLINE handleSplitStep #-}-    handleSplitStep cs sres =+    {-# INLINE split #-}+    split cs sres =         case sres of             Partial ss1 -> return $ Partial $ Tuple' ss1 cs-            Done sb -> runCollector cs sb+            Done sb -> cstep cs sb >>= collect -    {-# INLINE handleCollectStep #-}-    handleCollectStep cres =+    {-# INLINE collect #-}+    collect cres =         case cres of-            Partial cs -> do-                sres <- sinitial-                handleSplitStep cs sres+            Partial cs -> sinitial >>= split cs             Done cb -> return $ Done cb -    -- Do not inline this-    runCollector cs sb = cstep cs sb >>= handleCollectStep--    initial = cinitial >>= handleCollectStep+    initial = cinitial >>= collect      {-# INLINE step #-}-    step (Tuple' ss cs) a = do-        sres <- sstep ss a-        handleSplitStep cs sres+    step (Tuple' ss cs) a = sstep ss a >>= split cs      extract (Tuple' ss cs) = do-        sb <- sextract ss-        cres <- cstep cs sb+        cres <- sextract ss >>= cstep cs         case cres of             Partial s -> cextract s             Done b -> return b@@ -1216,116 +1304,113 @@ chunksOf :: Monad m => Int -> Fold m a b -> Fold m b c -> Fold m a c chunksOf n split = many (take n split) --- |+------------------------------------------------------------------------------+-- Refold and Fold Combinators+------------------------------------------------------------------------------++-- | Like 'many' but uses a 'Refold' for collecting. ----- /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'+{-# INLINE refoldMany #-}+refoldMany :: Monad m => Fold m a b -> Refold m x b c -> Refold m x a c+refoldMany (Fold sstep sinitial sextract) (Refold cstep cinject cextract) =+    Refold step inject extract      where -    loopUntilPartial s = do-        res <- initial1-        case res of-            Partial fs -> return $ Tuple3' 0 fs s-            Done _ -> loopUntilPartial s+    -- cs = collect state+    -- ss = split state+    -- cres = collect state result+    -- sres = split state result+    -- cb = collect done+    -- sb = split done -    inject' x = inject2 x >>= loopUntilPartial+    -- Caution! There is mutual recursion here, inlining the right functions is+    -- important. -    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+    {-# INLINE split #-}+    split cs f sres =+        case sres of+            Partial ss -> return $ Partial $ Tuple' cs (f ss)+            Done sb -> cstep cs sb >>= collect -    extract' (Tuple3' _ r1 r2) = extract1 r1 >>= step2 r2 >>= extract2+    {-# INLINE collect #-}+    collect cres =+        case cres of+            Partial cs -> sinitial >>= split cs Left+            Done cb -> return $ Done cb --- 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/+    inject x = cinject x >>= collect++    {-# INLINE step_ #-}+    step_ ss cs a = sstep ss a >>= split cs Right++    {-# INLINE step #-}+    step (Tuple' cs (Left ss)) a = step_ ss cs a+    step (Tuple' cs (Right ss)) a = step_ ss cs a++    -- Do not extract the split fold if no item was consumed.+    extract (Tuple' cs (Left _)) = cextract cs+    extract (Tuple' cs (Right ss )) = do+        cres <- sextract ss >>= cstep cs+        case cres of+            Partial s -> cextract s+            Done b -> return b++{-# ANN type ConsumeManyState Fuse #-}+data ConsumeManyState x cs ss = ConsumeMany x cs (Either ss ss)++-- | Like 'many' but uses a 'Refold' for splitting. ---{-# INLINE takeInterval #-}-takeInterval :: MonadAsync m => Double -> Fold m a b -> Fold m a b-takeInterval n (Fold step initial done) = Fold step' initial' done'+-- /Internal/+{-# INLINE refoldMany1 #-}+refoldMany1 :: Monad m => Refold m x a b -> Fold m b c -> Refold m x a c+refoldMany1 (Refold sstep sinject sextract) (Fold cstep cinitial cextract) =+    Refold step inject extract      where -    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+    -- cs = collect state+    -- ss = split state+    -- cres = collect state result+    -- sres = split state result+    -- cb = collect done+    -- sb = split done -    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)+    -- Caution! There is mutual recursion here, inlining the right functions is+    -- important. -    done' (Tuple3' s _ _) = done s+    {-# INLINE split #-}+    split x cs f sres =+        case sres of+            Partial ss -> return $ Partial $ ConsumeMany x cs (f ss)+            Done sb -> cstep cs sb >>= collect x -    timerThread mv = do-        liftIO $ threadDelay (round $ n * 1000000)-        -- Use IORef + CAS? instead of MVar since its a Bool?-        liftIO $ void $ swapMVar mv True+    {-# INLINE collect #-}+    collect x cres =+        case cres of+            Partial cs -> sinject x >>= split x cs Left+            Done cb -> return $ Done cb -    handleChildException :: MVar Bool -> SomeException -> IO ()-    handleChildException mv _ = void $ swapMVar mv True+    inject x = cinitial >>= collect x --- 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.+    {-# INLINE step_ #-}+    step_ x ss cs a = sstep ss a >>= split x cs Right --- | 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 step #-}+    step (ConsumeMany x cs (Left ss)) a = step_ x ss cs a+    step (ConsumeMany x cs (Right ss)) a = step_ x ss cs a++    -- Do not extract the split fold if no item was consumed.+    extract (ConsumeMany _ cs (Left _)) = cextract cs+    extract (ConsumeMany _ cs (Right ss )) = do+        cres <- sextract ss >>= cstep cs+        case cres of+            Partial s -> cextract s+            Done b -> return b++-- | Extract the output of a fold and refold it using a 'Refold'. ---{-# 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)+-- /Internal/+{-# INLINE refold #-}+refold :: Monad m => Fold m a b -> Refold m b a b -> Fold m a b+refold f (Refold step inject extract) = Fold step (finish f >>= inject) extract
src/Streamly/Internal/Data/IOFinalizer.hs view
@@ -23,7 +23,7 @@ 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)+import Streamly.Internal.Control.Concurrent (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
src/Streamly/Internal/Data/IORef/Prim.hs view
@@ -35,7 +35,6 @@      -- * Read     , readIORef-    , toStream     , toStreamD     ) where@@ -48,7 +47,6 @@ 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.@@ -100,11 +98,3 @@      {-# 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
@@ -72,11 +72,11 @@ #endif import GHC.Exts (IsList(..), IsString(..)) -import Streamly.Internal.Data.Stream.Serial (SerialT)-import Streamly.Internal.Data.Stream.Zip (ZipSerialM)+import Streamly.Internal.Data.Stream.Serial (SerialT(..))+import Streamly.Internal.Data.Stream.Zip (ZipSerialM(..)) -import qualified Streamly.Internal.Data.Stream.IsStream as Stream-import qualified Streamly.Internal.Data.Stream.StreamK as K+import qualified Streamly.Internal.Data.Stream.Serial as Serial+import qualified Streamly.Internal.Data.Stream.StreamK.Type as K  -- We implement list as a newtype instead of a type synonym to make type -- inference easier when using -XOverloadedLists and -XOverloadedStrings. When@@ -103,15 +103,15 @@  instance (a ~ Char) => IsString (List a) where     {-# INLINE fromString #-}-    fromString = List . Stream.fromList+    fromString = List . fromList  -- GHC versions 8.0 and below cannot derive IsList instance IsList (List a) where     type (Item (List a)) = a     {-# INLINE fromList #-}-    fromList = List . Stream.fromList+    fromList = List . fromList     {-# INLINE toList #-}-    toList = runIdentity . Stream.toList . toSerial+    toList = toList . toSerial  ------------------------------------------------------------------------------ -- Patterns@@ -128,8 +128,8 @@ -- -- @since 0.6.0 pattern Nil :: List a-pattern Nil <- (runIdentity . K.null . toSerial -> True) where-    Nil = List K.nil+pattern Nil <- (runIdentity . K.null . getSerialT . toSerial -> True) where+    Nil = List $ SerialT K.nil  infixr 5 `Cons` @@ -139,10 +139,15 @@ -- @since 0.6.0 pattern Cons :: a -> List a -> List a pattern Cons x xs <--    (fmap (second List) . runIdentity . K.uncons . toSerial-        -> Just (x, xs)) where-            Cons x xs = List $ K.cons x (toSerial xs)+    (fmap (second (List . SerialT))+        . runIdentity . K.uncons . getSerialT . toSerial+            -> Just (x, xs)+    ) +    where++    Cons x xs = List $ Serial.cons x (toSerial xs)+ #if __GLASGOW_HASKELL__ >= 802 {-# COMPLETE Nil, Cons #-} #endif@@ -165,24 +170,24 @@  instance (a ~ Char) => IsString (ZipList a) where     {-# INLINE fromString #-}-    fromString = ZipList . Stream.fromList+    fromString = ZipList . fromList  -- GHC versions 8.0 and below cannot derive IsList instance IsList (ZipList a) where     type (Item (ZipList a)) = a     {-# INLINE fromList #-}-    fromList = ZipList . Stream.fromList+    fromList = ZipList . fromList     {-# INLINE toList #-}-    toList = runIdentity . Stream.toList . K.adapt . toZipSerial+    toList = toList . toZipSerial  -- | Convert a 'ZipList' to a regular 'List' -- -- @since 0.6.0 fromZipList :: ZipList a -> List a-fromZipList = List . K.adapt . toZipSerial+fromZipList (ZipList zs) = List $ SerialT $ getZipSerialM zs  -- | Convert a regular 'List' to a 'ZipList' -- -- @since 0.6.0 toZipList :: List a -> ZipList a-toZipList = ZipList . K.adapt . toSerial+toZipList = ZipList . ZipSerialM . getSerialT . toSerial
src/Streamly/Internal/Data/Parser.hs view
@@ -51,6 +51,9 @@     , D.ParseError (..)     , D.Step (..) +    -- * Downgrade to Fold+    , toFold+     -- First order parsers     -- * Accumulators     , fromFold@@ -63,6 +66,7 @@     , peek     , eof     , satisfy+    , next     , maybe     , either @@ -78,6 +82,7 @@     , takeGE -- takeBetween n maxBound      -- Grab a sequence of input elements by inspecting them+    , takeP     , lookAhead     , takeWhileP     , takeWhile@@ -93,6 +98,7 @@     , wordBy     , groupBy     , groupByRolling+    , groupByRollingEither     , eqBy     -- | Unimplemented     --@@ -195,7 +201,7 @@     ) where -import Control.Monad.Catch (MonadCatch)+import Control.Monad.Catch (MonadCatch, MonadThrow) import Prelude        hiding (any, all, take, takeWhile, sequence, concatMap, maybe, either) @@ -216,6 +222,23 @@ -- >>> import qualified Streamly.Internal.Data.Parser as Parser  -------------------------------------------------------------------------------+-- Downgrade a parser to a Fold+-------------------------------------------------------------------------------+--+-- | Make a 'Fold' from a 'Parser'. The fold just throws an exception if the+-- parser fails or tries to backtrack.+--+-- This can be useful in combinators that accept a Fold and we know that a+-- Parser cannot fail or failure exception is acceptable as there is no way to+-- recover.+--+-- /Pre-release/+--+{-# INLINE toFold #-}+toFold :: MonadThrow m => Parser m a b -> Fold m a b+toFold p = D.toFold $ K.fromParserK p++------------------------------------------------------------------------------- -- Upgrade folds to parses ------------------------------------------------------------------------------- --@@ -320,6 +343,15 @@ satisfy :: MonadCatch m => (a -> Bool) -> Parser m a a satisfy = K.toParserK . D.satisfy +-- | Return the next element of the input. Returns 'Nothing'+-- on end of input. Also known as 'head'.+--+-- /Pre-release/+--+{-# INLINE next #-}+next :: MonadCatch m => Parser m a (Maybe a)+next = K.toParserK D.next+ -- | 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.@@ -678,6 +710,21 @@ groupByRolling :: MonadCatch m => (a -> a -> Bool) -> Fold m a b -> Parser m a b groupByRolling eq = K.toParserK . D.groupByRolling eq +-- | Like 'groupByRolling', but if the predicate is 'True' then collects using+-- the first fold as long as the predicate holds 'True', if the predicate is+-- 'False' collects using the second fold as long as it remains 'False'.+-- Returns 'Left' for the first case and 'Right' for the second case.+--+-- For example, if we want to detect sorted sequences in a stream, both+-- ascending and descending cases we can use 'groupByRollingEither (<=)+-- Fold.toList Fold.toList'.+--+-- /Unimplemented/+{-# INLINABLE groupByRollingEither #-}+groupByRollingEither :: MonadCatch m =>+    (a -> a -> Bool) -> Fold m a b -> Fold m a c -> Parser m a (Either b c)+groupByRollingEither eq f1 = K.toParserK . D.groupByRollingEither eq f1+ -- | Match the given sequence of elements using the given comparison function. -- -- >>> Stream.parse (Parser.eqBy (==) "string") $ Stream.fromList "string"@@ -852,6 +899,22 @@ lookAhead :: MonadCatch m => Parser m a b -> Parser m a b lookAhead p = K.toParserK $ D.lookAhead $ K.fromParserK p +-- | Takes at-most @n@ input elements.+--+-- * Stops - when the collecting parser stops.+-- * Fails - when the collecting parser fails.+--+-- >>> Stream.parse (Parser.takeP 4 (Parser.takeEQ 2 Fold.toList)) $ Stream.fromList [1, 2, 3, 4, 5]+-- [1,2]+--+-- >>> Stream.parse (Parser.takeP 4 (Parser.takeEQ 5 Fold.toList)) $ Stream.fromList [1, 2, 3, 4, 5]+-- *** Exception: ParseError "takeEQ: Expecting exactly 5 elements, input terminated on 4"+--+-- /Internal/+{-# INLINE takeP #-}+takeP :: MonadCatch m => Int -> Parser m a b -> Parser m a b+takeP i p = K.toParserK $ D.takeP i $ K.fromParserK p+ ------------------------------------------------------------------------------- -- Interleaving -------------------------------------------------------------------------------@@ -929,13 +992,12 @@ -- -- This is same as 'asum' but more efficient. ----- /Unimplemented/+-- /Broken/ -- {-# INLINE choice #-} choice ::-    -- Foldable t =>-    t (Parser m a b) -> Parser m a b-choice _ps = undefined+       (Functor t, Foldable t, MonadCatch m) => t (Parser m a b) -> Parser m a b+choice ps = K.toParserK $ D.choice $ K.fromParserK <$> ps  ------------------------------------------------------------------------------- -- Sequential Repetition
src/Streamly/Internal/Data/Parser/ParserD.hs view
@@ -18,6 +18,9 @@     , Initial (..)     , rmapM +    -- * Downgrade to Fold+    , toFold+     -- First order parsers     -- * Accumulators     , fromFold@@ -30,6 +33,7 @@     , peek     , eof     , satisfy+    , next     , maybe     , either @@ -52,6 +56,7 @@     , takeGE -- takeBetween n maxBound      -- Grab a sequence of input elements by inspecting them+    , takeP     , lookAhead     , takeWhile     , takeWhile1@@ -66,6 +71,7 @@     , wordBy     , groupBy     , groupByRolling+    , groupByRollingEither     , eqBy     -- , prefixOf -- match any prefix of a given string     -- , suffixOf -- match any suffix of a given string@@ -161,7 +167,8 @@     ) where -import Control.Exception (assert)+import Control.Exception (assert, Exception)+import Control.Monad (when) import Control.Monad.Catch (MonadCatch, MonadThrow(..)) import Fusion.Plugin.Types (Fuse(..)) import Streamly.Internal.Data.Fold.Type (Fold(..))@@ -184,6 +191,48 @@ -- >>> import qualified Streamly.Internal.Data.Parser as Parser  -------------------------------------------------------------------------------+-- Downgrade a parser to a Fold+-------------------------------------------------------------------------------++data ParserToFoldError =+      InitialError String+    | PartialError Int+    | ContinueError Int+    | DoneError Int+    | ErrorError String+    deriving Show++instance Exception ParserToFoldError++-- | See 'Streamly.Internal.Data.Parser.toFold'.+--+-- /Internal/+--+{-# INLINE toFold #-}+toFold :: MonadThrow m => Parser m a b -> Fold m a b+toFold (Parser pstep pinitial pextract) = Fold step initial pextract++    where++    initial = do+        r <- pinitial+        case r of+            IPartial s -> return $ FL.Partial s+            IDone b -> return $ FL.Done b+            IError err -> throwM $ InitialError err++    step st a = do+        r <- pstep st a+        case r of+            Partial 0 s -> return $ FL.Partial s+            Continue 0 s -> return $ FL.Partial s+            Done 0 b -> return $ FL.Done b+            Partial n _ -> throwM $ PartialError n+            Continue n _ -> throwM $ ContinueError n+            Done n _ -> throwM $ DoneError n+            Error err -> throwM $ ErrorError err++------------------------------------------------------------------------------- -- Upgrade folds to parses ------------------------------------------------------------------------------- --@@ -264,6 +313,18 @@      extract _ = throwM $ ParseError "satisfy: end of input" +-- | See 'Streamly.Internal.Data.Parser.next'.+--+-- /Pre-release/+--+{-# INLINE next #-}+next :: Monad m => Parser m a (Maybe a)+next = Parser step initial extract+  where+  initial = pure $ IPartial ()+  step _ a = pure $ Done 0 (Just a)+  extract _ = pure Nothing+ -- | See 'Streamly.Internal.Data.Parser.maybe'. -- -- /Pre-release/@@ -306,6 +367,10 @@ -- Taking elements ------------------------------------------------------------------------------- +-- Required to fuse "take" with "many" in "chunksOf", for ghc-9.x+{-# ANN type Tuple'Fused Fuse #-}+data Tuple'Fused a b = Tuple'Fused !a !b deriving Show+ -- | See 'Streamly.Internal.Data.Parser.takeBetween'. -- -- /Pre-release/@@ -314,62 +379,70 @@ takeBetween :: MonadCatch m => Int -> Int -> Fold m a b -> Parser m a b takeBetween low high (Fold fstep finitial fextract) = -    Parser step initial extract+    Parser step initial (extract streamErr)      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"+    streamErr i =+           "takeBetween: Expecting alteast " ++ show low+        ++ " elements, got " ++ show i -    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+    invalidRange =+        "takeBetween: lower bound - " ++ show low+            ++ " is greater than higher bound - " ++ show high -        where+    foldErr :: Int -> String+    foldErr i =+        "takeBetween: the collecting fold terminated after"+            ++ " consuming" ++ show i ++ " elements"+            ++ " minimum" ++ show low ++ " elements needed" -        i1 = i + 1+    -- Exactly the same as snext except different constructors, we can possibly+    -- deduplicate the two.+    {-# INLINE inext #-}+    inext i res =+        let i1 = i + 1+        in case res of+            FL.Partial s -> do+                let s1 = Tuple'Fused i1 s+                if i1 < high+                -- XXX ideally this should be a Continue instead+                then return $ IPartial s1+                else IDone <$> extract foldErr s1+            FL.Done b ->+                return+                    $ if i1 >= low+                      then IDone b+                      else IError (foldErr i1) -    extract (Tuple' i s)-        | i >= low && i <= high = fextract s-        | otherwise = throwM $ ParseError err+    initial = do+        when (low >= 0 && high >= 0 && low > high)+            $ throwM $ ParseError invalidRange -        where+        finitial >>= inext (-1) -        err =-               "takeBetween: Expecting alteast " ++ show low-            ++ " elements, got " ++ show i+    -- Keep the impl same as inext+    {-# INLINE snext #-}+    snext i res =+        let i1 = i + 1+        in case res of+            FL.Partial s -> do+                let s1 = Tuple'Fused i1 s+                if i1 < high+                then return $ Continue 0 s1+                else Done 0 <$> extract foldErr s1+            FL.Done b ->+                return+                    $ if i1 >= low+                      then Done 0 b+                      else Error (foldErr i1) +    step (Tuple'Fused i s) a = fstep s a >>= snext i++    extract f (Tuple'Fused i s)+        | i >= low && i <= high = fextract s+        | otherwise = throwM $ ParseError (f i)+ -- | See 'Streamly.Internal.Data.Parser.takeEQ'. -- -- /Pre-release/@@ -725,6 +798,94 @@     extract (GroupByInit s) = fextract s     extract (GroupByGrouping _ s) = fextract s +{-# ANN type GroupByStatePair Fuse #-}+data GroupByStatePair a s1 s2+    = GroupByInitPair !s1 !s2+    | GroupByGroupingPair !a !s1 !s2+    | GroupByGroupingPairL !a !s1 !s2+    | GroupByGroupingPairR !a !s1 !s2++{-# INLINABLE groupByRollingEither #-}+groupByRollingEither :: MonadCatch m =>+    (a -> a -> Bool) -> Fold m a b -> Fold m a c -> Parser m a (Either b c)+groupByRollingEither+    eq+    (Fold fstep1 finitial1 fextract1)+    (Fold fstep2 finitial2 fextract2) = Parser step initial extract++    where++    {-# INLINE grouper #-}+    grouper s1 s2 a = do+        return $ Continue 0 (GroupByGroupingPair a s1 s2)++    {-# INLINE grouperL2 #-}+    grouperL2 s1 s2 a = do+        res <- fstep1 s1 a+        return+            $ case res of+                FL.Done b -> Done 0 (Left b)+                FL.Partial s11 -> Partial 0 (GroupByGroupingPairL a s11 s2)++    {-# INLINE grouperL #-}+    grouperL s1 s2 a0 a = do+        res <- fstep1 s1 a0+        case res of+            FL.Done b -> return $ Done 0 (Left b)+            FL.Partial s11 -> grouperL2 s11 s2 a++    {-# INLINE grouperR2 #-}+    grouperR2 s1 s2 a = do+        res <- fstep2 s2 a+        return+            $ case res of+                FL.Done b -> Done 0 (Right b)+                FL.Partial s21 -> Partial 0 (GroupByGroupingPairR a s1 s21)++    {-# INLINE grouperR #-}+    grouperR s1 s2 a0 a = do+        res <- fstep2 s2 a0+        case res of+            FL.Done b -> return $ Done 0 (Right b)+            FL.Partial s21 -> grouperR2 s1 s21 a++    initial = do+        res1 <- finitial1+        res2 <- finitial2+        return+            $ case res1 of+                FL.Partial s1 ->+                    case res2 of+                        FL.Partial s2 -> IPartial $ GroupByInitPair s1 s2+                        FL.Done b -> IDone (Right b)+                FL.Done b -> IDone (Left b)++    step (GroupByInitPair s1 s2) a = grouper s1 s2 a++    step (GroupByGroupingPair a0 s1 s2) a =+        if not (eq a0 a)+        then grouperL s1 s2 a0 a+        else grouperR s1 s2 a0 a++    step (GroupByGroupingPairL a0 s1 s2) a =+        if not (eq a0 a)+        then grouperL2 s1 s2 a+        else Done 1 . Left <$> fextract1 s1++    step (GroupByGroupingPairR a0 s1 s2) a =+        if eq a0 a+        then grouperR2 s1 s2 a+        else Done 1 . Right <$> fextract2 s2++    extract (GroupByInitPair s1 _) = Left <$> fextract1 s1+    extract (GroupByGroupingPairL _ s1 _) = Left <$> fextract1 s1+    extract (GroupByGroupingPairR _ _ s2) = Right <$> fextract2 s2+    extract (GroupByGroupingPair a s1 _) = do+                res <- fstep1 s1 a+                case res of+                    FL.Done b -> return $ Left b+                    FL.Partial s11 -> Left <$> fextract1 s11+ -- XXX use an Unfold instead of a list? -- XXX custom combinators for matching list, array and stream? --@@ -814,6 +975,64 @@ -- nested parsers ------------------------------------------------------------------------------- +-- | See 'Streamly.Internal.Data.Parser.takeP'.+--+-- /Internal/+{-# INLINE takeP #-}+takeP :: Monad m => Int -> Parser m a b -> Parser m a b+takeP lim (Parser pstep pinitial pextract) = Parser step initial extract++    where++    initial = do+        res <- pinitial+        case res of+            IPartial s ->+                if lim > 0+                then return $ IPartial $ Tuple' 0 s+                else IDone <$> pextract s+            IDone b -> return $ IDone b+            IError e -> return $ IError e++    step (Tuple' cnt r) a = do+        assert (cnt < lim) (return ())+        res <- pstep r a+        let cnt1 = cnt + 1+        case res of+            Partial 0 s -> do+                assert (cnt1 >= 0) (return ())+                if cnt1 < lim+                then return $ Partial 0 $ Tuple' cnt1 s+                else Done 0 <$> pextract s+            Continue 0 s -> do+                assert (cnt1 >= 0) (return ())+                if cnt1 < lim+                then return $ Continue 0 $ Tuple' cnt1 s+                -- XXX This should error out?+                -- If designed properly, this will probably error out.+                -- "pextract" should error out+                --+                -- By Harendra,+                --+                -- This is a tricky case, we have the following options:+                --   1. Done 0 with extract as you have written+                --   2. Done n, will require buffering elements+                --   3. Use a backtracking fold and not a parser, once we have+                --      backtracking in folds+                else Done 0 <$> pextract s+            Partial n s -> do+                let taken = cnt1 - n+                assert (taken >= 0) (return ())+                return $ Partial n $ Tuple' taken s+            Continue n s -> do+                let taken = cnt1 - n+                assert (taken >= 0) (return ())+                return $ Continue n $ Tuple' taken s+            Done n b -> return $ Done n b+            Error str -> return $ Error str++    extract (Tuple' _ r) = pextract r+ -- | See 'Streamly.Internal.Data.Parser.lookahead'. -- -- /Pre-release/@@ -883,16 +1102,14 @@ ------------------------------------------------------------------------------- -- Alternative Collection ----------------------------------------------------------------------------------+ -- | See 'Streamly.Internal.Data.Parser.choice'. ----- /Unimplemented/+-- /Broken/ -- {-# INLINE choice #-}-choice ::-    -- Foldable t =>-    t (Parser m a b) -> Parser m a b-choice _ps = undefined+choice :: (MonadCatch m, Foldable t) => t (Parser m a b) -> Parser m a b+choice = foldl1 shortest  ------------------------------------------------------------------------------- -- Sequential Repetition
src/Streamly/Internal/Data/Parser/ParserD/Type.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE UndecidableInstances #-} #include "inline.hs"  -- |@@ -139,6 +140,9 @@ import Control.Applicative (Alternative(..), liftA2) import Control.Exception (assert, Exception(..)) import Control.Monad (MonadPlus(..), (>=>))+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Reader.Class (MonadReader, ask, local)+import Control.Monad.State.Class (MonadState, get, put) import Control.Monad.Catch (MonadCatch, try, throwM, MonadThrow) import Data.Bifunctor (Bifunctor(..)) import Fusion.Plugin.Types (Fuse(..))@@ -157,6 +161,19 @@ -- >>> import qualified Streamly.Internal.Data.Stream.IsStream as Stream (parse) -- >>> import qualified Streamly.Internal.Data.Parser as Parser +-- XXX The only differences between Initial and Step types are:+--+-- * There are no backtracking counts in Initial+-- * Continue and Partial are the same. Ideally Partial should mean that an+-- empty result is valid and can be extracted; and Continue should mean that+-- empty would result in an error on extraction. We can possibly distinguish+-- the two cases.+--+-- If we ignore the backtracking counts we can represent the Initial type using+-- Step itself. That will also simplify the implementation of various parsers+-- where the processing in intiial is just a sepcial case of step, see+-- takeBetween for example.+-- -- | The type of a 'Parser''s initial action. -- -- /Internal/@@ -199,6 +216,18 @@     {-# INLINE fmap #-}     fmap = second +-- We can simplify the Step type as follows:+--+-- Partial Int (Either s (s, b)) -- Left continue, right partial result+-- Done Int (Either String b)+--+-- In this case Error may also have a "leftover" return. This means that after+-- serveral successful partial results the last segment parsing failed and we+-- are returning the leftover of that. The driver may choose to restart from+-- the last segment where this parser failed or from the beginning.+--+-- Folds can only return the right values. Parsers can also return lefts.+ -- | The return type of a 'Parser' step. -- -- The parse operation feeds the input stream to the parser one element at a@@ -286,7 +315,8 @@ -- 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.+-- the fold. If the parser hits the end of input 'extract' is called.+-- It may result in an error or an output value. -- -- /Pre-release/ --@@ -1096,3 +1126,25 @@      {-# INLINE mplus #-}     mplus = alt++instance (MonadThrow m, MonadReader r m, MonadCatch m) => MonadReader r (Parser m a) where+    {-# INLINE ask #-}+    ask = fromEffect ask+    {-# INLINE local #-}+    local f (Parser step init' extract) =+      Parser ((local f .) . step)+             (local f init')+             (local f . extract)+++instance (MonadThrow m, MonadState s m) => MonadState s (Parser m a) where+    {-# INLINE get #-}+    get = fromEffect get+    {-# INLINE put #-}+    put = fromEffect . put+++instance (MonadThrow m, MonadIO m) => MonadIO (Parser m a) where+    {-# INLINE liftIO #-}+    liftIO = fromEffect . liftIO+
src/Streamly/Internal/Data/Parser/ParserK/Type.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE UndecidableInstances #-} #include "inline.hs"  -- |@@ -35,6 +36,9 @@ import Control.Exception (assert, Exception(..)) import Control.Monad (MonadPlus(..), ap) import Control.Monad.Catch (MonadCatch, MonadThrow(..), try)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Reader.Class (MonadReader, ask, local)+import Control.Monad.State.Class (MonadState, get, put) #if MIN_VERSION_base(4,9,0) import qualified Control.Monad.Fail as Fail #endif@@ -410,6 +414,25 @@     {-# INLINE fail #-}     fail = die #endif++instance (MonadThrow m, MonadReader r m, MonadCatch m) => MonadReader r (Parser m a) where+    {-# INLINE ask #-}+    ask = fromEffect ask+    {-# INLINE local #-}+    local f (fromParserK -> dp) =+      toParserK $ local f dp+++instance (MonadThrow m, MonadState s m) => MonadState s (Parser m a) where+    {-# INLINE get #-}+    get = fromEffect get+    {-# INLINE put #-}+    put = fromEffect . put+++instance (MonadThrow m, MonadIO m) => MonadIO (Parser m a) where+    {-# INLINE liftIO #-}+    liftIO = fromEffect . liftIO  ------------------------------------------------------------------------------- -- Alternative
src/Streamly/Internal/Data/Producer.hs view
@@ -46,7 +46,7 @@  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.SVar.Type (defState) import Streamly.Internal.Data.Unfold.Type (Unfold(..))  import Streamly.Internal.Data.Producer.Type
+ src/Streamly/Internal/Data/Refold/Type.hs view
@@ -0,0 +1,254 @@+-- |+-- Module      : Streamly.Internal.Data.Refold.Type+-- Copyright   : (c) 2019 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- The 'Fold' type embeds a default initial value, therefore, it is like a+-- 'Monoid' whereas the 'Refold' type has to be supplied with an initial+-- value, therefore, it is more like a 'Semigroup' operation.+--+-- Refolds can be appended to each other or to a fold to build the fold+-- incrementally. This is useful in incremental builder like use cases.+--+-- See the file splitting example in the @streamly-examples@ repository for an+-- application of the 'Refold' type. The 'Fold' type does not perform as well+-- in this situation.+--+-- 'Refold' type is to 'Fold' as 'Unfold' type is to 'Stream'. 'Unfold'+-- provides better optimizaiton than stream in nested operations, similarly,+-- 'Refold' provides better optimization than 'Fold'.+--+module Streamly.Internal.Data.Refold.Type+    (+    -- * Types+      Refold (..)++    -- * Constructors+    , foldl'++    -- * Refolds+    -- ** Accumulators+    , sconcat+    , drainBy+    , iterate++    -- * Combinators+    , lmapM+    , rmapM+    , append+    , take+    )+where++import Control.Monad ((>=>))+#if __GLASGOW_HASKELL__ < 804+import Data.Semigroup (Semigroup((<>)))+#endif+import Fusion.Plugin.Types (Fuse(..))+import Streamly.Internal.Data.Fold.Step (Step(..), mapMStep)++import Prelude hiding (take, iterate)++-- $setup+-- >>> :m+-- >>> import qualified Streamly.Internal.Data.Refold.Type as Refold+-- >>> import qualified Streamly.Internal.Data.Fold.Type as Fold+-- >>> import qualified Streamly.Internal.Data.Stream.IsStream as Stream++-- All folds in the Fold module should be implemented using Refolds.+--+-- | Like 'Fold' except that the initial state of the accmulator can be+-- generated using a dynamically supplied input. This affords better stream+-- fusion optimization in nested fold operations where the initial fold state+-- is determined based on a dynamic value.+--+-- /Internal/+data Refold m c a b =+  -- | @Fold @ @ step @ @ inject @ @ extract@+  forall s. Refold (s -> a -> m (Step s b)) (c -> m (Step s b)) (s -> m b)++------------------------------------------------------------------------------+-- Left fold constructors+------------------------------------------------------------------------------++-- | Make a consumer from a left fold style pure step function.+--+-- If your 'Fold' returns only 'Partial' (i.e. never returns a 'Done') then you+-- can use @foldl'*@ constructors.+--+-- See also: @Streamly.Prelude.foldl'@+--+-- /Internal/+--+{-# INLINE foldl' #-}+foldl' :: Monad m => (b -> a -> b) -> Refold m b a b+foldl' step =+    Refold+        (\s a -> return $ Partial $ step s a)+        (return . Partial)+        return++------------------------------------------------------------------------------+-- Mapping on input+------------------------------------------------------------------------------++-- | @lmapM f fold@ maps the monadic function @f@ on the input of the fold.+--+-- /Internal/+{-# INLINE lmapM #-}+lmapM :: Monad m => (a -> m b) -> Refold m c b r -> Refold m c a r+lmapM f (Refold step inject extract) = Refold step1 inject extract++    where++    step1 x a = f a >>= step x++------------------------------------------------------------------------------+-- Mapping on the output+------------------------------------------------------------------------------++-- | Map a monadic function on the output of a fold.+--+-- /Internal/+{-# INLINE rmapM #-}+rmapM :: Monad m => (b -> m c) -> Refold m x a b -> Refold m x a c+rmapM f (Refold step inject extract) = Refold step1 inject1 (extract >=> f)++    where++    inject1 x = inject x >>= mapMStep f+    step1 s a = step s a >>= mapMStep f++------------------------------------------------------------------------------+-- Refolds+------------------------------------------------------------------------------++-- |+--+-- /Internal/+{-# INLINE drainBy #-}+drainBy ::  Monad m => (c -> a -> m b) -> Refold m c a ()+drainBy f = Refold step inject extract++    where++    inject = return . Partial++    step c a = f c a >> return (Partial c)++    extract _ = return ()++------------------------------------------------------------------------------+-- Semigroup+------------------------------------------------------------------------------++-- | Append the elements of an input stream to a provided starting value.+--+-- >>> stream = Stream.map Data.Monoid.Sum $ Stream.enumerateFromTo 1 10+-- >>> Stream.fold (Fold.fromRefold Refold.sconcat 10) stream+-- Sum {getSum = 65}+--+-- >>> sconcat = Refold.foldl' (<>)+--+-- /Internal/+{-# INLINE sconcat #-}+sconcat :: (Monad m, Semigroup a) => Refold m a a a+sconcat = foldl' (<>)++------------------------------------------------------------------------------+-- append+------------------------------------------------------------------------------++-- | Supply the output of the first consumer as input to the second consumer.+--+-- /Internal/+{-# INLINE append #-}+append :: Monad m => Refold m x a b -> Refold m b a b -> Refold m x a b+append (Refold step1 inject1 extract1) (Refold step2 inject2 extract2) =+    Refold step inject extract++    where++    goLeft r = do+        case r of+            Partial s -> return $ Partial $ Left s+            Done b -> do+                r1 <- inject2 b+                return $ case r1 of+                    Partial s -> Partial $ Right s+                    Done b1 -> Done b1++    inject x = inject1 x >>= goLeft++    step (Left s) a = step1 s a >>= goLeft++    step (Right s) a = do+        r <- step2 s a+        case r of+            Partial s1 -> return $ Partial (Right s1)+            Done b -> return $ Done b++    extract (Left s) = extract1 s+    extract (Right s) = extract2 s++-- | Keep running the same consumer over and over again on the input, feeding+-- the output of the previous run to the next.+--+-- /Internal/+iterate :: Monad m => Refold m b a b -> Refold m b a b+iterate (Refold step1 inject1 extract1) =+    Refold step inject extract1++    where++    go r =+        case r of+            Partial s -> return $ Partial s+            Done b -> inject b++    inject x = inject1 x >>= go++    step s a = step1 s a >>= go++------------------------------------------------------------------------------+-- Transformation+------------------------------------------------------------------------------++-- Required to fuse "take" with "many" in "chunksOf", for ghc-9.x+{-# ANN type Tuple'Fused Fuse #-}+data Tuple'Fused a b = Tuple'Fused !a !b deriving Show++-- | Take at most @n@ input elements and fold them using the supplied fold. A+-- negative count is treated as 0.+--+-- /Internal/+{-# INLINE take #-}+take :: Monad m => Int -> Refold m x a b -> Refold m x a b+take n (Refold fstep finject fextract) = Refold step inject extract++    where++    inject x = do+        res <- finject x+        case res of+            Partial s ->+                if n > 0+                then return $ Partial $ Tuple'Fused 0 s+                else Done <$> fextract s+            Done b -> return $ Done b++    step (Tuple'Fused i r) a = do+        res <- fstep r a+        case res of+            Partial sres -> do+                let i1 = i + 1+                    s1 = Tuple'Fused i1 sres+                if i1 < n+                then return $ Partial s1+                else Done <$> fextract sres+            Done bres -> return $ Done bres++    extract (Tuple'Fused _ r) = fextract r
+ src/Streamly/Internal/Data/Ring.hs view
@@ -0,0 +1,44 @@+-- |+-- Module      : Streamly.Internal.Data.Ring+-- Copyright   : (c) 2021 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--++module Streamly.Internal.Data.Ring+    ( Ring(..)+    , createRing+    , unsafeInsertRing+    ) where++import Control.Monad.Primitive (PrimMonad(PrimState))+import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef, IORef)+import Data.Primitive.Array (newArray, writeArray, MutableArray)++data Ring a = Ring+    { arr :: MutableArray (PrimState IO) a+    , ringHead :: IORef Int -- current index to be over-written+    , ringMax :: !Int       -- first index beyond allocated memory+    }++{-# INLINE createRing #-}+createRing :: Int -> IO (Ring a)+createRing count = do+    arr' <- newArray count (undefined :: a)+    head' <- newIORef 0+    return (Ring+        { arr = arr'+        , ringHead = head'+        , ringMax = count+        })++{-# INLINE unsafeInsertRing #-}+unsafeInsertRing :: Ring a -> Int -> a -> IO ()+unsafeInsertRing Ring{..} idx x = do+    writeArray arr (mod idx ringMax) x+    ref <- readIORef ringHead+    if (ref+1) < ringMax+    then modifyIORef' ringHead ( + 1)+    else writeIORef ringHead 0
src/Streamly/Internal/Data/SVar.hs view
@@ -1,2410 +1,537 @@-{-# LANGUAGE UnboxedTuples #-}---- |--- Module      : Streamly.Internal.Data.SVar--- Copyright   : (c) 2017 Composewell Technologies------ License     : BSD3--- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC--module Streamly.Internal.Data.SVar-    (-      MonadAsync-    , SVarStyle (..)-    , SVarStopStyle (..)-    , SVar (..)--    -- State threaded around the stream-    , Limit (..)-    , State (streamVar)-    , defState-    , adaptState-    , getMaxThreads-    , setMaxThreads-    , getMaxBuffer-    , setMaxBuffer-    , getStreamRate-    , setStreamRate-    , setStreamLatency-    , getYieldLimit-    , setYieldLimit-    , getInspectMode-    , setInspectMode-    , recordMaxWorkers--    , cleanupSVar-    , cleanupSVarFromWorker--    -- SVar related-    , newAheadVar-    , newParallelVar-    , captureMonadState-    , RunInIO (..)--    , WorkerInfo (..)-    , YieldRateInfo (..)-    , ThreadAbort (..)-    , ChildEvent (..)-    , AheadHeapEntry (..)-    , send-    , sendToProducer-    , sendYield-    , sendStop-    , sendStopToProducer-    , enqueueLIFO-    , enqueueFIFO-    , enqueueAhead-    , reEnqueueAhead-    , pushWorkerPar-    , handleChildException-    , handleFoldException--    , queueEmptyAhead-    , dequeueAhead--    , HeapDequeueResult(..)-    , dequeueFromHeap-    , dequeueFromHeapSeq-    , requeueOnHeapTop-    , updateHeapSeq-    , withIORef-    , heapIsSane--    , Rate (..)-    , getYieldRateInfo-    , newSVarStats-    , collectLatency-    , workerUpdateLatency-    , isBeyondMaxRate-    , workerRateControl-    , updateYieldCount-    , decrementYieldLimit-    , incrementYieldLimit-    , decrementBufferLimit-    , incrementBufferLimit-    , postProcessBounded-    , postProcessPaced-    , readOutputQBounded-    , readOutputQPaced-    , readOutputQBasic-    , dispatchWorkerPaced-    , sendFirstWorker-    , delThread-    , modifyThread-    , doFork-    , fork-    , forkManaged--    , toStreamVar-    , SVarStats (..)-    , dumpSVar-    , printSVar-    , withDiagMVar-    )-where--import Control.Concurrent (ThreadId, myThreadId, threadDelay, throwTo)-import Control.Concurrent.MVar-       (MVar, newEmptyMVar, tryPutMVar, takeMVar, tryTakeMVar, newMVar,-        tryReadMVar)-import Control.Exception-       (SomeException(..), assert, Exception, catches,-        throwIO, Handler(..), BlockedIndefinitelyOnMVar(..),-        BlockedIndefinitelyOnSTM(..))-import Control.Monad (when)-import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad.Trans.Control (MonadBaseControl, control)-import Streamly.Internal.Data.Atomics-       (atomicModifyIORefCAS, atomicModifyIORefCAS_, writeBarrier,-        storeLoadBarrier)-import Data.Concurrent.Queue.MichaelScott (LinkedQueue, pushL)-import Data.Functor (void)-import Data.Heap (Heap, Entry(..))-import Data.Int (Int64)-import Data.IORef-       (IORef, modifyIORef, newIORef, readIORef, writeIORef, atomicModifyIORef)-import Data.Kind (Type)-import Data.Maybe (fromJust, fromMaybe)-#if __GLASGOW_HASKELL__ < 808-import Data.Semigroup ((<>))-#endif-import Data.Set (Set)-import System.IO (hPutStrLn, stderr)--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)--import qualified Data.Heap as H-import qualified Data.Set                    as S--newtype Count = Count Int64-    deriving ( Eq-             , Read-             , Show-             , Enum-             , Bounded-             , Num-             , Real-             , Integral-             , Ord-             )----------------------------------------------------------------------------------- Parent child thread communication type---------------------------------------------------------------------------------data ThreadAbort = ThreadAbort deriving Show--instance Exception ThreadAbort---- | Events that a child thread may send to a parent thread.-data ChildEvent a =-      ChildYield a-    | ChildStop ThreadId (Maybe SomeException)---- | Sorting out-of-turn outputs in a heap for Ahead style streams-data AheadHeapEntry (t :: (Type -> Type) -> Type -> Type) m a =-      AheadEntryNull-    | AheadEntryPure a-    | AheadEntryStream (RunInIO m, t m a)-#undef Type----------------------------------------------------------------------------------- State threaded around the monad for thread management----------------------------------------------------------------------------------- | Identify the type of the SVar. Two computations using the same style can--- be scheduled on the same SVar.-data SVarStyle =-      AsyncVar             -- depth first concurrent-    | WAsyncVar            -- breadth first concurrent-    | ParallelVar          -- all parallel-    | AheadVar             -- Concurrent look ahead-    deriving (Eq, Show)---- | An SVar or a Stream Var is a conduit to the output from multiple streams--- running concurrently and asynchronously. An SVar can be thought of as an--- asynchronous IO handle. We can write any number of streams to an SVar in a--- non-blocking manner and then read them back at any time at any pace.  The--- SVar would run the streams asynchronously and accumulate results. An SVar--- may not really execute the stream completely and accumulate all the results.--- However, it ensures that the reader can read the results at whatever paces--- it wants to read. The SVar monitors and adapts to the consumer's pace.------ An SVar is a mini scheduler, it has an associated workLoop that holds the--- stream tasks to be picked and run by a pool of worker threads. It has an--- associated output queue where the output stream elements are placed by the--- worker threads. A outputDoorBell is used by the worker threads to intimate the--- consumer thread about availability of new results in the output queue. More--- workers are added to the SVar by 'fromStreamVar' on demand if the output--- produced is not keeping pace with the consumer. On bounded SVars, workers--- block on the output queue to provide throttling of the producer  when the--- consumer is not pulling fast enough.  The number of workers may even get--- reduced depending on the consuming pace.------ New work is enqueued either at the time of creation of the SVar or as a--- result of executing the parallel combinators i.e. '<|' and '<|>' when the--- already enqueued computations get evaluated. See 'joinStreamVarAsync'.---- We measure the individual worker latencies to estimate the number of workers--- needed or the amount of time we have to sleep between dispatches to achieve--- a particular rate when controlled pace mode it used.-data WorkerInfo = WorkerInfo-    { workerYieldMax   :: Count -- 0 means unlimited-    -- total number of yields by the worker till now-    , workerYieldCount    :: IORef Count-    -- yieldCount at start, timestamp-    , workerLatencyStart  :: IORef (Count, AbsTime)-    }---- | Specifies the stream yield rate in yields per second (@Hertz@).--- We keep accumulating yield credits at 'rateGoal'. At any point of time we--- allow only as many yields as we have accumulated as per 'rateGoal' since the--- start of time. If the consumer or the producer is slower or faster, the--- actual rate may fall behind or exceed 'rateGoal'.  We try to recover the gap--- between the two by increasing or decreasing the pull rate from the producer.--- However, if the gap becomes more than 'rateBuffer' we try to recover only as--- much as 'rateBuffer'.------ 'rateLow' puts a bound on how low the instantaneous rate can go when--- recovering the rate gap.  In other words, it determines the maximum yield--- latency.  Similarly, 'rateHigh' puts a bound on how high the instantaneous--- rate can go when recovering the rate gap.  In other words, it determines the--- minimum yield latency. We reduce the latency by increasing concurrency,--- therefore we can say that it puts an upper bound on concurrency.------ If the 'rateGoal' is 0 or negative the stream never yields a value.--- If the 'rateBuffer' is 0 or negative we do not attempt to recover.------ /Since: 0.5.0 ("Streamly")/------ @since 0.8.0-data Rate = Rate-    { rateLow    :: Double -- ^ The lower rate limit-    , rateGoal   :: Double -- ^ The target rate we want to achieve-    , rateHigh   :: Double -- ^ The upper rate limit-    , rateBuffer :: Int    -- ^ Maximum slack from the goal-    }--data LatencyRange = LatencyRange-    { minLatency :: NanoSecond64-    , maxLatency :: NanoSecond64-    } deriving Show---- Rate control.-data YieldRateInfo = YieldRateInfo-    { svarLatencyTarget    :: NanoSecond64-    , svarLatencyRange     :: LatencyRange-    , svarRateBuffer       :: Int--    -- [LOCKING] Unlocked access. Modified by the consumer thread and unsafely-    -- read by the worker threads-    , svarGainedLostYields :: IORef Count--    -- Actual latency/througput as seen from the consumer side, we count the-    -- yields and the time it took to generates those yields. This is used to-    -- increase or decrease the number of workers needed to achieve the desired-    -- rate. The idle time of workers is adjusted in this, so that we only-    -- account for the rate when the consumer actually demands data.-    -- XXX interval latency is enough, we can move this under diagnostics build-    -- [LOCKING] Unlocked access. Modified by the consumer thread and unsafely-    -- read by the worker threads-    , svarAllTimeLatency :: IORef (Count, AbsTime)--    -- XXX Worker latency specified by the user to be used before the first-    -- actual measurement arrives. Not yet implemented-    , workerBootstrapLatency :: Maybe NanoSecond64--    -- After how many yields the worker should update the latency information.-    -- If the latency is high, this count is kept lower and vice-versa.  XXX If-    -- the latency suddenly becomes too high this count may remain too high for-    -- long time, in such cases the consumer can change it.-    -- 0 means no latency computation-    -- XXX this is derivable from workerMeasuredLatency, can be removed.-    -- [LOCKING] Unlocked access. Modified by the consumer thread and unsafely-    -- read by the worker threads-    , workerPollingInterval :: IORef Count--    -- This is in progress latency stats maintained by the workers which we-    -- empty into workerCollectedLatency stats at certain intervals - whenever-    -- we process the stream elements yielded in this period. The first count-    -- is all yields, the second count is only those yields for which the-    -- latency was measured to be non-zero (note that if the timer resolution-    -- is low the measured latency may be zero e.g. on JS platform).-    -- [LOCKING] Locked access. Modified by the consumer thread as well as-    -- worker threads. Workers modify it periodically based on-    -- workerPollingInterval and not on every yield to reduce the locking-    -- overhead.-    -- (allYieldCount, yieldCount, timeTaken)-    , workerPendingLatency   :: IORef (Count, Count, NanoSecond64)--    -- This is the second level stat which is an accmulation from-    -- workerPendingLatency stats. We keep accumulating latencies in this-    -- bucket until we have stats for a sufficient period and then we reset it-    -- to start collecting for the next period and retain the computed average-    -- latency for the last period in workerMeasuredLatency.-    -- [LOCKING] Unlocked access. Modified by the consumer thread and unsafely-    -- read by the worker threads-    -- (allYieldCount, yieldCount, timeTaken)-    , workerCollectedLatency :: IORef (Count, Count, NanoSecond64)--    -- Latency as measured by workers, aggregated for the last period.-    -- [LOCKING] Unlocked access. Modified by the consumer thread and unsafely-    -- read by the worker threads-    , workerMeasuredLatency :: IORef NanoSecond64-    }--data SVarStats = SVarStats {-      totalDispatches  :: IORef Int-    , maxWorkers       :: IORef Int-    , maxOutQSize      :: IORef Int-    , maxHeapSize      :: IORef Int-    , maxWorkQSize     :: IORef Int-    , avgWorkerLatency :: IORef (Count, NanoSecond64)-    , minWorkerLatency :: IORef NanoSecond64-    , maxWorkerLatency :: IORef NanoSecond64-    , svarStopTime     :: IORef (Maybe AbsTime)-}---- This is essentially a 'Maybe Word' type-data Limit = Unlimited | Limited Word deriving Show--instance Eq Limit where-    Unlimited == Unlimited = True-    Unlimited == Limited _ = False-    Limited _ == Unlimited = False-    Limited x == Limited y = x == y--instance Ord Limit where-    Unlimited <= Unlimited = True-    Unlimited <= Limited _ = False-    Limited _ <= Unlimited = True-    Limited x <= Limited y = x <= y---- When to stop the composed stream.-data SVarStopStyle =-      StopNone -- stops only when all streams are finished-    | StopAny  -- stop when any stream finishes-    | StopBy   -- stop when a specific stream finishes-    deriving (Eq, Show)---- | Buffering policy for persistent push workers (in ParallelT).  In a pull--- style SVar (in AsyncT, AheadT etc.), the consumer side dispatches workers on--- demand, workers terminate if the buffer is full or if the consumer is not--- cosuming fast enough.  In a push style SVar, a worker is dispatched only--- once, workers are persistent and keep pushing work to the consumer via a--- bounded buffer. If the buffer becomes full the worker either blocks, or it--- can drop an item from the buffer to make space.------ Pull style SVars are useful in lazy stream evaluation whereas push style--- SVars are useful in strict left Folds.------ XXX Maybe we can separate the implementation in two different types instead--- of using a common SVar type.----data PushBufferPolicy =-      PushBufferDropNew  -- drop the latest element and continue-    | PushBufferDropOld  -- drop the oldest element and continue-    | PushBufferBlock    -- block the thread until space-                         -- becomes available---- IMPORTANT NOTE: we cannot update the SVar after generating it as we have--- references to the original SVar stored in several functions which will keep--- pointing to the original data and the new updates won't reflect there.--- Any updateable parts must be kept in mutable references (IORef).----data SVar t m a = SVar-    {-    -- Read only state-      svarStyle       :: SVarStyle-    , svarMrun        :: RunInIO m-    , svarStopStyle   :: SVarStopStyle-    , svarStopBy      :: IORef ThreadId--    -- Shared output queue (events, length)-    -- XXX For better efficiency we can try a preallocated array type (perhaps-    -- something like a vector) that allows an O(1) append. That way we will-    -- avoid constructing and reversing the list. Possibly we can also avoid-    -- the GC copying overhead. When the size increases we should be able to-    -- allocate the array in chunks.-    ---    -- [LOCKING] Frequent locked access. This is updated by workers on each-    -- yield and once in a while read by the consumer thread. This could have-    -- big locking overhead if the number of workers is high.-    ---    -- XXX We can use a per-CPU data structure to reduce the locking overhead.-    -- However, a per-cpu structure cannot guarantee the exact sequence in-    -- which the elements were added, though that may not be important.-    , outputQueue    :: IORef ([ChildEvent a], Int)--    -- [LOCKING] Infrequent MVar. Used when the outputQ transitions from empty-    -- to non-empty, or a work item is queued by a worker to the work queue and-    -- needDoorBell is set by the consumer.-    , outputDoorBell :: MVar ()  -- signal the consumer about output-    , readOutputQ    :: m [ChildEvent a]-    , postProcess    :: m Bool--    -- channel to send events from the consumer to the worker. Used to send-    -- exceptions from a fold driver to the fold computation running as a-    -- consumer thread in the concurrent fold cases. Currently only one event-    -- is sent by the fold so we do not really need a queue for it.-    , outputQueueFromConsumer :: IORef ([ChildEvent a], Int)-    , outputDoorBellFromConsumer :: MVar ()--    -- Combined/aggregate parameters-    -- This is truncated to maxBufferLimit if set to more than that. Otherwise-    -- potentially each worker may yield one value to the buffer in the worst-    -- case exceeding the requested buffer size.-    , maxWorkerLimit :: Limit-    , maxBufferLimit :: Limit-    -- These two are valid and used only when maxBufferLimit is Limited.-    , pushBufferSpace  :: IORef Count-    , pushBufferPolicy :: PushBufferPolicy-    -- [LOCKING] The consumer puts this MVar after emptying the buffer, workers-    -- block on it when the buffer becomes full. No overhead unless the buffer-    -- becomes full.-    , pushBufferMVar :: MVar ()--    -- [LOCKING] Read only access by consumer when dispatching a worker.-    -- Decremented by workers when picking work and undo decrement if the-    -- worker does not yield a value.-    , remainingWork  :: Maybe (IORef Count)-    , yieldRateInfo  :: Maybe YieldRateInfo--    -- Used only by bounded SVar types-    , enqueue        :: (RunInIO m, t m a) -> IO ()-    , isWorkDone     :: IO Bool-    , isQueueDone    :: IO Bool-    , needDoorBell   :: IORef Bool-    , workLoop       :: Maybe WorkerInfo -> m ()--    -- Shared, thread tracking-    -- [LOCKING] Updated unlocked only by consumer thread in case of-    -- Async/Ahead style SVars. Updated locked by worker threads in case of-    -- Parallel style.-    , workerThreads  :: IORef (Set ThreadId)-    -- [LOCKING] Updated locked by consumer thread when dispatching a worker-    -- and by the worker threads when the thread stops. This is read unsafely-    -- at several places where we want to rely on an approximate value.-    , workerCount    :: IORef Int-    , accountThread  :: ThreadId -> m ()-    , workerStopMVar :: MVar ()--    , svarStats      :: SVarStats-    -- to track garbage collection of SVar-    , svarRef        :: Maybe (IORef ())--    -- Only for diagnostics-    , svarInspectMode :: Bool-    , svarCreator    :: ThreadId-    , outputHeap     :: IORef ( Heap (Entry Int (AheadHeapEntry t m a))-                              , Maybe Int)-    -- Shared work queue (stream, seqNo)-    , aheadWorkQueue :: IORef ([t m a], Int)-    }------------------------------------------------------------------------------------ State for concurrency control------------------------------------------------------------------------------------ XXX we can put the resettable fields in a oneShotConfig field and others in--- a persistentConfig field. That way reset would be fast and scalable--- irrespective of the number of fields.------ XXX make all these Limited types and use phantom types to distinguish them-data State t m a = State-    { -- one shot configuration, automatically reset for each API call-      streamVar   :: Maybe (SVar t m a)-    , _yieldLimit  :: Maybe Count--    -- persistent configuration, state that remains valid until changed by-    -- an explicit setting via a combinator.-    , _threadsHigh    :: Limit-    , _bufferHigh     :: Limit-    -- XXX these two can be collapsed into a single type-    , _streamLatency  :: Maybe NanoSecond64 -- bootstrap latency-    , _maxStreamRate  :: Maybe Rate-    , _inspectMode    :: Bool-    }------------------------------------------------------------------------------------ State defaults and reset------------------------------------------------------------------------------------ A magical value for the buffer size arrived at by running the smallest--- possible task and measuring the optimal value of the buffer for that.  This--- is obviously dependent on hardware, this figure is based on a 2.2GHz intel--- core-i7 processor.-magicMaxBuffer :: Word-magicMaxBuffer = 1500--defaultMaxThreads, defaultMaxBuffer :: Limit-defaultMaxThreads = Limited magicMaxBuffer-defaultMaxBuffer = Limited magicMaxBuffer---- The fields prefixed by an _ are not to be accessed or updated directly but--- via smart accessor APIs.-defState :: State t m a-defState = State-    { streamVar = Nothing-    , _yieldLimit = Nothing-    , _threadsHigh = defaultMaxThreads-    , _bufferHigh = defaultMaxBuffer-    , _maxStreamRate = Nothing-    , _streamLatency = Nothing-    , _inspectMode = False-    }---- XXX if perf gets affected we can have all the Nothing params in a single--- structure so that we reset is fast. We can also use rewrite rules such that--- reset occurs only in concurrent streams to reduce the impact on serial--- streams.--- We can optimize this so that we clear it only if it is a Just value, it--- results in slightly better perf for zip/zipM but the performance of scan--- worsens a lot, it does not fuse.------ XXX This has a side effect of clearing the SVar and yieldLimit, therefore it--- should not be used to convert from the same type to the same type, unless--- you want to clear the SVar. For clearing the SVar you should be using the--- appropriate unStream functions instead.------ | Adapt the stream state from one type to another.-adaptState :: State t m a -> State t n b-adaptState st = st-    { streamVar = Nothing-    , _yieldLimit = Nothing-    }------------------------------------------------------------------------------------ Smart get/set routines for State------------------------------------------------------------------------------------ Use get/set routines instead of directly accessing the State fields-setYieldLimit :: Maybe Int64 -> State t m a -> State t m a-setYieldLimit lim st =-    st { _yieldLimit =-            case lim of-                Nothing -> Nothing-                Just n  ->-                    if n <= 0-                    then Just 0-                    else Just (fromIntegral n)-       }--getYieldLimit :: State t m a -> Maybe Count-getYieldLimit = _yieldLimit--setMaxThreads :: Int -> State t m a -> State t m a-setMaxThreads n st =-    st { _threadsHigh =-            if n < 0-            then Unlimited-            else if n == 0-                 then defaultMaxThreads-                 else Limited (fromIntegral n)-       }--getMaxThreads :: State t m a -> Limit-getMaxThreads = _threadsHigh--setMaxBuffer :: Int -> State t m a -> State t m a-setMaxBuffer n st =-    st { _bufferHigh =-            if n < 0-            then Unlimited-            else if n == 0-                 then defaultMaxBuffer-                 else Limited (fromIntegral n)-       }--getMaxBuffer :: State t m a -> Limit-getMaxBuffer = _bufferHigh--setStreamRate :: Maybe Rate -> State t m a -> State t m a-setStreamRate r st = st { _maxStreamRate = r }--getStreamRate :: State t m a -> Maybe Rate-getStreamRate = _maxStreamRate--setStreamLatency :: Int -> State t m a -> State t m a-setStreamLatency n st =-    st { _streamLatency =-            if n <= 0-            then Nothing-            else Just (fromIntegral n)-       }--getStreamLatency :: State t m a -> Maybe NanoSecond64-getStreamLatency = _streamLatency--setInspectMode :: State t m a -> State t m a-setInspectMode st = st { _inspectMode = True }--getInspectMode :: State t m a -> Bool-getInspectMode = _inspectMode------------------------------------------------------------------------------------ Cleanup----------------------------------------------------------------------------------cleanupSVar :: SVar t m a -> IO ()-cleanupSVar sv = do-    workers <- readIORef (workerThreads sv)-    Prelude.mapM_ (`throwTo` ThreadAbort)-          workers--cleanupSVarFromWorker :: SVar t m a -> IO ()-cleanupSVarFromWorker sv = do-    workers <- readIORef (workerThreads sv)-    self <- myThreadId-    Prelude.mapM_ (`throwTo` ThreadAbort)-          (Prelude.filter (/= self) $ S.toList workers)------------------------------------------------------------------------------------ Worker latency data collection------------------------------------------------------------------------------------ Every once in a while workers update the latencies and check the yield rate.--- They return if we are above the expected yield rate. If we check too often--- it may impact performance, if we check less often we may have a stale--- picture. We update every minThreadDelay but we translate that into a yield--- count based on latency so that the checking overhead is little.------ XXX use a generation count to indicate that the value is updated. If the--- value is updated an existing worker must check it again on the next yield.--- Otherwise it is possible that we may keep updating it and because of the mod--- worker keeps skipping it.-updateWorkerPollingInterval :: YieldRateInfo -> NanoSecond64 -> IO ()-updateWorkerPollingInterval yinfo latency = do-    let periodRef = workerPollingInterval yinfo-        cnt = max 1 $ minThreadDelay `div` latency-        period = min cnt (fromIntegral magicMaxBuffer)--    writeIORef periodRef (fromIntegral period)--{-# INLINE recordMinMaxLatency #-}-recordMinMaxLatency :: SVar t m a -> NanoSecond64 -> IO ()-recordMinMaxLatency sv new = do-    let ss = svarStats sv-    minLat <- readIORef (minWorkerLatency ss)-    when (new < minLat || minLat == 0) $-        writeIORef (minWorkerLatency ss) new--    maxLat <- readIORef (maxWorkerLatency ss)-    when (new > maxLat) $ writeIORef (maxWorkerLatency ss) new--recordAvgLatency :: SVar t m a -> (Count, NanoSecond64) -> IO ()-recordAvgLatency sv (count, time) = do-    let ss = svarStats sv-    modifyIORef (avgWorkerLatency ss) $-        \(cnt, t) -> (cnt + count, t + time)---- Pour the pending latency stats into a collection bucket-{-# INLINE collectWorkerPendingLatency #-}-collectWorkerPendingLatency-    :: IORef (Count, Count, NanoSecond64)-    -> IORef (Count, Count, NanoSecond64)-    -> IO (Count, Maybe (Count, NanoSecond64))-collectWorkerPendingLatency cur col = do-    (fcount, count, time) <- atomicModifyIORefCAS cur $ \v -> ((0,0,0), v)--    (fcnt, cnt, t) <- readIORef col-    let totalCount = fcnt + fcount-        latCount   = cnt + count-        latTime    = t + time-    writeIORef col (totalCount, latCount, latTime)--    assert (latCount == 0 || latTime /= 0) (return ())-    let latPair =-            if latCount > 0 && latTime > 0-            then Just (latCount, latTime)-            else Nothing-    return (totalCount, latPair)--{-# INLINE shouldUseCollectedBatch #-}-shouldUseCollectedBatch-    :: Count-    -> NanoSecond64-    -> NanoSecond64-    -> NanoSecond64-    -> Bool-shouldUseCollectedBatch collectedYields collectedTime newLat prevLat =-    let r = fromIntegral newLat / fromIntegral prevLat :: Double-    in     (collectedYields > fromIntegral magicMaxBuffer)-        || (collectedTime > minThreadDelay)-        || (prevLat > 0 && (r > 2 || r < 0.5))-        || (prevLat == 0)---- Returns a triple, (1) yield count since last collection, (2) the base time--- when we started counting, (3) average latency in the last measurement--- period. The former two are used for accurate measurement of the going rate--- whereas the average is used for future estimates e.g. how many workers--- should be maintained to maintain the rate.--- CAUTION! keep it in sync with getWorkerLatency-collectLatency :: SVar t m a-               -> YieldRateInfo-               -> Bool-               -> IO (Count, AbsTime, NanoSecond64)-collectLatency sv yinfo drain = do-    let cur      = workerPendingLatency yinfo-        col      = workerCollectedLatency yinfo-        longTerm = svarAllTimeLatency yinfo-        measured = workerMeasuredLatency yinfo--    (newCount, newLatPair) <- collectWorkerPendingLatency cur col-    (lcount, ltime) <- readIORef longTerm-    prevLat <- readIORef measured--    let newLcount = lcount + newCount-        retWith lat = return (newLcount, ltime, lat)--    case newLatPair of-        Nothing -> retWith prevLat-        Just (count, time) -> do-            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,-            -- otherwise we return the previous latency derived from the-            -- previous batch.-            if shouldUseCollectedBatch newCount time newLat prevLat || drain-            then do-                -- XXX make this NOINLINE?-                updateWorkerPollingInterval yinfo (max newLat prevLat)-                when (svarInspectMode sv) $ recordAvgLatency sv (count, time)-                writeIORef col (0, 0, 0)-                writeIORef measured ((prevLat + newLat) `div` 2)-                modifyIORef longTerm $ \(_, t) -> (newLcount, t)-                retWith newLat-            else retWith prevLat------------------------------------------------------------------------------------ Dumping the SVar for debug/diag----------------------------------------------------------------------------------dumpSVarStats :: SVar t m a -> SVarStats -> SVarStyle -> IO String-dumpSVarStats sv ss style = do-    case yieldRateInfo sv of-        Nothing -> return ()-        Just yinfo -> do-            _ <- liftIO $ collectLatency sv yinfo True-            return ()--    dispatches <- readIORef $ totalDispatches ss-    maxWrk <- readIORef $ maxWorkers ss-    maxOq <- readIORef $ maxOutQSize ss-    maxHp <- readIORef $ maxHeapSize ss-    minLat <- readIORef $ minWorkerLatency ss-    maxLat <- readIORef $ maxWorkerLatency ss-    (avgCnt, avgTime) <- readIORef $ avgWorkerLatency ss-    (svarCnt, svarGainLossCnt, svarLat) <- case yieldRateInfo sv of-        Nothing -> return (0, 0, 0)-        Just yinfo -> do-            (cnt, startTime) <- readIORef $ svarAllTimeLatency yinfo-            if cnt > 0-            then do-                t <- readIORef (svarStopTime ss)-                gl <- readIORef (svarGainedLostYields yinfo)-                case t of-                    Nothing -> do-                        now <- getTime Monotonic-                        let interval = diffAbsTime64 now startTime-                        return (cnt, gl, interval `div` fromIntegral cnt)-                    Just stopTime -> do-                        let interval = diffAbsTime64 stopTime startTime-                        return (cnt, gl, interval `div` fromIntegral cnt)-            else return (0, 0, 0)--    return $ unlines-        [ "total dispatches = " <> show dispatches-        , "max workers = " <> show maxWrk-        , "max outQSize = " <> show maxOq-            <> (if style == AheadVar-               then "\nheap max size = " <> show maxHp-               else "")-            <> (if minLat > 0-               then "\nmin worker latency = " <> showNanoSecond64 minLat-               else "")-            <> (if maxLat > 0-               then "\nmax worker latency = " <> showNanoSecond64 maxLat-               else "")-            <> (if avgCnt > 0-                then let lat = avgTime `div` fromIntegral avgCnt-                     in "\navg worker latency = " <> showNanoSecond64 lat-                else "")-            <> (if svarLat > 0-               then "\nSVar latency = " <> showRelTime64 svarLat-               else "")-            <> (if svarCnt > 0-               then "\nSVar yield count = " <> show svarCnt-               else "")-            <> (if svarGainLossCnt > 0-               then "\nSVar gain/loss yield count = " <> show svarGainLossCnt-               else "")-        ]--{-# NOINLINE dumpSVar #-}-dumpSVar :: SVar t m a -> IO String-dumpSVar sv = do-    (oqList, oqLen) <- readIORef $ outputQueue sv-    db <- tryReadMVar $ outputDoorBell sv-    aheadDump <--        if svarStyle sv == AheadVar-        then do-            (oheap, oheapSeq) <- readIORef $ outputHeap sv-            (wq, wqSeq) <- readIORef $ aheadWorkQueue sv-            return $ unlines-                [ "heap length = " <> show (H.size oheap)-                , "heap seqeunce = " <> show oheapSeq-                , "work queue length = " <> show (length wq)-                , "work queue sequence = " <> show wqSeq-                ]-        else return []--    let style = svarStyle sv-    waiting <--        if style /= ParallelVar-        then readIORef $ needDoorBell sv-        else return False-    rthread <- readIORef $ workerThreads sv-    workers <- readIORef $ workerCount sv-    stats <- dumpSVarStats sv (svarStats sv) (svarStyle sv)--    return $ unlines-        [-          "Creator tid = " <> show (svarCreator sv),-          "style = " <> show (svarStyle sv)-        , "---------CURRENT STATE-----------"-        , "outputQueue length computed  = " <> show (length oqList)-        , "outputQueue length maintained = " <> show oqLen-        -- XXX print the types of events in the outputQueue, first 5-        , "outputDoorBell = " <> show db-        ]-        <> aheadDump-        <> unlines-        [ "needDoorBell = " <> show waiting-        , "running threads = " <> show rthread-        -- XXX print the status of first 5 threads-        , "running thread count = " <> show workers-        ]-        <> "---------STATS-----------\n"-        <> stats--printSVar :: SVar t m a -> String -> IO ()-printSVar sv how = do-    svInfo <- dumpSVar sv-    hPutStrLn stderr $ "\n" <> how <> "\n" <> svInfo---- 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.--{-# NOINLINE mvarExcHandler #-}-mvarExcHandler :: SVar t m a -> String -> BlockedIndefinitelyOnMVar -> IO ()-mvarExcHandler sv label e@BlockedIndefinitelyOnMVar = do-    svInfo <- dumpSVar sv-    hPutStrLn stderr $ label <> " " <> "BlockedIndefinitelyOnMVar\n" <> svInfo-    throwIO e--{-# NOINLINE stmExcHandler #-}-stmExcHandler :: SVar t m a -> String -> BlockedIndefinitelyOnSTM -> IO ()-stmExcHandler sv label e@BlockedIndefinitelyOnSTM = do-    svInfo <- dumpSVar sv-    hPutStrLn stderr $ label <> " " <> "BlockedIndefinitelyOnSTM\n" <> svInfo-    throwIO e--withDiagMVar :: SVar t m a -> String -> IO () -> IO ()-withDiagMVar sv label action =-    if svarInspectMode sv-    then-        action `catches` [ Handler (mvarExcHandler sv label)-                         , Handler (stmExcHandler sv label)-                         ]-    else action----------------------------------------------------------------------------------- Spawning threads----------------------------------------------------------------------------------- | 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.-captureMonadState :: MonadBaseControl IO m => m (RunInIO m)-captureMonadState = control $ \run -> run (return $ RunInIO run)----------------------------------------------------------------------------------- Collecting results from child workers in a streamed fashion----------------------------------------------------------------------------------- XXX Can we make access to remainingWork and yieldRateInfo fields in sv--- faster, along with the fields in sv required by send?--- XXX make it noinline------ XXX we may want to employ an increment and decrement in batches when the--- througput is high or when the cost of synchronization is high. For example--- if the application is distributed then inc/dec of a shared variable may be--- very costly.------ A worker decrements the yield limit before it executes an action. However,--- the action may not result in an element being yielded, in that case we have--- to increment the yield limit.------ Note that we need it to be an Int type so that we have the ability to undo a--- decrement that takes it below zero.-{-# INLINE decrementYieldLimit #-}-decrementYieldLimit :: SVar t m a -> IO Bool-decrementYieldLimit sv =-    case remainingWork sv of-        Nothing -> return True-        Just ref -> do-            r <- atomicModifyIORefCAS ref $ \x -> (x - 1, x)-            return $ r >= 1--{-# INLINE incrementYieldLimit #-}-incrementYieldLimit :: SVar t m a -> IO ()-incrementYieldLimit sv =-    case remainingWork sv of-        Nothing -> return ()-        Just ref -> atomicModifyIORefCAS_ ref (+ 1)---- XXX exception safety of all atomic/MVar operations---- TBD Each worker can have their own queue and the consumer can empty one--- queue at a time, that way contention can be reduced.---- XXX Only yields should be counted in the buffer limit and not the Stop--- events.--{-# INLINE decrementBufferLimit #-}-decrementBufferLimit :: SVar t m a -> IO ()-decrementBufferLimit sv =-    case maxBufferLimit sv of-        Unlimited -> return ()-        Limited _ -> do-            let ref = pushBufferSpace sv-            old <- atomicModifyIORefCAS ref $ \x ->-                        (if x >= 1 then x - 1 else x, x)-            when (old <= 0) $-                case pushBufferPolicy sv of-                    PushBufferBlock -> blockAndRetry-                    PushBufferDropNew -> do-                        -- We just drop one item and proceed. It is possible-                        -- that by the time we drop the item the consumer-                        -- thread might have run and created space in the-                        -- buffer, but we do not care about that condition.-                        -- This is not pedantically correct but it should be-                        -- fine in practice.-                        -- XXX we may want to drop only if n == maxBuf-                        -- otherwise we must have space in the buffer and a-                        -- decrement should be possible.-                        block <- atomicModifyIORefCAS (outputQueue sv) $-                            \(es, n) ->-                                case es of-                                    [] -> (([],n), True)-                                    _ : xs -> ((xs, n - 1), False)-                        when block blockAndRetry-                    -- XXX need a dequeue or ring buffer for this-                    PushBufferDropOld -> undefined--    where--    blockAndRetry = do-        let ref = pushBufferSpace sv-        liftIO $ takeMVar (pushBufferMVar sv)-        old <- atomicModifyIORefCAS ref $ \x ->-                        (if x >= 1 then x - 1 else x, x)-        -- When multiple threads sleep on takeMVar, the first thread would-        -- wakeup due to a putMVar by the consumer, but the rest of the threads-        -- would have to put back the MVar after taking it and decrementing the-        -- buffer count, otherwise all other threads will remain asleep.-        if old >= 1-        then void $ liftIO $ tryPutMVar (pushBufferMVar sv) ()-        -- We do not put the MVar back in this case, instead we-        -- wait for the consumer to put it.-        else blockAndRetry--{-# INLINE incrementBufferLimit #-}-incrementBufferLimit :: SVar t m a -> IO ()-incrementBufferLimit sv =-    case maxBufferLimit sv of-        Unlimited -> return ()-        Limited _ -> do-            atomicModifyIORefCAS_ (pushBufferSpace sv) (+ 1)-            writeBarrier-            void $ liftIO $ tryPutMVar (pushBufferMVar sv) ()--{-# INLINE resetBufferLimit #-}-resetBufferLimit :: SVar t m a -> IO ()-resetBufferLimit sv =-    case maxBufferLimit sv of-        Unlimited -> return ()-        Limited n -> atomicModifyIORefCAS_ (pushBufferSpace sv)-                                           (const (fromIntegral n))--{-# INLINE sendWithDoorBell #-}-sendWithDoorBell ::-    IORef ([ChildEvent a], Int) -> MVar () -> ChildEvent a -> IO Int-sendWithDoorBell q bell msg = do-    -- XXX can the access to outputQueue be made faster somehow?-    oldlen <- atomicModifyIORefCAS q $ \(es, n) ->-        ((msg : es, n + 1), n)-    when (oldlen <= 0) $ do-        -- The wake up must happen only after the store has finished otherwise-        -- we can have lost wakeup problems.-        writeBarrier-        -- Since multiple workers can try this at the same time, it is possible-        -- that we may put a spurious MVar after the consumer has already seen-        -- the output. But that's harmless, at worst it may cause the consumer-        -- to read the queue again and find it empty.-        -- The important point is that the consumer is guaranteed to receive a-        -- doorbell if something was added to the queue after it empties it.-        void $ tryPutMVar bell ()-    return oldlen---- | 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 = sendWithDoorBell (outputQueue sv) (outputDoorBell sv)---- There is no bound implemented on the buffer, this is assumed to be low--- traffic.-sendToProducer :: SVar t m a -> ChildEvent a -> IO Int-sendToProducer sv msg = do-    -- In case the producer stream is blocked on pushing to the fold buffer-    -- then wake it up so that it can check for the stop event or exception-    -- being sent to it otherwise we will be deadlocked.-    void $ tryPutMVar (pushBufferMVar sv) ()-    sendWithDoorBell (outputQueueFromConsumer sv)-                     (outputDoorBellFromConsumer sv) msg---- {-# NOINLINE sendStopToProducer #-}-sendStopToProducer :: MonadIO m => SVar t m a -> m ()-sendStopToProducer sv = liftIO $ do-    tid <- myThreadId-    void $ sendToProducer sv (ChildStop tid Nothing)--workerCollectLatency :: WorkerInfo -> IO (Maybe (Count, NanoSecond64))-workerCollectLatency winfo = do-    (cnt0, t0) <- readIORef (workerLatencyStart winfo)-    cnt1 <- readIORef (workerYieldCount winfo)-    let cnt = cnt1 - cnt0--    if cnt > 0-    then do-        t1 <- getTime Monotonic-        let period = fromRelTime64 $ diffAbsTime64 t1 t0-        writeIORef (workerLatencyStart winfo) (cnt1, t1)-        return $ Just (cnt, period)-    else return Nothing---- XXX There are a number of gotchas in measuring latencies.--- 1) We measure latencies only when a worker yields a value--- 2) It is possible that a stream calls the stop continuation, in which case--- the worker would not yield a value and we would not account that worker in--- latencies. Even though this case should ideally be accounted we do not--- account it because we cannot or do not distinguish it from the case--- described next.--- 3) It is possible that a worker returns without yielding anything because it--- never got a chance to pick up work.--- 4) If the system timer resolution is lower than the latency, the latency--- computation turns out to be zero.------ We can fix this if we measure the latencies by counting the work items--- picked rather than based on the outputs yielded.-workerUpdateLatency :: YieldRateInfo -> WorkerInfo -> IO ()-workerUpdateLatency yinfo winfo = do-    r <- workerCollectLatency winfo-    case r of-        Just (cnt, period) -> do-        -- NOTE: On JS platform the timer resolution could be pretty low. When-        -- the timer resolution is low, measurement of latencies could be-        -- tricky. All the worker latencies will turn out to be zero if they-        -- are lower than the resolution. We only take into account those-        -- measurements which are more than the timer resolution.--            let ref = workerPendingLatency yinfo-                (cnt1, t1) = if period > 0 then (cnt, period) else (0, 0)-            atomicModifyIORefCAS_ ref $-                    \(fc, n, t) -> (fc + cnt, n + cnt1, t + t1)-        Nothing -> return ()--updateYieldCount :: WorkerInfo -> IO Count-updateYieldCount winfo = do-    cnt <- readIORef (workerYieldCount winfo)-    let cnt1 = cnt + 1-    writeIORef (workerYieldCount winfo) cnt1-    return cnt1--isBeyondMaxYield :: Count -> WorkerInfo -> Bool-isBeyondMaxYield cnt winfo =-    let ymax = workerYieldMax winfo-    in ymax /= 0 && cnt >= ymax---- XXX we should do rate control periodically based on the total yields rather--- than based on the worker local yields as other workers may have yielded more--- and we should stop based on the aggregate yields. However, latency update--- period can be based on individual worker yields.-{-# NOINLINE checkRatePeriodic #-}-checkRatePeriodic :: SVar t m a-                  -> YieldRateInfo-                  -> WorkerInfo-                  -> Count-                  -> IO Bool-checkRatePeriodic sv yinfo winfo ycnt = do-    i <- readIORef (workerPollingInterval yinfo)-    -- XXX use generation count to check if the interval has been updated-    if i /= 0 && (ycnt `mod` i) == 0-    then do-        workerUpdateLatency yinfo winfo-        -- XXX not required for parallel streams-        isBeyondMaxRate sv yinfo-    else return False---- CAUTION! this also updates the yield count and therefore should be called--- only when we are actually yielding an element.-{-# NOINLINE workerRateControl #-}-workerRateControl :: SVar t m a -> YieldRateInfo -> WorkerInfo -> IO Bool-workerRateControl sv yinfo winfo = do-    cnt <- updateYieldCount winfo-    beyondMaxRate <- checkRatePeriodic sv yinfo winfo cnt-    return $ not (isBeyondMaxYield cnt winfo || beyondMaxRate)---- XXX we should do rate control here but not latency update in case of ahead--- streams. latency update must be done when we yield directly to outputQueue--- or when we yield to heap.------ returns whether the worker should continue (True) or stop (False).-{-# INLINE sendYield #-}-sendYield :: SVar t m a -> Maybe WorkerInfo -> ChildEvent a -> IO Bool-sendYield sv mwinfo msg = do-    oldlen <- send sv msg-    let limit = maxBufferLimit sv-    bufferSpaceOk <- case limit of-            Unlimited -> return True-            Limited lim -> do-                active <- readIORef (workerCount sv)-                return $ (oldlen + 1) < (fromIntegral lim - active)-    rateLimitOk <--        case mwinfo of-            Just winfo ->-                case yieldRateInfo sv of-                    Nothing -> return True-                    Just yinfo -> workerRateControl sv yinfo winfo-            Nothing -> return True-    return $ bufferSpaceOk && rateLimitOk--{-# INLINE workerStopUpdate #-}-workerStopUpdate :: WorkerInfo -> YieldRateInfo -> IO ()-workerStopUpdate winfo info = do-    i <- readIORef (workerPollingInterval info)-    when (i /= 0) $ workerUpdateLatency info winfo--{-# INLINABLE sendStop #-}-sendStop :: SVar t m a -> Maybe WorkerInfo -> IO ()-sendStop sv mwinfo = do-    atomicModifyIORefCAS_ (workerCount sv) $ \n -> n - 1-    case (mwinfo, yieldRateInfo sv) of-      (Just winfo, Just info) ->-          workerStopUpdate winfo info-      _ ->-          return ()-    myThreadId >>= \tid -> void $ send sv (ChildStop tid Nothing)------------------------------------------------------------------------------------ Doorbell----------------------------------------------------------------------------------{-# INLINE ringDoorBell #-}-ringDoorBell :: SVar t m a -> IO ()-ringDoorBell sv = do-    storeLoadBarrier-    w <- readIORef $ needDoorBell sv-    when w $ do-        -- Note: the sequence of operations is important for correctness here.-        -- We need to set the flag to false strictly before sending the-        -- outputDoorBell, otherwise the outputDoorBell may get processed too-        -- early and then we may set the flag to False to later making the-        -- consumer lose the flag, even without receiving a outputDoorBell.-        atomicModifyIORefCAS_ (needDoorBell sv) (const False)-        void $ tryPutMVar (outputDoorBell sv) ()------------------------------------------------------------------------------------ Async------------------------------------------------------------------------------------ Note: For purely right associated expressions this queue should have at most--- one element. It grows to more than one when we have left associcated--- expressions. Large left associated compositions can grow this to a--- large size-{-# INLINE enqueueLIFO #-}-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------------------------------------------------------------------------------------ WAsync------------------------------------------------------------------------------------ XXX we can use the Ahead style sequence/heap mechanism to make the best--- effort to always try to finish the streams on the left side of an expression--- first as long as possible.--{-# INLINE enqueueFIFO #-}-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------------------------------------------------------------------------------------ Ahead------------------------------------------------------------------------------------ Lookahead streams can execute multiple tasks concurrently, ahead of time,--- but always serve them in the same order as they appear in the stream. To--- implement lookahead streams efficiently we assign a sequence number to each--- task when the task is picked up for execution. When the task finishes, the--- output is tagged with the same sequence number and we rearrange the outputs--- in sequence based on that number.------ To explain the mechanism imagine that the current task at the head of the--- stream has a "token" to yield to the outputQueue. The ownership of the token--- is determined by the current sequence number is maintained in outputHeap.--- Sequence number is assigned when a task is queued. When a thread dequeues a--- task it picks up the sequence number as well and when the output is ready it--- uses the sequence number to queue the output to the outputQueue.------ The thread with current sequence number sends the output directly to the--- outputQueue. Other threads push the output to the outputHeap. When the task--- being queued on the heap is a stream of many elements we evaluate only the--- first element and keep the rest of the unevaluated computation in the heap.--- When such a task gets the "token" for outputQueue it evaluates and directly--- yields all the elements to the outputQueue without checking for the--- "token".------ Note that no two outputs in the heap can have the same sequence numbers and--- therefore we do not need a stable heap. We have also separated the buffer--- for the current task (outputQueue) and the pending tasks (outputHeap) so--- that the pending tasks cannot interfere with the current task. Note that for--- a single task just the outputQueue is enough and for the case of many--- threads just a heap is good enough. However we balance between these two--- cases, so that both are efficient.------ For bigger streams it may make sense to have separate buffers for each--- stream. However, for singleton streams this may become inefficient. However,--- if we do not have separate buffers, then the streams that come later in--- sequence may hog the buffer, hindering the streams that are ahead. For this--- reason we have a single element buffer limitation for the streams being--- executed in advance.------ This scheme works pretty efficiently with less than 40% extra overhead--- compared to the Async streams where we do not have any kind of sequencing of--- the outputs. It is especially devised so that we are most efficient when we--- have short tasks and need just a single thread. Also when a thread yields--- many items it can hold lockfree access to the outputQueue and do it--- efficiently.------ XXX Maybe we can start the ahead threads at a lower cpu and IO priority so--- that they do not hog the resources and hinder the progress of the threads in--- front of them.---- XXX Left associated ahead expressions are expensive. We start a new SVar for--- each left associative expression. The queue is used only for right--- associated expression, we queue the right expression and execute the left.--- Thererefore the queue never has more than one item in it.------ XXX we can fix this. When we queue more than one item on the queue we can--- mark the previously queued item as not-runnable. The not-runnable item is--- not dequeued until the already running one has finished and at that time we--- would also know the exact sequence number of the already queued item.------ 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) -> (RunInIO m, t m a) -> IO ()-enqueueAhead sv q m = do-    atomicModifyIORefCAS_ q $ \ case-        ([], n) -> ([snd m], n + 1)  -- increment sequence-        _ -> error "enqueueAhead: queue is not empty"-    ringDoorBell sv---- enqueue without incrementing the sequence number-{-# INLINE reEnqueueAhead #-}-reEnqueueAhead :: SVar t m a -> IORef ([t m a], Int) -> t m a -> IO ()-reEnqueueAhead sv q m = do-    atomicModifyIORefCAS_ q $ \ case-        ([], n) -> ([m], n)  -- DO NOT increment sequence-        _ -> error "reEnqueueAhead: queue is not empty"-    ringDoorBell sv---- Normally the thread that has the token should never go away. The token gets--- handed over to another thread, but someone or the other has the token at any--- point of time. But if the task that has the token finds that the outputQueue--- is full, in that case it can go away without even handing over the token to--- another thread. In that case it sets the nextSequence number in the heap its--- own sequence number before going away. To handle this case, any task that--- does not have the token tries to dequeue from the heap first before--- dequeuing from the work queue. If it finds that the task at the top of the--- heap is the one that owns the current sequence number then it grabs the--- token and starts with that.------ XXX instead of queueing just the head element and the remaining computation--- on the heap, evaluate as many as we can and place them on the heap. But we--- need to give higher priority to the lower sequence numbers so that lower--- priority tasks do not fill up the heap making higher priority tasks block--- due to full heap. Maybe we can have a weighted space for them in the heap.--- The weight is inversely proportional to the sequence number.------ XXX review for livelock----{-# INLINE queueEmptyAhead #-}-queueEmptyAhead :: MonadIO m => IORef ([t m a], Int) -> m Bool-queueEmptyAhead q = liftIO $ do-    (xs, _) <- readIORef q-    return $ null xs--{-# INLINE dequeueAhead #-}-dequeueAhead :: MonadIO m-    => IORef ([t m a], Int) -> m (Maybe (t m a, Int))-dequeueAhead q = liftIO $-    atomicModifyIORefCAS q $ \case-            ([], n) -> (([], n), Nothing)-            (x : [], n) -> (([], n), Just (x, n))-            _ -> error "more than one item on queue"------------------------------------------------------------------------------------ Heap manipulation----------------------------------------------------------------------------------withIORef :: IORef a -> (a -> IO b) -> IO b-withIORef ref f = readIORef ref >>= f--atomicModifyIORef_ :: IORef a -> (a -> a) -> IO ()-atomicModifyIORef_ ref f =-    atomicModifyIORef ref $ \x -> (f x, ())--data HeapDequeueResult t m a =-      Clearing-    | Waiting Int-    | Ready (Entry Int (AheadHeapEntry t m a))--{-# INLINE dequeueFromHeap #-}-dequeueFromHeap-    :: IORef (Heap (Entry Int (AheadHeapEntry t m a)), Maybe Int)-    -> IO (HeapDequeueResult t m a)-dequeueFromHeap hpVar =-    atomicModifyIORef hpVar $ \pair@(hp, snum) ->-        case snum of-            Nothing -> (pair, Clearing)-            Just n -> do-                let r = H.uncons hp-                case r of-                    Just (ent@(Entry seqNo _ev), hp') ->-                            if seqNo == n-                            then ((hp', Nothing), Ready ent)-                            else assert (seqNo >= n) (pair, Waiting n)-                    Nothing -> (pair, Waiting n)--{-# INLINE dequeueFromHeapSeq #-}-dequeueFromHeapSeq-    :: IORef (Heap (Entry Int (AheadHeapEntry t m a)), Maybe Int)-    -> Int-    -> IO (HeapDequeueResult t m a)-dequeueFromHeapSeq hpVar i =-    atomicModifyIORef hpVar $ \(hp, snum) ->-        case snum of-            Nothing -> do-                let r = H.uncons hp-                case r of-                    Just (ent@(Entry seqNo _ev), hp') ->-                        if seqNo == i-                        then ((hp', Nothing), Ready ent)-                        else assert (seqNo >= i) ((hp, Just i), Waiting i)-                    Nothing -> ((hp, Just i), Waiting i)-            Just _ -> error "dequeueFromHeapSeq: unreachable"--heapIsSane :: Maybe Int -> Int -> Bool-heapIsSane snum seqNo =-    case snum of-        Nothing -> True-        Just n -> seqNo >= n--{-# INLINE requeueOnHeapTop #-}-requeueOnHeapTop-    :: IORef (Heap (Entry Int (AheadHeapEntry t m a)), Maybe Int)-    -> Entry Int (AheadHeapEntry t m a)-    -> Int-    -> IO ()-requeueOnHeapTop hpVar ent seqNo =-    atomicModifyIORef_ hpVar $ \(hp, snum) ->-        assert (heapIsSane snum seqNo) (H.insert ent hp, Just seqNo)--{-# INLINE updateHeapSeq #-}-updateHeapSeq-    :: IORef (Heap (Entry Int (AheadHeapEntry t m a)), Maybe Int)-    -> Int-    -> IO ()-updateHeapSeq hpVar seqNo =-    atomicModifyIORef_ hpVar $ \(hp, snum) ->-        assert (heapIsSane snum seqNo) (hp, Just seqNo)------------------------------------------------------------------------------------ WAhead------------------------------------------------------------------------------------ XXX To be implemented. Use a linked queue like WAsync and put back the--- remaining computation at the back of the queue instead of the heap, and--- increment the sequence number.------------------------------------------------------------------------------------ Dispatching workers and tracking them------------------------------------------------------------------------------------ Thread tracking is needed for two reasons:------ 1) Killing threads on exceptions. Threads may not be left to go away by--- themselves because they may run for significant times before going away or--- worse they may be stuck in IO and never go away.------ 2) To know when all threads are done and the stream has ended.--{-# NOINLINE addThread #-}-addThread :: MonadIO m => SVar t m a -> ThreadId -> m ()-addThread sv tid =-    liftIO $ modifyIORef (workerThreads sv) (S.insert tid)---- This is cheaper than modifyThread because we do not have to send a--- outputDoorBell This can make a difference when more workers are being--- dispatched.-{-# INLINE delThread #-}-delThread :: MonadIO m => SVar t m a -> ThreadId -> m ()-delThread sv tid =-    liftIO $ modifyIORef (workerThreads sv) (S.delete tid)---- If present then delete else add. This takes care of out of order add and--- delete i.e. a delete arriving before we even added a thread.--- This occurs when the forked thread is done even before the 'addThread' right--- after the fork gets a chance to run.-{-# INLINE modifyThread #-}-modifyThread :: MonadIO m => SVar t m a -> ThreadId -> m ()-modifyThread sv tid = do-    changed <- liftIO $ atomicModifyIORefCAS (workerThreads sv) $ \old ->-        if S.member tid old-        then let new = S.delete tid old in (new, new)-        else let new = S.insert tid old in (new, old)-    when (null changed) $-         liftIO $ do-            writeBarrier-            void $ tryPutMVar (outputDoorBell sv) ()---- | This is safe even if we are adding more threads concurrently because if--- a child thread is adding another thread then anyway 'workerThreads' will--- not be empty.-{-# INLINE allThreadsDone #-}-allThreadsDone :: MonadIO m => SVar t m a -> m Bool-allThreadsDone sv = liftIO $ S.null <$> readIORef (workerThreads sv)--{-# NOINLINE handleChildException #-}-handleChildException :: SVar t m a -> SomeException -> IO ()-handleChildException sv e = do-    tid <- myThreadId-    void $ send sv (ChildStop tid (Just e))--{-# NOINLINE handleFoldException #-}-handleFoldException :: SVar t m a -> SomeException -> IO ()-handleFoldException sv e = do-    tid <- myThreadId-    void $ sendToProducer sv (ChildStop tid (Just e))--{-# NOINLINE recordMaxWorkers #-}-recordMaxWorkers :: MonadIO m => SVar t m a -> m ()-recordMaxWorkers sv = liftIO $ do-    active <- readIORef (workerCount sv)-    maxWrk <- readIORef (maxWorkers $ svarStats sv)-    when (active > maxWrk) $ writeIORef (maxWorkers $ svarStats sv) active-    modifyIORef (totalDispatches $ svarStats sv) (+1)--{-# NOINLINE pushWorker #-}-pushWorker :: MonadAsync m => Count -> SVar t m a -> m ()-pushWorker yieldMax sv = do-    liftIO $ atomicModifyIORefCAS_ (workerCount sv) $ \n -> n + 1-    when (svarInspectMode sv) $ recordMaxWorkers sv-    -- This allocation matters when significant number of workers are being-    -- sent. We allocate it only when needed.-    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 = yieldMax-                    , workerYieldCount = cntRef-                    , workerLatencyStart = lat-                    }-    doFork (workLoop sv winfo) (svarMrun sv) (handleChildException sv)-        >>= addThread sv---- XXX we can push the workerCount modification in accountThread and use the--- same pushWorker for Parallel case as well.------ | In contrast to pushWorker which always happens only from the consumer--- thread, a pushWorkerPar can happen concurrently from multiple threads on the--- producer side. So we need to use a thread safe modification of--- workerThreads. Alternatively, we can use a CreateThread event to avoid--- using a CAS based modification.-{-# INLINE pushWorkerPar #-}-pushWorkerPar-    :: MonadAsync m-    => SVar t m a -> (Maybe WorkerInfo -> m ()) -> m ()-pushWorkerPar sv wloop =-    if svarInspectMode sv-    then forkWithDiag-    else doFork (wloop Nothing) (svarMrun sv) (handleChildException sv)-            >>= modifyThread sv--    where--    {-# 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-                        }--        doFork (wloop winfo) (svarMrun sv) (handleChildException sv)-            >>= modifyThread sv---- Returns:--- True: can dispatch more--- False: cannot dispatch any more-dispatchWorker :: MonadAsync m => Count -> SVar t m a -> m Bool-dispatchWorker yieldCount sv = do-    let workerLimit = maxWorkerLimit sv-    -- XXX in case of Ahead streams we should not send more than one worker-    -- when the work queue is done but heap is not done.-    done <- liftIO $ isWorkDone sv-    -- Note, "done" may not mean that the work is actually finished if there-    -- are workers active, because there may be a worker which has not yet-    -- queued the leftover work.-    if not done-    then do-        qDone <- liftIO $ isQueueDone sv-        -- This count may not be accurate as it is decremented by the workers-        -- and we have no synchronization with that decrement.-        active <- liftIO $ readIORef $ workerCount sv-        if not qDone-        then do-            -- Note that we may deadlock if the previous workers (tasks in the-            -- stream) wait/depend on the future workers (tasks in the stream)-            -- executing. In that case we should either configure the maxWorker-            -- count to higher or use parallel style instead of ahead or async-            -- style.-            limit <- case remainingWork sv of-                Nothing -> return workerLimit-                Just ref -> do-                    n <- liftIO $ readIORef ref-                    case yieldRateInfo sv of-                        Just _ -> return workerLimit-                        Nothing ->-                            return $-                                case workerLimit of-                                    Unlimited -> Limited (fromIntegral n)-                                    Limited lim -> Limited $ min lim (fromIntegral n)--            -- XXX for ahead streams shall we take the heap yields into account-            -- for controlling the dispatch? We should not dispatch if the heap-            -- has already got the limit covered.-            let dispatch = pushWorker yieldCount sv >> return True-             in case limit of-                Unlimited -> dispatch-                -- Note that the use of remainingWork and workerCount is not-                -- atomic and the counts may even have changed between reading-                -- and using them here, so this is just approximate logic and-                -- we cannot rely on it for correctness. We may actually-                -- dispatch more workers than required.-                Limited lim | lim > fromIntegral active -> dispatch-                _ -> return False-        else do-            when (active <= 0) $ pushWorker 0 sv-            return False-    else return False------------------------------------------------------------------------------------ Dispatch workers with rate control------------------------------------------------------------------------------------ | This is a magic number and it is overloaded, and used at several places to--- achieve batching:------ 1. If we have to sleep to slowdown this is the minimum period that we---    accumulate before we sleep. Also, workers do not stop until this much---    sleep time is accumulated.--- 3. Collected latencies are computed and transferred to measured latency---    after a minimum of this period.-minThreadDelay :: NanoSecond64-minThreadDelay = 1000000---- | Another magic number! When we have to start more workers to cover up a--- number of yields that we are lagging by then we cannot start one worker for--- each yield because that may be a very big number and if the latency of the--- workers is low these number of yields could be very high. We assume that we--- run each extra worker for at least this much time.-rateRecoveryTime :: NanoSecond64-rateRecoveryTime = 1000000---- We either block, or send one worker with limited yield count or one or more--- workers with unlimited yield count.-data Work-    = BlockWait NanoSecond64-    | PartialWorker Count-    | ManyWorkers Int Count-    deriving Show---- XXX we can use phantom types to distinguish the duration/latency/expectedLat-estimateWorkers-    :: Limit-    -> Count-    -> Count-    -> NanoSecond64-    -> NanoSecond64-    -> NanoSecond64-    -> LatencyRange-    -> Work-estimateWorkers workerLimit svarYields gainLossYields-                svarElapsed wLatency targetLat range =-    -- XXX we can have a maxEfficiency combinator as well which runs the-    -- producer at the maximal efficiency i.e. the number of workers are chosen-    -- such that the latency is minimum or within a range. Or we can call it-    -- maxWorkerLatency.-    ---    let-        -- How many workers do we need to achieve the required rate?-        ---        -- When the workers are IO bound we can increase the throughput by-        -- increasing the number of workers as long as the IO device has enough-        -- capacity to process all the requests concurrently. If the IO-        -- bandwidth is saturated increasing the workers won't help. Also, if-        -- the CPU utilization in processing all these requests exceeds the CPU-        -- bandwidth, then increasing the number of workers won't help.-        ---        -- When the workers are purely CPU bound, increasing the workers beyond-        -- the number of CPUs won't help.-        ---        -- TODO - measure the CPU and IO requirements of the workers. Have a-        -- way to specify the max bandwidth of the underlying IO mechanism and-        -- use that to determine the max rate of workers, and also take the CPU-        -- bandwidth into account. We can also discover the IO bandwidth if we-        -- know that we are not CPU bound, then how much steady state rate are-        -- we able to achieve. Design tests for CPU bound and IO bound cases.--        -- Calculate how many yields are we ahead or behind to match the exact-        -- required rate. Based on that we increase or decrease the effective-        -- workers.-        ---        -- When the worker latency is lower than required latency we begin with-        -- a yield and then wait rather than first waiting and then yielding.-        targetYields = (svarElapsed + wLatency + targetLat - 1) `div` targetLat-        effectiveYields = svarYields + gainLossYields-        deltaYields = fromIntegral targetYields - effectiveYields--        -- We recover the deficit by running at a higher/lower rate for a-        -- certain amount of time. To keep the effective rate in reasonable-        -- limits we use rateRecoveryTime, minLatency and maxLatency.-        in  if deltaYields > 0-            then-                let deltaYieldsFreq :: Double-                    deltaYieldsFreq =-                        fromIntegral deltaYields /-                            fromIntegral rateRecoveryTime-                    yieldsFreq = 1.0 / fromIntegral targetLat-                    totalYieldsFreq = yieldsFreq + deltaYieldsFreq-                    requiredLat = NanoSecond64 $ round $ 1.0 / totalYieldsFreq-                    adjustedLat = min (max requiredLat (minLatency range))-                                      (maxLatency range)-                in  assert (adjustedLat > 0) $-                    if wLatency <= adjustedLat-                    then PartialWorker deltaYields-                    else let workers = withLimit $ wLatency `div` adjustedLat-                             limited = min workers (fromIntegral deltaYields)-                         in ManyWorkers (fromIntegral limited) deltaYields-            else-                let expectedDuration = fromIntegral effectiveYields * targetLat-                    sleepTime = expectedDuration - svarElapsed-                    maxSleepTime = maxLatency range - wLatency-                    s = min sleepTime maxSleepTime-                in assert (sleepTime >= 0) $-                    -- if s is less than 0 it means our maxSleepTime is less-                    -- than the worker latency.-                    if s > 0 then BlockWait s else ManyWorkers 1 (Count 0)-    where-        withLimit n =-            case workerLimit of-                Unlimited -> n-                Limited x -> min n (fromIntegral x)---- | Get the worker latency without resetting workerPendingLatency--- Returns (total yield count, base time, measured latency)--- CAUTION! keep it in sync with collectLatency-getWorkerLatency :: YieldRateInfo -> IO (Count, AbsTime, NanoSecond64)-getWorkerLatency yinfo  = do-    let cur      = workerPendingLatency yinfo-        col      = workerCollectedLatency yinfo-        longTerm = svarAllTimeLatency yinfo-        measured = workerMeasuredLatency yinfo--    (curTotalCount, curCount, curTime) <- readIORef cur-    (colTotalCount, colCount, colTime) <- readIORef col-    (lcount, ltime)     <- readIORef longTerm-    prevLat             <- readIORef measured--    let latCount = colCount + curCount-        latTime  = colTime + curTime-        totalCount = colTotalCount + curTotalCount-        newLat =-            if latCount > 0 && latTime > 0-            then let lat = latTime `div` fromIntegral latCount-                 -- XXX Give more weight to new?-                 in (lat + prevLat) `div` 2-            else prevLat-    return (lcount + totalCount, ltime, newLat)--isBeyondMaxRate :: SVar t m a -> YieldRateInfo -> IO Bool-isBeyondMaxRate sv yinfo = do-    (count, tstamp, wLatency) <- getWorkerLatency yinfo-    now <- getTime Monotonic-    let duration = fromRelTime64 $ diffAbsTime64 now tstamp-    let targetLat = svarLatencyTarget yinfo-    gainLoss <- readIORef (svarGainedLostYields yinfo)-    let work = estimateWorkers (maxWorkerLimit sv) count gainLoss duration-                               wLatency targetLat (svarLatencyRange yinfo)-    cnt <- readIORef $ workerCount sv-    return $ case work of-        -- XXX set the worker's maxYields or polling interval based on yields-        PartialWorker _yields -> cnt > 1-        ManyWorkers n _ -> cnt > n-        BlockWait _ -> True---- XXX in case of ahead style stream we need to take the heap size into account--- because we return the workers on the basis of that which causes a condition--- where we keep dispatching and they keep returning. So we must have exactly--- the same logic for not dispatching and for returning.------ Returns:--- True: can dispatch more--- False: full, no more dispatches-dispatchWorkerPaced :: MonadAsync m => SVar t m a -> m Bool-dispatchWorkerPaced sv = do-    let yinfo = fromJust $ yieldRateInfo sv-    (svarYields, svarElapsed, wLatency) <- do-        now <- liftIO $ getTime Monotonic-        (yieldCount, baseTime, lat) <--            liftIO $ collectLatency sv yinfo False-        let elapsed = fromRelTime64 $ diffAbsTime64 now baseTime-        let latency =-                if lat == 0-                then fromMaybe lat (workerBootstrapLatency yinfo)-                else lat--        return (yieldCount, elapsed, latency)--    if wLatency == 0-    -- Need to measure the latency with a single worker before we can perform-    -- any computation.-    then return False-    else do-        let workerLimit = maxWorkerLimit sv-        let targetLat = svarLatencyTarget yinfo-        let range = svarLatencyRange yinfo-        gainLoss <- liftIO $ readIORef (svarGainedLostYields yinfo)-        let work = estimateWorkers workerLimit svarYields gainLoss svarElapsed-                                   wLatency targetLat range--        -- XXX we need to take yieldLimit into account here. If we are at the-        -- end of the limit as well as the time, we should not be sleeping.-        -- If we are not actually planning to dispatch any more workers we need-        -- to take that in account.-        case work of-            BlockWait s -> do-                assert (s >= 0) (return ())-                -- XXX note that when we return from here we will block waiting-                -- for the result from the existing worker. If that takes too-                -- long we won't be able to send another worker until the-                -- result arrives.-                ---                -- Sleep only if there are no active workers, otherwise we will-                -- defer the output of those. Note we cannot use workerCount-                -- here as it is not a reliable way to ensure there are-                -- definitely no active workers. When workerCount is 0 we may-                -- still have a Stop event waiting in the outputQueue.-                done <- allThreadsDone sv-                when done $ void $ do-                    let us = fromRelTime64 (toRelTime64 s) :: MicroSecond64-                    liftIO $ threadDelay (fromIntegral us)-                    dispatchWorker 1 sv-                return False-            PartialWorker yields -> do-                assert (yields > 0) (return ())-                updateGainedLostYields yinfo yields--                done <- allThreadsDone sv-                when done $ void $ dispatchWorker yields sv-                return False-            ManyWorkers netWorkers yields -> do-                assert (netWorkers >= 1) (return ())-                assert (yields >= 0) (return ())-                updateGainedLostYields yinfo yields--                let periodRef = workerPollingInterval yinfo-                    ycnt = max 1 $ yields `div` fromIntegral netWorkers-                    period = min ycnt (fromIntegral magicMaxBuffer)--                old <- liftIO $ readIORef periodRef-                when (period < old) $-                    liftIO $ writeIORef periodRef period--                cnt <- liftIO $ readIORef $ workerCount sv-                if cnt < netWorkers-                then do-                    let total = netWorkers - cnt-                        batch = max 1 $ fromIntegral $-                                    minThreadDelay `div` targetLat-                    -- XXX stagger the workers over a period?-                    -- XXX cannot sleep, as that would mean we cannot process-                    -- the outputs. need to try a different mechanism to-                    -- stagger.-                    -- when (total > batch) $-                       -- liftIO $ threadDelay $ nanoToMicroSecs minThreadDelay-                    dispatchN (min total batch)-                else return False--    where--    updateGainedLostYields yinfo yields = do-        let buf = fromIntegral $ svarRateBuffer yinfo-        when (yields /= 0 && abs yields > buf) $ do-            let delta =-                   if yields > 0-                   then yields - buf-                   else yields + buf-            liftIO $ modifyIORef (svarGainedLostYields yinfo) (+ delta)--    dispatchN n =-        if n == 0-        then return True-        else do-            r <- dispatchWorker 0 sv-            if r-            then dispatchN (n - 1)-            else return False------------------------------------------------------------------------------------ Worker dispatch and wait loop----------------------------------------------------------------------------------sendWorkerDelayPaced :: SVar t m a -> IO ()-sendWorkerDelayPaced _ = return ()--sendWorkerDelay :: SVar t m a -> IO ()-sendWorkerDelay _sv =-    -- XXX we need a better way to handle this than hardcoded delays. The-    -- delays may be different for different systems.-    -- If there is a usecase where this is required we can create a combinator-    -- to set it as a config in the state.-    {--  do-    ncpu <- getNumCapabilities-    if ncpu <= 1-    then-        if (svarStyle sv == AheadVar)-        then threadDelay 100-        else threadDelay 25-    else-        if (svarStyle sv == AheadVar)-        then threadDelay 100-        else threadDelay 10-    -}-    return ()--{-# NOINLINE sendWorkerWait #-}-sendWorkerWait-    :: MonadAsync m-    => (SVar t m a -> IO ())-    -> (SVar t m a -> m Bool)-    -> SVar t m a-    -> m ()-sendWorkerWait delay dispatch sv = do-    -- Note that we are guaranteed to have at least one outstanding worker when-    -- we enter this function. So if we sleep we are guaranteed to be woken up-    -- by an outputDoorBell, when the worker exits.--    liftIO $ delay sv-    (_, n) <- liftIO $ readIORef (outputQueue sv)-    when (n <= 0) $ do-        -- The queue may be empty temporarily if the worker has dequeued the-        -- work item but has not enqueued the remaining part yet. For the same-        -- reason, a worker may come back if it tries to dequeue and finds the-        -- queue empty, even though the whole work has not finished yet.--        -- If we find that the queue is empty, but it may be empty-        -- temporarily, when we checked it. If that's the case we might-        -- sleep indefinitely unless the active workers produce some-        -- output. We may deadlock specially if the otuput from the active-        -- workers depends on the future workers that we may never send.-        -- So in case the queue was temporarily empty set a flag to inform-        -- the enqueue to send us a doorbell.--        -- Note that this is just a best effort mechanism to avoid a-        -- deadlock. Deadlocks may still happen if for some weird reason-        -- the consuming computation shares an MVar or some other resource-        -- with the producing computation and gets blocked on that resource-        -- and therefore cannot do any pushworker to add more threads to-        -- the producer. In such cases the programmer should use a parallel-        -- style so that all the producers are scheduled immediately and-        -- unconditionally. We can also use a separate monitor thread to-        -- push workers instead of pushing them from the consumer, but then-        -- we are no longer using pull based concurrency rate adaptation.-        ---        -- XXX update this in the tutorial.-        ---        -- Having pending active workers does not mean that we are guaranteed-        -- to be woken up if we sleep. In case of Ahead streams, there may be-        -- queued items in the heap even though the outputQueue is empty, and-        -- we may have active workers which are deadlocked on those items to be-        -- processed by the consumer. We should either guarantee that any-        -- worker, before returning, clears the heap or we send a worker to-        -- clear it. Normally we always send a worker if no output is seen, but-        -- if the thread limit is reached or we are using pacing then we may-        -- not send a worker. See the concurrentApplication test in the tests,-        -- that test case requires at least one yield from the producer to not-        -- deadlock, if the last workers output is stuck in the heap then this-        -- test fails.  This problem can be extended to n threads when the-        -- consumer may depend on the evaluation of next n items in the-        -- producer stream.--        -- register for the outputDoorBell before we check the queue so that if-        -- we sleep because the queue was empty we are guaranteed to get a-        -- doorbell on the next enqueue.--        liftIO $ atomicModifyIORefCAS_ (needDoorBell sv) $ const True-        liftIO storeLoadBarrier-        canDoMore <- dispatch sv--        -- XXX test for the case when we miss sending a worker when the worker-        -- count is more than 1500.-        ---        -- XXX Assert here that if the heap is not empty then there is at-        -- least one outstanding worker. Otherwise we could be sleeping-        -- forever.--        if canDoMore-        then sendWorkerWait delay dispatch sv-        else do-            liftIO $ withDiagMVar sv "sendWorkerWait: nothing to do"-                             $ takeMVar (outputDoorBell sv)-            (_, len) <- liftIO $ readIORef (outputQueue sv)-            when (len <= 0) $ sendWorkerWait delay dispatch sv------------------------------------------------------------------------------------ Reading from the workers' output queue/buffer----------------------------------------------------------------------------------{-# INLINE readOutputQBasic #-}-readOutputQBasic :: IORef ([ChildEvent a], Int) -> IO ([ChildEvent a], Int)-readOutputQBasic q = atomicModifyIORefCAS q $ \x -> (([],0), x)--{-# INLINE readOutputQRaw #-}-readOutputQRaw :: SVar t m a -> IO ([ChildEvent a], Int)-readOutputQRaw sv = do-    (list, len) <- readOutputQBasic (outputQueue sv)-    when (svarInspectMode sv) $ do-        let ref = maxOutQSize $ svarStats sv-        oqLen <- readIORef ref-        when (len > oqLen) $ writeIORef ref len-    return (list, len)--readOutputQBounded :: MonadAsync m => SVar t m a -> m [ChildEvent a]-readOutputQBounded sv = do-    (list, len) <- liftIO $ readOutputQRaw sv-    -- When there is no output seen we dispatch more workers to help-    -- out if there is work pending in the work queue.-    if len <= 0-    then blockingRead-    else do-        -- send a worker proactively, if needed, even before we start-        -- processing the output.  This may degrade single processor-        -- perf but improves multi-processor, because of more-        -- parallelism-        sendOneWorker-        return list--    where--    sendOneWorker = do-        cnt <- liftIO $ readIORef $ workerCount sv-        when (cnt <= 0) $ do-            done <- liftIO $ isWorkDone sv-            when (not done) (pushWorker 0 sv)--    {-# INLINE blockingRead #-}-    blockingRead = do-        sendWorkerWait sendWorkerDelay (dispatchWorker 0) sv-        liftIO (fst `fmap` readOutputQRaw sv)--readOutputQPaced :: MonadAsync m => SVar t m a -> m [ChildEvent a]-readOutputQPaced sv = do-    (list, len) <- liftIO $ readOutputQRaw sv-    if len <= 0-    then blockingRead-    else do-        -- XXX send a worker proactively, if needed, even before we start-        -- processing the output.-        void $ dispatchWorkerPaced sv-        return list--    where--    {-# INLINE blockingRead #-}-    blockingRead = do-        sendWorkerWait sendWorkerDelayPaced dispatchWorkerPaced sv-        liftIO (fst `fmap` readOutputQRaw sv)--postProcessBounded :: MonadAsync m => SVar t m a -> m Bool-postProcessBounded sv = do-    workersDone <- allThreadsDone sv-    -- There may still be work pending even if there are no workers pending-    -- because all the workers may return if the outputQueue becomes full. In-    -- that case send off a worker to kickstart the work again.-    ---    -- Note that isWorkDone can only be safely checked if all workers are done.-    -- When some workers are in progress they may have decremented the yield-    -- Limit and later ending up incrementing it again. If we look at the yield-    -- limit in that window we may falsely say that it is 0 and therefore we-    -- are done.-    if workersDone-    then do-        r <- liftIO $ isWorkDone sv-        -- Note that we need to guarantee a worker, therefore we cannot just-        -- use dispatchWorker which may or may not send a worker.-        when (not r) (pushWorker 0 sv)-        -- XXX do we need to dispatch many here?-        -- void $ dispatchWorker sv-        return r-    else return False--postProcessPaced :: MonadAsync m => SVar t m a -> m Bool-postProcessPaced sv = do-    workersDone <- allThreadsDone sv-    -- XXX If during consumption we figure out we are getting delayed then we-    -- should trigger dispatch there as well.  We should try to check on the-    -- workers after consuming every n item from the buffer?-    if workersDone-    then do-        r <- liftIO $ isWorkDone sv-        when (not r) $ do-            void $ dispatchWorkerPaced sv-            -- Note that we need to guarantee a worker since the work is not-            -- finished, therefore we cannot just rely on dispatchWorkerPaced-            -- which may or may not send a worker.-            noWorker <- allThreadsDone sv-            when noWorker $ pushWorker 0 sv-        return r-    else return False------------------------------------------------------------------------------------ Creating an SVar----------------------------------------------------------------------------------getYieldRateInfo :: State t m a -> IO (Maybe YieldRateInfo)-getYieldRateInfo st = do-    -- convert rate in Hertz to latency in Nanoseconds-    let rateToLatency r = if r <= 0 then maxBound else round $ 1.0e9 / r-    case getStreamRate st of-        Just (Rate low goal high buf) ->-            let l    = rateToLatency goal-                minl = rateToLatency high-                maxl = rateToLatency low-            in mkYieldRateInfo l (LatencyRange minl maxl) buf-        Nothing -> return Nothing--    where--    mkYieldRateInfo latency latRange buf = do-        measured <- newIORef 0-        wcur     <- newIORef (0,0,0)-        wcol     <- newIORef (0,0,0)-        now      <- getTime Monotonic-        wlong    <- newIORef (0,now)-        period   <- newIORef 1-        gainLoss <- newIORef (Count 0)--        return $ Just YieldRateInfo-            { svarLatencyTarget      = latency-            , svarLatencyRange       = latRange-            , svarRateBuffer         = buf-            , svarGainedLostYields   = gainLoss-            , workerBootstrapLatency = getStreamLatency st-            , workerPollingInterval  = period-            , workerMeasuredLatency  = measured-            , workerPendingLatency   = wcur-            , workerCollectedLatency = wcol-            , svarAllTimeLatency     = wlong-            }--newSVarStats :: IO SVarStats-newSVarStats = do-    disp   <- newIORef 0-    maxWrk <- newIORef 0-    maxOq  <- newIORef 0-    maxHs  <- newIORef 0-    maxWq  <- newIORef 0-    avgLat <- newIORef (0, NanoSecond64 0)-    maxLat <- newIORef (NanoSecond64 0)-    minLat <- newIORef (NanoSecond64 0)-    stpTime <- newIORef Nothing--    return SVarStats-        { totalDispatches  = disp-        , maxWorkers       = maxWrk-        , maxOutQSize      = maxOq-        , maxHeapSize      = maxHs-        , maxWorkQSize     = maxWq-        , avgWorkerLatency = avgLat-        , minWorkerLatency = minLat-        , maxWorkerLatency = maxLat-        , svarStopTime     = stpTime-        }---- XXX remove polymorphism in t, inline f-getAheadSVar :: MonadAsync m-    => State t m a-    -> (   IORef ([t m a], Int)-        -> IORef (Heap (Entry Int (AheadHeapEntry t m a)), Maybe Int)-        -> State t m a-        -> SVar t m a-        -> Maybe WorkerInfo-        -> m ())-    -> RunInIO m-    -> IO (SVar t m a)-getAheadSVar st f mrun = do-    outQ    <- newIORef ([], 0)-    -- the second component of the tuple is "Nothing" when heap is being-    -- cleared, "Just n" when we are expecting sequence number n to arrive-    -- before we can start clearing the heap.-    outH    <- newIORef (H.empty, Just 0)-    outQMv  <- newEmptyMVar-    active  <- newIORef 0-    wfw     <- newIORef False-    running <- newIORef S.empty-    -- Sequence number is incremented whenever something is queued, therefore,-    -- first sequence number would be 0-    q <- newIORef ([], -1)-    stopMVar <- newMVar ()-    yl <- case getYieldLimit st of-            Nothing -> return Nothing-            Just x -> Just <$> newIORef x-    rateInfo <- getYieldRateInfo st--    stats <- newSVarStats-    tid <- myThreadId--    let getSVar sv readOutput postProc = SVar-            { outputQueue      = outQ-            , outputQueueFromConsumer = undefined-            , remainingWork  = yl-            , maxBufferLimit   = getMaxBuffer st-            , pushBufferSpace = undefined-            , pushBufferPolicy = undefined-            , pushBufferMVar   = undefined-            , maxWorkerLimit   = min (getMaxThreads st) (getMaxBuffer st)-            , yieldRateInfo    = rateInfo-            , outputDoorBell   = outQMv-            , outputDoorBellFromConsumer = undefined-            , readOutputQ      = readOutput sv-            , postProcess      = postProc sv-            , workerThreads    = running-            , workLoop         = f q outH st{streamVar = Just sv} sv-            , enqueue          = enqueueAhead sv q-            , isWorkDone       = isWorkDoneAhead sv q outH-            , isQueueDone      = isQueueDoneAhead sv q-            , needDoorBell     = wfw-            , svarStyle        = AheadVar-            , svarStopStyle    = StopNone-            , svarStopBy       = undefined-            , svarMrun         = mrun-            , workerCount      = active-            , accountThread    = delThread sv-            , workerStopMVar   = stopMVar-            , svarRef          = Nothing-            , svarInspectMode  = getInspectMode st-            , svarCreator      = tid-            , aheadWorkQueue   = q-            , outputHeap       = outH-            , svarStats        = stats-            }--    let sv =-            case getStreamRate st of-                Nothing -> getSVar sv readOutputQBounded postProcessBounded-                Just _  -> getSVar sv readOutputQPaced postProcessPaced-     in return sv--    where--    {-# INLINE isQueueDoneAhead #-}-    isQueueDoneAhead sv q = do-        queueDone <- checkEmpty q-        yieldsDone <--                case remainingWork sv of-                    Just yref -> do-                        n <- readIORef yref-                        return (n <= 0)-                    Nothing -> return False-        -- XXX note that yieldsDone can only be authoritative only when there-        -- are no workers running. If there are active workers they can-        -- later increment the yield count and therefore change the result.-        return $ yieldsDone || queueDone--    {-# INLINE isWorkDoneAhead #-}-    isWorkDoneAhead sv q ref = do-        heapDone <- do-                (hp, _) <- readIORef ref-                return (H.size hp <= 0)-        queueDone <- isQueueDoneAhead sv q-        return $ heapDone && queueDone--    checkEmpty q = do-        (xs, _) <- readIORef q-        return $ null xs--getParallelSVar :: MonadIO m-    => SVarStopStyle -> State t m a -> RunInIO m -> IO (SVar t m a)-getParallelSVar ss st mrun = do-    outQ    <- newIORef ([], 0)-    outQRev <- newIORef ([], 0)-    outQMv  <- newEmptyMVar-    outQMvRev <- newEmptyMVar-    active  <- newIORef 0-    running <- newIORef S.empty-    yl <- case getYieldLimit st of-            Nothing -> return Nothing-            Just x -> Just <$> newIORef x-    rateInfo <- getYieldRateInfo st-    let bufLim =-            case getMaxBuffer st of-                Unlimited -> undefined-                Limited x -> fromIntegral x-    remBuf <- newIORef bufLim-    pbMVar <- newMVar ()--    stats <- newSVarStats-    tid <- myThreadId--    stopBy <--        case ss of-            StopBy -> liftIO $ newIORef undefined-            _ -> return undefined--    let sv =-            SVar { outputQueue      = outQ-                 , outputQueueFromConsumer = outQRev-                 , remainingWork    = yl-                 , maxBufferLimit   = getMaxBuffer st-                 , pushBufferSpace  = remBuf-                 , pushBufferPolicy = PushBufferBlock-                 , pushBufferMVar   = pbMVar-                 , maxWorkerLimit   = Unlimited-                 -- Used only for diagnostics-                 , yieldRateInfo    = rateInfo-                 , outputDoorBell   = outQMv-                 , outputDoorBellFromConsumer = outQMvRev-                 , readOutputQ      = readOutputQPar sv-                 , postProcess      = allThreadsDone sv-                 , workerThreads    = running-                 , workLoop         = undefined-                 , enqueue          = undefined-                 , isWorkDone       = undefined-                 , isQueueDone      = undefined-                 , needDoorBell     = undefined-                 , svarStyle        = ParallelVar-                 , svarStopStyle    = ss-                 , svarStopBy       = stopBy-                 , svarMrun         = mrun-                 , workerCount      = active-                 , accountThread    = modifyThread sv-                 , workerStopMVar   = undefined-                 , svarRef          = Nothing-                 , svarInspectMode  = getInspectMode st-                 , svarCreator      = tid-                 , aheadWorkQueue   = undefined-                 , outputHeap       = undefined-                 , svarStats        = stats-                 }-     in return sv--    where--    readOutputQPar sv = liftIO $ do-        withDiagMVar sv "readOutputQPar: doorbell"-            $ takeMVar (outputDoorBell sv)-        case yieldRateInfo sv of-            Nothing -> return ()-            Just yinfo -> void $ collectLatency sv yinfo False-        r <- fst `fmap` readOutputQRaw sv-        liftIO $ do-            void $ tryTakeMVar (pushBufferMVar sv)-            resetBufferLimit sv-            writeBarrier-            void $ tryPutMVar (pushBufferMVar sv) ()-        return r--sendFirstWorker :: MonadAsync m => SVar t m a -> t m a -> m (SVar t m a)-sendFirstWorker sv m = do-    -- 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.-    runIn <- captureMonadState-    liftIO $ enqueue sv (runIn, m)-    case yieldRateInfo sv of-        Nothing -> pushWorker 0 sv-        Just yinfo  ->-            if svarLatencyTarget yinfo == maxBound-            then liftIO $ threadDelay maxBound-            else pushWorker 1 sv-    return sv--{-# INLINABLE newAheadVar #-}-newAheadVar :: MonadAsync m-    => State t m a-    -> t m a-    -> (   IORef ([t m a], Int)-        -> IORef (Heap (Entry Int (AheadHeapEntry t m a)), Maybe Int)-        -> State t m a-        -> SVar t m a-        -> Maybe WorkerInfo-        -> m ())-    -> m (SVar t m a)-newAheadVar st m wloop = do-    mrun <- captureMonadState-    sv <- liftIO $ getAheadSVar st wloop mrun-    sendFirstWorker sv m--{-# INLINABLE newParallelVar #-}-newParallelVar :: MonadAsync m-    => SVarStopStyle -> State t m a -> m (SVar t m a)-newParallelVar ss st = do-    mrun <- captureMonadState-    liftIO $ getParallelSVar ss st mrun------------------------------------------------------------------------------------ Write a stream to an SVar------------------------------------------------------------------------------------ XXX this errors out for Parallel/Ahead SVars--- | Write a stream to an 'SVar' in a non-blocking manner. The stream can then--- be read back from the SVar using 'fromSVar'.-toStreamVar :: MonadAsync m => SVar t m a -> t m a -> m ()-toStreamVar sv m = do-    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-    -- consumer thread.-    -- XXX do this only if the work queue is not empty. The work may have been-    -- carried out by existing workers.-    when done $-        case yieldRateInfo sv of-            Nothing -> pushWorker 0 sv-            Just _  -> pushWorker 1 sv+-- |+-- Module      : Streamly.Internal.Data.SVar+-- Copyright   : (c) 2017 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+--+module Streamly.Internal.Data.SVar+    (+      module Streamly.Internal.Data.SVar.Type+    , module Streamly.Internal.Data.SVar.Worker+    , module Streamly.Internal.Data.SVar.Dispatch+    , module Streamly.Internal.Data.SVar.Pull++    -- * New SVar+    , getYieldRateInfo+    , newSVarStats++    -- ** Parallel+    , newParallelVar++    -- ** Ahead+    , enqueueAhead+    , reEnqueueAhead+    , queueEmptyAhead+    , dequeueAhead+    , HeapDequeueResult(..)+    , dequeueFromHeap+    , dequeueFromHeapSeq+    , requeueOnHeapTop+    , updateHeapSeq+    , withIORef+    , heapIsSane+    , newAheadVar+    )+where++#include "inline.hs"++import Control.Concurrent (myThreadId, takeMVar)+import Control.Concurrent.MVar (newEmptyMVar, tryPutMVar, tryTakeMVar, newMVar)+import Control.Exception (assert)+import Control.Monad (void)+import Control.Monad.IO.Class (MonadIO(liftIO))+import Data.Heap (Heap, Entry(..))+import Data.IORef (newIORef, readIORef)+import Data.IORef (IORef, atomicModifyIORef)+import Streamly.Internal.Control.Concurrent+    (MonadAsync, captureMonadState, RunInIO(..))+import Streamly.Internal.Data.Atomics+       (atomicModifyIORefCAS, atomicModifyIORefCAS_, writeBarrier)+import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime)+import Streamly.Internal.Data.Time.Units (NanoSecond64(..))++import qualified Data.Heap as H+import qualified Data.Set as S++import Streamly.Internal.Data.SVar.Dispatch+import Streamly.Internal.Data.SVar.Pull+import Streamly.Internal.Data.SVar.Type+import Streamly.Internal.Data.SVar.Worker++-------------------------------------------------------------------------------+-- Creating an SVar+-------------------------------------------------------------------------------++getYieldRateInfo :: State t m a -> IO (Maybe YieldRateInfo)+getYieldRateInfo st = do+    -- convert rate in Hertz to latency in Nanoseconds+    let rateToLatency r = if r <= 0 then maxBound else round $ 1.0e9 / r+    case getStreamRate st of+        Just (Rate low goal high buf) ->+            let l    = rateToLatency goal+                minl = rateToLatency high+                maxl = rateToLatency low+            in mkYieldRateInfo l (LatencyRange minl maxl) buf+        Nothing -> return Nothing++    where++    mkYieldRateInfo latency latRange buf = do+        measured <- newIORef 0+        wcur     <- newIORef (0,0,0)+        wcol     <- newIORef (0,0,0)+        now      <- getTime Monotonic+        wlong    <- newIORef (0,now)+        period   <- newIORef 1+        gainLoss <- newIORef (Count 0)++        return $ Just YieldRateInfo+            { svarLatencyTarget      = latency+            , svarLatencyRange       = latRange+            , svarRateBuffer         = buf+            , svarGainedLostYields   = gainLoss+            , workerBootstrapLatency = getStreamLatency st+            , workerPollingInterval  = period+            , workerMeasuredLatency  = measured+            , workerPendingLatency   = wcur+            , workerCollectedLatency = wcol+            , svarAllTimeLatency     = wlong+            }++newSVarStats :: IO SVarStats+newSVarStats = do+    disp   <- newIORef 0+    maxWrk <- newIORef 0+    maxOq  <- newIORef 0+    maxHs  <- newIORef 0+    maxWq  <- newIORef 0+    avgLat <- newIORef (0, NanoSecond64 0)+    maxLat <- newIORef (NanoSecond64 0)+    minLat <- newIORef (NanoSecond64 0)+    stpTime <- newIORef Nothing++    return SVarStats+        { totalDispatches  = disp+        , maxWorkers       = maxWrk+        , maxOutQSize      = maxOq+        , maxHeapSize      = maxHs+        , maxWorkQSize     = maxWq+        , avgWorkerLatency = avgLat+        , minWorkerLatency = minLat+        , maxWorkerLatency = maxLat+        , svarStopTime     = stpTime+        }++-------------------------------------------------------------------------------+-- Ahead+-------------------------------------------------------------------------------++-- Lookahead streams can execute multiple tasks concurrently, ahead of time,+-- but always serve them in the same order as they appear in the stream. To+-- implement lookahead streams efficiently we assign a sequence number to each+-- task when the task is picked up for execution. When the task finishes, the+-- output is tagged with the same sequence number and we rearrange the outputs+-- in sequence based on that number.+--+-- To explain the mechanism imagine that the current task at the head of the+-- stream has a "token" to yield to the outputQueue. The ownership of the token+-- is determined by the current sequence number is maintained in outputHeap.+-- Sequence number is assigned when a task is queued. When a thread dequeues a+-- task it picks up the sequence number as well and when the output is ready it+-- uses the sequence number to queue the output to the outputQueue.+--+-- The thread with current sequence number sends the output directly to the+-- outputQueue. Other threads push the output to the outputHeap. When the task+-- being queued on the heap is a stream of many elements we evaluate only the+-- first element and keep the rest of the unevaluated computation in the heap.+-- When such a task gets the "token" for outputQueue it evaluates and directly+-- yields all the elements to the outputQueue without checking for the+-- "token".+--+-- Note that no two outputs in the heap can have the same sequence numbers and+-- therefore we do not need a stable heap. We have also separated the buffer+-- for the current task (outputQueue) and the pending tasks (outputHeap) so+-- that the pending tasks cannot interfere with the current task. Note that for+-- a single task just the outputQueue is enough and for the case of many+-- threads just a heap is good enough. However we balance between these two+-- cases, so that both are efficient.+--+-- For bigger streams it may make sense to have separate buffers for each+-- stream. However, for singleton streams this may become inefficient. However,+-- if we do not have separate buffers, then the streams that come later in+-- sequence may hog the buffer, hindering the streams that are ahead. For this+-- reason we have a single element buffer limitation for the streams being+-- executed in advance.+--+-- This scheme works pretty efficiently with less than 40% extra overhead+-- compared to the Async streams where we do not have any kind of sequencing of+-- the outputs. It is especially devised so that we are most efficient when we+-- have short tasks and need just a single thread. Also when a thread yields+-- many items it can hold lockfree access to the outputQueue and do it+-- efficiently.+--+-- XXX Maybe we can start the ahead threads at a lower cpu and IO priority so+-- that they do not hog the resources and hinder the progress of the threads in+-- front of them.++-- XXX Left associated ahead expressions are expensive. We start a new SVar for+-- each left associative expression. The queue is used only for right+-- associated expression, we queue the right expression and execute the left.+-- Thererefore the queue never has more than one item in it.+--+-- XXX we can fix this. When we queue more than one item on the queue we can+-- mark the previously queued item as not-runnable. The not-runnable item is+-- not dequeued until the already running one has finished and at that time we+-- would also know the exact sequence number of the already queued item.+--+-- 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) -> (RunInIO m, t m a) -> IO ()+enqueueAhead sv q m = do+    atomicModifyIORefCAS_ q $ \ case+        ([], n) -> ([snd m], n + 1)  -- increment sequence+        _ -> error "enqueueAhead: queue is not empty"+    ringDoorBell sv++-- enqueue without incrementing the sequence number+{-# INLINE reEnqueueAhead #-}+reEnqueueAhead :: SVar t m a -> IORef ([t m a], Int) -> t m a -> IO ()+reEnqueueAhead sv q m = do+    atomicModifyIORefCAS_ q $ \ case+        ([], n) -> ([m], n)  -- DO NOT increment sequence+        _ -> error "reEnqueueAhead: queue is not empty"+    ringDoorBell sv++-- Normally the thread that has the token should never go away. The token gets+-- handed over to another thread, but someone or the other has the token at any+-- point of time. But if the task that has the token finds that the outputQueue+-- is full, in that case it can go away without even handing over the token to+-- another thread. In that case it sets the nextSequence number in the heap its+-- own sequence number before going away. To handle this case, any task that+-- does not have the token tries to dequeue from the heap first before+-- dequeuing from the work queue. If it finds that the task at the top of the+-- heap is the one that owns the current sequence number then it grabs the+-- token and starts with that.+--+-- XXX instead of queueing just the head element and the remaining computation+-- on the heap, evaluate as many as we can and place them on the heap. But we+-- need to give higher priority to the lower sequence numbers so that lower+-- priority tasks do not fill up the heap making higher priority tasks block+-- due to full heap. Maybe we can have a weighted space for them in the heap.+-- The weight is inversely proportional to the sequence number.+--+-- XXX review for livelock+--+{-# INLINE queueEmptyAhead #-}+queueEmptyAhead :: MonadIO m => IORef ([t m a], Int) -> m Bool+queueEmptyAhead q = liftIO $ do+    (xs, _) <- readIORef q+    return $ null xs++{-# INLINE dequeueAhead #-}+dequeueAhead :: MonadIO m+    => IORef ([t m a], Int) -> m (Maybe (t m a, Int))+dequeueAhead q = liftIO $+    atomicModifyIORefCAS q $ \case+            ([], n) -> (([], n), Nothing)+            (x : [], n) -> (([], n), Just (x, n))+            _ -> error "more than one item on queue"++-------------------------------------------------------------------------------+-- Heap manipulation+-------------------------------------------------------------------------------++withIORef :: IORef a -> (a -> IO b) -> IO b+withIORef ref f = readIORef ref >>= f++atomicModifyIORef_ :: IORef a -> (a -> a) -> IO ()+atomicModifyIORef_ ref f =+    atomicModifyIORef ref $ \x -> (f x, ())++data HeapDequeueResult t m a =+      Clearing+    | Waiting Int+    | Ready (Entry Int (AheadHeapEntry t m a))++{-# INLINE dequeueFromHeap #-}+dequeueFromHeap+    :: IORef (Heap (Entry Int (AheadHeapEntry t m a)), Maybe Int)+    -> IO (HeapDequeueResult t m a)+dequeueFromHeap hpVar =+    atomicModifyIORef hpVar $ \pair@(hp, snum) ->+        case snum of+            Nothing -> (pair, Clearing)+            Just n -> do+                let r = H.uncons hp+                case r of+                    Just (ent@(Entry seqNo _ev), hp') ->+                            if seqNo == n+                            then ((hp', Nothing), Ready ent)+                            else assert (seqNo >= n) (pair, Waiting n)+                    Nothing -> (pair, Waiting n)++{-# INLINE dequeueFromHeapSeq #-}+dequeueFromHeapSeq+    :: IORef (Heap (Entry Int (AheadHeapEntry t m a)), Maybe Int)+    -> Int+    -> IO (HeapDequeueResult t m a)+dequeueFromHeapSeq hpVar i =+    atomicModifyIORef hpVar $ \(hp, snum) ->+        case snum of+            Nothing -> do+                let r = H.uncons hp+                case r of+                    Just (ent@(Entry seqNo _ev), hp') ->+                        if seqNo == i+                        then ((hp', Nothing), Ready ent)+                        else assert (seqNo >= i) ((hp, Just i), Waiting i)+                    Nothing -> ((hp, Just i), Waiting i)+            Just _ -> error "dequeueFromHeapSeq: unreachable"++heapIsSane :: Maybe Int -> Int -> Bool+heapIsSane snum seqNo =+    case snum of+        Nothing -> True+        Just n -> seqNo >= n++{-# INLINE requeueOnHeapTop #-}+requeueOnHeapTop+    :: IORef (Heap (Entry Int (AheadHeapEntry t m a)), Maybe Int)+    -> Entry Int (AheadHeapEntry t m a)+    -> Int+    -> IO ()+requeueOnHeapTop hpVar ent seqNo =+    atomicModifyIORef_ hpVar $ \(hp, snum) ->+        assert (heapIsSane snum seqNo) (H.insert ent hp, Just seqNo)++{-# INLINE updateHeapSeq #-}+updateHeapSeq+    :: IORef (Heap (Entry Int (AheadHeapEntry t m a)), Maybe Int)+    -> Int+    -> IO ()+updateHeapSeq hpVar seqNo =+    atomicModifyIORef_ hpVar $ \(hp, snum) ->+        assert (heapIsSane snum seqNo) (hp, Just seqNo)++-- XXX remove polymorphism in t, inline f+getAheadSVar :: MonadAsync m+    => State t m a+    -> (   IORef ([t m a], Int)+        -> IORef (Heap (Entry Int (AheadHeapEntry t m a)), Maybe Int)+        -> State t m a+        -> SVar t m a+        -> Maybe WorkerInfo+        -> m ())+    -> RunInIO m+    -> IO (SVar t m a)+getAheadSVar st f mrun = do+    outQ    <- newIORef ([], 0)+    -- the second component of the tuple is "Nothing" when heap is being+    -- cleared, "Just n" when we are expecting sequence number n to arrive+    -- before we can start clearing the heap.+    outH    <- newIORef (H.empty, Just 0)+    outQMv  <- newEmptyMVar+    active  <- newIORef 0+    wfw     <- newIORef False+    running <- newIORef S.empty+    -- Sequence number is incremented whenever something is queued, therefore,+    -- first sequence number would be 0+    q <- newIORef ([], -1)+    stopMVar <- newMVar ()+    yl <- case getYieldLimit st of+            Nothing -> return Nothing+            Just x -> Just <$> newIORef x+    rateInfo <- getYieldRateInfo st++    stats <- newSVarStats+    tid <- myThreadId++    let getSVar sv readOutput postProc = SVar+            { outputQueue      = outQ+            , outputQueueFromConsumer = undefined+            , remainingWork  = yl+            , maxBufferLimit   = getMaxBuffer st+            , pushBufferSpace = undefined+            , pushBufferPolicy = undefined+            , pushBufferMVar   = undefined+            , maxWorkerLimit   = min (getMaxThreads st) (getMaxBuffer st)+            , yieldRateInfo    = rateInfo+            , outputDoorBell   = outQMv+            , outputDoorBellFromConsumer = undefined+            , readOutputQ      = readOutput sv+            , postProcess      = postProc sv+            , workerThreads    = running+            , workLoop         = f q outH st{streamVar = Just sv} sv+            , enqueue          = enqueueAhead sv q+            , isWorkDone       = isWorkDoneAhead sv q outH+            , isQueueDone      = isQueueDoneAhead sv q+            , needDoorBell     = wfw+            , svarStyle        = AheadVar+            , svarStopStyle    = StopNone+            , svarStopBy       = undefined+            , svarMrun         = mrun+            , workerCount      = active+            , accountThread    = delThread sv+            , workerStopMVar   = stopMVar+            , svarRef          = Nothing+            , svarInspectMode  = getInspectMode st+            , svarCreator      = tid+            , aheadWorkQueue   = q+            , outputHeap       = outH+            , svarStats        = stats+            }++    let sv =+            case getStreamRate st of+                Nothing -> getSVar sv readOutputQBounded postProcessBounded+                Just _  -> getSVar sv readOutputQPaced postProcessPaced+     in return sv++    where++    {-# INLINE isQueueDoneAhead #-}+    isQueueDoneAhead sv q = do+        queueDone <- checkEmpty q+        yieldsDone <-+                case remainingWork sv of+                    Just yref -> do+                        n <- readIORef yref+                        return (n <= 0)+                    Nothing -> return False+        -- XXX note that yieldsDone can only be authoritative only when there+        -- are no workers running. If there are active workers they can+        -- later increment the yield count and therefore change the result.+        return $ yieldsDone || queueDone++    {-# INLINE isWorkDoneAhead #-}+    isWorkDoneAhead sv q ref = do+        heapDone <- do+                (hp, _) <- readIORef ref+                return (H.size hp <= 0)+        queueDone <- isQueueDoneAhead sv q+        return $ heapDone && queueDone++    checkEmpty q = do+        (xs, _) <- readIORef q+        return $ null xs++{-# INLINABLE newAheadVar #-}+newAheadVar :: MonadAsync m+    => State t m a+    -> t m a+    -> (   IORef ([t m a], Int)+        -> IORef (Heap (Entry Int (AheadHeapEntry t m a)), Maybe Int)+        -> State t m a+        -> SVar t m a+        -> Maybe WorkerInfo+        -> m ())+    -> m (SVar t m a)+newAheadVar st m wloop = do+    mrun <- captureMonadState+    sv <- liftIO $ getAheadSVar st wloop mrun+    sendFirstWorker sv m++-------------------------------------------------------------------------------+-- WAhead+-------------------------------------------------------------------------------++-- XXX To be implemented. Use a linked queue like WAsync and put back the+-- remaining computation at the back of the queue instead of the heap, and+-- increment the sequence number.++-------------------------------------------------------------------------------+-- Parallel+-------------------------------------------------------------------------------++getParallelSVar :: MonadIO m+    => SVarStopStyle -> State t m a -> RunInIO m -> IO (SVar t m a)+getParallelSVar ss st mrun = do+    outQ    <- newIORef ([], 0)+    outQRev <- newIORef ([], 0)+    outQMv  <- newEmptyMVar+    outQMvRev <- newEmptyMVar+    active  <- newIORef 0+    running <- newIORef S.empty+    yl <- case getYieldLimit st of+            Nothing -> return Nothing+            Just x -> Just <$> newIORef x+    rateInfo <- getYieldRateInfo st+    let bufLim =+            case getMaxBuffer st of+                Unlimited -> undefined+                Limited x -> fromIntegral x+    remBuf <- newIORef bufLim+    pbMVar <- newMVar ()++    stats <- newSVarStats+    tid <- myThreadId++    stopBy <-+        case ss of+            StopBy -> liftIO $ newIORef undefined+            _ -> return undefined++    let sv =+            SVar { outputQueue      = outQ+                 , outputQueueFromConsumer = outQRev+                 , remainingWork    = yl+                 , maxBufferLimit   = getMaxBuffer st+                 , pushBufferSpace  = remBuf+                 , pushBufferPolicy = PushBufferBlock+                 , pushBufferMVar   = pbMVar+                 , maxWorkerLimit   = Unlimited+                 -- Used only for diagnostics+                 , yieldRateInfo    = rateInfo+                 , outputDoorBell   = outQMv+                 , outputDoorBellFromConsumer = outQMvRev+                 , readOutputQ      = readOutputQPar sv+                 , postProcess      = allThreadsDone sv+                 , workerThreads    = running+                 , workLoop         = undefined+                 , enqueue          = undefined+                 , isWorkDone       = undefined+                 , isQueueDone      = undefined+                 , needDoorBell     = undefined+                 , svarStyle        = ParallelVar+                 , svarStopStyle    = ss+                 , svarStopBy       = stopBy+                 , svarMrun         = mrun+                 , workerCount      = active+                 , accountThread    = modifyThread sv+                 , workerStopMVar   = undefined+                 , svarRef          = Nothing+                 , svarInspectMode  = getInspectMode st+                 , svarCreator      = tid+                 , aheadWorkQueue   = undefined+                 , outputHeap       = undefined+                 , svarStats        = stats+                 }+     in return sv++    where++    readOutputQPar sv = liftIO $ do+        withDiagMVar sv "readOutputQPar: doorbell"+            $ takeMVar (outputDoorBell sv)+        case yieldRateInfo sv of+            Nothing -> return ()+            Just yinfo -> void $ collectLatency sv yinfo False+        r <- fst `fmap` readOutputQRaw sv+        liftIO $ do+            void $ tryTakeMVar (pushBufferMVar sv)+            resetBufferLimit sv+            writeBarrier+            void $ tryPutMVar (pushBufferMVar sv) ()+        return r++{-# INLINABLE newParallelVar #-}+newParallelVar :: MonadAsync m+    => SVarStopStyle -> State t m a -> m (SVar t m a)+newParallelVar ss st = do+    mrun <- captureMonadState+    liftIO $ getParallelSVar ss st mrun
+ src/Streamly/Internal/Data/SVar/Dispatch.hs view
@@ -0,0 +1,742 @@+-- |+-- Module      : Streamly.Internal.Data.SVar.Dispatch+-- Copyright   : (c) 2017 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+--+module Streamly.Internal.Data.SVar.Dispatch+    (+    -- * Latency collection+      collectLatency++    -- * Diagnostics+    , withDiagMVar+    , dumpSVar+    , printSVar++    -- * Thread accounting+    , delThread+    , modifyThread+    , allThreadsDone++    -- * Dispatching+    , recordMaxWorkers+    , pushWorker+    , pushWorkerPar+    , dispatchWorker+    , dispatchWorkerPaced+    , sendWorkerWait+    , sendFirstWorker+    , sendWorkerDelay+    , sendWorkerDelayPaced+    )+where++#include "inline.hs"++import Control.Concurrent (takeMVar, tryReadMVar, ThreadId, threadDelay)+import Control.Concurrent.MVar (tryPutMVar)+import Control.Exception+       (assert, catches, throwIO, Handler(..), BlockedIndefinitelyOnMVar(..),+        BlockedIndefinitelyOnSTM(..))+import Control.Monad (when, void)+import Control.Monad.IO.Class (MonadIO(liftIO))+import Data.Maybe (fromJust, fromMaybe)+import Data.IORef (IORef, modifyIORef, newIORef, readIORef, writeIORef)+#if __GLASGOW_HASKELL__ < 804+import Data.Semigroup ((<>))+#endif+import Streamly.Internal.Control.Concurrent+    (MonadAsync, captureMonadState, doFork)+import Streamly.Internal.Data.Atomics+       (atomicModifyIORefCAS, atomicModifyIORefCAS_, writeBarrier,+        storeLoadBarrier)+import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime)+import Streamly.Internal.Data.Time.Units+       (AbsTime, NanoSecond64(..), MicroSecond64(..), diffAbsTime64,+        fromRelTime64, toRelTime64, showNanoSecond64, showRelTime64)+import System.IO (hPutStrLn, stderr)++import qualified Data.Heap as H+import qualified Data.Set as S++import Streamly.Internal.Data.SVar.Type+import Streamly.Internal.Data.SVar.Worker++-------------------------------------------------------------------------------+-- Worker latency data processing+-------------------------------------------------------------------------------++-- Every once in a while workers update the latencies and check the yield rate.+-- They return if we are above the expected yield rate. If we check too often+-- it may impact performance, if we check less often we may have a stale+-- picture. We update every minThreadDelay but we translate that into a yield+-- count based on latency so that the checking overhead is little.+--+-- XXX use a generation count to indicate that the value is updated. If the+-- value is updated an existing worker must check it again on the next yield.+-- Otherwise it is possible that we may keep updating it and because of the mod+-- worker keeps skipping it.+updateWorkerPollingInterval :: YieldRateInfo -> NanoSecond64 -> IO ()+updateWorkerPollingInterval yinfo latency = do+    let periodRef = workerPollingInterval yinfo+        cnt = max 1 $ minThreadDelay `div` latency+        period = min cnt (fromIntegral magicMaxBuffer)++    writeIORef periodRef (fromIntegral period)++{-# INLINE recordMinMaxLatency #-}+recordMinMaxLatency :: SVar t m a -> NanoSecond64 -> IO ()+recordMinMaxLatency sv new = do+    let ss = svarStats sv+    minLat <- readIORef (minWorkerLatency ss)+    when (new < minLat || minLat == 0) $+        writeIORef (minWorkerLatency ss) new++    maxLat <- readIORef (maxWorkerLatency ss)+    when (new > maxLat) $ writeIORef (maxWorkerLatency ss) new++recordAvgLatency :: SVar t m a -> (Count, NanoSecond64) -> IO ()+recordAvgLatency sv (count, time) = do+    let ss = svarStats sv+    modifyIORef (avgWorkerLatency ss) $+        \(cnt, t) -> (cnt + count, t + time)++-- Pour the pending latency stats into a collection bucket+{-# INLINE collectWorkerPendingLatency #-}+collectWorkerPendingLatency+    :: IORef (Count, Count, NanoSecond64)+    -> IORef (Count, Count, NanoSecond64)+    -> IO (Count, Maybe (Count, NanoSecond64))+collectWorkerPendingLatency cur col = do+    (fcount, count, time) <- atomicModifyIORefCAS cur $ \v -> ((0,0,0), v)++    (fcnt, cnt, t) <- readIORef col+    let totalCount = fcnt + fcount+        latCount   = cnt + count+        latTime    = t + time+    writeIORef col (totalCount, latCount, latTime)++    assert (latCount == 0 || latTime /= 0) (return ())+    let latPair =+            if latCount > 0 && latTime > 0+            then Just (latCount, latTime)+            else Nothing+    return (totalCount, latPair)++{-# INLINE shouldUseCollectedBatch #-}+shouldUseCollectedBatch+    :: Count+    -> NanoSecond64+    -> NanoSecond64+    -> NanoSecond64+    -> Bool+shouldUseCollectedBatch collectedYields collectedTime newLat prevLat =+    let r = fromIntegral newLat / fromIntegral prevLat :: Double+    in     (collectedYields > fromIntegral magicMaxBuffer)+        || (collectedTime > minThreadDelay)+        || (prevLat > 0 && (r > 2 || r < 0.5))+        || (prevLat == 0)++-- Returns a triple, (1) yield count since last collection, (2) the base time+-- when we started counting, (3) average latency in the last measurement+-- period. The former two are used for accurate measurement of the going rate+-- whereas the average is used for future estimates e.g. how many workers+-- should be maintained to maintain the rate.+-- CAUTION! keep it in sync with getWorkerLatency+collectLatency :: SVar t m a+               -> YieldRateInfo+               -> Bool+               -> IO (Count, AbsTime, NanoSecond64)+collectLatency sv yinfo drain = do+    let cur      = workerPendingLatency yinfo+        col      = workerCollectedLatency yinfo+        longTerm = svarAllTimeLatency yinfo+        measured = workerMeasuredLatency yinfo++    (newCount, newLatPair) <- collectWorkerPendingLatency cur col+    (lcount, ltime) <- readIORef longTerm+    prevLat <- readIORef measured++    let newLcount = lcount + newCount+        retWith lat = return (newLcount, ltime, lat)++    case newLatPair of+        Nothing -> retWith prevLat+        Just (count, time) -> do+            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,+            -- otherwise we return the previous latency derived from the+            -- previous batch.+            if shouldUseCollectedBatch newCount time newLat prevLat || drain+            then do+                -- XXX make this NOINLINE?+                updateWorkerPollingInterval yinfo (max newLat prevLat)+                when (svarInspectMode sv) $ recordAvgLatency sv (count, time)+                writeIORef col (0, 0, 0)+                writeIORef measured ((prevLat + newLat) `div` 2)+                modifyIORef longTerm $ \(_, t) -> (newLcount, t)+                retWith newLat+            else retWith prevLat++-------------------------------------------------------------------------------+-- Dumping the SVar for debug/diag+-------------------------------------------------------------------------------++dumpSVarStats :: SVar t m a -> SVarStats -> SVarStyle -> IO String+dumpSVarStats sv ss style = do+    case yieldRateInfo sv of+        Nothing -> return ()+        Just yinfo -> do+            _ <- liftIO $ collectLatency sv yinfo True+            return ()++    dispatches <- readIORef $ totalDispatches ss+    maxWrk <- readIORef $ maxWorkers ss+    maxOq <- readIORef $ maxOutQSize ss+    maxHp <- readIORef $ maxHeapSize ss+    minLat <- readIORef $ minWorkerLatency ss+    maxLat <- readIORef $ maxWorkerLatency ss+    (avgCnt, avgTime) <- readIORef $ avgWorkerLatency ss+    (svarCnt, svarGainLossCnt, svarLat) <- case yieldRateInfo sv of+        Nothing -> return (0, 0, 0)+        Just yinfo -> do+            (cnt, startTime) <- readIORef $ svarAllTimeLatency yinfo+            if cnt > 0+            then do+                t <- readIORef (svarStopTime ss)+                gl <- readIORef (svarGainedLostYields yinfo)+                case t of+                    Nothing -> do+                        now <- getTime Monotonic+                        let interval = diffAbsTime64 now startTime+                        return (cnt, gl, interval `div` fromIntegral cnt)+                    Just stopTime -> do+                        let interval = diffAbsTime64 stopTime startTime+                        return (cnt, gl, interval `div` fromIntegral cnt)+            else return (0, 0, 0)++    return $ unlines+        [ "total dispatches = " <> show dispatches+        , "max workers = " <> show maxWrk+        , "max outQSize = " <> show maxOq+            <> (if style == AheadVar+               then "\nheap max size = " <> show maxHp+               else "")+            <> (if minLat > 0+               then "\nmin worker latency = " <> showNanoSecond64 minLat+               else "")+            <> (if maxLat > 0+               then "\nmax worker latency = " <> showNanoSecond64 maxLat+               else "")+            <> (if avgCnt > 0+                then let lat = avgTime `div` fromIntegral avgCnt+                     in "\navg worker latency = " <> showNanoSecond64 lat+                else "")+            <> (if svarLat > 0+               then "\nSVar latency = " <> showRelTime64 svarLat+               else "")+            <> (if svarCnt > 0+               then "\nSVar yield count = " <> show svarCnt+               else "")+            <> (if svarGainLossCnt > 0+               then "\nSVar gain/loss yield count = " <> show svarGainLossCnt+               else "")+        ]++{-# NOINLINE dumpSVar #-}+dumpSVar :: SVar t m a -> IO String+dumpSVar sv = do+    (oqList, oqLen) <- readIORef $ outputQueue sv+    db <- tryReadMVar $ outputDoorBell sv+    aheadDump <-+        if svarStyle sv == AheadVar+        then do+            (oheap, oheapSeq) <- readIORef $ outputHeap sv+            (wq, wqSeq) <- readIORef $ aheadWorkQueue sv+            return $ unlines+                [ "heap length = " <> show (H.size oheap)+                , "heap seqeunce = " <> show oheapSeq+                , "work queue length = " <> show (length wq)+                , "work queue sequence = " <> show wqSeq+                ]+        else return []++    let style = svarStyle sv+    waiting <-+        if style /= ParallelVar+        then readIORef $ needDoorBell sv+        else return False+    rthread <- readIORef $ workerThreads sv+    workers <- readIORef $ workerCount sv+    stats <- dumpSVarStats sv (svarStats sv) (svarStyle sv)++    return $ unlines+        [+          "Creator tid = " <> show (svarCreator sv),+          "style = " <> show (svarStyle sv)+        , "---------CURRENT STATE-----------"+        , "outputQueue length computed  = " <> show (length oqList)+        , "outputQueue length maintained = " <> show oqLen+        -- XXX print the types of events in the outputQueue, first 5+        , "outputDoorBell = " <> show db+        ]+        <> aheadDump+        <> unlines+        [ "needDoorBell = " <> show waiting+        , "running threads = " <> show rthread+        -- XXX print the status of first 5 threads+        , "running thread count = " <> show workers+        ]+        <> "---------STATS-----------\n"+        <> stats++-- 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.++{-# NOINLINE mvarExcHandler #-}+mvarExcHandler :: SVar t m a -> String -> BlockedIndefinitelyOnMVar -> IO ()+mvarExcHandler sv label e@BlockedIndefinitelyOnMVar = do+    svInfo <- dumpSVar sv+    hPutStrLn stderr $ label <> " " <> "BlockedIndefinitelyOnMVar\n" <> svInfo+    throwIO e++{-# NOINLINE stmExcHandler #-}+stmExcHandler :: SVar t m a -> String -> BlockedIndefinitelyOnSTM -> IO ()+stmExcHandler sv label e@BlockedIndefinitelyOnSTM = do+    svInfo <- dumpSVar sv+    hPutStrLn stderr $ label <> " " <> "BlockedIndefinitelyOnSTM\n" <> svInfo+    throwIO e++withDiagMVar :: SVar t m a -> String -> IO () -> IO ()+withDiagMVar sv label action =+    if svarInspectMode sv+    then+        action `catches` [ Handler (mvarExcHandler sv label)+                         , Handler (stmExcHandler sv label)+                         ]+    else action++printSVar :: SVar t m a -> String -> IO ()+printSVar sv how = do+    svInfo <- dumpSVar sv+    hPutStrLn stderr $ "\n" <> how <> "\n" <> svInfo++-------------------------------------------------------------------------------+-- Thread accounting+-------------------------------------------------------------------------------++-- Thread tracking is needed for two reasons:+--+-- 1) Killing threads on exceptions. Threads may not be left to go away by+-- themselves because they may run for significant times before going away or+-- worse they may be stuck in IO and never go away.+--+-- 2) To know when all threads are done and the stream has ended.++{-# NOINLINE addThread #-}+addThread :: MonadIO m => SVar t m a -> ThreadId -> m ()+addThread sv tid =+    liftIO $ modifyIORef (workerThreads sv) (S.insert tid)++-- This is cheaper than modifyThread because we do not have to send a+-- outputDoorBell This can make a difference when more workers are being+-- dispatched.+{-# INLINE delThread #-}+delThread :: MonadIO m => SVar t m a -> ThreadId -> m ()+delThread sv tid =+    liftIO $ modifyIORef (workerThreads sv) (S.delete tid)++-- If present then delete else add. This takes care of out of order add and+-- delete i.e. a delete arriving before we even added a thread.+-- This occurs when the forked thread is done even before the 'addThread' right+-- after the fork gets a chance to run.+{-# INLINE modifyThread #-}+modifyThread :: MonadIO m => SVar t m a -> ThreadId -> m ()+modifyThread sv tid = do+    changed <- liftIO $ atomicModifyIORefCAS (workerThreads sv) $ \old ->+        if S.member tid old+        then let new = S.delete tid old in (new, new)+        else let new = S.insert tid old in (new, old)+    when (null changed) $+         liftIO $ do+            writeBarrier+            void $ tryPutMVar (outputDoorBell sv) ()++-- | This is safe even if we are adding more threads concurrently because if+-- a child thread is adding another thread then anyway 'workerThreads' will+-- not be empty.+{-# INLINE allThreadsDone #-}+allThreadsDone :: MonadIO m => SVar t m a -> m Bool+allThreadsDone sv = liftIO $ S.null <$> readIORef (workerThreads sv)++-------------------------------------------------------------------------------+-- Dispatching workers+-------------------------------------------------------------------------------++{-# NOINLINE recordMaxWorkers #-}+recordMaxWorkers :: MonadIO m => SVar t m a -> m ()+recordMaxWorkers sv = liftIO $ do+    active <- readIORef (workerCount sv)+    maxWrk <- readIORef (maxWorkers $ svarStats sv)+    when (active > maxWrk) $ writeIORef (maxWorkers $ svarStats sv) active+    modifyIORef (totalDispatches $ svarStats sv) (+1)++{-# NOINLINE pushWorker #-}+pushWorker :: MonadAsync m => Count -> SVar t m a -> m ()+pushWorker yieldMax sv = do+    liftIO $ atomicModifyIORefCAS_ (workerCount sv) $ \n -> n + 1+    when (svarInspectMode sv) $ recordMaxWorkers sv+    -- This allocation matters when significant number of workers are being+    -- sent. We allocate it only when needed.+    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 = yieldMax+                    , workerYieldCount = cntRef+                    , workerLatencyStart = lat+                    }+    doFork (workLoop sv winfo) (svarMrun sv) (handleChildException sv)+        >>= addThread sv++-- XXX we can push the workerCount modification in accountThread and use the+-- same pushWorker for Parallel case as well.+--+-- | In contrast to pushWorker which always happens only from the consumer+-- thread, a pushWorkerPar can happen concurrently from multiple threads on the+-- producer side. So we need to use a thread safe modification of+-- workerThreads. Alternatively, we can use a CreateThread event to avoid+-- using a CAS based modification.+{-# INLINE pushWorkerPar #-}+pushWorkerPar+    :: MonadAsync m+    => SVar t m a -> (Maybe WorkerInfo -> m ()) -> m ()+pushWorkerPar sv wloop =+    if svarInspectMode sv+    then forkWithDiag+    else doFork (wloop Nothing) (svarMrun sv) (handleChildException sv)+            >>= modifyThread sv++    where++    {-# 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+                        }++        doFork (wloop winfo) (svarMrun sv) (handleChildException sv)+            >>= modifyThread sv++-- Returns:+-- True: can dispatch more+-- False: cannot dispatch any more+dispatchWorker :: MonadAsync m => Count -> SVar t m a -> m Bool+dispatchWorker yieldCount sv = do+    let workerLimit = maxWorkerLimit sv+    -- XXX in case of Ahead streams we should not send more than one worker+    -- when the work queue is done but heap is not done.+    done <- liftIO $ isWorkDone sv+    -- Note, "done" may not mean that the work is actually finished if there+    -- are workers active, because there may be a worker which has not yet+    -- queued the leftover work.+    if not done+    then do+        qDone <- liftIO $ isQueueDone sv+        -- This count may not be accurate as it is decremented by the workers+        -- and we have no synchronization with that decrement.+        active <- liftIO $ readIORef $ workerCount sv+        if not qDone+        then do+            -- Note that we may deadlock if the previous workers (tasks in the+            -- stream) wait/depend on the future workers (tasks in the stream)+            -- executing. In that case we should either configure the maxWorker+            -- count to higher or use parallel style instead of ahead or async+            -- style.+            limit <- case remainingWork sv of+                Nothing -> return workerLimit+                Just ref -> do+                    n <- liftIO $ readIORef ref+                    case yieldRateInfo sv of+                        Just _ -> return workerLimit+                        Nothing ->+                            return $+                                case workerLimit of+                                    Unlimited -> Limited (fromIntegral n)+                                    Limited lim -> Limited $ min lim (fromIntegral n)++            -- XXX for ahead streams shall we take the heap yields into account+            -- for controlling the dispatch? We should not dispatch if the heap+            -- has already got the limit covered.+            let dispatch = pushWorker yieldCount sv >> return True+             in case limit of+                Unlimited -> dispatch+                -- Note that the use of remainingWork and workerCount is not+                -- atomic and the counts may even have changed between reading+                -- and using them here, so this is just approximate logic and+                -- we cannot rely on it for correctness. We may actually+                -- dispatch more workers than required.+                Limited lim | lim > fromIntegral active -> dispatch+                _ -> return False+        else do+            when (active <= 0) $ pushWorker 0 sv+            return False+    else return False++-- XXX in case of ahead style stream we need to take the heap size into account+-- because we return the workers on the basis of that which causes a condition+-- where we keep dispatching and they keep returning. So we must have exactly+-- the same logic for not dispatching and for returning.+--+-- Returns:+-- True: can dispatch more+-- False: full, no more dispatches+dispatchWorkerPaced :: MonadAsync m => SVar t m a -> m Bool+dispatchWorkerPaced sv = do+    let yinfo = fromJust $ yieldRateInfo sv+    (svarYields, svarElapsed, wLatency) <- do+        now <- liftIO $ getTime Monotonic+        (yieldCount, baseTime, lat) <-+            liftIO $ collectLatency sv yinfo False+        let elapsed = fromRelTime64 $ diffAbsTime64 now baseTime+        let latency =+                if lat == 0+                then fromMaybe lat (workerBootstrapLatency yinfo)+                else lat++        return (yieldCount, elapsed, latency)++    if wLatency == 0+    -- Need to measure the latency with a single worker before we can perform+    -- any computation.+    then return False+    else do+        let workerLimit = maxWorkerLimit sv+        let targetLat = svarLatencyTarget yinfo+        let range = svarLatencyRange yinfo+        gainLoss <- liftIO $ readIORef (svarGainedLostYields yinfo)+        let work = estimateWorkers workerLimit svarYields gainLoss svarElapsed+                                   wLatency targetLat range++        -- XXX we need to take yieldLimit into account here. If we are at the+        -- end of the limit as well as the time, we should not be sleeping.+        -- If we are not actually planning to dispatch any more workers we need+        -- to take that in account.+        case work of+            BlockWait s -> do+                assert (s >= 0) (return ())+                -- XXX note that when we return from here we will block waiting+                -- for the result from the existing worker. If that takes too+                -- long we won't be able to send another worker until the+                -- result arrives.+                --+                -- Sleep only if there are no active workers, otherwise we will+                -- defer the output of those. Note we cannot use workerCount+                -- here as it is not a reliable way to ensure there are+                -- definitely no active workers. When workerCount is 0 we may+                -- still have a Stop event waiting in the outputQueue.+                done <- allThreadsDone sv+                when done $ void $ do+                    let us = fromRelTime64 (toRelTime64 s) :: MicroSecond64+                    liftIO $ threadDelay (fromIntegral us)+                    dispatchWorker 1 sv+                return False+            PartialWorker yields -> do+                assert (yields > 0) (return ())+                updateGainedLostYields yinfo yields++                done <- allThreadsDone sv+                when done $ void $ dispatchWorker yields sv+                return False+            ManyWorkers netWorkers yields -> do+                assert (netWorkers >= 1) (return ())+                assert (yields >= 0) (return ())+                updateGainedLostYields yinfo yields++                let periodRef = workerPollingInterval yinfo+                    ycnt = max 1 $ yields `div` fromIntegral netWorkers+                    period = min ycnt (fromIntegral magicMaxBuffer)++                old <- liftIO $ readIORef periodRef+                when (period < old) $+                    liftIO $ writeIORef periodRef period++                cnt <- liftIO $ readIORef $ workerCount sv+                if cnt < netWorkers+                then do+                    let total = netWorkers - cnt+                        batch = max 1 $ fromIntegral $+                                    minThreadDelay `div` targetLat+                    -- XXX stagger the workers over a period?+                    -- XXX cannot sleep, as that would mean we cannot process+                    -- the outputs. need to try a different mechanism to+                    -- stagger.+                    -- when (total > batch) $+                       -- liftIO $ threadDelay $ nanoToMicroSecs minThreadDelay+                    dispatchN (min total batch)+                else return False++    where++    updateGainedLostYields yinfo yields = do+        let buf = fromIntegral $ svarRateBuffer yinfo+        when (yields /= 0 && abs yields > buf) $ do+            let delta =+                   if yields > 0+                   then yields - buf+                   else yields + buf+            liftIO $ modifyIORef (svarGainedLostYields yinfo) (+ delta)++    dispatchN n =+        if n == 0+        then return True+        else do+            r <- dispatchWorker 0 sv+            if r+            then dispatchN (n - 1)+            else return False++{-# NOINLINE sendWorkerWait #-}+sendWorkerWait+    :: MonadAsync m+    => (SVar t m a -> IO ())+    -> (SVar t m a -> m Bool)+    -> SVar t m a+    -> m ()+sendWorkerWait delay dispatch sv = do+    -- Note that we are guaranteed to have at least one outstanding worker when+    -- we enter this function. So if we sleep we are guaranteed to be woken up+    -- by an outputDoorBell, when the worker exits.++    liftIO $ delay sv+    (_, n) <- liftIO $ readIORef (outputQueue sv)+    when (n <= 0) $ do+        -- The queue may be empty temporarily if the worker has dequeued the+        -- work item but has not enqueued the remaining part yet. For the same+        -- reason, a worker may come back if it tries to dequeue and finds the+        -- queue empty, even though the whole work has not finished yet.++        -- If we find that the queue is empty, but it may be empty+        -- temporarily, when we checked it. If that's the case we might+        -- sleep indefinitely unless the active workers produce some+        -- output. We may deadlock specially if the otuput from the active+        -- workers depends on the future workers that we may never send.+        -- So in case the queue was temporarily empty set a flag to inform+        -- the enqueue to send us a doorbell.++        -- Note that this is just a best effort mechanism to avoid a+        -- deadlock. Deadlocks may still happen if for some weird reason+        -- the consuming computation shares an MVar or some other resource+        -- with the producing computation and gets blocked on that resource+        -- and therefore cannot do any pushworker to add more threads to+        -- the producer. In such cases the programmer should use a parallel+        -- style so that all the producers are scheduled immediately and+        -- unconditionally. We can also use a separate monitor thread to+        -- push workers instead of pushing them from the consumer, but then+        -- we are no longer using pull based concurrency rate adaptation.+        --+        -- XXX update this in the tutorial.+        --+        -- Having pending active workers does not mean that we are guaranteed+        -- to be woken up if we sleep. In case of Ahead streams, there may be+        -- queued items in the heap even though the outputQueue is empty, and+        -- we may have active workers which are deadlocked on those items to be+        -- processed by the consumer. We should either guarantee that any+        -- worker, before returning, clears the heap or we send a worker to+        -- clear it. Normally we always send a worker if no output is seen, but+        -- if the thread limit is reached or we are using pacing then we may+        -- not send a worker. See the concurrentApplication test in the tests,+        -- that test case requires at least one yield from the producer to not+        -- deadlock, if the last workers output is stuck in the heap then this+        -- test fails.  This problem can be extended to n threads when the+        -- consumer may depend on the evaluation of next n items in the+        -- producer stream.++        -- register for the outputDoorBell before we check the queue so that if+        -- we sleep because the queue was empty we are guaranteed to get a+        -- doorbell on the next enqueue.++        liftIO $ atomicModifyIORefCAS_ (needDoorBell sv) $ const True+        liftIO storeLoadBarrier+        canDoMore <- dispatch sv++        -- XXX test for the case when we miss sending a worker when the worker+        -- count is more than 1500.+        --+        -- XXX Assert here that if the heap is not empty then there is at+        -- least one outstanding worker. Otherwise we could be sleeping+        -- forever.++        if canDoMore+        then sendWorkerWait delay dispatch sv+        else do+            liftIO $ withDiagMVar sv "sendWorkerWait: nothing to do"+                             $ takeMVar (outputDoorBell sv)+            (_, len) <- liftIO $ readIORef (outputQueue sv)+            when (len <= 0) $ sendWorkerWait delay dispatch sv++sendFirstWorker :: MonadAsync m => SVar t m a -> t m a -> m (SVar t m a)+sendFirstWorker sv m = do+    -- 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.+    runIn <- captureMonadState+    liftIO $ enqueue sv (runIn, m)+    case yieldRateInfo sv of+        Nothing -> pushWorker 0 sv+        Just yinfo  ->+            if svarLatencyTarget yinfo == maxBound+            then liftIO $ threadDelay maxBound+            else pushWorker 1 sv+    return sv++sendWorkerDelayPaced :: SVar t m a -> IO ()+sendWorkerDelayPaced _ = return ()++sendWorkerDelay :: SVar t m a -> IO ()+sendWorkerDelay _sv =+    -- XXX we need a better way to handle this than hardcoded delays. The+    -- delays may be different for different systems.+    -- If there is a usecase where this is required we can create a combinator+    -- to set it as a config in the state.+    {-+  do+    ncpu <- getNumCapabilities+    if ncpu <= 1+    then+        if (svarStyle sv == AheadVar)+        then threadDelay 100+        else threadDelay 25+    else+        if (svarStyle sv == AheadVar)+        then threadDelay 100+        else threadDelay 10+    -}+    return ()
+ src/Streamly/Internal/Data/SVar/Pull.hs view
@@ -0,0 +1,164 @@+-- |+-- Module      : Streamly.Internal.Data.SVar.Pull+-- Copyright   : (c) 2017 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+--+module Streamly.Internal.Data.SVar.Pull+    (+    -- * Read Output+      readOutputQBasic+    , readOutputQRaw+    , readOutputQPaced+    , readOutputQBounded++    -- * Postprocess Hook After Reading+    , postProcessPaced+    , postProcessBounded++    -- * Release Resources+    , cleanupSVar+    , cleanupSVarFromWorker+    )+where++#include "inline.hs"++import Control.Concurrent (myThreadId, throwTo)+import Control.Monad (when, void)+import Control.Monad.IO.Class (MonadIO(liftIO))+import Data.IORef (readIORef, writeIORef)+import Data.IORef (IORef)+import Streamly.Internal.Control.Concurrent (MonadAsync)+import Streamly.Internal.Data.Atomics (atomicModifyIORefCAS)++import qualified Data.Set as S++import Streamly.Internal.Data.SVar.Type+import Streamly.Internal.Data.SVar.Dispatch++-------------------------------------------------------------------------------+-- Reading from the workers' output queue/buffer+-------------------------------------------------------------------------------++{-# INLINE readOutputQBasic #-}+readOutputQBasic :: IORef ([ChildEvent a], Int) -> IO ([ChildEvent a], Int)+readOutputQBasic q = atomicModifyIORefCAS q $ \x -> (([],0), x)++{-# INLINE readOutputQRaw #-}+readOutputQRaw :: SVar t m a -> IO ([ChildEvent a], Int)+readOutputQRaw sv = do+    (list, len) <- readOutputQBasic (outputQueue sv)+    when (svarInspectMode sv) $ do+        let ref = maxOutQSize $ svarStats sv+        oqLen <- readIORef ref+        when (len > oqLen) $ writeIORef ref len+    return (list, len)++readOutputQBounded :: MonadAsync m => SVar t m a -> m [ChildEvent a]+readOutputQBounded sv = do+    (list, len) <- liftIO $ readOutputQRaw sv+    -- When there is no output seen we dispatch more workers to help+    -- out if there is work pending in the work queue.+    if len <= 0+    then blockingRead+    else do+        -- send a worker proactively, if needed, even before we start+        -- processing the output.  This may degrade single processor+        -- perf but improves multi-processor, because of more+        -- parallelism+        sendOneWorker+        return list++    where++    sendOneWorker = do+        cnt <- liftIO $ readIORef $ workerCount sv+        when (cnt <= 0) $ do+            done <- liftIO $ isWorkDone sv+            when (not done) (pushWorker 0 sv)++    {-# INLINE blockingRead #-}+    blockingRead = do+        sendWorkerWait sendWorkerDelay (dispatchWorker 0) sv+        liftIO (fst `fmap` readOutputQRaw sv)++readOutputQPaced :: MonadAsync m => SVar t m a -> m [ChildEvent a]+readOutputQPaced sv = do+    (list, len) <- liftIO $ readOutputQRaw sv+    if len <= 0+    then blockingRead+    else do+        -- XXX send a worker proactively, if needed, even before we start+        -- processing the output.+        void $ dispatchWorkerPaced sv+        return list++    where++    {-# INLINE blockingRead #-}+    blockingRead = do+        sendWorkerWait sendWorkerDelayPaced dispatchWorkerPaced sv+        liftIO (fst `fmap` readOutputQRaw sv)++postProcessPaced :: MonadAsync m => SVar t m a -> m Bool+postProcessPaced sv = do+    workersDone <- allThreadsDone sv+    -- XXX If during consumption we figure out we are getting delayed then we+    -- should trigger dispatch there as well.  We should try to check on the+    -- workers after consuming every n item from the buffer?+    if workersDone+    then do+        r <- liftIO $ isWorkDone sv+        when (not r) $ do+            void $ dispatchWorkerPaced sv+            -- Note that we need to guarantee a worker since the work is not+            -- finished, therefore we cannot just rely on dispatchWorkerPaced+            -- which may or may not send a worker.+            noWorker <- allThreadsDone sv+            when noWorker $ pushWorker 0 sv+        return r+    else return False++postProcessBounded :: MonadAsync m => SVar t m a -> m Bool+postProcessBounded sv = do+    workersDone <- allThreadsDone sv+    -- There may still be work pending even if there are no workers pending+    -- because all the workers may return if the outputQueue becomes full. In+    -- that case send off a worker to kickstart the work again.+    --+    -- Note that isWorkDone can only be safely checked if all workers are done.+    -- When some workers are in progress they may have decremented the yield+    -- Limit and later ending up incrementing it again. If we look at the yield+    -- limit in that window we may falsely say that it is 0 and therefore we+    -- are done.+    if workersDone+    then do+        r <- liftIO $ isWorkDone sv+        -- Note that we need to guarantee a worker, therefore we cannot just+        -- use dispatchWorker which may or may not send a worker.+        when (not r) (pushWorker 0 sv)+        -- XXX do we need to dispatch many here?+        -- void $ dispatchWorker sv+        return r+    else return False++-------------------------------------------------------------------------------+-- Cleanup+-------------------------------------------------------------------------------++cleanupSVar :: SVar t m a -> IO ()+cleanupSVar sv = do+    workers <- readIORef (workerThreads sv)+    Prelude.mapM_ (`throwTo` ThreadAbort)+          workers++cleanupSVarFromWorker :: SVar t m a -> IO ()+cleanupSVarFromWorker sv = do+    workers <- readIORef (workerThreads sv)+    self <- myThreadId+    Prelude.mapM_ (`throwTo` ThreadAbort)+          (Prelude.filter (/= self) $ S.toList workers)
+ src/Streamly/Internal/Data/SVar/Type.hs view
@@ -0,0 +1,531 @@+-- |+-- Module      : Streamly.Internal.Data.SVar.Type+-- Copyright   : (c) 2017 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Internal.Data.SVar.Type+    (+    -- * Parent child communication+      ThreadAbort (..)+    , ChildEvent (..)+    , AheadHeapEntry (..)++    -- * SVar+    , Count (..)+    , Limit (..)+    , SVarStyle (..)+    , SVarStopStyle (..)+    , SVarStats (..)+    , WorkerInfo (..)+    , PushBufferPolicy(..)+    , LatencyRange (..)+    , YieldRateInfo (..)+    , SVar (..)++    -- * State threaded around the stream+    , Rate (..)+    , State (streamVar)++    -- ** Default State+    , magicMaxBuffer+    , defState++    -- ** Type cast+    , adaptState++    -- ** State accessors+    , getMaxThreads+    , setMaxThreads+    , getMaxBuffer+    , setMaxBuffer+    , getStreamRate+    , setStreamRate+    , getStreamLatency+    , setStreamLatency+    , getYieldLimit+    , setYieldLimit+    , getInspectMode+    , setInspectMode+    )+where++import Control.Concurrent (ThreadId)+import Control.Concurrent.MVar (MVar)+import Control.Exception (SomeException(..), Exception)+import Data.Heap (Heap, Entry(..))+import Data.Int (Int64)+import Data.IORef (IORef)+import Data.Kind (Type)+import Data.Set (Set)++import Streamly.Internal.Data.Time.Units (AbsTime, NanoSecond64(..))+import Streamly.Internal.Control.Concurrent (RunInIO(..))++newtype Count = Count Int64+    deriving ( Eq+             , Read+             , Show+             , Enum+             , Bounded+             , Num+             , Real+             , Integral+             , Ord+             )++------------------------------------------------------------------------------+-- Parent child thread communication type+------------------------------------------------------------------------------++data ThreadAbort = ThreadAbort deriving Show++instance Exception ThreadAbort++-- | Events that a child thread may send to a parent thread.+data ChildEvent a =+      ChildYield a+    | ChildStop ThreadId (Maybe SomeException)++-- | Sorting out-of-turn outputs in a heap for Ahead style streams+data AheadHeapEntry (t :: (Type -> Type) -> Type -> Type) m a =+      AheadEntryNull+    | AheadEntryPure a+    | AheadEntryStream (RunInIO m, t m a)+#undef Type++------------------------------------------------------------------------------+-- SVar: the state for thread management+------------------------------------------------------------------------------++-- | Identify the type of the SVar. Two computations using the same style can+-- be scheduled on the same SVar.+data SVarStyle =+      AsyncVar             -- depth first concurrent+    | WAsyncVar            -- breadth first concurrent+    | ParallelVar          -- all parallel+    | AheadVar             -- Concurrent look ahead+    deriving (Eq, Show)++-- | An SVar or a Stream Var is a conduit to the output from multiple streams+-- running concurrently and asynchronously. An SVar can be thought of as an+-- asynchronous IO handle. We can write any number of streams to an SVar in a+-- non-blocking manner and then read them back at any time at any pace.  The+-- SVar would run the streams asynchronously and accumulate results. An SVar+-- may not really execute the stream completely and accumulate all the results.+-- However, it ensures that the reader can read the results at whatever paces+-- it wants to read. The SVar monitors and adapts to the consumer's pace.+--+-- An SVar is a mini scheduler, it has an associated workLoop that holds the+-- stream tasks to be picked and run by a pool of worker threads. It has an+-- associated output queue where the output stream elements are placed by the+-- worker threads. A outputDoorBell is used by the worker threads to intimate the+-- consumer thread about availability of new results in the output queue. More+-- workers are added to the SVar by 'fromStreamVar' on demand if the output+-- produced is not keeping pace with the consumer. On bounded SVars, workers+-- block on the output queue to provide throttling of the producer  when the+-- consumer is not pulling fast enough.  The number of workers may even get+-- reduced depending on the consuming pace.+--+-- New work is enqueued either at the time of creation of the SVar or as a+-- result of executing the parallel combinators i.e. '<|' and '<|>' when the+-- already enqueued computations get evaluated. See 'joinStreamVarAsync'.++-- We measure the individual worker latencies to estimate the number of workers+-- needed or the amount of time we have to sleep between dispatches to achieve+-- a particular rate when controlled pace mode it used.+data WorkerInfo = WorkerInfo+    { workerYieldMax   :: Count -- 0 means unlimited+    -- total number of yields by the worker till now+    , workerYieldCount    :: IORef Count+    -- yieldCount at start, timestamp+    , workerLatencyStart  :: IORef (Count, AbsTime)+    }++data LatencyRange = LatencyRange+    { minLatency :: NanoSecond64+    , maxLatency :: NanoSecond64+    } deriving Show++-- Rate control.+data YieldRateInfo = YieldRateInfo+    { svarLatencyTarget    :: NanoSecond64+    , svarLatencyRange     :: LatencyRange+    , svarRateBuffer       :: Int++    -- [LOCKING] Unlocked access. Modified by the consumer thread and unsafely+    -- read by the worker threads+    , svarGainedLostYields :: IORef Count++    -- Actual latency/througput as seen from the consumer side, we count the+    -- yields and the time it took to generates those yields. This is used to+    -- increase or decrease the number of workers needed to achieve the desired+    -- rate. The idle time of workers is adjusted in this, so that we only+    -- account for the rate when the consumer actually demands data.+    -- XXX interval latency is enough, we can move this under diagnostics build+    -- [LOCKING] Unlocked access. Modified by the consumer thread and unsafely+    -- read by the worker threads+    , svarAllTimeLatency :: IORef (Count, AbsTime)++    -- XXX Worker latency specified by the user to be used before the first+    -- actual measurement arrives. Not yet implemented+    , workerBootstrapLatency :: Maybe NanoSecond64++    -- After how many yields the worker should update the latency information.+    -- If the latency is high, this count is kept lower and vice-versa.  XXX If+    -- the latency suddenly becomes too high this count may remain too high for+    -- long time, in such cases the consumer can change it.+    -- 0 means no latency computation+    -- XXX this is derivable from workerMeasuredLatency, can be removed.+    -- [LOCKING] Unlocked access. Modified by the consumer thread and unsafely+    -- read by the worker threads+    , workerPollingInterval :: IORef Count++    -- This is in progress latency stats maintained by the workers which we+    -- empty into workerCollectedLatency stats at certain intervals - whenever+    -- we process the stream elements yielded in this period. The first count+    -- is all yields, the second count is only those yields for which the+    -- latency was measured to be non-zero (note that if the timer resolution+    -- is low the measured latency may be zero e.g. on JS platform).+    -- [LOCKING] Locked access. Modified by the consumer thread as well as+    -- worker threads. Workers modify it periodically based on+    -- workerPollingInterval and not on every yield to reduce the locking+    -- overhead.+    -- (allYieldCount, yieldCount, timeTaken)+    , workerPendingLatency   :: IORef (Count, Count, NanoSecond64)++    -- This is the second level stat which is an accmulation from+    -- workerPendingLatency stats. We keep accumulating latencies in this+    -- bucket until we have stats for a sufficient period and then we reset it+    -- to start collecting for the next period and retain the computed average+    -- latency for the last period in workerMeasuredLatency.+    -- [LOCKING] Unlocked access. Modified by the consumer thread and unsafely+    -- read by the worker threads+    -- (allYieldCount, yieldCount, timeTaken)+    , workerCollectedLatency :: IORef (Count, Count, NanoSecond64)++    -- Latency as measured by workers, aggregated for the last period.+    -- [LOCKING] Unlocked access. Modified by the consumer thread and unsafely+    -- read by the worker threads+    , workerMeasuredLatency :: IORef NanoSecond64+    }++data SVarStats = SVarStats {+      totalDispatches  :: IORef Int+    , maxWorkers       :: IORef Int+    , maxOutQSize      :: IORef Int+    , maxHeapSize      :: IORef Int+    , maxWorkQSize     :: IORef Int+    , avgWorkerLatency :: IORef (Count, NanoSecond64)+    , minWorkerLatency :: IORef NanoSecond64+    , maxWorkerLatency :: IORef NanoSecond64+    , svarStopTime     :: IORef (Maybe AbsTime)+}++-- This is essentially a 'Maybe Word' type+data Limit = Unlimited | Limited Word deriving Show++instance Eq Limit where+    Unlimited == Unlimited = True+    Unlimited == Limited _ = False+    Limited _ == Unlimited = False+    Limited x == Limited y = x == y++instance Ord Limit where+    Unlimited <= Unlimited = True+    Unlimited <= Limited _ = False+    Limited _ <= Unlimited = True+    Limited x <= Limited y = x <= y++-- When to stop the composed stream.+data SVarStopStyle =+      StopNone -- stops only when all streams are finished+    | StopAny  -- stop when any stream finishes+    | StopBy   -- stop when a specific stream finishes+    deriving (Eq, Show)++-- | Buffering policy for persistent push workers (in ParallelT).  In a pull+-- style SVar (in AsyncT, AheadT etc.), the consumer side dispatches workers on+-- demand, workers terminate if the buffer is full or if the consumer is not+-- cosuming fast enough.  In a push style SVar, a worker is dispatched only+-- once, workers are persistent and keep pushing work to the consumer via a+-- bounded buffer. If the buffer becomes full the worker either blocks, or it+-- can drop an item from the buffer to make space.+--+-- Pull style SVars are useful in lazy stream evaluation whereas push style+-- SVars are useful in strict left Folds.+--+-- XXX Maybe we can separate the implementation in two different types instead+-- of using a common SVar type.+--+data PushBufferPolicy =+      PushBufferDropNew  -- drop the latest element and continue+    | PushBufferDropOld  -- drop the oldest element and continue+    | PushBufferBlock    -- block the thread until space+                         -- becomes available++-- IMPORTANT NOTE: we cannot update the SVar after generating it as we have+-- references to the original SVar stored in several functions which will keep+-- pointing to the original data and the new updates won't reflect there.+-- Any updateable parts must be kept in mutable references (IORef).+--+data SVar t m a = SVar+    {+    -- Read only state+      svarStyle       :: SVarStyle+    , svarMrun        :: RunInIO m+    , svarStopStyle   :: SVarStopStyle+    , svarStopBy      :: IORef ThreadId++    -- Shared output queue (events, length)+    -- XXX For better efficiency we can try a preallocated array type (perhaps+    -- something like a vector) that allows an O(1) append. That way we will+    -- avoid constructing and reversing the list. Possibly we can also avoid+    -- the GC copying overhead. When the size increases we should be able to+    -- allocate the array in chunks.+    --+    -- [LOCKING] Frequent locked access. This is updated by workers on each+    -- yield and once in a while read by the consumer thread. This could have+    -- big locking overhead if the number of workers is high.+    --+    -- XXX We can use a per-CPU data structure to reduce the locking overhead.+    -- However, a per-cpu structure cannot guarantee the exact sequence in+    -- which the elements were added, though that may not be important.+    , outputQueue    :: IORef ([ChildEvent a], Int)++    -- [LOCKING] Infrequent MVar. Used when the outputQ transitions from empty+    -- to non-empty, or a work item is queued by a worker to the work queue and+    -- needDoorBell is set by the consumer.+    , outputDoorBell :: MVar ()  -- signal the consumer about output+    , readOutputQ    :: m [ChildEvent a]+    , postProcess    :: m Bool++    -- channel to send events from the consumer to the worker. Used to send+    -- exceptions from a fold driver to the fold computation running as a+    -- consumer thread in the concurrent fold cases. Currently only one event+    -- is sent by the fold so we do not really need a queue for it.+    , outputQueueFromConsumer :: IORef ([ChildEvent a], Int)+    , outputDoorBellFromConsumer :: MVar ()++    -- Combined/aggregate parameters+    -- This is truncated to maxBufferLimit if set to more than that. Otherwise+    -- potentially each worker may yield one value to the buffer in the worst+    -- case exceeding the requested buffer size.+    , maxWorkerLimit :: Limit+    , maxBufferLimit :: Limit+    -- These two are valid and used only when maxBufferLimit is Limited.+    , pushBufferSpace  :: IORef Count+    , pushBufferPolicy :: PushBufferPolicy+    -- [LOCKING] The consumer puts this MVar after emptying the buffer, workers+    -- block on it when the buffer becomes full. No overhead unless the buffer+    -- becomes full.+    , pushBufferMVar :: MVar ()++    -- [LOCKING] Read only access by consumer when dispatching a worker.+    -- Decremented by workers when picking work and undo decrement if the+    -- worker does not yield a value.+    , remainingWork  :: Maybe (IORef Count)+    , yieldRateInfo  :: Maybe YieldRateInfo++    -- Used only by bounded SVar types+    , enqueue        :: (RunInIO m, t m a) -> IO ()+    , isWorkDone     :: IO Bool+    , isQueueDone    :: IO Bool+    , needDoorBell   :: IORef Bool+    , workLoop       :: Maybe WorkerInfo -> m ()++    -- Shared, thread tracking+    -- [LOCKING] Updated unlocked only by consumer thread in case of+    -- Async/Ahead style SVars. Updated locked by worker threads in case of+    -- Parallel style.+    , workerThreads  :: IORef (Set ThreadId)+    -- [LOCKING] Updated locked by consumer thread when dispatching a worker+    -- and by the worker threads when the thread stops. This is read unsafely+    -- at several places where we want to rely on an approximate value.+    , workerCount    :: IORef Int+    , accountThread  :: ThreadId -> m ()+    , workerStopMVar :: MVar ()++    , svarStats      :: SVarStats+    -- to track garbage collection of SVar+    , svarRef        :: Maybe (IORef ())++    -- Only for diagnostics+    , svarInspectMode :: Bool+    , svarCreator    :: ThreadId+    , outputHeap     :: IORef ( Heap (Entry Int (AheadHeapEntry t m a))+                              , Maybe Int)+    -- Shared work queue (stream, seqNo)+    , aheadWorkQueue :: IORef ([t m a], Int)+    }++-------------------------------------------------------------------------------+-- Overall state threaded around a stream+-------------------------------------------------------------------------------++-- | Specifies the stream yield rate in yields per second (@Hertz@).+-- We keep accumulating yield credits at 'rateGoal'. At any point of time we+-- allow only as many yields as we have accumulated as per 'rateGoal' since the+-- start of time. If the consumer or the producer is slower or faster, the+-- actual rate may fall behind or exceed 'rateGoal'.  We try to recover the gap+-- between the two by increasing or decreasing the pull rate from the producer.+-- However, if the gap becomes more than 'rateBuffer' we try to recover only as+-- much as 'rateBuffer'.+--+-- 'rateLow' puts a bound on how low the instantaneous rate can go when+-- recovering the rate gap.  In other words, it determines the maximum yield+-- latency.  Similarly, 'rateHigh' puts a bound on how high the instantaneous+-- rate can go when recovering the rate gap.  In other words, it determines the+-- minimum yield latency. We reduce the latency by increasing concurrency,+-- therefore we can say that it puts an upper bound on concurrency.+--+-- If the 'rateGoal' is 0 or negative the stream never yields a value.+-- If the 'rateBuffer' is 0 or negative we do not attempt to recover.+--+-- /Since: 0.5.0 ("Streamly")/+--+-- @since 0.8.0+data Rate = Rate+    { rateLow    :: Double -- ^ The lower rate limit+    , rateGoal   :: Double -- ^ The target rate we want to achieve+    , rateHigh   :: Double -- ^ The upper rate limit+    , rateBuffer :: Int    -- ^ Maximum slack from the goal+    }++-- XXX we can put the resettable fields in a oneShotConfig field and others in+-- a persistentConfig field. That way reset would be fast and scalable+-- irrespective of the number of fields.+--+-- XXX make all these Limited types and use phantom types to distinguish them+data State t m a = State+    { -- one shot configuration, automatically reset for each API call+      streamVar   :: Maybe (SVar t m a)+    , _yieldLimit  :: Maybe Count++    -- persistent configuration, state that remains valid until changed by+    -- an explicit setting via a combinator.+    , _threadsHigh    :: Limit+    , _bufferHigh     :: Limit+    -- XXX these two can be collapsed into a single type+    , _streamLatency  :: Maybe NanoSecond64 -- bootstrap latency+    , _maxStreamRate  :: Maybe Rate+    , _inspectMode    :: Bool+    }++-------------------------------------------------------------------------------+-- State defaults and reset+-------------------------------------------------------------------------------++-- A magical value for the buffer size arrived at by running the smallest+-- possible task and measuring the optimal value of the buffer for that.  This+-- is obviously dependent on hardware, this figure is based on a 2.2GHz intel+-- core-i7 processor.+magicMaxBuffer :: Word+magicMaxBuffer = 1500++defaultMaxThreads, defaultMaxBuffer :: Limit+defaultMaxThreads = Limited magicMaxBuffer+defaultMaxBuffer = Limited magicMaxBuffer++-- The fields prefixed by an _ are not to be accessed or updated directly but+-- via smart accessor APIs.+defState :: State t m a+defState = State+    { streamVar = Nothing+    , _yieldLimit = Nothing+    , _threadsHigh = defaultMaxThreads+    , _bufferHigh = defaultMaxBuffer+    , _maxStreamRate = Nothing+    , _streamLatency = Nothing+    , _inspectMode = False+    }++-- XXX if perf gets affected we can have all the Nothing params in a single+-- structure so that we reset is fast. We can also use rewrite rules such that+-- reset occurs only in concurrent streams to reduce the impact on serial+-- streams.+-- We can optimize this so that we clear it only if it is a Just value, it+-- results in slightly better perf for zip/zipM but the performance of scan+-- worsens a lot, it does not fuse.+--+-- XXX This has a side effect of clearing the SVar and yieldLimit, therefore it+-- should not be used to convert from the same type to the same type, unless+-- you want to clear the SVar. For clearing the SVar you should be using the+-- appropriate unStream functions instead.+--+-- | Adapt the stream state from one type to another.+adaptState :: State t m a -> State t n b+adaptState st = st+    { streamVar = Nothing+    , _yieldLimit = Nothing+    }++-------------------------------------------------------------------------------+-- Smart get/set routines for State+-------------------------------------------------------------------------------++-- Use get/set routines instead of directly accessing the State fields+setYieldLimit :: Maybe Int64 -> State t m a -> State t m a+setYieldLimit lim st =+    st { _yieldLimit =+            case lim of+                Nothing -> Nothing+                Just n  ->+                    if n <= 0+                    then Just 0+                    else Just (fromIntegral n)+       }++getYieldLimit :: State t m a -> Maybe Count+getYieldLimit = _yieldLimit++setMaxThreads :: Int -> State t m a -> State t m a+setMaxThreads n st =+    st { _threadsHigh =+            if n < 0+            then Unlimited+            else if n == 0+                 then defaultMaxThreads+                 else Limited (fromIntegral n)+       }++getMaxThreads :: State t m a -> Limit+getMaxThreads = _threadsHigh++setMaxBuffer :: Int -> State t m a -> State t m a+setMaxBuffer n st =+    st { _bufferHigh =+            if n < 0+            then Unlimited+            else if n == 0+                 then defaultMaxBuffer+                 else Limited (fromIntegral n)+       }++getMaxBuffer :: State t m a -> Limit+getMaxBuffer = _bufferHigh++setStreamRate :: Maybe Rate -> State t m a -> State t m a+setStreamRate r st = st { _maxStreamRate = r }++getStreamRate :: State t m a -> Maybe Rate+getStreamRate = _maxStreamRate++setStreamLatency :: Int -> State t m a -> State t m a+setStreamLatency n st =+    st { _streamLatency =+            if n <= 0+            then Nothing+            else Just (fromIntegral n)+       }++getStreamLatency :: State t m a -> Maybe NanoSecond64+getStreamLatency = _streamLatency++setInspectMode :: State t m a -> State t m a+setInspectMode st = st { _inspectMode = True }++getInspectMode :: State t m a -> Bool+getInspectMode = _inspectMode
+ src/Streamly/Internal/Data/SVar/Worker.hs view
@@ -0,0 +1,544 @@+-- |+-- Module      : Streamly.Internal.Data.SVar.Worker+-- Copyright   : (c) 2017 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+--+module Streamly.Internal.Data.SVar.Worker+    (+    -- * Adjusting Limits+      decrementYieldLimit+    , incrementYieldLimit+    , decrementBufferLimit+    , incrementBufferLimit+    , resetBufferLimit++    -- * Rate Control+    , Work (..)+    , isBeyondMaxRate+    , estimateWorkers+    , updateYieldCount+    , minThreadDelay+    , workerRateControl+    , workerUpdateLatency++    -- * Send Events+    , send+    , ringDoorBell++    -- ** Yield+    , sendYield+    , sendToProducer++    -- ** Stop+    , sendStop+    , sendStopToProducer++    -- ** Exception+    , handleChildException+    , handleFoldException+    )+where++#include "inline.hs"++import Control.Concurrent (myThreadId, takeMVar)+import Control.Concurrent.MVar (MVar, tryPutMVar)+import Control.Exception (SomeException(..), assert)+import Control.Monad (when, void)+import Control.Monad.IO.Class (MonadIO(liftIO))+import Data.IORef (IORef, readIORef, writeIORef)+import Streamly.Internal.Data.Atomics+       (atomicModifyIORefCAS, atomicModifyIORefCAS_, writeBarrier,+        storeLoadBarrier)+import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime)+import Streamly.Internal.Data.Time.Units+       (AbsTime, NanoSecond64(..), diffAbsTime64, fromRelTime64)++import Streamly.Internal.Data.SVar.Type++------------------------------------------------------------------------------+-- Collecting results from child workers in a streamed fashion+------------------------------------------------------------------------------++-- XXX Can we make access to remainingWork and yieldRateInfo fields in sv+-- faster, along with the fields in sv required by send?+-- XXX make it noinline+--+-- XXX we may want to employ an increment and decrement in batches when the+-- througput is high or when the cost of synchronization is high. For example+-- if the application is distributed then inc/dec of a shared variable may be+-- very costly.+--+-- A worker decrements the yield limit before it executes an action. However,+-- the action may not result in an element being yielded, in that case we have+-- to increment the yield limit.+--+-- Note that we need it to be an Int type so that we have the ability to undo a+-- decrement that takes it below zero.+{-# INLINE decrementYieldLimit #-}+decrementYieldLimit :: SVar t m a -> IO Bool+decrementYieldLimit sv =+    case remainingWork sv of+        Nothing -> return True+        Just ref -> do+            r <- atomicModifyIORefCAS ref $ \x -> (x - 1, x)+            return $ r >= 1++{-# INLINE incrementYieldLimit #-}+incrementYieldLimit :: SVar t m a -> IO ()+incrementYieldLimit sv =+    case remainingWork sv of+        Nothing -> return ()+        Just ref -> atomicModifyIORefCAS_ ref (+ 1)++-- XXX exception safety of all atomic/MVar operations++-- TBD Each worker can have their own queue and the consumer can empty one+-- queue at a time, that way contention can be reduced.++-- XXX Only yields should be counted in the buffer limit and not the Stop+-- events.++{-# INLINE decrementBufferLimit #-}+decrementBufferLimit :: SVar t m a -> IO ()+decrementBufferLimit sv =+    case maxBufferLimit sv of+        Unlimited -> return ()+        Limited _ -> do+            let ref = pushBufferSpace sv+            old <- atomicModifyIORefCAS ref $ \x ->+                        (if x >= 1 then x - 1 else x, x)+            when (old <= 0) $+                case pushBufferPolicy sv of+                    PushBufferBlock -> blockAndRetry+                    PushBufferDropNew -> do+                        -- We just drop one item and proceed. It is possible+                        -- that by the time we drop the item the consumer+                        -- thread might have run and created space in the+                        -- buffer, but we do not care about that condition.+                        -- This is not pedantically correct but it should be+                        -- fine in practice.+                        -- XXX we may want to drop only if n == maxBuf+                        -- otherwise we must have space in the buffer and a+                        -- decrement should be possible.+                        block <- atomicModifyIORefCAS (outputQueue sv) $+                            \(es, n) ->+                                case es of+                                    [] -> (([],n), True)+                                    _ : xs -> ((xs, n - 1), False)+                        when block blockAndRetry+                    -- XXX need a dequeue or ring buffer for this+                    PushBufferDropOld -> undefined++    where++    blockAndRetry = do+        let ref = pushBufferSpace sv+        liftIO $ takeMVar (pushBufferMVar sv)+        old <- atomicModifyIORefCAS ref $ \x ->+                        (if x >= 1 then x - 1 else x, x)+        -- When multiple threads sleep on takeMVar, the first thread would+        -- wakeup due to a putMVar by the consumer, but the rest of the threads+        -- would have to put back the MVar after taking it and decrementing the+        -- buffer count, otherwise all other threads will remain asleep.+        if old >= 1+        then void $ liftIO $ tryPutMVar (pushBufferMVar sv) ()+        -- We do not put the MVar back in this case, instead we+        -- wait for the consumer to put it.+        else blockAndRetry++{-# INLINE incrementBufferLimit #-}+incrementBufferLimit :: SVar t m a -> IO ()+incrementBufferLimit sv =+    case maxBufferLimit sv of+        Unlimited -> return ()+        Limited _ -> do+            atomicModifyIORefCAS_ (pushBufferSpace sv) (+ 1)+            writeBarrier+            void $ liftIO $ tryPutMVar (pushBufferMVar sv) ()++{-# INLINE resetBufferLimit #-}+resetBufferLimit :: SVar t m a -> IO ()+resetBufferLimit sv =+    case maxBufferLimit sv of+        Unlimited -> return ()+        Limited n -> atomicModifyIORefCAS_ (pushBufferSpace sv)+                                           (const (fromIntegral n))++-------------------------------------------------------------------------------+-- Yield control+-------------------------------------------------------------------------------++updateYieldCount :: WorkerInfo -> IO Count+updateYieldCount winfo = do+    cnt <- readIORef (workerYieldCount winfo)+    let cnt1 = cnt + 1+    writeIORef (workerYieldCount winfo) cnt1+    return cnt1++isBeyondMaxYield :: Count -> WorkerInfo -> Bool+isBeyondMaxYield cnt winfo =+    let ymax = workerYieldMax winfo+    in ymax /= 0 && cnt >= ymax++-------------------------------------------------------------------------------+-- Sending results from worker+-------------------------------------------------------------------------------++{-# INLINE ringDoorBell #-}+ringDoorBell :: SVar t m a -> IO ()+ringDoorBell sv = do+    storeLoadBarrier+    w <- readIORef $ needDoorBell sv+    when w $ do+        -- Note: the sequence of operations is important for correctness here.+        -- We need to set the flag to false strictly before sending the+        -- outputDoorBell, otherwise the outputDoorBell may get processed too+        -- early and then we may set the flag to False to later making the+        -- consumer lose the flag, even without receiving a outputDoorBell.+        atomicModifyIORefCAS_ (needDoorBell sv) (const False)+        void $ tryPutMVar (outputDoorBell sv) ()++{-# INLINE sendWithDoorBell #-}+sendWithDoorBell ::+    IORef ([ChildEvent a], Int) -> MVar () -> ChildEvent a -> IO Int+sendWithDoorBell q bell msg = do+    -- XXX can the access to outputQueue be made faster somehow?+    oldlen <- atomicModifyIORefCAS q $ \(es, n) ->+        ((msg : es, n + 1), n)+    when (oldlen <= 0) $ do+        -- The wake up must happen only after the store has finished otherwise+        -- we can have lost wakeup problems.+        writeBarrier+        -- Since multiple workers can try this at the same time, it is possible+        -- that we may put a spurious MVar after the consumer has already seen+        -- the output. But that's harmless, at worst it may cause the consumer+        -- to read the queue again and find it empty.+        -- The important point is that the consumer is guaranteed to receive a+        -- doorbell if something was added to the queue after it empties it.+        void $ tryPutMVar bell ()+    return oldlen++-- | 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 = sendWithDoorBell (outputQueue sv) (outputDoorBell sv)++-- There is no bound implemented on the buffer, this is assumed to be low+-- traffic.+sendToProducer :: SVar t m a -> ChildEvent a -> IO Int+sendToProducer sv msg = do+    -- In case the producer stream is blocked on pushing to the fold buffer+    -- then wake it up so that it can check for the stop event or exception+    -- being sent to it otherwise we will be deadlocked.+    void $ tryPutMVar (pushBufferMVar sv) ()+    sendWithDoorBell (outputQueueFromConsumer sv)+                     (outputDoorBellFromConsumer sv) msg++-------------------------------------------------------------------------------+-- Collect and update worker latency+-------------------------------------------------------------------------------++workerCollectLatency :: WorkerInfo -> IO (Maybe (Count, NanoSecond64))+workerCollectLatency winfo = do+    (cnt0, t0) <- readIORef (workerLatencyStart winfo)+    cnt1 <- readIORef (workerYieldCount winfo)+    let cnt = cnt1 - cnt0++    if cnt > 0+    then do+        t1 <- getTime Monotonic+        let period = fromRelTime64 $ diffAbsTime64 t1 t0+        writeIORef (workerLatencyStart winfo) (cnt1, t1)+        return $ Just (cnt, period)+    else return Nothing++-- XXX There are a number of gotchas in measuring latencies.+-- 1) We measure latencies only when a worker yields a value+-- 2) It is possible that a stream calls the stop continuation, in which case+-- the worker would not yield a value and we would not account that worker in+-- latencies. Even though this case should ideally be accounted we do not+-- account it because we cannot or do not distinguish it from the case+-- described next.+-- 3) It is possible that a worker returns without yielding anything because it+-- never got a chance to pick up work.+-- 4) If the system timer resolution is lower than the latency, the latency+-- computation turns out to be zero.+--+-- We can fix this if we measure the latencies by counting the work items+-- picked rather than based on the outputs yielded.+workerUpdateLatency :: YieldRateInfo -> WorkerInfo -> IO ()+workerUpdateLatency yinfo winfo = do+    r <- workerCollectLatency winfo+    case r of+        Just (cnt, period) -> do+        -- NOTE: On JS platform the timer resolution could be pretty low. When+        -- the timer resolution is low, measurement of latencies could be+        -- tricky. All the worker latencies will turn out to be zero if they+        -- are lower than the resolution. We only take into account those+        -- measurements which are more than the timer resolution.++            let ref = workerPendingLatency yinfo+                (cnt1, t1) = if period > 0 then (cnt, period) else (0, 0)+            atomicModifyIORefCAS_ ref $+                    \(fc, n, t) -> (fc + cnt, n + cnt1, t + t1)+        Nothing -> return ()++-------------------------------------------------------------------------------+-- Worker rate control+-------------------------------------------------------------------------------++-- We either block, or send one worker with limited yield count or one or more+-- workers with unlimited yield count.+data Work+    = BlockWait NanoSecond64+    | PartialWorker Count+    | ManyWorkers Int Count+    deriving Show++-- | This is a magic number and it is overloaded, and used at several places to+-- achieve batching:+--+-- 1. If we have to sleep to slowdown this is the minimum period that we+--    accumulate before we sleep. Also, workers do not stop until this much+--    sleep time is accumulated.+-- 3. Collected latencies are computed and transferred to measured latency+--    after a minimum of this period.+minThreadDelay :: NanoSecond64+minThreadDelay = 1000000++-- | Another magic number! When we have to start more workers to cover up a+-- number of yields that we are lagging by then we cannot start one worker for+-- each yield because that may be a very big number and if the latency of the+-- workers is low these number of yields could be very high. We assume that we+-- run each extra worker for at least this much time.+rateRecoveryTime :: NanoSecond64+rateRecoveryTime = 1000000++-- | Get the worker latency without resetting workerPendingLatency+-- Returns (total yield count, base time, measured latency)+-- CAUTION! keep it in sync with collectLatency+getWorkerLatency :: YieldRateInfo -> IO (Count, AbsTime, NanoSecond64)+getWorkerLatency yinfo  = do+    let cur      = workerPendingLatency yinfo+        col      = workerCollectedLatency yinfo+        longTerm = svarAllTimeLatency yinfo+        measured = workerMeasuredLatency yinfo++    (curTotalCount, curCount, curTime) <- readIORef cur+    (colTotalCount, colCount, colTime) <- readIORef col+    (lcount, ltime)     <- readIORef longTerm+    prevLat             <- readIORef measured++    let latCount = colCount + curCount+        latTime  = colTime + curTime+        totalCount = colTotalCount + curTotalCount+        newLat =+            if latCount > 0 && latTime > 0+            then let lat = latTime `div` fromIntegral latCount+                 -- XXX Give more weight to new?+                 in (lat + prevLat) `div` 2+            else prevLat+    return (lcount + totalCount, ltime, newLat)++-- XXX we can use phantom types to distinguish the duration/latency/expectedLat+estimateWorkers+    :: Limit+    -> Count+    -> Count+    -> NanoSecond64+    -> NanoSecond64+    -> NanoSecond64+    -> LatencyRange+    -> Work+estimateWorkers workerLimit svarYields gainLossYields+                svarElapsed wLatency targetLat range =+    -- XXX we can have a maxEfficiency combinator as well which runs the+    -- producer at the maximal efficiency i.e. the number of workers are chosen+    -- such that the latency is minimum or within a range. Or we can call it+    -- maxWorkerLatency.+    --+    let+        -- How many workers do we need to achieve the required rate?+        --+        -- When the workers are IO bound we can increase the throughput by+        -- increasing the number of workers as long as the IO device has enough+        -- capacity to process all the requests concurrently. If the IO+        -- bandwidth is saturated increasing the workers won't help. Also, if+        -- the CPU utilization in processing all these requests exceeds the CPU+        -- bandwidth, then increasing the number of workers won't help.+        --+        -- When the workers are purely CPU bound, increasing the workers beyond+        -- the number of CPUs won't help.+        --+        -- TODO - measure the CPU and IO requirements of the workers. Have a+        -- way to specify the max bandwidth of the underlying IO mechanism and+        -- use that to determine the max rate of workers, and also take the CPU+        -- bandwidth into account. We can also discover the IO bandwidth if we+        -- know that we are not CPU bound, then how much steady state rate are+        -- we able to achieve. Design tests for CPU bound and IO bound cases.++        -- Calculate how many yields are we ahead or behind to match the exact+        -- required rate. Based on that we increase or decrease the effective+        -- workers.+        --+        -- When the worker latency is lower than required latency we begin with+        -- a yield and then wait rather than first waiting and then yielding.+        targetYields = (svarElapsed + wLatency + targetLat - 1) `div` targetLat+        effectiveYields = svarYields + gainLossYields+        deltaYields = fromIntegral targetYields - effectiveYields++        -- We recover the deficit by running at a higher/lower rate for a+        -- certain amount of time. To keep the effective rate in reasonable+        -- limits we use rateRecoveryTime, minLatency and maxLatency.+        in  if deltaYields > 0+            then+                let deltaYieldsFreq :: Double+                    deltaYieldsFreq =+                        fromIntegral deltaYields /+                            fromIntegral rateRecoveryTime+                    yieldsFreq = 1.0 / fromIntegral targetLat+                    totalYieldsFreq = yieldsFreq + deltaYieldsFreq+                    requiredLat = NanoSecond64 $ round $ 1.0 / totalYieldsFreq+                    adjustedLat = min (max requiredLat (minLatency range))+                                      (maxLatency range)+                in  assert (adjustedLat > 0) $+                    if wLatency <= adjustedLat+                    then PartialWorker deltaYields+                    else let workers = withLimit $ wLatency `div` adjustedLat+                             limited = min workers (fromIntegral deltaYields)+                         in ManyWorkers (fromIntegral limited) deltaYields+            else+                let expectedDuration = fromIntegral effectiveYields * targetLat+                    sleepTime = expectedDuration - svarElapsed+                    maxSleepTime = maxLatency range - wLatency+                    s = min sleepTime maxSleepTime+                in assert (sleepTime >= 0) $+                    -- if s is less than 0 it means our maxSleepTime is less+                    -- than the worker latency.+                    if s > 0 then BlockWait s else ManyWorkers 1 (Count 0)+    where+        withLimit n =+            case workerLimit of+                Unlimited -> n+                Limited x -> min n (fromIntegral x)++isBeyondMaxRate :: SVar t m a -> YieldRateInfo -> IO Bool+isBeyondMaxRate sv yinfo = do+    (count, tstamp, wLatency) <- getWorkerLatency yinfo+    now <- getTime Monotonic+    let duration = fromRelTime64 $ diffAbsTime64 now tstamp+    let targetLat = svarLatencyTarget yinfo+    gainLoss <- readIORef (svarGainedLostYields yinfo)+    let work = estimateWorkers (maxWorkerLimit sv) count gainLoss duration+                               wLatency targetLat (svarLatencyRange yinfo)+    cnt <- readIORef $ workerCount sv+    return $ case work of+        -- XXX set the worker's maxYields or polling interval based on yields+        PartialWorker _yields -> cnt > 1+        ManyWorkers n _ -> cnt > n+        BlockWait _ -> True++-- XXX we should do rate control periodically based on the total yields rather+-- than based on the worker local yields as other workers may have yielded more+-- and we should stop based on the aggregate yields. However, latency update+-- period can be based on individual worker yields.+{-# NOINLINE checkRatePeriodic #-}+checkRatePeriodic :: SVar t m a+                  -> YieldRateInfo+                  -> WorkerInfo+                  -> Count+                  -> IO Bool+checkRatePeriodic sv yinfo winfo ycnt = do+    i <- readIORef (workerPollingInterval yinfo)+    -- XXX use generation count to check if the interval has been updated+    if i /= 0 && (ycnt `mod` i) == 0+    then do+        workerUpdateLatency yinfo winfo+        -- XXX not required for parallel streams+        isBeyondMaxRate sv yinfo+    else return False++-- CAUTION! this also updates the yield count and therefore should be called+-- only when we are actually yielding an element.+{-# NOINLINE workerRateControl #-}+workerRateControl :: SVar t m a -> YieldRateInfo -> WorkerInfo -> IO Bool+workerRateControl sv yinfo winfo = do+    cnt <- updateYieldCount winfo+    beyondMaxRate <- checkRatePeriodic sv yinfo winfo cnt+    return $ not (isBeyondMaxYield cnt winfo || beyondMaxRate)++-------------------------------------------------------------------------------+-- Send a yield event+-------------------------------------------------------------------------------++-- XXX we should do rate control here but not latency update in case of ahead+-- streams. latency update must be done when we yield directly to outputQueue+-- or when we yield to heap.+--+-- returns whether the worker should continue (True) or stop (False).+{-# INLINE sendYield #-}+sendYield :: SVar t m a -> Maybe WorkerInfo -> ChildEvent a -> IO Bool+sendYield sv mwinfo msg = do+    oldlen <- send sv msg+    let limit = maxBufferLimit sv+    bufferSpaceOk <- case limit of+            Unlimited -> return True+            Limited lim -> do+                active <- readIORef (workerCount sv)+                return $ (oldlen + 1) < (fromIntegral lim - active)+    rateLimitOk <-+        case mwinfo of+            Just winfo ->+                case yieldRateInfo sv of+                    Nothing -> return True+                    Just yinfo -> workerRateControl sv yinfo winfo+            Nothing -> return True+    return $ bufferSpaceOk && rateLimitOk++-------------------------------------------------------------------------------+-- Send a Stop event+-------------------------------------------------------------------------------++{-# INLINE workerStopUpdate #-}+workerStopUpdate :: WorkerInfo -> YieldRateInfo -> IO ()+workerStopUpdate winfo info = do+    i <- readIORef (workerPollingInterval info)+    when (i /= 0) $ workerUpdateLatency info winfo++{-# INLINABLE sendStop #-}+sendStop :: SVar t m a -> Maybe WorkerInfo -> IO ()+sendStop sv mwinfo = do+    atomicModifyIORefCAS_ (workerCount sv) $ \n -> n - 1+    case (mwinfo, yieldRateInfo sv) of+      (Just winfo, Just info) ->+          workerStopUpdate winfo info+      _ ->+          return ()+    myThreadId >>= \tid -> void $ send sv (ChildStop tid Nothing)++-- {-# NOINLINE sendStopToProducer #-}+sendStopToProducer :: MonadIO m => SVar t m a -> m ()+sendStopToProducer sv = liftIO $ do+    tid <- myThreadId+    void $ sendToProducer sv (ChildStop tid Nothing)++-------------------------------------------------------------------------------+-- Send exceptions+-------------------------------------------------------------------------------++{-# NOINLINE handleFoldException #-}+handleFoldException :: SVar t m a -> SomeException -> IO ()+handleFoldException sv e = do+    tid <- myThreadId+    void $ sendToProducer sv (ChildStop tid (Just e))++{-# NOINLINE handleChildException #-}+handleChildException :: SVar t m a -> SomeException -> IO ()+handleChildException sv e = do+    tid <- myThreadId+    void $ send sv (ChildStop tid (Just e))
src/Streamly/Internal/Data/SmallArray.hs view
@@ -53,8 +53,7 @@ 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 Streamly.Internal.Data.Stream.Serial (SerialT(..))  import qualified Streamly.Internal.Data.Stream.StreamD as D import qualified Streamly.Internal.Data.Fold.Type as FL@@ -106,22 +105,29 @@ -- 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+writeN len = Fold step initial extract      where +    {-# INLINE next #-}+    next marr i = do+        let i1 = i + 1+            st = Tuple' marr i1+        if len > i1+        then return $ FL.Partial st+        else fmap FL.Done $ extract st+     initial = do-        marr <- liftIO $ newSmallArray limit bottomElement-        return $ FL.Partial (Tuple' marr 0)+        marr <- liftIO $ newSmallArray len bottomElement+        next marr (-1) -    step st@(Tuple' marr i) x-        | i == limit = FL.Done <$> extract st-        | otherwise = do-            liftIO $ writeSmallArray marr i x-            return $ FL.Partial (Tuple' marr (i + 1))+    step (Tuple' marr i) x = do+        liftIO $ writeSmallArray marr i x+        next marr i -    extract (Tuple' marr len) = liftIO $ freezeSmallArray marr 0 len+    extract (Tuple' marr l) = liftIO $ freezeSmallArray marr 0 l + {-# INLINE_NORMAL fromStreamDN #-} fromStreamDN :: MonadIO m => Int -> D.Stream m a -> m (SmallArray a) fromStreamDN limit str = do@@ -155,17 +161,17 @@ -- For optimal performance use this with @n@ <= 128. {-# INLINE fromStreamN #-} fromStreamN :: MonadIO m => Int -> SerialT m a -> m (SmallArray a)-fromStreamN n m = do+fromStreamN n (SerialT m) = do     when (n < 0) $ error "fromStreamN: negative write count specified"-    fromStreamDN n $ D.toStreamD m+    fromStreamDN n $ D.fromStreamK m  {-# INLINE_EARLY toStream #-}-toStream :: (Monad m, IsStream t) => SmallArray a -> t m a-toStream = D.fromStreamD . toStreamD+toStream :: Monad m => SmallArray a -> SerialT m a+toStream = SerialT . D.toStreamK . toStreamD  {-# INLINE_EARLY toStreamRev #-}-toStreamRev :: (Monad m, IsStream t) => SmallArray a -> t m a-toStreamRev = D.fromStreamD . toStreamDRev+toStreamRev :: Monad m => SmallArray a -> SerialT m a+toStreamRev = SerialT . D.toStreamK . toStreamDRev  {-# INLINE fold #-} fold :: Monad m => Fold m a b -> SmallArray a -> m b
src/Streamly/Internal/Data/Stream/Ahead.hs view
@@ -22,10 +22,10 @@ -- module Streamly.Internal.Data.Stream.Ahead     (-      AheadT+      AheadT(..)     , Ahead-    , fromAhead-    , ahead+    , aheadK+    , consM     ) where @@ -50,15 +50,16 @@  import qualified Data.Heap as H -import Streamly.Internal.Data.Stream.SVar (fromSVar)-import Streamly.Internal.Data.SVar-import Streamly.Internal.Data.Stream.StreamK.Type-       (IsStream(..), Stream, mkStream, foldStream, foldStreamShared)+import Streamly.Internal.Control.Concurrent+    (MonadAsync, RunInIO(..), captureMonadState)+import Streamly.Internal.Data.Stream.Serial (SerialT(..))+import Streamly.Internal.Data.Stream.StreamK.Type (Stream) -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 Streamly.Internal.Data.Stream.SVar.Generate+import Streamly.Internal.Data.SVar import Prelude hiding (map)  #include "Instances.hs"@@ -319,7 +320,7 @@             let stop = do                   liftIO (incrementYieldLimit sv)                   nextHeap seqNo-            foldStreamShared st+            K.foldStreamShared st                           (yieldStreamFromHeap seqNo)                           (singleStreamFromHeap seqNo)                           stop@@ -378,7 +379,7 @@         mrun = runInIO $ svarMrun sv      r <- liftIO $ mrun $-            foldStreamShared st+            K.foldStreamShared st                 (\a r -> do                     runIn <- captureMonadState                     toHeap $ AheadEntryStream (runIn, K.cons a r))@@ -449,7 +450,7 @@         mrun = runInIO $ svarMrun sv      r <- liftIO $ mrun $-        foldStreamShared st (yieldOutput sno) (singleOutput sno) stop action+        K.foldStreamShared st (yieldOutput sno) (singleOutput sno) stop action      res <- restoreM r     case res of@@ -477,7 +478,7 @@             let stop = do                     liftIO (incrementYieldLimit sv)                     return $ TokenContinue (seqNo + 1)-            foldStreamShared st+            K.foldStreamShared st                           (yieldOutput seqNo)                           (singleOutput seqNo)                           stop@@ -511,7 +512,7 @@                                 return $ TokenContinue (seqNo + 1)                             mrun = runInIO $ svarMrun sv                         r <- liftIO $ mrun $-                            foldStreamShared st+                            K.foldStreamShared st                                           (yieldOutput seqNo)                                           (singleOutput seqNo)                                           stop@@ -602,80 +603,36 @@  -- The only difference between forkSVarAsync and this is that we run the left -- computation without a shared SVar.-forkSVarAhead :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a-forkSVarAhead m1 m2 = mkStream $ \st yld sng stp -> do-        sv <- newAheadVar st (concurrently (toStream m1) (toStream m2))+forkSVarAhead :: MonadAsync m => Stream m a -> Stream m a -> Stream m a+forkSVarAhead m1 m2 = K.mkStream $ \st yld sng stp -> do+        sv <- newAheadVar st (concurrently m1 m2)                           workLoopAhead-        foldStream st yld sng stp (fromSVar sv)+        K.foldStream st yld sng stp $ getSerialT (fromSVar sv)     where-    concurrently ma mb = mkStream $ \st yld sng stp -> do+    concurrently ma mb = K.mkStream $ \st yld sng stp -> do         runInIO <- captureMonadState         liftIO $ enqueue (fromJust $ streamVar st) (runInIO, mb)-        foldStream st yld sng stp ma--infixr 6 `ahead`+        K.foldStream st yld sng stp ma --- | 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:------ >>> 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 ->+{-# INLINE aheadK #-}+aheadK :: MonadAsync m => Stream m a -> Stream m a -> Stream m a+aheadK m1 m2 = K.mkStream $ \st yld sng stp ->     case streamVar st of         Just sv | svarStyle sv == AheadVar -> do             runInIO <- captureMonadState-            liftIO $ enqueue sv (runInIO, toStream m2)+            liftIO $ enqueue sv (runInIO, 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.-            foldStream st yld sng stp m1-        _ -> foldStreamShared st yld sng stp (forkSVarAhead m1 m2)+            K.foldStream st yld sng stp m1+        _ -> K.foldStreamShared st yld sng stp (forkSVarAhead m1 m2)  -- | XXX we can implement it more efficienty by directly implementing instead -- of combining streams using ahead.-{-# 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.fromEffect m `ahead` (toStream r)+{-# INLINE consM #-}+{-# SPECIALIZE consM :: IO a -> AheadT IO a -> AheadT IO a #-}+consM :: MonadAsync m => m a -> AheadT m a -> AheadT m a+consM m (AheadT r) = AheadT $ aheadK (K.fromEffect m) r  ------------------------------------------------------------------------------ -- AheadT@@ -735,66 +692,58 @@ -- @since 0.8.0 type Ahead = AheadT IO --- | Fix the type of a polymorphic stream as 'AheadT'.------ /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-    fromStream = AheadT-    consM = consMAhead-    (|:) = consMAhead- ------------------------------------------------------------------------------ -- Semigroup ------------------------------------------------------------------------------ -{-# INLINE mappendAhead #-}-{-# SPECIALIZE mappendAhead :: AheadT IO a -> AheadT IO a -> AheadT IO a #-}-mappendAhead :: MonadAsync m => AheadT m a -> AheadT m a -> AheadT m a-mappendAhead m1 m2 = fromStream $ ahead (toStream m1) (toStream m2)+{-# INLINE append #-}+{-# SPECIALIZE append :: AheadT IO a -> AheadT IO a -> AheadT IO a #-}+append :: MonadAsync m => AheadT m a -> AheadT m a -> AheadT m a+append (AheadT m1) (AheadT m2) = AheadT $ aheadK m1 m2  instance MonadAsync m => Semigroup (AheadT m a) where-    (<>) = mappendAhead+    (<>) = append  ------------------------------------------------------------------------------ -- Monoid ------------------------------------------------------------------------------  instance MonadAsync m => Monoid (AheadT m a) where-    mempty = K.nil+    mempty = AheadT K.nil     mappend = (<>)  --------------------------------------------------------------------------------- Monad+-- Applicative ------------------------------------------------------------------------------ -{-# INLINE concatMapAhead #-}-{-# SPECIALIZE concatMapAhead :: (a -> AheadT IO b) -> AheadT IO a -> AheadT IO b #-}-concatMapAhead :: MonadAsync m => (a -> AheadT m b) -> AheadT m a -> AheadT m b-concatMapAhead f m = fromStream $-    K.concatMapBy ahead (\a -> K.adapt $ f a) (K.adapt m)- {-# INLINE apAhead #-} apAhead :: MonadAsync m => AheadT m (a -> b) -> AheadT m a -> AheadT m b apAhead (AheadT m1) (AheadT m2) =-        let f x1 = K.concatMapBy ahead (pure . x1) m2-         in AheadT $ K.concatMapBy ahead f m1+    let f x1 = K.concatMapWith aheadK (pure . x1) m2+    in AheadT $ K.concatMapWith aheadK f m1  instance (Monad m, MonadAsync m) => Applicative (AheadT m) where     {-# INLINE pure #-}     pure = AheadT . K.fromPure+     {-# INLINE (<*>) #-}     (<*>) = apAhead +------------------------------------------------------------------------------+-- Monad+------------------------------------------------------------------------------++{-# INLINE bindAhead #-}+{-# SPECIALIZE bindAhead ::+    AheadT IO a -> (a -> AheadT IO b) -> AheadT IO b #-}+bindAhead :: MonadAsync m => AheadT m a -> (a -> AheadT m b) -> AheadT m b+bindAhead (AheadT m) f = AheadT $ K.bindWith aheadK m (getAheadT . f)+ instance MonadAsync m => Monad (AheadT m) where     return = pure+     {-# INLINE (>>=) #-}-    (>>=) = flip concatMapAhead+    (>>=) = bindAhead  ------------------------------------------------------------------------------ -- Other instances
src/Streamly/Internal/Data/Stream/Async.hs view
@@ -24,18 +24,17 @@ -- module Streamly.Internal.Data.Stream.Async     (-      AsyncT+      AsyncT(..)     , Async-    , fromAsync-    , async-    , (<|)             --deprecated-    , mkAsync+    , consMAsync+    , asyncK     , mkAsyncK+    , mkAsyncD -    , WAsyncT+    , WAsyncT(..)     , WAsync-    , fromWAsync-    , wAsync+    , consMWAsync+    , wAsyncK     ) where @@ -49,7 +48,7 @@ import Control.Monad.Reader.Class (MonadReader(..)) import Control.Monad.State.Class (MonadState(..)) import Control.Monad.Trans.Class (MonadTrans(lift))-import Data.Concurrent.Queue.MichaelScott (LinkedQueue, newQ, nullQ, tryPopR)+import Data.Concurrent.Queue.MichaelScott (LinkedQueue, newQ, nullQ, tryPopR, pushL) import Data.IORef (IORef, newIORef, readIORef) import Data.Maybe (fromJust) #if __GLASGOW_HASKELL__ < 808@@ -59,16 +58,20 @@ import Prelude hiding (map) import qualified Data.Set as S -import Streamly.Internal.Data.Atomics (atomicModifyIORefCAS)-import Streamly.Internal.Data.Stream.SVar (fromSVar, fromSVarD)-import Streamly.Internal.Data.SVar-import Streamly.Internal.Data.Stream.StreamK.Type-       (IsStream(..), Stream, mkStream, foldStream, adapt, foldStreamShared)+import Streamly.Internal.Control.Concurrent+    (MonadAsync, RunInIO(..), captureMonadState)+import Streamly.Internal.Data.Atomics+    (atomicModifyIORefCAS, atomicModifyIORefCAS_)+import Streamly.Internal.Data.Stream.Serial (SerialT (..))+import Streamly.Internal.Data.Stream.StreamK.Type (Stream)+import Streamly.Internal.Data.Stream.SVar.Generate (fromSVar, fromSVarD) -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 Streamly.Internal.Data.SVar.Type+import Streamly.Internal.Data.SVar+ #include "Instances.hs"  -- $setup@@ -86,6 +89,17 @@ -- Async ------------------------------------------------------------------------------- +-- Note: For purely right associated expressions this queue should have at most+-- one element. It grows to more than one when we have left associcated+-- expressions. Large left associated compositions can grow this to a+-- large size+{-# INLINE enqueueLIFO #-}+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+ data WorkerStatus = Continue | Suspend  {-# INLINE workLoopLIFO #-}@@ -114,7 +128,7 @@                 -- monad state here. That way it can work easily for                 -- distributed case as well.                 r <- liftIO $ runin $-                        foldStreamShared st yieldk single (return Continue) m+                        K.foldStreamShared st yieldk single (return Continue) m                 res <- restoreM r                 case res of                     Continue -> run@@ -127,7 +141,7 @@     yieldk a r = do         res <- liftIO $ sendYield sv winfo (ChildYield a)         if res-        then foldStreamShared st yieldk single (return Continue) r+        then K.foldStreamShared st yieldk single (return Continue) r         else do             runInIO <- captureMonadState             liftIO $ enqueueLIFO sv q (runInIO, r)@@ -171,7 +185,7 @@                 if yieldLimitOk                 then do                     r <- liftIO $ runin $-                            foldStreamShared st yieldk single incrContinue m+                            K.foldStreamShared st yieldk single incrContinue m                     res <- restoreM r                     case res of                         Continue -> run@@ -193,7 +207,7 @@         res <- liftIO $ sendYield sv winfo (ChildYield a)         yieldLimitOk <- liftIO $ decrementYieldLimit sv         if res && yieldLimitOk-        then foldStreamShared st yieldk single incrContinue r+        then K.foldStreamShared st yieldk single incrContinue r         else do             runInIO <- captureMonadState             liftIO $ incrementYieldLimit sv@@ -208,6 +222,20 @@ -- WAsync ------------------------------------------------------------------------------- +-- XXX we can use the Ahead style sequence/heap mechanism to make the best+-- effort to always try to finish the streams on the left side of an expression+-- first as long as possible.++{-# INLINE enqueueFIFO #-}+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+ -- XXX we can remove sv as it is derivable from st  {-# INLINE workLoopFIFO #-}@@ -229,7 +257,7 @@             Nothing -> stop             Just (RunInIO runin, m) -> do                 r <- liftIO $ runin $-                        foldStreamShared st yieldk single (return Continue) m+                        K.foldStreamShared st yieldk single (return Continue) m                 res <- restoreM r                 case res of                     Continue -> run@@ -272,7 +300,7 @@                 if yieldLimitOk                 then do                     r <- liftIO $ runin $-                            foldStreamShared st yieldk single incrContinue m+                            K.foldStreamShared st yieldk single incrContinue m                     res <- restoreM r                     case res of                         Continue -> run@@ -515,18 +543,21 @@ -- /Pre-release/ -- {-# INLINABLE mkAsyncK #-}-mkAsyncK :: (IsStream t, MonadAsync m) => t m a -> t m a-mkAsyncK m = mkStream $ \st yld sng stp -> do-    sv <- newAsyncVar (adaptState st) (toStream m)-    foldStream st yld sng stp $ fromSVar sv+mkAsyncK :: MonadAsync m => Stream m a -> Stream m a+mkAsyncK m = K.mkStream $ \st yld sng stp -> do+    sv <- newAsyncVar (adaptState st) m+    K.foldStream st yld sng stp $ getSerialT $ fromSVar sv +--+-- This is slightly faster than the CPS version above+-- {-# INLINE_NORMAL mkAsyncD #-} mkAsyncD :: MonadAsync m => D.Stream m a -> D.Stream m a mkAsyncD m = D.Stream step Nothing     where      step gst Nothing = do-        sv <- newAsyncVar gst (D.fromStreamD m)+        sv <- newAsyncVar gst (D.toStreamK m)         return $ D.Skip $ Just $ fromSVarD sv      step gst (Just (D.UnStream step1 st)) = do@@ -536,23 +567,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--- buffer between them. The producer thread evaluates the input stream until--- the buffer fills, it terminates if the buffer is full and a worker thread is--- kicked off again to evaluate the remaining stream when there is space in the--- buffer.  The consumer consumes the stream lazily from the buffer.------ /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-+-- XXX We can pass captureMonadState instead of using MonadAsync -- | Create a new SVar and enqueue one stream computation on it. {-# INLINABLE newWAsyncVar #-} newWAsyncVar :: MonadAsync m@@ -560,6 +575,8 @@ newWAsyncVar st m = do     mrun <- captureMonadState     sv <- liftIO $ getFifoSVar st mrun+    -- XXX Use just Stream and IO in all the functions below+    -- XXX pass mrun instead of calling captureMonadState again inside it     sendFirstWorker sv m  ------------------------------------------------------------------------------@@ -626,109 +643,38 @@ --   composition and vice-versa we create a new SVar to isolate the scheduling --   of the two. -forkSVarAsync :: (IsStream t, MonadAsync m)-    => SVarStyle -> t m a -> t m a -> t m a-forkSVarAsync style m1 m2 = mkStream $ \st yld sng stp -> do+forkSVarAsync :: MonadAsync m+    => SVarStyle -> Stream m a -> Stream m a -> Stream m a+forkSVarAsync style m1 m2 = K.mkStream $ \st yld sng stp -> do     sv <- case style of-        AsyncVar -> newAsyncVar st (concurrently (toStream m1) (toStream m2))-        WAsyncVar -> newWAsyncVar st (concurrently (toStream m1) (toStream m2))+        AsyncVar -> newAsyncVar st (concurrently m1 m2)+        WAsyncVar -> newWAsyncVar st (concurrently m1 m2)         _ -> error "illegal svar type"-    foldStream st yld sng stp $ fromSVar sv+    K.foldStream st yld sng stp $ getSerialT $ fromSVar sv     where-    concurrently ma mb = mkStream $ \st yld sng stp -> do+    concurrently ma mb = K.mkStream $ \st yld sng stp -> do         runInIO <- captureMonadState-        liftIO $ enqueue (fromJust $ streamVar st) $ (runInIO, mb)-        foldStreamShared st yld sng stp ma+        liftIO $ enqueue (fromJust $ streamVar st) (runInIO, mb)+        K.foldStreamShared st yld sng stp ma  {-# INLINE joinStreamVarAsync #-}-joinStreamVarAsync :: (IsStream t, MonadAsync m)-    => SVarStyle -> t m a -> t m a -> t m a-joinStreamVarAsync style m1 m2 = mkStream $ \st yld sng stp ->+joinStreamVarAsync :: MonadAsync m+    => SVarStyle -> Stream m a -> Stream m a -> Stream m a+joinStreamVarAsync style m1 m2 = K.mkStream $ \st yld sng stp ->     case streamVar st of         Just sv | svarStyle sv == style -> do             runInIO <- captureMonadState-            liftIO $ enqueue sv $ (runInIO, toStream m2)-            foldStreamShared st yld sng stp m1-        _ -> foldStreamShared st yld sng stp (forkSVarAsync style m1 m2)+            liftIO $ enqueue sv (runInIO, m2)+            K.foldStreamShared st yld sng stp m1+        _ -> K.foldStreamShared st yld sng stp (forkSVarAsync style m1 m2)  ------------------------------------------------------------------------------ -- Semigroup and Monoid style compositions for parallel actions ------------------------------------------------------------------------------ -infixr 6 `async`---- | Merges two streams, both the streams may be evaluated concurrently,--- outputs from both are used as they arrive:------ >>> 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---- | Same as 'async'.------ @since 0.1.0-{-# DEPRECATED (<|) "Please use 'async' instead." #-}-{-# INLINE (<|) #-}-(<|) :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a-(<|) = async+{-# INLINE asyncK #-}+asyncK :: MonadAsync m => Stream m a -> Stream m a -> Stream m a+asyncK = joinStreamVarAsync AsyncVar  -- IMPORTANT: using a monomorphically typed and SPECIALIZED consMAsync makes a -- huge difference in the performance of consM in IsStream instance even we@@ -739,7 +685,7 @@ {-# 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.fromEffect m `async` (toStream r)+consMAsync m (AsyncT r) = AsyncT $ asyncK (K.fromEffect m) r  ------------------------------------------------------------------------------ -- AsyncT@@ -799,40 +745,26 @@ -- @since 0.8.0 type Async = AsyncT IO --- | Fix the type of a polymorphic stream as 'AsyncT'.------ /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-    fromStream = AsyncT-    consM = consMAsync-    (|:) = consMAsync- ------------------------------------------------------------------------------ -- Semigroup ------------------------------------------------------------------------------  -- Monomorphically typed version of "async" for better performance of Semigroup -- instance.-{-# INLINE mappendAsync #-}-{-# SPECIALIZE mappendAsync :: AsyncT IO a -> AsyncT IO a -> AsyncT IO a #-}-mappendAsync :: MonadAsync m => AsyncT m a -> AsyncT m a -> AsyncT m a-mappendAsync m1 m2 = fromStream $ async (toStream m1) (toStream m2)+{-# INLINE append #-}+{-# SPECIALIZE append :: AsyncT IO a -> AsyncT IO a -> AsyncT IO a #-}+append :: MonadAsync m => AsyncT m a -> AsyncT m a -> AsyncT m a+append (AsyncT m1) (AsyncT m2) = AsyncT $ asyncK m1 m2  instance MonadAsync m => Semigroup (AsyncT m a) where-    (<>) = mappendAsync+    (<>) = append  ------------------------------------------------------------------------------ -- Monoid ------------------------------------------------------------------------------  instance MonadAsync m => Monoid (AsyncT m a) where-    mempty = K.nil+    mempty = AsyncT K.nil     mappend = (<>)  ------------------------------------------------------------------------------@@ -843,12 +775,13 @@ {-# SPECIALIZE apAsync :: AsyncT IO (a -> b) -> AsyncT IO a -> AsyncT IO b #-} apAsync :: MonadAsync m => AsyncT m (a -> b) -> AsyncT m a -> AsyncT m b apAsync (AsyncT m1) (AsyncT m2) =-    let f x1 = K.concatMapBy async (pure . x1) m2-    in AsyncT $ K.concatMapBy async f m1+    let f x1 = K.concatMapWith asyncK (pure . x1) m2+    in AsyncT $ K.concatMapWith asyncK f m1  instance (Monad m, MonadAsync m) => Applicative (AsyncT m) where     {-# INLINE pure #-}     pure = AsyncT . K.fromPure+     {-# INLINE (<*>) #-}     (<*>) = apAsync @@ -859,9 +792,10 @@ -- GHC: if we change the implementation of bindWith with arguments in a -- different order we see a significant performance degradation (~2x). {-# INLINE bindAsync #-}-{-# SPECIALIZE bindAsync :: AsyncT IO a -> (a -> AsyncT IO b) -> AsyncT IO b #-}+{-# SPECIALIZE bindAsync ::+    AsyncT IO a -> (a -> AsyncT IO b) -> AsyncT IO b #-} bindAsync :: MonadAsync m => AsyncT m a -> (a -> AsyncT m b) -> AsyncT m b-bindAsync m f = fromStream $ K.bindWith async (adapt m) (\a -> adapt $ f a)+bindAsync (AsyncT m) f = AsyncT $ K.bindWith asyncK m (getAsyncT . f)  -- GHC: if we specify arguments in the definition of (>>=) we see a significant -- performance degradation (~2x).@@ -879,84 +813,16 @@ -- WAsyncT ------------------------------------------------------------------------------ +{-# INLINE wAsyncK #-}+wAsyncK :: MonadAsync m => Stream m a -> Stream m a -> Stream m a+wAsyncK = joinStreamVarAsync WAsyncVar+ -- | XXX we can implement it more efficienty by directly implementing instead -- of combining streams using wAsync. {-# 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.fromEffect m `wAsync` (toStream r)--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.------ 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+consMWAsync m (WAsyncT r) = WAsyncT $ wAsyncK (K.fromEffect m) r  -- | For 'WAsyncT' streams: --@@ -1102,38 +968,24 @@ -- @since 0.8.0 type WAsync = WAsyncT IO --- | Fix the type of a polymorphic stream as 'WAsyncT'.------ /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-    fromStream = WAsyncT-    consM = consMWAsync-    (|:) = consMWAsync- ------------------------------------------------------------------------------ -- Semigroup ------------------------------------------------------------------------------ -{-# INLINE mappendWAsync #-}-{-# SPECIALIZE mappendWAsync :: WAsyncT IO a -> WAsyncT IO a -> WAsyncT IO a #-}-mappendWAsync :: MonadAsync m => WAsyncT m a -> WAsyncT m a -> WAsyncT m a-mappendWAsync m1 m2 = fromStream $ wAsync (toStream m1) (toStream m2)+{-# INLINE wAppend #-}+{-# SPECIALIZE wAppend :: WAsyncT IO a -> WAsyncT IO a -> WAsyncT IO a #-}+wAppend :: MonadAsync m => WAsyncT m a -> WAsyncT m a -> WAsyncT m a+wAppend (WAsyncT m1) (WAsyncT m2) = WAsyncT $ wAsyncK m1 m2  instance MonadAsync m => Semigroup (WAsyncT m a) where-    (<>) = mappendWAsync+    (<>) = wAppend  ------------------------------------------------------------------------------ -- Monoid ------------------------------------------------------------------------------  instance MonadAsync m => Monoid (WAsyncT m a) where-    mempty = K.nil+    mempty = WAsyncT K.nil     mappend = (<>)  ------------------------------------------------------------------------------@@ -1141,11 +993,12 @@ ------------------------------------------------------------------------------  {-# INLINE apWAsync #-}-{-# SPECIALIZE apWAsync :: WAsyncT IO (a -> b) -> WAsyncT IO a -> WAsyncT IO b #-}+{-# SPECIALIZE apWAsync ::+    WAsyncT IO (a -> b) -> WAsyncT IO a -> WAsyncT IO b #-} apWAsync :: MonadAsync m => WAsyncT m (a -> b) -> WAsyncT m a -> WAsyncT m b apWAsync (WAsyncT m1) (WAsyncT m2) =-    let f x1 = K.concatMapBy wAsync (pure . x1) m2-    in WAsyncT $ K.concatMapBy wAsync f m1+    let f x1 = K.concatMapWith wAsyncK (pure . x1) m2+    in WAsyncT $ K.concatMapWith wAsyncK f m1  -- GHC: if we specify arguments in the definition of (<*>) we see a significant -- performance degradation (~2x).@@ -1160,9 +1013,10 @@ -- GHC: if we change the implementation of bindWith with arguments in a -- different order we see a significant performance degradation (~2x). {-# INLINE bindWAsync #-}-{-# SPECIALIZE bindWAsync :: WAsyncT IO a -> (a -> WAsyncT IO b) -> WAsyncT IO b #-}+{-# SPECIALIZE bindWAsync ::+    WAsyncT IO a -> (a -> WAsyncT IO b) -> WAsyncT IO b #-} bindWAsync :: MonadAsync m => WAsyncT m a -> (a -> WAsyncT m b) -> WAsyncT m b-bindWAsync m f = fromStream $ K.bindWith wAsync (adapt m) (\a -> adapt $ f a)+bindWAsync (WAsyncT m) f = WAsyncT $ K.bindWith wAsyncK m (getWAsyncT . f)  -- GHC: if we specify arguments in the definition of (>>=) we see a significant -- performance degradation (~2x).
src/Streamly/Internal/Data/Stream/Instances.hs view
@@ -10,7 +10,8 @@ #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;  \+    fmap f (STREAM m) =                                                       \+        STREAM $ D.toStreamK $ D.mapM (return . f) $ D.fromStreamK m;         \     {-# INLINE (<$) #-};                                                      \     (<$) =  fmap . const };                                                   \                                                                               \@@ -32,7 +33,7 @@                                                                               \ instance (MonadReader r m CONSTRAINT) => MonadReader r (STREAM m) where {     \     ask = lift ask;                                                           \-    local f m = fromStream $ K.withLocal f (toStream m) };                    \+    local f (STREAM m) = STREAM $ K.withLocal f m };                          \                                                                               \ instance (MonadState s m CONSTRAINT) => MonadState s (STREAM m) where {       \     {-# INLINE get #-}; \@@ -59,7 +60,7 @@ #define NFDATA1_INSTANCE(STREAM)                                              \ instance NFData1 (STREAM Identity) where {                                    \     {-# INLINE liftRnf #-};                                                   \-    liftRnf r = runIdentity . P.foldl' (\_ x -> r x) () }+    liftRnf f (STREAM xs) = runIdentity $ P.foldl' (\_ x -> f x) () xs} #else #define NFDATA1_INSTANCE(STREAM) #endif@@ -68,17 +69,17 @@ instance IsList (STREAM Identity a) where {                                   \     type (Item (STREAM Identity a)) = a;                                      \     {-# INLINE fromList #-};                                                  \-    fromList = P.fromList;                                                    \+    fromList xs = STREAM $ P.fromList xs;                                     \     {-# INLINE toList #-};                                                    \-    toList = runIdentity . P.toList };                                        \+    toList (STREAM xs) = runIdentity $ P.toList xs };                         \                                                                               \ instance Eq a => Eq (STREAM Identity a) where {                               \     {-# INLINE (==) #-};                                                      \-    (==) xs ys = runIdentity $ P.eqBy (==) xs ys };                           \+    (==) (STREAM xs) (STREAM ys) = runIdentity $ P.eqBy (==) xs ys };         \                                                                               \ instance Ord a => Ord (STREAM Identity a) where {                             \     {-# INLINE compare #-};                                                   \-    compare xs ys = runIdentity $ P.cmpBy compare xs ys;                      \+    compare (STREAM xs) (STREAM ys) = runIdentity $ P.cmpBy compare xs ys;    \     {-# INLINE (<) #-};                                                       \     x <  y = case compare x y of { LT -> True;  _ -> False };                 \     {-# INLINE (<=) #-};                                                      \@@ -104,11 +105,11 @@                                                                               \ instance (a ~ Char) => IsString (STREAM Identity a) where {                   \     {-# INLINE fromString #-};                                                \-    fromString = P.fromList };                                                \+    fromString xs = STREAM $ P.fromList xs };                                                \                                                                               \ instance NFData a => NFData (STREAM Identity a) where {                       \     {-# INLINE rnf #-};                                                       \-    rnf = runIdentity . P.foldl' (\_ x -> rnf x) () };                        \+    rnf (STREAM xs) = runIdentity $ P.foldl' (\_ x -> rnf x) () xs};                        \  ------------------------------------------------------------------------------- -- Foldable@@ -125,7 +126,7 @@ instance (Foldable m, Monad m) => Foldable (STREAM m) where {                 \                                                                               \     {-# INLINE foldMap #-};                                                   \-    foldMap f = fold . P.foldr (mappend . f) mempty;                          \+    foldMap f (STREAM xs) = fold $ P.foldr (mappend . f) mempty xs;           \                                                                               \     {-# INLINE foldr #-};                                                     \     foldr f z t = appEndo (foldMap (Endo #. f) t) z;                          \@@ -169,5 +170,6 @@ #define TRAVERSABLE_INSTANCE(STREAM)                                          \ instance Traversable (STREAM Identity) where {                                \     {-# INLINE traverse #-};                                                  \-    traverse f s = runIdentity $ P.foldr consA (pure mempty) s                \+    traverse f (STREAM xs) =                                                  \+        fmap STREAM $ runIdentity $ P.foldr consA (pure mempty) xs            \         where { consA x ys = liftA2 K.cons (f x) ys }}
src/Streamly/Internal/Data/Stream/IsStream.hs view
@@ -11,7 +11,7 @@ -- experimental APIs.  module Streamly.Internal.Data.Stream.IsStream-    ( module Streamly.Internal.Data.Stream.IsStream.Types+    ( module Streamly.Internal.Data.Stream.IsStream.Type     , module Streamly.Internal.Data.Stream.IsStream.Generate     , module Streamly.Internal.Data.Stream.IsStream.Eliminate     , module Streamly.Internal.Data.Stream.IsStream.Transform@@ -31,4 +31,6 @@ 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+import Streamly.Internal.Data.Stream.IsStream.Type+    hiding (cmpBy, drain, eqBy, foldl', foldrM, foldr, fold, toList, toStream+        , fromEffect, fromPure, repeat)
src/Streamly/Internal/Data/Stream/IsStream/Combinators.hs view
@@ -26,9 +26,12 @@ 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.IsStream.Type+    (IsStream, mkStream, foldStreamShared) import Streamly.Internal.Data.Stream.Serial (SerialT)+import Streamly.Internal.Data.Stream.StreamK.Type (Stream)++import Streamly.Internal.Data.SVar  ------------------------------------------------------------------------------- -- Concurrency control
src/Streamly/Internal/Data/Stream/IsStream/Common.hs view
@@ -22,10 +22,12 @@     , relTimesWith      -- * Elimination+    , foldOn     , fold     , fold_      -- * Transformation+    , map     , scanlMAfter'     , postscanlM'     , smapM@@ -39,12 +41,21 @@     , reverse     , reverse' +    -- * Concurrent+    , mkAsync+    , mkParallel+    , parallelFst+     -- * Nesting     , concatM     , concatMapM     , concatMap     , splitOnSeq +    -- * Zipping+    , zipWithM+    , zipWith+     -- * Deprecated     , yield     , yieldM@@ -56,19 +67,19 @@ import Control.Concurrent (threadDelay) import Control.Monad.IO.Class (MonadIO(..)) import Foreign.Storable (Storable)+import Streamly.Internal.Control.Concurrent (MonadAsync) 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.IsStream.Type+    (IsStream(..), fromStreamD, toStreamD, 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.Array.Foreign.Type as A+import qualified Streamly.Internal.Data.Stream.Async as Async+import qualified Streamly.Internal.Data.Stream.IsStream.Type as IsStream 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@@ -76,17 +87,26 @@ #else import qualified Streamly.Internal.Data.Stream.StreamD as S #endif+import Streamly.Internal.System.IO (defaultChunkSize) -import Prelude hiding (take, takeWhile, drop, reverse, concatMap)+import Prelude hiding (take, takeWhile, drop, reverse, concatMap, map, zipWith)  -- -- $setup -- >>> :m+-- >>> import Control.Concurrent (threadDelay)+-- >>> import Control.Monad (join)+-- >>> import Control.Monad.Trans.Class (lift)+-- >>> import Data.Function (fix, (&))+-- >>> import Data.Semigroup (cycle1) -- >>> import Prelude hiding (take, takeWhile, drop, reverse)+-- >>> import System.IO.Unsafe (unsafePerformIO) -- >>> 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+-- >>> import qualified Streamly.Data.Fold as Fold+-- >>> import qualified Streamly.Internal.Data.Fold as Fold+-- >>> import qualified Streamly.Data.Unfold as Unfold  ------------------------------------------------------------------------------ -- Generation@@ -117,7 +137,7 @@ -- {-# INLINE fromPure #-} fromPure :: IsStream t => a -> t m a-fromPure = K.fromPure+fromPure = fromStream . K.fromPure  -- | Same as 'fromPure' --@@ -144,7 +164,7 @@ -- {-# INLINE fromEffect #-} fromEffect :: (Monad m, IsStream t) => m a -> t m a-fromEffect = K.fromEffect+fromEffect = fromStream . K.fromEffect  -- | Same as 'fromEffect' --@@ -154,24 +174,25 @@ yieldM :: (Monad m, IsStream t) => m a -> t m a yieldM = fromEffect -- |--- @--- repeatM = fix . consM--- repeatM = cycle1 . 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)--- @+-- >>> :{+-- repeatAsync =+--        Stream.repeatM (threadDelay 1000000 >> print 1)+--      & Stream.take 10+--      & Stream.fromAsync+--      & Stream.drain+-- :} -- -- /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+repeatM = K.repeatMWith IsStream.consM  {-# RULES "repeatM serial" repeatM = repeatMSerial #-} {-# INLINE repeatMSerial #-}@@ -247,6 +268,19 @@ -- Elimination - Running a Fold ------------------------------------------------------------------------------ +-- | We can create higher order folds using 'foldOn'. We can fold a number of+-- streams to a given fold efficiently with full stream fusion. For example, to+-- fold a list of streams on the same sum fold:+--+-- >>> concatFold = Prelude.foldl Stream.foldOn Fold.sum+--+-- >>> fold f = Fold.finish . Stream.foldOn f+--+-- /Internal/+{-# INLINE foldOn #-}+foldOn :: Monad m => Fold m a b -> SerialT m a -> Fold m a b+foldOn f s = D.foldOn f $ IsStream.toStreamD s+ -- | 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@@ -278,13 +312,30 @@ {-# 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)+    (b, str) <- D.fold_ fl $ IsStream.toStreamD strm+    return $! (b, IsStream.fromStreamD str)  ------------------------------------------------------------------------------ -- Transformation ------------------------------------------------------------------------------ +-- |+-- @+-- map = fmap+-- @+--+-- Same as 'fmap'.+--+-- @+-- > S.toList $ S.map (+1) $ S.fromList [1,2,3]+-- [2,3,4]+-- @+--+-- @since 0.4.0+{-# INLINE map #-}+map :: (IsStream t, Monad m) => (a -> b) -> t m a -> t m b+map f = fromStreamD . D.map f . toStreamD+ -- | @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@@ -305,6 +356,8 @@ -- XXX this needs to be concurrent -- | Like 'postscanl'' but with a monadic step function and a monadic seed. --+-- >>> postscanlM' f z xs = Stream.drop 1 $ Stream.scanlM' f z xs+-- -- /Since: 0.7.0/ -- -- /Since: 0.8.0 (signature change)/@@ -356,7 +409,7 @@                 (\(s, _) a -> step s a)                 (fmap (,undefined) initial)                 stream-     in Serial.map snd r+     in map snd r  ------------------------------------------------------------------------------ -- Transformation - Trimming@@ -429,7 +482,7 @@ interjectSuffix     :: (IsStream t, MonadAsync m)     => Double -> m a -> t m a -> t m a-interjectSuffix n f xs = xs `Par.parallelFst` repeatM timed+interjectSuffix n f xs = xs `parallelFst` repeatM timed     where timed = liftIO (threadDelay (round $ n * 1000000)) >> f  ------------------------------------------------------------------------------@@ -442,11 +495,11 @@ -- /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. --+-- >>> reverse = Stream.foldlT (flip Stream.cons) Stream.nil+-- -- /Since 0.7.0 (Monad m constraint)/ -- -- /Since: 0.1.1/@@ -459,9 +512,61 @@ -- /Pre-release/ {-# INLINE reverse' #-} reverse' :: (IsStream t, MonadIO m, Storable a) => t m a -> t m a-reverse' s = fromStreamD $ D.reverse' $ toStreamD s+-- reverse' s = fromStreamD $ D.reverse' $ toStreamD s+reverse' =+        fromStreamD+        . A.flattenArraysRev -- unfoldMany A.readRev+        . D.fromStreamK+        . K.reverse+        . D.toStreamK+        . A.arraysOf defaultChunkSize+        . toStreamD  ------------------------------------------------------------------------------+-- Concurrent Transformations and Combining+------------------------------------------------------------------------------++-- | 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 terminates if the buffer is full and a worker thread is+-- kicked off again to evaluate the remaining stream when there is space in the+-- buffer.  The consumer consumes the stream lazily from the buffer.+--+-- /Since: 0.2.0 (Streamly)/+--+-- @since 0.8.0+--+{-# INLINE_NORMAL mkAsync #-}+mkAsync :: (IsStream t, MonadAsync m) => t m a -> t m a+mkAsync = fromStreamD . Async.mkAsyncD . toStreamD++-- 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.+--+-- @mkParallel = IsStream.fromStreamD . mkParallelD . IsStream.toStreamD@+--+-- /Pre-release/+--+{-# INLINE_NORMAL mkParallel #-}+mkParallel :: (IsStream t, MonadAsync m) => t m a -> t m a+mkParallel = fromStreamD . Par.mkParallelD . toStreamD++-- | Like `parallel` but stops the output as soon as the first stream stops.+--+-- /Pre-release/+{-# INLINE parallelFst #-}+parallelFst :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a+parallelFst m1 m2 = fromStream $ Par.parallelFstK (toStream m1) (toStream m2)++------------------------------------------------------------------------------ -- Combine streams and flatten ------------------------------------------------------------------------------ @@ -478,12 +583,10 @@ -- | 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)--- @+-- >>> concatMap f = Stream.concatMapM (return . f)+-- >>> concatMap f = Stream.concatMapWith Stream.serial f+-- >>> concatMap f = Stream.concat . Stream.map f+-- >>> concatMap f = Stream.unfoldMany (Unfold.lmap f Unfold.fromStream) -- -- @since 0.6.0 {-# INLINE concatMap #-}@@ -493,11 +596,9 @@ -- | 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))@--- @+-- >>> concatM = Stream.concat . Stream.fromEffect+-- >>> concatM = Stream.concat . lift    -- requires (MonadTrans t)+-- >>> concatM = join . lift             -- requires (MonadTrans t, Monad (t m)) -- -- See also: 'concat', 'sequence' --@@ -511,6 +612,10 @@ -- Split stream and fold ------------------------------------------------------------------------------ +-- $+-- > intercalate . splitOnSeq == id+-- prop> (\f -> unsafePerformIO . Stream.toList . f . Stream.fromList) (Stream.intercalate Unfold.fromList " " .  Stream.splitOnSeq (Array.fromList " ") Fold.toList) xs == xs+ -- | Like 'splitOn' but the separator is a sequence of elements instead of a -- single element. --@@ -547,12 +652,12 @@ -- -- 'splitOnSeq' is an inverse of 'intercalate'. The following law always holds: ----- > intercalate . splitOn == id+-- > intercalate . splitOnSeq == 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+-- > splitOnSeq . intercalate == id -- -- /Pre-release/ @@ -565,4 +670,37 @@ 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)+splitOnSeq patt f m =+    IsStream.fromStreamD $ D.splitOnSeq patt f (IsStream.toStreamD m)++------------------------------------------------------------------------------+-- Zipping+------------------------------------------------------------------------------++-- | Like 'zipWith' but using a monadic zipping function.+--+-- @since 0.4.0+{-# INLINABLE zipWithM #-}+zipWithM :: (IsStream t, Monad m) => (a -> b -> m c) -> t m a -> t m b -> t m c+zipWithM f m1 m2 =+    IsStream.fromStreamS+        $ S.zipWithM f (IsStream.toStreamS m1) (IsStream.toStreamS m2)++-- | Stream @a@ is evaluated first, followed by stream @b@, the resulting+-- elements @a@ and @b@ are then zipped using the supplied zip function and the+-- result @c@ is yielded to the consumer.+--+-- If stream @a@ or stream @b@ ends, the zipped stream ends. If stream @b@ ends+-- first, the element @a@ from previous evaluation of stream @a@ is discarded.+--+-- @+-- > S.toList $ S.zipWith (+) (S.fromList [1,2,3]) (S.fromList [4,5,6])+-- [5,7,9]+-- @+--+-- @since 0.1.0+{-# INLINABLE zipWith #-}+zipWith :: (IsStream t, Monad m) => (a -> b -> c) -> t m a -> t m b -> t m c+zipWith f m1 m2 =+    IsStream.fromStreamS+        $ S.zipWith f (IsStream.toStreamS m1) (IsStream.toStreamS m2)
src/Streamly/Internal/Data/Stream/IsStream/Eliminate.hs view
@@ -24,6 +24,7 @@     --  See "Streamly.Internal.Data.Fold".       fold     , fold_+    , foldOn      -- * Running a 'Parser'     -- "Streamly.Internal.Data.Parser".@@ -45,6 +46,10 @@     , foldr      -- * Left Folds+    -- Lazy left folds are useful only for reversing the stream+    , foldlS+    , foldlT+     , foldl'     , foldl1'     , foldlM'@@ -151,24 +156,23 @@  import Control.Monad.Catch (MonadThrow) import Control.Monad.IO.Class (MonadIO(..))-import Data.Functor.Identity (Identity (..))+import Control.Monad.Trans.Class (MonadTrans(..)) import Foreign.Storable (Storable)+import Streamly.Internal.Control.Concurrent (MonadAsync) import Streamly.Internal.Data.Parser (Parser (..))-import Streamly.Internal.Data.SVar (MonadAsync, defState)+import Streamly.Internal.Data.SVar (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)+    ( fold, fold_, foldOn, drop, findIndices, reverse, splitOnSeq, take+    , takeWhile, mkParallel)+import Streamly.Internal.Data.Stream.IsStream.Type+    (IsStream, toStreamS, fromStreamD, toStreamD)+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.IsStream.Type as IsStream import qualified Streamly.Internal.Data.Stream.StreamD as D-import qualified Streamly.Internal.Data.Stream.StreamK as K+import qualified Streamly.Internal.Data.Stream.StreamK.Type 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@@ -212,7 +216,7 @@ -- @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)+uncons (SerialT m) = fmap (fmap (fmap IsStream.fromStream)) $ K.uncons m  ------------------------------------------------------------------------------ -- Right Folds@@ -240,7 +244,7 @@ -- /Since: 0.1.0/ {-# INLINE foldrM #-} foldrM :: Monad m => (a -> m b -> m b) -> m b -> SerialT m a -> m b-foldrM = P.foldrM+foldrM = IsStream.foldrM  -- | Right fold, lazy for lazy monads and pure streams, and strict for strict -- monads.@@ -255,7 +259,7 @@ -- @since 0.1.0 {-# INLINE foldr #-} foldr :: Monad m => (a -> b -> b) -> b -> SerialT m a -> m b-foldr = P.foldr+foldr = IsStream.foldr  -- XXX This seems to be of limited use as it cannot be used to construct -- recursive structures and for reduction foldl1' is better.@@ -273,6 +277,27 @@ -- Left Folds ------------------------------------------------------------------------------ +-- | Lazy left fold to a stream.+{-# INLINE foldlS #-}+foldlS :: IsStream t => (t m b -> a -> t m b) -> t m b -> t m a -> t m b+foldlS f z =+    IsStream.fromStream+        . K.foldlS+            (\xs x -> IsStream.toStream $ f (IsStream.fromStream xs) x)+            (IsStream.toStream z)+        . IsStream.toStream++-- | Lazy left fold to a transformer monad.+--+-- For example, to reverse a stream:+--+-- > S.toList $ S.foldlT (flip S.cons) S.nil $ (S.fromList [1..5] :: SerialT IO Int)+--+{-# INLINE foldlT #-}+foldlT :: (Monad m, IsStream t, Monad (s m), MonadTrans s)+    => (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)+ -- | 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@@ -282,7 +307,7 @@ {-# 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'+foldx = IsStream.foldlx'  -- | Left associative/strict push fold. @foldl' reduce initial stream@ invokes -- @reduce@ with the accumulator and the next input in the input stream, using@@ -295,7 +320,7 @@ -- @since 0.2.0 {-# INLINE foldl' #-} foldl' :: Monad m => (b -> a -> b) -> b -> SerialT m a -> m b-foldl' = P.foldl'+foldl' = IsStream.foldl'  -- | Strict left fold, for non-empty streams, using first element as the -- starting value. Returns 'Nothing' if the stream is empty.@@ -317,7 +342,7 @@ {-# 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'+foldxM = IsStream.foldlMx'  -- | Like 'foldl'' but with a monadic step function. --@@ -422,7 +447,7 @@ -- @since 0.7.0 {-# INLINE drain #-} drain :: Monad m => SerialT m a -> m ()-drain = P.drain+drain = IsStream.drain  -- | -- > drainN n = Stream.drain . Stream.take n@@ -513,14 +538,14 @@ -- @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)+tail (SerialT m) = fmap (fmap IsStream.fromStream) $ K.tail 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)+init (SerialT m) = fmap (fmap IsStream.fromStream) $ K.init m  -- | Extract the last element of the stream, if any. --@@ -657,7 +682,7 @@ -- @since 0.1.0 {-# INLINE maximum #-} maximum :: (Monad m, Ord a) => SerialT m a -> m (Maybe a)-maximum = P.maximum+maximum m = S.maximum (toStreamS m)  -- | Determine the maximum element in a stream using the supplied comparison -- function.@@ -755,7 +780,7 @@ -- @since 0.1.0 {-# INLINE toList #-} toList :: Monad m => SerialT m a -> m [a]-toList = P.toList+toList = IsStream.toList  -- | -- @@@ -789,7 +814,7 @@         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+        in IsStream.foldStream defState yieldk single stop m1  -- | Convert a stream to a pure stream. --@@ -800,8 +825,8 @@ -- /Pre-release/ -- {-# INLINE toStream #-}-toStream :: Monad m => SerialT m a -> m (SerialT Identity a)-toStream = foldr K.cons K.nil+toStream :: Monad m => SerialT m a -> m (SerialT n a)+toStream = foldr IsStream.cons IsStream.nil  -- | Convert a stream to a pure stream in reverse order. --@@ -812,8 +837,8 @@ -- /Pre-release/ -- {-# INLINE toStreamRev #-}-toStreamRev :: Monad m => SerialT m a -> m (SerialT Identity a)-toStreamRev = foldl' (flip K.cons) K.nil+toStreamRev :: Monad m => SerialT m a -> m (SerialT n a)+toStreamRev = foldl' (flip IsStream.cons) IsStream.nil  ------------------------------------------------------------------------------ -- Concurrent Application@@ -853,7 +878,7 @@ {-# INLINE (|$.) #-} (|$.) :: (IsStream t, MonadAsync m) => (t m a -> m b) -> (t m a -> m b) -- (|$.) f = f . Async.mkAsync-(|$.) f = f . Par.mkParallel+(|$.) f = f . mkParallel  infixr 0 |$. @@ -1009,7 +1034,7 @@ -- @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+eqBy = IsStream.eqBy  -- | Compare two streams lexicographically using a comparison function. --@@ -1018,4 +1043,4 @@ cmpBy     :: (IsStream t, Monad m)     => (a -> b -> Ordering) -> t m a -> t m b -> m Ordering-cmpBy = P.cmpBy+cmpBy = IsStream.cmpBy
src/Streamly/Internal/Data/Stream/IsStream/Enumeration.hs view
@@ -60,9 +60,9 @@ 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 Streamly.Internal.Data.Stream.IsStream.Type (IsStream(..), fromStreamD) +import qualified Streamly.Internal.Data.Stream.IsStream.Type as IsStream import qualified Streamly.Internal.Data.Stream.StreamD.Generate as D import qualified Streamly.Internal.Data.Stream.Serial as Serial (map) @@ -202,7 +202,7 @@ -- @since 0.6.0 {-# INLINE enumerateFromFractional #-} enumerateFromFractional :: (IsStream t, Monad m, Fractional a) => a -> t m a-enumerateFromFractional from = fromStreamD $ D.numFrom from+enumerateFromFractional from = fromStreamD $ D.enumerateFromNum from  -- | Numerically stable enumeration from a 'Fractional' number in steps. -- @enumerateFromThenFractional from then@ generates a stream whose first@@ -227,7 +227,7 @@ enumerateFromThenFractional     :: (IsStream t, Monad m, Fractional a)     => a -> a -> t m a-enumerateFromThenFractional from next = fromStreamD $ D.numFromThen from next+enumerateFromThenFractional from next = fromStreamD $ D.enumerateFromThenNum from next  -- | Numerically stable enumeration from a 'Fractional' number to a given -- limit.  @enumerateFromToFractional from to@ generates a finite stream whose@@ -292,8 +292,10 @@ -- @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)+enumerateFromToSmall from to =+    IsStream.fromSerial+        $ Serial.map toEnum+        $ enumerateFromToIntegral (fromEnum from) (fromEnum to)  -- | 'enumerateFromThenTo' for 'Enum' types not larger than 'Int'. --@@ -301,8 +303,11 @@ {-# 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)+enumerateFromThenToSmall from next to =+    IsStream.fromSerial+        $ Serial.map toEnum+        $ enumerateFromThenToIntegral+            (fromEnum from) (fromEnum next) (fromEnum to)  -- | 'enumerateFromThen' for 'Enum' types not larger than 'Int'. --@@ -550,17 +555,19 @@  instance Enumerable a => Enumerable (Identity a) where     {-# INLINE enumerateFrom #-}-    enumerateFrom (Identity from) = Serial.map Identity $-        enumerateFrom from+    enumerateFrom (Identity from) =+        IsStream.fromSerial $ Serial.map Identity $ enumerateFrom from     {-# INLINE enumerateFromThen #-}-    enumerateFromThen (Identity from) (Identity next) = Serial.map Identity $-        enumerateFromThen from next+    enumerateFromThen (Identity from) (Identity next) =+        IsStream.fromSerial $ Serial.map Identity $ enumerateFromThen from next     {-# INLINE enumerateFromTo #-}-    enumerateFromTo (Identity from) (Identity to) = Serial.map Identity $-        enumerateFromTo from to+    enumerateFromTo (Identity from) (Identity to) =+        IsStream.fromSerial $ Serial.map Identity $ enumerateFromTo from to     {-# INLINE enumerateFromThenTo #-}     enumerateFromThenTo (Identity from) (Identity next) (Identity to) =-        Serial.map Identity $ enumerateFromThenTo from next to+        IsStream.fromSerial+            $ Serial.map Identity+            $ enumerateFromThenTo from next to  -- TODO {-
src/Streamly/Internal/Data/Stream/IsStream/Exception.hs view
@@ -13,11 +13,13 @@     , after     , bracket_     , bracket+    , bracket'     , onException     , finally_     , finally     , ghandle     , handle+    , retry     ) where @@ -25,24 +27,33 @@ 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 Data.Map.Strict (Map)+import Streamly.Internal.Control.Concurrent (MonadAsync)+import Streamly.Internal.Data.Stream.IsStream.Type+    (IsStream(..), fromStreamD, toStreamD)  import qualified Streamly.Internal.Data.Stream.StreamD as D +-- $setup+-- >>> :m+-- >>> import qualified Streamly.Prelude as Stream+-- >>> import qualified Streamly.Internal.Data.Stream.IsStream as Stream (nilM)+ ------------------------------------------------------------------------------ -- Exceptions ------------------------------------------------------------------------------  -- | Run the action @m b@ before the stream yields its first element. ----- > before action xs = 'nilM' action <> xs+-- Same as the following but more efficient due to fusion: --+-- >>> before action xs = Stream.nilM action <> xs+-- >>> before action xs = Stream.concatMap (const xs) (Stream.fromEffect action)+-- -- @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+before action xs = fromStreamD $ D.before action $ toStreamD xs  -- | Like 'after', with following differences: --@@ -59,7 +70,7 @@ -- {-# 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+after_ action xs = fromStreamD $ D.after_ action $ 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.@@ -74,7 +85,7 @@ {-# 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+after action xs = fromStreamD $ D.after action $ toStreamD xs  -- | Run the action @m b@ if the stream aborts due to an exception. The -- exception is not caught, simply rethrown.@@ -84,7 +95,7 @@ -- @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+onException action xs = fromStreamD $ D.onException action $ toStreamD xs  -- | Like 'finally' with following differences: --@@ -99,7 +110,7 @@ -- {-# 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+finally_ action xs = fromStreamD $ D.finally_ action $ 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@@ -120,7 +131,7 @@ -- {-# 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+finally action xs = fromStreamD $ D.finally action $ toStreamD xs  -- | Like 'bracket' but with following differences: --@@ -137,7 +148,7 @@ {-# 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 $+bracket_ bef aft bet = fromStreamD $     D.bracket_ bef aft (toStreamD . bet)  -- | Run the alloc action @m b@ with async exceptions disabled but keeping@@ -166,9 +177,25 @@ {-# 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)+bracket bef aft = bracket' bef aft aft aft +-- For a use case of this see the "streamly-process" package. It needs to kill+-- the process in case of exception or garbage collection, but waits for the+-- process to terminate in normal cases.+--+-- | Like 'bracket' but can use separate cleanup actions depending on the mode+-- of termination.  @bracket' before onStop onGC onException action@ runs+-- @action@ using the result of @before@. If the stream stops, @onStop@ action+-- is executed, if the stream is abandoned @onGC@ is executed, if the stream+-- encounters an exception @onException@ is executed.+--+-- /Pre-release/+{-# INLINE bracket' #-}+bracket' :: (IsStream t, MonadAsync m, MonadCatch m)+    => m b -> (b -> m c) -> (b -> m d) -> (b -> m e) -> (b -> t m a) -> t m a+bracket' bef aft gc exc bet = fromStreamD $+    D.bracket' bef aft exc gc (toStreamD . bet)+ -- | Like 'handle' but the exception handler is also provided with the stream -- that generated the exception as input. The exception handler can thus -- re-evaluate the stream to retry the action that failed. The exception@@ -185,9 +212,9 @@ 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+      fromStreamD+    . D.ghandle (\e xs -> toStreamD $ handler e (fromStreamD xs))+    . toStreamD  -- | When evaluating a stream if an exception occurs, stream evaluation aborts -- and the specified exception handler is run with the exception as argument.@@ -199,4 +226,47 @@ 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+    fromStreamD $ D.handle (toStreamD . handler) $ toStreamD xs+++-- | @retry@ takes 3 arguments+--+-- 1. A map @m@ whose keys are exceptions and values are the number of times to+-- retry the action given that the exception occurs.+--+-- 2. A handler @han@ that decides how to handle an exception when the exception+-- cannot be retried.+--+-- 3. The stream itself that we want to run this mechanism on.+--+-- When evaluating a stream if an exception occurs,+--+-- 1. The stream evaluation aborts+--+-- 2. The exception is looked up in @m@+--+--    a. If the exception exists and the mapped value is > 0 then,+--+--       i. The value is decreased by 1.+--+--       ii. The stream is resumed from where the exception was called, retrying+--       the action.+--+--    b. If the exception exists and the mapped value is == 0 then the stream+--    evaluation stops.+--+--    c. If the exception does not exist then we handle the exception using+--    @han@.+--+-- /Internal/+--+{-# INLINE retry #-}+retry :: (IsStream t, MonadCatch m, Exception e, Ord e)+    => Map e Int+       -- ^ map from exception to retry count+    -> (e -> t m a)+       -- ^ default handler for those exceptions that are not in the map+    -> t m a+    -> t m a+retry emap handler inp =+    fromStreamD $ D.retry emap (toStreamD . handler) $ toStreamD inp
src/Streamly/Internal/Data/Stream/IsStream/Expand.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+ -- | -- Module      : Streamly.Internal.Data.Stream.IsStream.Expand -- Copyright   : (c) 2017 Composewell Technologies@@ -30,8 +32,8 @@     , async     , wAsync     , parallel-    , Par.parallelFst-    , Par.parallelMin+    , parallelFst+    , parallelMin      -- * Binary Combinators (Pair Wise)     -- | Like the functions in the section above these functions also combine@@ -45,7 +47,8 @@     , append      -- ** wSerial-    -- | 'wSerial' is a CPS based stream interleaving functions. It can be+    -- | 'wSerial' is a CPS based stream interleaving functions. Use+    -- 'concatPairsWith wSerial' to interleave @n@ streams uniformly. 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.@@ -68,15 +71,16 @@     , roundrobin      -- ** Zip-    , Z.zipWith-    , Z.zipWithM-    , Z.zipAsyncWith-    , Z.zipAsyncWithM+    , zipWith+    , zipWithM+    , zipAsyncWith+    , zipAsyncWithM      -- ** Merge     -- , merge     , mergeBy     , mergeByM+    , mergeByMFused     , mergeAsyncBy     , mergeAsyncByM @@ -120,9 +124,9 @@     -- * Flatten Containers     -- | Flatten 'Foldable' containers using the binary stream merging     -- operations.-    , concatFoldableWith-    , concatMapFoldableWith-    , concatForFoldableWith+    , IsStream.concatFoldableWith+    , IsStream.concatMapFoldableWith+    , IsStream.concatForFoldableWith      -- * ConcatMapWith     -- | Map and flatten a stream like 'concatMap' but using a custom binary@@ -136,8 +140,8 @@     -- fashion, a pair wise merging using 'concatPairsWith' would be more     -- efficient. These cases include operations like 'mergeBy' or 'zipWith'. -    , concatMapWith-    , K.bindWith+    , IsStream.concatMapWith+    , IsStream.bindWith     , concatSmapMWith      -- * ConcatPairsWith@@ -153,49 +157,52 @@      -- * Deprecated     , concatUnfold+    , (<=>)+    , (<|)     ) where  #include "inline.hs" -import Streamly.Internal.Data.Stream.Ahead (ahead)-import Streamly.Internal.Data.Stream.Async (async, wAsync)+import Streamly.Internal.Control.Concurrent (MonadAsync)+import Streamly.Internal.Data.Stream.Ahead (aheadK)+import Streamly.Internal.Data.Stream.Async (asyncK, wAsyncK) 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)+    ( concatM, concatMapM, concatMap, smapM, fromPure, fromEffect, parallelFst+    , zipWith, zipWithM)+import Streamly.Internal.Data.Stream.IsStream.Type+    (IsStream(..), fromStreamD, toStreamD) import Streamly.Internal.Data.Unfold.Type (Unfold) +import qualified Streamly.Internal.Data.Stream.IsStream.Type as IsStream 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 qualified Streamly.Internal.Data.Stream.StreamK as K (mergeBy, mergeByM)+import qualified Streamly.Internal.Data.Stream.StreamK.Type as K+import qualified Streamly.Internal.Data.Stream.Zip as Zip -import Prelude hiding (concat, concatMap)+import Prelude hiding (concat, concatMap, zipWith)  -- $setup -- >>> :m+-- >>> import Control.Concurrent (threadDelay) -- >>> 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.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+-- >>> :{+--  delay n = do+--      threadDelay (n * 1000000)   -- sleep for n seconds+--      putStrLn (show n ++ " sec") -- print "n sec"+--      return n                    -- IO Int+-- :}+--  ------------------------------------------------------------------------------- -- Appending@@ -218,10 +225,79 @@ append ::(IsStream t, Monad m) => t m b -> t m b -> t m b append m1 m2 = fromStreamD $ D.append (toStreamD m1) (toStreamD m2) +infixr 6 `serial`++-- | Appends two streams sequentially, yielding all elements from the first+-- stream, and then all elements from the second stream.+--+-- >>> 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+serial m1 m2 = fromStream $ K.serial (toStream m1) (toStream m2)+ ------------------------------------------------------------------------------- -- Interleaving ------------------------------------------------------------------------------- +infixr 6 `wSerial`++-- XXX doc duplicated from Stream.Serial module.+--+-- | 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.+--+-- >>> 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 = fromStream $ Serial.wSerialK (toStream m1) (toStream m2)++infixr 5 <=>++-- | Same as 'wSerial'.+--+-- @since 0.1.0+{-# DEPRECATED (<=>) "Please use 'wSerial' instead." #-}+{-# INLINE (<=>) #-}+(<=>) :: IsStream t => t m a -> t m a -> t m a+(<=>) = wSerial+ -- XXX Same as 'wSerial'. We should perhaps rename wSerial to interleave. -- XXX Document the interleaving behavior of side effects in all the -- interleaving combinators.@@ -341,7 +417,277 @@ roundrobin ::(IsStream t, Monad m) => t m b -> t m b -> t m b roundrobin m1 m2 = fromStreamD $ D.roundRobin (toStreamD m1) (toStreamD m2) +infixr 6 `async`++-- | Merges two streams, both the streams may be evaluated concurrently,+-- outputs from both are used as they arrive:+--+-- >>> 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 m1 m2 = fromStream $ asyncK (toStream m1) (toStream m2)++-- | Same as 'async'.+--+-- @since 0.1.0+{-# DEPRECATED (<|) "Please use 'async' instead." #-}+{-# INLINE (<|) #-}+(<|) :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a+(<|) = async++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.+--+-- With a single thread, 'async' starts behaving like 'serial' while 'wAsync'+-- starts behaving like 'wSerial'.+--+-- >>> import Streamly.Prelude (async, 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 m1 m2 = fromStream $ wAsyncK (toStream m1) (toStream m2)++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:+--+-- >>> 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 = fromStream $ aheadK (toStream m1) (toStream m2)++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.+--+-- >>> 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 m1 m2 = fromStream $ Par.parallelK (toStream m1) (toStream m2)++-- This is a race like combinator for streams.+--+-- | Like `parallel` but stops the output as soon as any of the two streams+-- stops.+--+-- /Pre-release/+{-# INLINE parallelMin #-}+parallelMin :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a+parallelMin m1 m2 = fromStream $ Par.parallelMinK (toStream m1) (toStream m2)+ ------------------------------------------------------------------------------+-- Zipping+------------------------------------------------------------------------------++-- | Like 'zipAsyncWith' but with a monadic zipping function.+--+-- @since 0.4.0+{-# INLINE zipAsyncWithM #-}+zipAsyncWithM :: (IsStream t, MonadAsync m)+    => (a -> b -> m c) -> t m a -> t m b -> t m c+zipAsyncWithM f m1 m2 =+    fromStream $ Zip.zipAsyncWithMK f (toStream m1) (toStream m2)++-- XXX Should we rename this to zipParWith or zipParallelWith? This can happen+-- along with the change of behvaior to end the stream concurrently.+--+-- | Like 'zipWith' but zips concurrently i.e. both the streams being zipped+-- are evaluated concurrently using the 'ParallelT' concurrent evaluation+-- style. The maximum number of elements of each stream evaluated in advance+-- can be controlled by 'maxBuffer'.+--+-- The stream ends if stream @a@ or stream @b@ ends. However, if stream @b@+-- ends while we are still evaluating stream @a@ and waiting for a result then+-- stream will not end until after the evaluation of stream @a@ finishes. This+-- behavior can potentially be changed in future to end the stream immediately+-- as soon as any of the stream end is detected.+--+-- @since 0.1.0+{-# INLINE zipAsyncWith #-}+zipAsyncWith :: (IsStream t, MonadAsync m)+    => (a -> b -> c) -> t m a -> t m b -> t m c+zipAsyncWith f = zipAsyncWithM (\a b -> return (f a b))++------------------------------------------------------------------------------ -- Merging (sorted streams) ------------------------------------------------------------------------------ @@ -359,11 +705,13 @@ -- -- @ --+-- See also: 'mergeByMFused'+-- -- @since 0.6.0-{-# INLINABLE mergeBy #-}+{-# INLINE 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)+mergeBy f m1 m2 = fromStream $ K.mergeBy f (toStream m1) (toStream m2)  -- | Like 'mergeBy' but with a monadic comparison function. --@@ -379,13 +727,13 @@ -- -- @ -- >>> :{--- do    +-- 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  +--          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@@ -394,13 +742,31 @@ -- -- @ --+-- See also: 'mergeByMFused'+-- -- @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)+mergeByM f m1 m2 = fromStream $ K.mergeByM f (toStream m1) (toStream m2) +-- XXX Fused versions should probably go to a separate module using the same+-- names for the combinators.+--+-- | Like 'mergeByM' but much faster, works best when merging statically known+-- number of streams. When merging more than two streams try to merge pairs and+-- pair pf pairs in a tree like structure.'mergeByM' works better with variable+-- number of streams being merged using 'concatPairsWith'.+--+-- /Internal/+{-# INLINE mergeByMFused #-}+mergeByMFused+    :: (IsStream t, Monad m)+    => (a -> a -> m Ordering) -> t m a -> t m a -> t m a+mergeByMFused f m1 m2 =+    fromStreamD $ D.mergeByM f (toStreamD m1) (toStreamD m2)+ {- -- | Like 'mergeByM' but stops merging as soon as any of the two streams stops. {-# INLINABLE mergeEndByAny #-}@@ -510,7 +876,7 @@ 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)+    fromStreamD $ D.interpose (return x) unf (toStreamD str)  -- interposeSuffix x unf str = gintercalateSuffix unf str UF.identity (repeat x) --@@ -524,7 +890,7 @@ 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)+    fromStreamD $ D.interposeSuffix (return x) unf (toStreamD str)  ------------------------------------------------------------------------------ -- Combine N Streams - intercalate@@ -546,9 +912,9 @@     :: (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)+    fromStreamD $ D.gintercalate+        unf1 (toStreamD str1)+        unf2 (toStreamD str2)  -- > intercalate unf seed str = gintercalate unf str unf (repeatM seed) --@@ -565,7 +931,7 @@ {-# INLINE intercalate #-} intercalate :: (IsStream t, Monad m)     => Unfold m b c -> b -> t m b -> t m c-intercalate unf seed str = D.fromStreamD $+intercalate unf seed str = fromStreamD $     D.unfoldMany unf $ D.intersperse seed (toStreamD str)  -- | 'interleaveSuffix' followed by unfold and concat.@@ -576,9 +942,9 @@     :: (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)+    fromStreamD $ D.gintercalateSuffix+        unf1 (toStreamD str1)+        unf2 (toStreamD str2)  -- > intercalateSuffix unf seed str = gintercalateSuffix unf str unf (repeatM seed) --@@ -596,7 +962,7 @@ 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)+    $ D.intersperseSuffix (return seed) (toStreamD str)  {- {-# INLINE iterateUnfold #-}@@ -624,25 +990,6 @@ -- 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. --@@ -660,7 +1007,8 @@     -> m s     -> t m a     -> t m b-concatSmapMWith combine f initial = concatMapWith combine id . smapM f initial+concatSmapMWith combine f initial =+    IsStream.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.@@ -700,7 +1048,12 @@     -> (a -> t m b)     -> t m a     -> t m b-concatPairsWith = K.concatPairsWith+concatPairsWith par f m =+    fromStream+        $ K.concatPairsWith+            (\s1 s2 -> toStream $ fromStream s1 `par` fromStream s2)+            (toStream . f)+            (toStream m)  ------------------------------------------------------------------------------ -- IterateMap - Map and flatten Trees of Streams@@ -737,9 +1090,9 @@     -> (a -> t m a)     -> t m a     -> t m a-iterateMapWith combine f = concatMapWith combine go+iterateMapWith combine f = IsStream.concatMapWith combine go     where-    go x = fromPure x `combine` concatMapWith combine go (f x)+    go x = fromPure x `combine` IsStream.concatMapWith combine go (f x)  {- {-# INLINE iterateUnfold #-}@@ -776,7 +1129,9 @@     -> t m a     -> t m a iterateSmapMWith combine f initial stream =-    concatMap (\b -> concatMapWith combine (go b) stream) (fromEffect initial)+    concatMap+        (\b -> IsStream.concatMapWith combine (go b) stream)+        (fromEffect initial)      where @@ -784,7 +1139,7 @@      feedback b a =         concatMap-            (\(b1, s) -> concatMapWith combine (go b1) s)+            (\(b1, s) -> IsStream.concatMapWith combine (go b1) s)             (fromEffect $ f b a)  ------------------------------------------------------------------------------@@ -813,4 +1168,5 @@     -> (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))+iterateMapLeftsWith combine f =+    iterateMapWith combine (either f (const IsStream.nil))
src/Streamly/Internal/Data/Stream/IsStream/Generate.hs view
@@ -18,10 +18,10 @@ module Streamly.Internal.Data.Stream.IsStream.Generate     (     -- * Primitives-      K.nil-    , K.nilM-    , K.cons-    , (K..:)+      IsStream.nil+    , IsStream.nilM+    , IsStream.cons+    , (IsStream..:)      , consM     , (|:)@@ -68,17 +68,18 @@     , iterateM      -- * Cyclic Elements-    , K.mfix+    , mfix      -- * From Containers-    , P.fromList+    , IsStream.fromList     , fromListM-    , K.fromFoldable+    , fromFoldable     , fromFoldableM     , fromCallback+    , fromPrimIORef      -- * Deprecated-    , K.once+    , once     , yield     , yieldM     , each@@ -90,28 +91,31 @@ #include "inline.hs"  import Control.Monad.IO.Class (MonadIO(..))+import Data.Primitive.Types (Prim) import Data.Void (Void)+import Streamly.Internal.Control.Concurrent (MonadAsync) import Streamly.Internal.Data.Unfold.Type (Unfold)-import Streamly.Internal.Data.SVar (MonadAsync, Rate (..))+import Streamly.Internal.Data.SVar (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.IsStream.Type+    (IsStream (..), fromSerial, consM, fromStreamD, fromStreamS)+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.IORef.Prim as Prim+import qualified Streamly.Internal.Data.Stream.IsStream.Type as IsStream 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+import qualified Streamly.Internal.Data.Stream.StreamK.Type as K #ifdef USE_STREAMK_ONLY import qualified Streamly.Internal.Data.Stream.StreamK as S+import qualified Streamly.Internal.Data.Stream.StreamK.Type as S #else import qualified Streamly.Internal.Data.Stream.StreamD.Generate as S #endif@@ -121,11 +125,15 @@  -- $setup -- >>> :m+-- >>> import Data.Function ((&)) -- >>> 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)+-- >>> import System.IO (stdout, hSetBuffering, BufferMode(LineBuffering))+--+-- >>> hSetBuffering stdout LineBuffering  ------------------------------------------------------------------------------ -- From Unfold@@ -155,29 +163,26 @@ ------------------------------------------------------------------------------  -- |--- @+-- >>> :{ -- unfoldr step s = --     case step s of---         Nothing -> 'K.nil'---         Just (a, b) -> a \`cons` unfoldr step b--- @+--         Nothing -> Stream.nil+--         Just (a, b) -> a `Stream.cons` unfoldr step b+-- :} -- -- Build a stream by unfolding a /pure/ step function @step@ starting from a -- seed @s@.  The step function returns the next element in the stream and the -- next seed value. When it is done it returns 'Nothing' and the stream ends. -- For example, ----- @ -- >>> :{ -- let f b =---         if b > 3+--         if b > 2 --         then Nothing --         else Just (b, b + 1) -- in Stream.toList $ Stream.unfoldr f 0 -- :}--- [0,1,2,3]------ @+-- [0,1,2] -- -- @since 0.1.0 {-# INLINE_EARLY unfoldr #-}@@ -191,33 +196,36 @@ -- seed value. When it is done it returns 'Nothing' and the stream ends. For -- example, ----- @ -- >>> :{ -- let f b =---         if b > 3+--         if b > 2 --         then return Nothing --         else return (Just (b, b + 1)) -- in Stream.toList $ Stream.unfoldrM f 0 -- :}--- [0,1,2,3]+-- [0,1,2] ----- @ -- 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) ()--- @+-- >>> :{+-- let f b =+--         if b > 2+--         then return Nothing+--         else threadDelay 1000000 >> return (Just (b, b + 1))+-- in Stream.toList $ Stream.delay 1 $ Stream.fromAsync $ Stream.unfoldrM f 0+-- :}+-- [0,1,2] -- -- /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+unfoldrM :: forall t m b a. (IsStream t, MonadAsync m) =>+    (b -> m (Maybe (a, b))) -> b -> t m a+unfoldrM step = fromStream . K.unfoldrMWith (IsStream.toConsK (consM @t)) step  {-# RULES "unfoldrM serial" unfoldrM = unfoldrMSerial #-} {-# INLINE_EARLY unfoldrMSerial #-}@@ -227,12 +235,13 @@ {-# RULES "unfoldrM wSerial" unfoldrM = unfoldrMWSerial #-} {-# INLINE_EARLY unfoldrMWSerial #-} unfoldrMWSerial :: MonadAsync m => (b -> m (Maybe (a, b))) -> b -> WSerialT m a-unfoldrMWSerial = Serial.unfoldrM+unfoldrMWSerial f = fromSerial . Serial.unfoldrM f  {-# RULES "unfoldrM zipSerial" unfoldrM = unfoldrMZipSerial #-} {-# INLINE_EARLY unfoldrMZipSerial #-}-unfoldrMZipSerial :: MonadAsync m => (b -> m (Maybe (a, b))) -> b -> ZipSerialM m a-unfoldrMZipSerial = Serial.unfoldrM+unfoldrMZipSerial :: MonadAsync m =>+    (b -> m (Maybe (a, b))) -> b -> ZipSerialM m a+unfoldrMZipSerial f = fromSerial . Serial.unfoldrM f  ------------------------------------------------------------------------------ -- From Values@@ -247,9 +256,7 @@ repeat = fromStreamS . S.repeat  -- |--- @--- replicate = take n . repeat--- @+-- >>> replicate n = Stream.take n . Stream.repeat -- -- Generate a stream of length @n@ by repeating a value @n@ times. --@@ -259,23 +266,33 @@ replicate n = fromStreamS . S.replicate n  -- |--- @--- replicateM = take n . repeatM--- @+-- >>> replicateM n = Stream.take n . Stream.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)--- @+-- >>> pr n = threadDelay 1000000 >> print n --+-- This runs serially and takes 3 seconds:+--+-- >>> Stream.drain $ Stream.fromSerial $ Stream.replicateM 3 $ pr 1+-- 1+-- 1+-- 1+--+-- This runs concurrently and takes just 1 second:+--+-- >>> Stream.drain $ Stream.fromAsync  $ Stream.replicateM 3 $ pr 1+-- 1+-- 1+-- 1+-- -- /Concurrent/ -- -- @since 0.1.1 {-# INLINE_EARLY replicateM #-}-replicateM :: (IsStream t, MonadAsync m) => Int -> m a -> t m a-replicateM = K.replicateM+replicateM :: forall t m a. (IsStream t, MonadAsync m) => Int -> m a -> t m a+replicateM count =+    fromStream . K.replicateMWith (IsStream.toConsK (consM @t)) count  {-# RULES "replicateM serial" replicateM = replicateMSerial #-} {-# INLINE replicateMSerial #-}@@ -391,10 +408,8 @@ -- 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--- @+-- >>> fromIndices f = fmap f $ Stream.enumerateFrom 0+-- >>> fromIndices f = let g i = f i `Stream.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.@@ -409,10 +424,8 @@  -- -- |--- @--- fromIndicesM f = Stream.mapM f $ Stream.enumerateFrom 0--- fromIndicesM f = let g i = f i \`consM` g (i + 1) in g 0--- @+-- >>> fromIndicesM f = Stream.mapM f $ Stream.enumerateFrom 0+-- >>> fromIndicesM f = let g i = f i `Stream.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.@@ -421,8 +434,9 @@ -- -- @since 0.6.0 {-# INLINE_EARLY fromIndicesM #-}-fromIndicesM :: (IsStream t, MonadAsync m) => (Int -> m a) -> t m a-fromIndicesM = K.fromIndicesM+fromIndicesM :: forall t m a. (IsStream t, MonadAsync m) =>+    (Int -> m a) -> t m a+fromIndicesM = fromStream . K.fromIndicesMWith (IsStream.toConsK (consM @t))  {-# RULES "fromIndicesM serial" fromIndicesM = fromIndicesMSerial #-} {-# INLINE fromIndicesMSerial #-}@@ -434,46 +448,53 @@ ------------------------------------------------------------------------------  -- |--- @--- iterate f x = x \`cons` iterate f x--- @+-- >>> iterate f x = x `Stream.cons` iterate f x -- -- Generate an infinite stream with @x@ as the first element and each -- successive element derived by applying the function @f@ on the previous -- element. ----- @ -- >>> Stream.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)--- @+-- >>> iterateM f m = m >>= \a -> return a `Stream.consM` iterateM f (f a) -- -- Generate an infinite stream with the first element generated by the action -- @m@ and each successive element derived by applying the monadic function -- @f@ on the previous element. --+-- >>> pr n = threadDelay 1000000 >> print n+-- >>> :{+-- Stream.iterateM (\x -> pr x >> return (x + 1)) (return 0)+--     & Stream.take 3+--     & Stream.fromSerial+--     & Stream.toList+-- :}+-- 0+-- 1+-- [0,1,2]+-- -- 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)--- @+-- >>> :{+-- Stream.iterateM (\x -> pr x >> return (x + 1)) (return 0)+--     & Stream.delay 1+--     & Stream.take 3+--     & Stream.fromAsync+--     & Stream.toList+-- :}+-- 0+-- 1+-- ... -- -- /Concurrent/ --@@ -481,41 +502,112 @@ -- -- /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+iterateM :: forall t m a. (IsStream t, MonadAsync m) =>+    (a -> m a) -> m a -> t m a+iterateM f = fromStream . K.iterateMWith (IsStream.toConsK (consM @t))  f  {-# RULES "iterateM serial" iterateM = iterateMSerial #-} {-# INLINE iterateMSerial #-} iterateMSerial :: MonadAsync m => (a -> m a) -> m a -> SerialT m a iterateMSerial step = fromStreamS . S.iterateM step +-- | We can define cyclic structures using @let@:+--+-- >>> let (a, b) = ([1, b], head a) in (a, b)+-- ([1,1],1)+--+-- The function @fix@ defined as:+--+-- >>> fix f = let x = f x in x+--+-- ensures that the argument of a function and its output refer to the same+-- lazy value @x@ i.e.  the same location in memory.  Thus @x@ can be defined+-- in terms of itself, creating structures with cyclic references.+--+-- >>> f ~(a, b) = ([1, b], head a)+-- >>> fix f+-- ([1,1],1)+--+-- 'Control.Monad.mfix' is essentially the same as @fix@ but for monadic+-- values.+--+-- Using 'mfix' for streams we can construct a stream in which each element of+-- the stream is defined in a cyclic fashion. The argument of the function+-- being fixed represents the current element of the stream which is being+-- returned by the stream monad. Thus, we can use the argument to construct+-- itself.+--+-- In the following example, the argument @action@ of the function @f@+-- represents the tuple @(x,y)@ returned by it in a given iteration. We define+-- the first element of the tuple in terms of the second.+--+-- >>> import Streamly.Internal.Data.Stream.IsStream as Stream+-- >>> import System.IO.Unsafe (unsafeInterleaveIO)+--+-- >>> :{+-- main = 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: you cannot achieve this by just changing the order of the monad+-- statements because that would change the order in which the stream elements+-- are generated.+--+-- Note that the function @f@ must be lazy in its argument, that's why we use+-- 'unsafeInterleaveIO' on @action@ because IO monad is strict.+--+-- /Pre-release/+{-# INLINE mfix #-}+mfix :: (IsStream t, Monad m) => (m a -> t m a) -> t m a+mfix f = fromStream $ K.mfix (toStream . f)+ ------------------------------------------------------------------------------ -- Conversions ------------------------------------------------------------------------------  -- |--- @--- fromFoldableM = 'Prelude.foldr' 'consM' 'K.nil'--- @+-- >>> fromFoldable = Prelude.foldr Stream.cons Stream.nil --+-- Construct a stream from a 'Foldable' containing pure values:+--+-- @since 0.2.0+{-# INLINE fromFoldable #-}+fromFoldable :: (IsStream t, Foldable f) => f a -> t m a+fromFoldable = fromStream . K.fromFoldable++-- |+-- >>> fromFoldableM = Prelude.foldr Stream.consM Stream.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)--- @+-- >>> pr n = threadDelay 1000000 >> print n+-- >>> Stream.drain $ Stream.fromSerial $ Stream.fromFoldableM $ map pr [1,2,3]+-- 1+-- 2+-- 3 --+-- >>> Stream.drain $ Stream.fromAsync $ Stream.fromFoldableM $ map pr [1,2,3]+-- ...+-- ...+-- ...+-- -- /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+fromFoldableM = Prelude.foldr consM IsStream.nil  -- |--- @--- fromListM = 'Prelude.foldr' 'K.consM' 'K.nil'--- @+-- >>> fromListM = Stream.fromFoldableM+-- >>> fromListM = Stream.sequence . Stream.fromList+-- >>> fromListM = Stream.mapM id . Stream.fromList+-- >>> fromListM = Prelude.foldr Stream.consM Stream.nil -- -- Construct a stream from a list of monadic actions. This is more efficient -- than 'fromFoldableM' for serial streams.@@ -525,7 +617,7 @@ 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 #-}+    forall a. D.toStreamK (D.fromListM a) = K.fromFoldableM a #-}  {-# RULES "fromListM serial" fromListM = fromListMSerial #-} {-# INLINE_EARLY fromListMSerial #-}@@ -538,7 +630,7 @@ {-# DEPRECATED each "Please use fromFoldable instead." #-} {-# INLINE each #-} each :: (IsStream t, Foldable f) => f a -> t m a-each = K.fromFoldable+each = fromFoldable  -- | Read lines from an IO Handle into a stream of Strings. --@@ -548,7 +640,7 @@ fromHandle :: (IsStream t, MonadIO m) => IO.Handle -> t m String fromHandle h = go   where-  go = K.mkStream $ \_ yld _ stp -> do+  go = IsStream.mkStream $ \_ yld _ stp -> do         eof <- liftIO $ IO.hIsEOF h         if eof         then stp@@ -569,4 +661,20 @@ fromCallback setCallback = concatM $ do     (callback, stream) <- Par.newCallbackStream     setCallback callback-    return stream+    return $ SerialT stream++-- | Construct a stream by reading a 'Prim' 'IORef' repeatedly.+--+-- /Pre-release/+--+{-# INLINE fromPrimIORef #-}+fromPrimIORef :: (IsStream t, MonadIO m, Prim a) => Prim.IORef a -> t m a+fromPrimIORef = fromStreamD . Prim.toStreamD++-- | Same as fromEffect+--+-- @since 0.2.0+{-# DEPRECATED once "Please use fromEffect instead." #-}+{-# INLINE once #-}+once :: (Monad m, IsStream t) => m a -> t m a+once = IsStream.fromEffect
src/Streamly/Internal/Data/Stream/IsStream/Lift.hs view
@@ -28,10 +28,9 @@ 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.IsStream.Type+    (IsStream(..), fromStreamS, toStreamS, fromStreamD, toStreamD) 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
src/Streamly/Internal/Data/Stream/IsStream/Reduce.hs view
@@ -29,14 +29,17 @@     -- | Apply folds on a stream.     , foldMany     , foldManyPost+    , refoldMany     , foldSequence     , foldIterateM+    , refoldIterateM      -- ** Chunking     -- | Element unaware grouping.     , chunksOf     , arraysOf     , intervalsOf+    , chunksOfTimeout      -- ** Splitting     -- | Streams can be sliced into segments in space or in time. We use the@@ -138,9 +141,6 @@     -- * Nested splitting     , splitInnerBy     , splitInnerBySuffix--     -- * Fold2-    , chunksOf2     ) where @@ -154,24 +154,27 @@ import Data.Kind (Type) import Data.Maybe (isNothing) import Foreign.Storable (Storable)-import Streamly.Internal.Data.Fold.Type (Fold (..), Fold2 (..))+import Streamly.Internal.Control.Concurrent (MonadAsync)+import Streamly.Internal.Data.Fold.Type (Fold (..))+import Streamly.Internal.Data.Refold.Type (Refold (..)) 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+    , map+    , parallelFst     , repeatM     , scanlMAfter'     , splitOnSeq     , fromPure)-import Streamly.Internal.Data.Stream.StreamK (IsStream)+import Streamly.Internal.Data.Stream.IsStream.Type+    (IsStream(..), fromStreamD, toStreamD, cons) 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@@ -179,12 +182,11 @@ 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.IsStream.Type as IsStream import qualified Streamly.Internal.Data.Stream.StreamD as D-import qualified Streamly.Internal.Data.Stream.StreamK as K+import qualified Streamly.Internal.Data.Stream.IsStream.Transform as Transform -import Prelude hiding (concatMap)+import Prelude hiding (concatMap, map)  -- $setup -- >>> :m@@ -265,7 +267,7 @@     => Fold m a b     -> t m a     -> t m b-foldManyPost f m = D.fromStreamD $ D.foldManyPost f (D.toStreamD m)+foldManyPost f m = fromStreamD $ D.foldManyPost f (toStreamD m)  -- | Apply a 'Fold' repeatedly on a stream and emit the fold outputs in the -- output stream.@@ -292,12 +294,20 @@     => Fold m a b     -> t m a     -> t m b-foldMany f m = D.fromStreamD $ D.foldMany f (D.toStreamD m)+foldMany f m = fromStreamD $ D.foldMany f (toStreamD m) +-- | Like 'foldMany' but using the 'Refold' type instead of 'Fold'.+--+-- /Pre-release/+{-# INLINE refoldMany #-}+refoldMany :: (IsStream t, Monad m) =>+    Refold m c a b -> m c -> t m a -> t m b+refoldMany f action = fromStreamD . D.refoldMany f action . toStreamD+ -- | Apply a stream of folds to an input stream and emit the results in the -- output stream. ----- /Pre-release/+-- /Unimplemented/ -- {-# INLINE foldSequence #-} foldSequence@@ -315,7 +325,7 @@ -- >>> 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+-- >>> Stream.toList $ Stream.map getSum $ Stream.foldIterateM f (pure 0) s -- [3,10,21,36,55,55] -- -- @@@ -327,9 +337,18 @@ -- {-# 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)+       (IsStream t, Monad m) => (b -> m (Fold m a b)) -> m b -> t m a -> t m b+foldIterateM f i m = fromStreamD $ D.foldIterateM f i (toStreamD m) +-- | Like 'foldIterateM' but using the 'Refold' type instead. This could be+-- much more efficient due to stream fusion.+--+-- /Internal/+{-# INLINE refoldIterateM #-}+refoldIterateM :: (IsStream t, Monad m) =>+    Refold m b a b -> m b -> t m a -> t m b+refoldIterateM c i m = fromStreamD $ D.refoldIterateM c i (toStreamD m)+ ------------------------------------------------------------------------------ -- Parsing ------------------------------------------------------------------------------@@ -365,7 +384,7 @@     -> t m a     -> t m b parseMany p m =-    D.fromStreamD $ D.parseMany (PRK.fromParserK p) (D.toStreamD m)+    fromStreamD $ D.parseMany (PRK.fromParserK p) (toStreamD m)  {-# INLINE parseManyD #-} parseManyD@@ -374,7 +393,7 @@     -> t m a     -> t m b parseManyD p m =-    D.fromStreamD $ D.parseMany p (D.toStreamD m)+    fromStreamD $ D.parseMany p (toStreamD m)  -- | Apply a stream of parsers to an input stream and emit the results in the -- output stream.@@ -428,8 +447,8 @@     -> b     -> t m a     -> t m b-parseIterate f i m = D.fromStreamD $-    D.parseIterate (PRK.fromParserK . f) i (D.toStreamD m)+parseIterate f i m = fromStreamD $+    D.parseIterate (PRK.fromParserK . f) i (toStreamD m)  ------------------------------------------------------------------------------ -- Generalized grouping@@ -492,7 +511,7 @@     -> Fold m a b     -> t m a     -> t m b-groupsBy cmp f m = D.fromStreamD $ D.groupsBy cmp f (D.toStreamD m)+groupsBy cmp f m = fromStreamD $ D.groupsBy cmp f (toStreamD m)  -- | Unlike @groupsBy@ this function performs a rolling comparison of two -- successive elements in the input stream. @groupsByRolling cmp f $ S.fromList@@ -513,7 +532,7 @@     -> Fold m a b     -> t m a     -> t m b-groupsByRolling cmp f m =  D.fromStreamD $ D.groupsRollingBy cmp f (D.toStreamD m)+groupsByRolling cmp f m =  fromStreamD $ D.groupsRollingBy cmp f (toStreamD m)  -- | -- > groups = groupsBy (==)@@ -736,7 +755,7 @@     :: (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)+    fromStreamD $ D.wordsBy predicate f (toStreamD m)  -- | Like 'splitOnSuffix' but keeps the suffix attached to the resulting -- splits.@@ -812,7 +831,8 @@ 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)+splitOnAny subseq f m = undefined+    -- fromStreamD $ D.splitOnAny f subseq (toStreamD m) -}  -- XXX use a non-monadic intersperse to remove the MonadAsync constraint.@@ -907,7 +927,7 @@     :: (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)+    fromStreamD $ D.splitOnSuffixSeq False patt f (toStreamD m)  {- -- | Like 'splitOn' but drops any empty splits.@@ -916,7 +936,8 @@ 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)+wordsOn subseq f m = undefined+    -- fromStreamD $ D.wordsOn f subseq (toStreamD m) -}  -- | Like 'splitOnSuffixSeq' but keeps the suffix intact in the splits.@@ -953,7 +974,7 @@     :: (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)+    fromStreamD $ D.splitOnSuffixSeq True patt f (toStreamD m)  {- -- This can be implemented easily using Rabin Karp@@ -963,7 +984,7 @@     :: (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)+    -- fromStreamD $ D.splitPostAny f subseq (toStreamD m) -}  ------------------------------------------------------------------------------@@ -986,16 +1007,7 @@ 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)+chunksOf n f = fromStreamD . D.chunksOf n f . toStreamD  -- | @arraysOf n stream@ groups the elements in the input stream into arrays of -- @n@ elements each.@@ -1008,7 +1020,7 @@ {-# 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+arraysOf n = fromStreamD . A.arraysOf n . toStreamD  -- XXX we can implement this by repeatedly applying the 'lrunFor' fold. -- XXX add this example after fixing the serial stream rate control@@ -1026,8 +1038,29 @@     => 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))+        (interjectSuffix n (return Nothing) (map Just xs)) +-- XXX This can be implemented more efficiently by sharing a Clock.Timer across+-- parallel threads and resetting it whenever a span is emitted.+--+-- | Like 'chunksOf' but if the chunk is not completed within the specified+-- time interval then emit whatever we have collected till now. The chunk+-- timeout is reset whenever a chunk is emitted.+--+-- >>> s = Stream.delayPost 0.3 $ Stream.fromList [1..1000]+-- >>> f = Stream.mapM_ print $ Stream.chunksOfTimeout 5 1 Fold.toList s+--+-- /Pre-release/+{-# INLINE chunksOfTimeout #-}+chunksOfTimeout :: (IsStream t, MonadAsync m, Functor (t m))+    => Int -> Double -> FL.Fold m a b -> t m a -> t m b+chunksOfTimeout n timeout f =+      map snd+    . classifySessionsBy+        timeout False (const (return False)) timeout (FL.take n f)+    . Transform.timestamped+    . map ((),)+ ------------------------------------------------------------------------------ -- Windowed classification ------------------------------------------------------------------------------@@ -1162,6 +1195,8 @@     , sessionOutputStream :: t (m :: Type -> Type) (k, b) -- ^ Completed sessions     } +data SessionEntry a b = LiveSession !a !b | ZombieSession+ -- | @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@@ -1223,7 +1258,7 @@         , sessionCount = 0         , sessionTimerHeap = H.empty         , sessionKeyValueMap = Map.empty-        , sessionOutputStream = K.nil+        , sessionOutputStream = IsStream.nil         }      -- We can eject sessions based on the current session count to limit@@ -1241,15 +1276,34 @@         -- 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.         --+        -- When we insert a key in the Map we insert an entry into the heap as+        -- well with the session expiry as the sort key.  The Map entry+        -- consists of the fold result, and the expiry time of the session. If+        -- "reset" is True the expiry time is readjusted whenever a new event+        -- is processed. If the fold terminates and a new session is started+        -- for the same key the expiry time is set to the first timestamp of+        -- the new session.+        --+        -- The heap must have at most one entry for any given key. The heap is+        -- processed periodically to remove the expired entries.  We pick up an+        -- expired entry from the top of the heap and if the session has+        -- expired based on the expiry time in the Map entry then we remove the+        -- session from the Map and yield its fold output. Otherwise, we+        -- reinsert the entry into the heap based on the current expiry in the+        -- Map entry.+        --+        -- If an entry is removed from the Map and not removed from the heap+        -- and in the meantime it is inserted again in the Map (using the same+        -- key) then how do we avoid inserting multiple entries in the heap?+        -- For this reason we maintain the invariant that the Map entry is+        -- removed only when the heap entry is removed. Even if the fold has+        -- finished we still keep a dummy Map entry (ZombieSession) until the+        -- heap entry is removed. That way if we have a Map entry we do not+        -- insert a heap entry because we know it is already there.+        --         let curTime = max sessionEventTime timestamp             mOld = Map.lookup key sessionKeyValueMap         let done fb = do@@ -1260,9 +1314,11 @@                 -- should not be expensive.                 --                 let (mp, cnt) = case mOld of-                        Nothing -> (sessionKeyValueMap, sessionCount)-                        Just _ -> (Map.delete key sessionKeyValueMap-                                  , sessionCount - 1)+                        Just (LiveSession _ _) ->+                            ( Map.insert key ZombieSession sessionKeyValueMap+                            , sessionCount - 1+                            )+                        _ -> (sessionKeyValueMap, sessionCount)                 return $ session                     { sessionCurTime = curTime                     , sessionEventTime = curTime@@ -1271,14 +1327,14 @@                     , sessionOutputStream = fromPure (key, fb)                     }             partial fs1 = do-                let acc = Tuple' timestamp fs1+                let expiry = addToAbsTime timestamp timeoutMs                 (hp1, mp1, out1, cnt1) <- do                         let vars = (sessionTimerHeap, sessionKeyValueMap,-                                           K.nil, sessionCount)+                                           IsStream.nil, sessionCount)                         case mOld of                             -- inserting new entry                             Nothing -> do-                                -- Eject a session from heap and map is needed+                                -- Eject a session from heap and map if needed                                 eject <- ejectPred sessionCount                                 (hp, mp, out, cnt) <-                                     if eject@@ -1286,13 +1342,13 @@                                     else return vars                                  -- Insert the new session in heap-                                let expiry = addToAbsTime timestamp timeoutMs-                                    hp' = H.insert (Entry expiry key) hp+                                let 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+                let acc = LiveSession expiry fs1+                    mp2 = Map.insert key acc mp1                 return $ SessionState                     { sessionCurTime = curTime                     , sessionEventTime = curTime@@ -1303,10 +1359,12 @@                     }         res0 <- do             case mOld of-                Nothing -> initial-                Just (Tuple' _ acc) -> return $ FL.Partial acc+                Just (LiveSession _ acc) -> return $ FL.Partial acc+                _ -> initial         case res0 of-            FL.Done fb -> done fb+            FL.Done _ ->+                error $ "classifySessionsBy: "+                    ++ "The supplied fold must consume at least one input"             FL.Partial fs -> do                 res <- step fs value                 case res of@@ -1323,7 +1381,7 @@             ejectAll                 ( sessionTimerHeap                 , sessionKeyValueMap-                , K.nil+                , IsStream.nil                 , sessionCount                 )         return $ session@@ -1336,7 +1394,7 @@     -- 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 out1 = (key, sess) `cons` out         let mp1 = Map.delete key mp         return (hp, mp1, out1, cnt - 1) @@ -1346,7 +1404,10 @@             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+                    Just ZombieSession ->+                        return (hp1, Map.delete key mp, out, cnt)+                    Just (LiveSession _ acc) ->+                        ejectEntry hp1 mp out cnt acc key                 ejectAll r             Nothing -> do                 assert (Map.null mp) (return ())@@ -1358,8 +1419,9 @@             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+                    Just ZombieSession ->+                        ejectOne (hp1, Map.delete key mp, out, cnt)+                    Just (LiveSession expiry1 acc) -> do                         if not reset || expiry1 <= expiry                         then ejectEntry hp1 mp out cnt acc key                         else@@ -1372,7 +1434,8 @@      ejectExpired session@SessionState{..} curTime = do         (hp', mp', out, count) <--            ejectLoop sessionTimerHeap sessionKeyValueMap K.nil sessionCount+            ejectLoop+                sessionTimerHeap sessionKeyValueMap IsStream.nil sessionCount         return $ session             { sessionCurTime = curTime             , sessionCount = count@@ -1397,8 +1460,9 @@                     then                         case Map.lookup key mp of                             Nothing -> ejectLoop hp1 mp out cnt-                            Just (Tuple' latestTS acc) -> do-                                let expiry1 = addToAbsTime latestTS timeoutMs+                            Just ZombieSession ->+                                ejectLoop hp1 (Map.delete key mp) out cnt+                            Just (LiveSession expiry1 acc) -> do                                 if expiry1 <= curTime || not reset || force                                 then do                                     (hp2,mp1,out1,cnt1) <-@@ -1414,7 +1478,7 @@                     return (hp, mp, out, cnt)      -- merge timer events in the stream-    stream = Serial.map Just str `Par.parallelFst` repeatM timer+    stream = map Just str `parallelFst` repeatM timer     timer = do         liftIO $ threadDelay (round $ tick * 1000000)         return Nothing@@ -1510,7 +1574,7 @@     -> t m (f a)     -> t m (f a) splitInnerBy splitter joiner xs =-    D.fromStreamD $ D.splitInnerBy splitter joiner $ D.toStreamD xs+    fromStreamD $ D.splitInnerBy splitter joiner $ toStreamD xs  -- | Like 'splitInnerBy' but splits assuming the separator joins the segment in -- a suffix style.@@ -1524,4 +1588,4 @@     -> t m (f a)     -> t m (f a) splitInnerBySuffix splitter joiner xs =-    D.fromStreamD $ D.splitInnerBySuffix splitter joiner $ D.toStreamD xs+    fromStreamD $ D.splitInnerBySuffix splitter joiner $ toStreamD xs
src/Streamly/Internal/Data/Stream/IsStream/Top.hs view
@@ -50,6 +50,7 @@  #include "inline.hs" +import Control.Monad.Catch (MonadCatch) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State.Strict (get, put)@@ -59,23 +60,24 @@ #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup (Semigroup(..)) #endif-import Streamly.Internal.Data.SVar (MonadAsync)+import Streamly.Internal.Control.Concurrent (MonadAsync) import Streamly.Internal.Data.Stream.IsStream.Common (concatM)-import Streamly.Internal.Data.Stream.Prelude (foldl', fromList)+import Streamly.Internal.Data.Stream.IsStream.Type+    (IsStream(..), adapt, 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.Parser as Parser 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 qualified Streamly.Internal.Data.Stream.IsStream.Type as IsStream  import Prelude hiding (filter, zipWith, concatMap, concat) @@ -190,9 +192,16 @@ -- /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+sortBy :: MonadCatch m => (a -> a -> Ordering) -> SerialT m a -> SerialT m a+-- sortBy f = Stream.concatPairsWith (Stream.mergeBy f) Stream.fromPure+sortBy cmp =+    let p =+            Parser.groupByRollingEither+                (\x -> (< GT) . cmp x)+                Fold.toStreamRev+                Fold.toStream+     in   Stream.concatPairsWith (Stream.mergeBy cmp) id+        . Stream.parseMany (fmap (either id id) p)  ------------------------------------------------------------------------------ -- SQL Joins@@ -272,7 +281,7 @@     b <- s2     if a `eq` b     then return (a, b)-    else StreamK.nil+    else Stream.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.@@ -338,8 +347,8 @@     let final = do             r <- lift get             if r-            then StreamK.nil-            else StreamK.fromPure Nothing+            then Stream.nil+            else Stream.fromPure Nothing     b <- fmap Just (Stream.liftInner s2) <> final     case b of         Just b1 ->@@ -347,7 +356,7 @@             then do                 lift $ put True                 return (a, Just b1)-            else StreamK.nil+            else Stream.nil         Nothing -> return (a, Nothing)  -- | Like 'outerJoin' but uses a hashmap for efficiency.@@ -415,11 +424,11 @@         let final = do                 r <- lift get                 if r-                then StreamK.nil-                else StreamK.fromPure Nothing+                then Stream.nil+                else Stream.fromPure Nothing         (_i, b) <--            Stream.indexed-                $ fmap Just (Stream.liftInner (Array.toStream arr)) <> final+            let stream = IsStream.fromSerial $ Array.toStream arr+             in Stream.indexed $ fmap Just (Stream.liftInner stream) <> final         case b of             Just (b1, _used) ->                 if a `eq` b1@@ -428,7 +437,7 @@                     -- XXX Need to use a mutable array                     -- when (not used) $ Array.writeIndex i True                     return (Just a, Just b1)-                else StreamK.nil+                else Stream.nil             Nothing -> return (Just a, Nothing)  -- Put the b's that have been paired, in another hash or mutate the hash to set@@ -496,7 +505,7 @@     concatM         $ do             -- This may work well when s2 is small-            xs <- Stream.toListRev $ Stream.uniqBy eq $ StreamK.adapt s2+            xs <- Stream.toListRev $ Stream.uniqBy eq $ adapt s2             return $ Stream.filter (\x -> List.any (eq x) xs) s1  -- | Like 'intersectBy' but works only on sorted streams.@@ -546,7 +555,7 @@             -- 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+            xs <- Stream.toList $ adapt s1             fmap fromList $ foldl' (flip (List.deleteBy eq)) xs s2  -- | Like 'differenceBy' but works only on sorted streams.@@ -585,7 +594,7 @@ unionBy eq s1 s2 =     concatM         $ do-            xs <- Stream.toList $ StreamK.adapt s2+            xs <- Stream.toList $ adapt s2             -- XXX we can use postscanlMAfter' instead of IORef             ref <- liftIO $ newIORef $! List.nubBy eq xs             let f x = do
src/Streamly/Internal/Data/Stream/IsStream/Transform.hs view
@@ -14,11 +14,12 @@      -- * Folding     , foldrS+    , foldrSShared     , foldrT      -- * Mapping     -- | Stateless one-to-one maps.-    , Serial.map+    , map     , sequence     , mapM     , smapM@@ -30,6 +31,8 @@     , tap     , tapOffsetEvery     , tapAsync+    , tapAsyncK+    , distributeAsync_     , tapRate     , pollCounts @@ -164,12 +167,14 @@     -- Move these to Streamly.Data.Either.Stream?     , lefts     , rights+    , both      -- * Concurrent Evaluation     -- ** Concurrent Pipelines     -- | Run streaming stages concurrently. -    , Par.mkParallel+    , mkAsync+    , mkParallel     , applyAsync     , (|$)     , (|&)@@ -225,6 +230,7 @@     ( absTimesWith     , drop     , findIndices+    , map     , postscanlM'     , relTimesWith     , reverse@@ -235,30 +241,35 @@     , takeWhile     , interjectSuffix     , intersperseM+    , mkAsync+    , mkParallel+    , zipWith     )-import Streamly.Internal.Data.Stream.Prelude (fromStreamS, toStreamS)+import Streamly.Internal.Control.Concurrent (MonadAsync)+import Streamly.Internal.Data.Stream.IsStream.Type+    (IsStream(..), fromStreamS, toStreamS, fromStreamD, toStreamD, toConsK) 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.SVar (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+#if __GLASGOW_HASKELL__ == 802 import qualified Streamly.Internal.Data.Stream.StreamK as K-import qualified Streamly.Internal.Data.Stream.Zip as Z+#endif+import qualified Streamly.Internal.Data.Stream.StreamK.Type 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 Prelude  import Prelude hiding        ( filter, drop, dropWhile, take, takeWhile, foldr, map, mapM, sequence-       , reverse, foldr1 , scanl, scanl1)+       , reverse, foldr1 , scanl, scanl1, zipWith)  -- -- $setup@@ -271,6 +282,9 @@ -- >>> import Streamly.Internal.Data.Stream.IsStream as Stream -- >>> import qualified Streamly.Data.Fold as Fold -- >>> import qualified Streamly.Internal.Data.Fold as Fold+-- >>> import System.IO (stdout, hSetBuffering, BufferMode(LineBuffering))+--+-- >>> hSetBuffering stdout LineBuffering  ------------------------------------------------------------------------------ -- Piping@@ -318,8 +332,22 @@ -- /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+foldrS f z xs =+    fromStream+        $ K.foldrS+            (\y ys -> toStream $ f y (fromStream ys))+            (toStream z)+            (toStream xs) +{-# INLINE foldrSShared #-}+foldrSShared :: IsStream t => (a -> t m b -> t m b) -> t m b -> t m a -> t m b+foldrSShared f z xs =+    fromStream+        $ K.foldrSShared+            (\y ys -> toStream $ f y (fromStream ys))+            (toStream z)+            (toStream xs)+ -- | 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:@@ -368,8 +396,9 @@ -- -- @since 0.1.0 {-# INLINE_EARLY mapM #-}-mapM :: (IsStream t, MonadAsync m) => (a -> m b) -> t m a -> t m b-mapM = K.mapM+mapM :: forall t m a b. (IsStream t, MonadAsync m) =>+    (a -> m b) -> t m a -> t m b+mapM f = fromStream . K.mapMWith (toConsK (consM @t)) f . toStream  {-# RULES "mapM serial" mapM = mapMSerial #-} {-# INLINE mapMSerial #-}@@ -389,20 +418,20 @@ -- abc -- -- >>> :{--- drain $ Stream.replicateM 10 (return $ threadDelay 1000000 >> print 1)+-- drain $ Stream.replicateM 3 (return $ threadDelay 1000000 >> print 1) --  & (fromSerial . Stream.sequence) -- :} -- 1--- ... -- 1+-- 1 -- -- >>> :{--- drain $ Stream.replicateM 10 (return $ threadDelay 1000000 >> print 1)+-- drain $ Stream.replicateM 3 (return $ threadDelay 1000000 >> print 1) --  & (fromAsync . Stream.sequence) -- :} -- 1--- ... -- 1+-- 1 -- -- @ --@@ -411,7 +440,7 @@ -- @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)+sequence = mapM id  ------------------------------------------------------------------------------ -- Mapping side effects@@ -437,7 +466,7 @@ -- @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)+tap f xs = fromStreamD $ D.tap f (toStreamD xs)  -- XXX Remove this. It can be expressed in terms of Fold.sampleFromThen. --@@ -456,7 +485,7 @@ 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)+    fromStreamD $ D.tapOffsetEvery offset n f (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@@ -488,8 +517,62 @@ -- /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)+tapAsync f xs = fromStreamD $ Par.tapAsyncF f (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 'Streamly.Prelude.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'.+--+-- /Pre-release/+{-# INLINE tapAsyncK #-}+tapAsyncK :: (IsStream t, MonadAsync m) => (t m a -> m b) -> t m a -> t m a+tapAsyncK f m = fromStream $ Par.tapAsyncK (f . fromStream) (toStream m)++-- | Concurrently distribute a stream to a collection of fold functions,+-- discarding the outputs of the folds.+--+-- @+-- > Stream.drain $ Stream.distributeAsync_ [Stream.mapM_ print, Stream.mapM_ print] (Stream.enumerateFromTo 1 2)+-- 1+-- 2+-- 1+-- 2+--+-- @+--+-- @+-- distributeAsync_ = flip (foldr tapAsync)+-- @+--+-- /Pre-release/+--+{-# INLINE distributeAsync_ #-}+distributeAsync_ :: (Foldable f, IsStream t, MonadAsync m)+    => f (t m a -> m b) -> t m a -> t m a+distributeAsync_ = flip (Prelude.foldr tapAsyncK)+ -- | @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@@ -516,9 +599,9 @@     -> 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+      fromStreamD+    $ D.pollCounts predicate (toStreamD . transf . fromStreamD) f+    $ toStreamD xs  -- | Calls the supplied function with the number of elements consumed -- every @n@ seconds. The given function is run in a separate thread@@ -545,7 +628,7 @@     -> (Int -> m b)     -> t m a     -> t m a-tapRate n f xs = D.fromStreamD $ D.tapRate n f $ D.toStreamD xs+tapRate n f xs = fromStreamD $ D.tapRate n f $ toStreamD xs  -- | Apply a monadic function to each element flowing through the stream and -- discard the results.@@ -581,7 +664,7 @@ -- /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)+trace_ eff = fromStreamD . D.mapM (\x -> eff >> return x) . toStreamD  ------------------------------------------------------------------------------ -- Scanning with a Fold@@ -595,7 +678,8 @@ -- @since 0.7.0 {-# INLINE scan #-} scan :: (IsStream t, Monad m) => Fold m a b -> t m a -> t m b-scan = P.scanOnce+-- scan = P.scanOnce+scan fld m = fromStreamD $ D.scanOnce fld $ toStreamD m  -- | Postscan a stream using the given monadic fold. --@@ -615,7 +699,7 @@ -- @since 0.7.0 {-# INLINE postscan #-} postscan :: (IsStream t, Monad m) => Fold m a b -> t m a -> t m b-postscan = P.postscanOnce+postscan fld = fromStreamD . D.postscanOnce fld . toStreamD  ------------------------------------------------------------------------------ -- Scanning - Transformation by Folding@@ -642,7 +726,7 @@ {-# 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'+scanx step begin done = fromStreamS . S.scanlx' step begin done . toStreamS  -- XXX this needs to be concurrent -- XXX because of the use of D.cons for appending, scanlM' has quadratic@@ -712,6 +796,9 @@ -- lazy expressions inside the accumulator, it is recommended that a strict -- data structure is used for accumulator. --+-- >>> scanl' f z xs = scanlM' (\a b -> return (f a b)) (return z) xs+-- >>> scanl' f z xs = z `Stream.cons` postscanl' f z xs+-- -- See also: 'usingStateT' -- -- @since 0.2.0@@ -721,7 +808,8 @@  -- | Like 'scanl'' but does not stream the initial value of the accumulator. ----- > postscanl' f z xs = Stream.drop 1 $ Stream.scanl' f z xs+-- >>> postscanl' f z = postscanlM' (\a b -> return (f a b)) (return z)+-- >>> postscanl' f z xs = Stream.drop 1 $ Stream.scanl' f z xs -- -- @since 0.7.0 {-# INLINE postscanl' #-}@@ -801,7 +889,7 @@ filter p m = fromStreamS $ S.filter p $ toStreamS m #else filter :: IsStream t => (a -> Bool) -> t m a -> t m a-filter = K.filter+filter p m = fromStream $ K.filter p $ toStream m #endif  -- | Same as 'filter' but with a monadic predicate.@@ -1359,7 +1447,7 @@ {-# 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)+timestampWith g stream = zipWith (flip (,)) stream (absTimesWith g)  -- TBD: check performance vs a custom implementation without using zipWith. --@@ -1384,7 +1472,7 @@ {-# 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)+timeIndexWith g stream = zipWith (flip (,)) stream (relTimesWith g)  -- | Pair each element in a stream with relative times starting from 0, using a -- 10 ms granularity clock. The time is measured just before the element is@@ -1474,7 +1562,7 @@ {-# 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+mapMaybeM f = fmap fromJust . filter isJust . mapM f  {-# RULES "mapMaybeM serial" mapMaybeM = mapMaybeMSerial #-} {-# INLINE mapMaybeMSerial #-}@@ -1485,6 +1573,7 @@ -- -- /Pre-release/ --+{-# INLINE catMaybes #-} catMaybes :: (IsStream t, Monad m, Functor (t m)) => t m (Maybe a) -> t m a catMaybes = fmap fromJust . filter isJust @@ -1496,6 +1585,7 @@ -- -- /Pre-release/ --+{-# INLINE lefts #-} lefts :: (IsStream t, Monad m, Functor (t m)) => t m (Either a b) -> t m a lefts = fmap (fromLeft undefined) . filter isLeft @@ -1503,9 +1593,19 @@ -- -- /Pre-release/ --+{-# INLINE rights #-} rights :: (IsStream t, Monad m, Functor (t m)) => t m (Either a b) -> t m b rights = fmap (fromRight undefined) . filter isRight +-- | Remove the either wrapper and flatten both lefts and as well as rights in+-- the output stream.+--+-- /Pre-release/+--+{-# INLINE both #-}+both :: Functor (t m) => t m (Either a a) -> t m a+both = fmap (either id id)+ ------------------------------------------------------------------------------ -- Concurrent Application ------------------------------------------------------------------------------@@ -1541,8 +1641,8 @@ -- @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+-- (|$) f = f . mkAsync+(|$) f = f . mkParallel  infixr 0 |$
+ src/Streamly/Internal/Data/Stream/IsStream/Type.hs view
@@ -0,0 +1,698 @@+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- |+-- Module      : Streamly.Internal.Data.Stream.Type+-- Copyright   : (c) 2017 Composewell Technologies+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+--+module Streamly.Internal.Data.Stream.IsStream.Type+    (+    -- * IsStream Type Class+      IsStream (..)+    , K.Stream (..)+    , Streaming++    -- * Type Conversion+    , fromStreamS+    , toStreamS+    , fromStreamD+    , toStreamD+    , adapt+    , toConsK++    -- * Building a stream+    , mkStream+    , foldStreamShared+    , foldStream++    -- * Stream Types+    , SerialT+    , Serial+    , fromSerial++    , WSerialT+    , WSerial+    , fromWSerial++    , AsyncT+    , Async+    , fromAsync++    , WAsyncT+    , WAsync+    , fromWAsync++    , AheadT+    , Ahead+    , fromAhead++    , ParallelT+    , Parallel+    , fromParallel++    , ZipSerialM+    , ZipSerial+    , fromZipSerial++    , ZipAsyncM+    , ZipAsync+    , fromZipAsync++    -- * Construction+    , cons+    , (.:)+    , nil+    , nilM+    , fromPure+    , fromEffect+    , repeat++    -- * Bind/Concat+    , bindWith+    , concatMapWith++    -- * Fold Utilities+    , concatFoldableWith+    , concatMapFoldableWith+    , concatForFoldableWith++    -- * Running Effects+    , drain++    -- * Conversion operations+    , fromList+    , toList++    -- * Fold operations+    , foldrM+    , foldrMx+    , foldr++    , foldlx'+    , foldlMx'+    , foldl'+    , fold++    -- * Zip style operations+    , eqBy+    , cmpBy++    -- * Deprecated+    , interleaving+    , zipping+    , zippingAsync+    )+where++import Streamly.Internal.Control.Concurrent (MonadAsync)+import Streamly.Internal.Data.Fold.Type (Fold (..))+import Streamly.Internal.Data.Stream.Serial+    (SerialT(..), Serial, WSerialT(..), WSerial)+import Streamly.Internal.Data.Stream.Async+    (AsyncT(..), Async, WAsyncT(..), WAsync)+import Streamly.Internal.Data.Stream.Ahead (AheadT(..), Ahead)+import Streamly.Internal.Data.Stream.Parallel (ParallelT(..), Parallel)+import Streamly.Internal.Data.Stream.Zip+    (ZipSerialM(..), ZipSerial, ZipAsyncM(..), ZipAsync)+import Streamly.Internal.Data.SVar.Type (State, adaptState)++import qualified Prelude+import qualified Streamly.Internal.Data.Stream.Ahead as Ahead+import qualified Streamly.Internal.Data.Stream.Async as Async+import qualified Streamly.Internal.Data.Stream.Parallel as Parallel+import qualified Streamly.Internal.Data.Stream.Serial as Serial+import qualified Streamly.Internal.Data.Stream.StreamD.Type as D+import qualified Streamly.Internal.Data.Stream.StreamK.Type as K+#ifdef USE_STREAMK_ONLY+import qualified Streamly.Internal.Data.Stream.StreamK as S+import qualified Streamly.Internal.Data.Stream.StreamK.Type as S+#else+import qualified Streamly.Internal.Data.Stream.StreamD.Type as S+#endif+import qualified Streamly.Internal.Data.Stream.Zip as Zip++import Prelude hiding (foldr, repeat)++#include "inline.hs"+#define USE_IS_STREAM+#include "PreludeCommon.hs"++------------------------------------------------------------------------------+-- Types that can behave as a Stream+------------------------------------------------------------------------------++infixr 5 `consM`+infixr 5 |:++-- XXX Use a different SVar based on the stream type. But we need to make sure+-- that we do not lose performance due to polymorphism.+--+-- | Class of types that can represent a stream of elements of some type 'a' in+-- some monad 'm'.+--+-- /Since: 0.2.0 ("Streamly")/+--+-- @since 0.8.0+class+#if __GLASGOW_HASKELL__ >= 806+    ( 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)+    ) =>+#endif+      IsStream t where+    toStream :: t m a -> K.Stream m a+    fromStream :: K.Stream m a -> t m a+    -- | Constructs a stream by adding a monadic action at the head of an+    -- existing stream. For example:+    --+    -- @+    -- > toList $ getLine \`consM` getLine \`consM` nil+    -- hello+    -- world+    -- ["hello","world"]+    -- @+    --+    -- /Concurrent (do not use 'fromParallel' to construct infinite streams)/+    --+    -- @since 0.2.0+    consM :: MonadAsync m => m a -> t m a -> t m a+    -- | Operator equivalent of 'consM'. We can read it as "@parallel colon@"+    -- to remember that @|@ comes before ':'.+    --+    -- @+    -- > toList $ getLine |: getLine |: nil+    -- hello+    -- world+    -- ["hello","world"]+    -- @+    --+    -- @+    -- let delay = threadDelay 1000000 >> print 1+    -- drain $ fromSerial  $ delay |: delay |: delay |: nil+    -- drain $ fromParallel $ delay |: delay |: delay |: nil+    -- @+    --+    -- /Concurrent (do not use 'fromParallel' to construct infinite streams)/+    --+    -- @since 0.2.0+    (|:) :: MonadAsync m => m a -> t m a -> t m a+    -- We can define (|:) just as 'consM' but it is defined explicitly for each+    -- type because we want to use SPECIALIZE pragma on the definition.++-- | Same as 'IsStream'.+--+-- @since 0.1.0+{-# DEPRECATED Streaming "Please use IsStream instead." #-}+type Streaming = IsStream++-------------------------------------------------------------------------------+-- Type adapting combinators+-------------------------------------------------------------------------------++-- XXX Move/reset the State here by reconstructing the stream with cleared+-- state. Can we make sure we do not do that when t1 = t2? If we do this then+-- we do not need to do that explicitly using svarStyle.  It would act as+-- unShare when the stream type is the same.+--+-- | Adapt any specific stream type to any other specific stream type.+--+-- /Since: 0.1.0 ("Streamly")/+--+-- @since 0.8.0+adapt :: (IsStream t1, IsStream t2) => t1 m a -> t2 m a+adapt = fromStream . toStream++{-# INLINE fromStreamD #-}+fromStreamD :: (IS_STREAM Monad m) => D.Stream m a -> STREAM m a+fromStreamD = FROM_STREAM . D.toStreamK++-- | Adapt a polymorphic consM operation to a StreamK cons operation+{-# INLINE toConsK #-}+toConsK :: IsStream t =>+    (m a -> t m a -> t m a) -> m a -> K.Stream m a -> K.Stream m a+toConsK cns x xs = toStream $ x `cns` fromStream xs++------------------------------------------------------------------------------+-- Building a stream+------------------------------------------------------------------------------++-- XXX The State is always parameterized by "Stream" which means State is not+-- different for different stream types. So we have to manually make sure that+-- when converting from one stream to another we migrate the state correctly.+-- This can be fixed if we use a different SVar type for different streams.+-- Currently we always use "SVar Stream" and therefore a different State type+-- parameterized by that stream.+--+-- XXX Since t is coercible we should be able to coerce k+-- mkStream k = fromStream $ MkStream $ coerce k+--+-- | Build a stream from an 'SVar', a stop continuation, a singleton stream+-- continuation and a yield continuation.+{-# INLINE_EARLY mkStream #-}+mkStream :: IsStream t+    => (forall r. State K.Stream m a+        -> (a -> t m a -> m r)+        -> (a -> m r)+        -> m r+        -> m r)+    -> t m a+mkStream k = fromStream $ K.MkStream $ \st yld sng stp ->+    let yieldk a r = yld a (toStream r)+     in k st yieldk sng stp++{-# RULES "mkStream from stream" mkStream = mkStreamFromStream #-}+mkStreamFromStream :: IsStream t+    => (forall r. State K.Stream m a+        -> (a -> K.Stream m a -> m r)+        -> (a -> m r)+        -> m r+        -> m r)+    -> t m a+mkStreamFromStream k = fromStream $ K.MkStream k++{-# RULES "mkStream stream" mkStream = mkStreamStream #-}+mkStreamStream+    :: (forall r. State K.Stream m a+        -> (a -> K.Stream m a -> m r)+        -> (a -> m r)+        -> m r+        -> m r)+    -> K.Stream m a+mkStreamStream = K.MkStream++------------------------------------------------------------------------------+-- Folding a stream+------------------------------------------------------------------------------++-- | Fold a stream by providing an SVar, a stop continuation, a singleton+-- continuation and a yield continuation. The stream would share the current+-- SVar passed via the State.+{-# INLINE_EARLY foldStreamShared #-}+foldStreamShared+    :: IsStream t+    => State K.Stream m a+    -> (a -> t m a -> m r)+    -> (a -> m r)+    -> m r+    -> t m a+    -> m r+foldStreamShared st yld sng stp m =+    let yieldk a x = yld a (fromStream x)+        K.MkStream k = toStream m+     in k st yieldk sng stp++-- XXX write a similar rule for foldStream as well?+{-# RULES "foldStreamShared from stream"+   foldStreamShared = foldStreamSharedStream #-}+foldStreamSharedStream+    :: State K.Stream m a+    -> (a -> K.Stream m a -> m r)+    -> (a -> m r)+    -> m r+    -> K.Stream m a+    -> m r+foldStreamSharedStream st yld sng stp m =+    let K.MkStream k = m+     in k st yld sng stp++-- | Fold a stream by providing a State, stop continuation, a singleton+-- continuation and a yield continuation. The stream will not use the SVar+-- passed via State.+{-# INLINE foldStream #-}+foldStream+    :: IsStream t+    => State K.Stream m a+    -> (a -> t m a -> m r)+    -> (a -> m r)+    -> m r+    -> t m a+    -> m r+foldStream st yld sng stp m =+    let yieldk a x = yld a (fromStream x)+        K.MkStream k = toStream m+     in k (adaptState st) yieldk sng stp++-------------------------------------------------------------------------------+-- Serial+-------------------------------------------------------------------------------++-- | Fix the type of a polymorphic stream as 'SerialT'.+--+-- /Since: 0.1.0 ("Streamly")/+--+-- @since 0.8.0+fromSerial :: IsStream t => SerialT m a -> t m a+fromSerial = adapt++instance IsStream SerialT where+    toStream = getSerialT+    fromStream = SerialT++    {-# INLINE consM #-}+    {-# SPECIALIZE consM :: IO a -> SerialT IO a -> SerialT IO a #-}+    consM = Serial.consM++    {-# INLINE (|:) #-}+    {-# SPECIALIZE (|:) :: IO a -> SerialT IO a -> SerialT IO a #-}+    (|:) = Serial.consM++-- | Fix the type of a polymorphic stream as 'WSerialT'.+--+-- /Since: 0.2.0 ("Streamly")/+--+-- @since 0.8.0+fromWSerial :: IsStream t => WSerialT m a -> t m a+fromWSerial = adapt++-- | Same as 'fromWSerial'.+--+-- @since 0.1.0+{-# DEPRECATED interleaving "Please use fromWSerial instead." #-}+interleaving :: IsStream t => WSerialT m a -> t m a+interleaving = fromWSerial++instance IsStream WSerialT where+    toStream = getWSerialT+    fromStream = WSerialT++    {-# INLINE consM #-}+    {-# SPECIALIZE consM :: IO a -> WSerialT IO a -> WSerialT IO a #-}+    consM :: Monad m => m a -> WSerialT m a -> WSerialT m a+    consM = Serial.consMWSerial++    {-# INLINE (|:) #-}+    {-# SPECIALIZE (|:) :: IO a -> WSerialT IO a -> WSerialT IO a #-}+    (|:) :: Monad m => m a -> WSerialT m a -> WSerialT m a+    (|:) = Serial.consMWSerial++-------------------------------------------------------------------------------+-- Async+-------------------------------------------------------------------------------++-- | Fix the type of a polymorphic stream as 'AsyncT'.+--+-- /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+    fromStream = AsyncT++    {-# INLINE consM #-}+    {-# SPECIALIZE consM :: IO a -> AsyncT IO a -> AsyncT IO a #-}+    consM = Async.consMAsync++    {-# INLINE (|:) #-}+    {-# SPECIALIZE (|:) :: IO a -> AsyncT IO a -> AsyncT IO a #-}+    (|:) = Async.consMAsync++-- | Fix the type of a polymorphic stream as 'WAsyncT'.+--+-- /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+    fromStream = WAsyncT++    {-# INLINE consM #-}+    {-# SPECIALIZE consM :: IO a -> WAsyncT IO a -> WAsyncT IO a #-}+    consM = Async.consMWAsync++    {-# INLINE (|:) #-}+    {-# SPECIALIZE (|:) :: IO a -> WAsyncT IO a -> WAsyncT IO a #-}+    (|:) = Async.consMWAsync++-------------------------------------------------------------------------------+-- Ahead+-------------------------------------------------------------------------------++-- | Fix the type of a polymorphic stream as 'AheadT'.+--+-- /Since: 0.3.0 ("Streamly")/+--+-- @since 0.8.0+fromAhead :: IsStream t => AheadT m a -> t m a+fromAhead = adapt++instance IsStream AheadT where+    toStream = getAheadT+    fromStream = AheadT++    {-# INLINE consM #-}+    {-# SPECIALIZE consM :: IO a -> AheadT IO a -> AheadT IO a #-}+    consM = Ahead.consM++    {-# INLINE (|:) #-}+    {-# SPECIALIZE (|:) :: IO a -> AheadT IO a -> AheadT IO a #-}+    (|:) = Ahead.consM++-------------------------------------------------------------------------------+-- Parallel+-------------------------------------------------------------------------------++-- | Fix the type of a polymorphic stream as 'ParallelT'.+--+-- /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+    fromStream = ParallelT++    {-# INLINE consM #-}+    {-# SPECIALIZE consM :: IO a -> ParallelT IO a -> ParallelT IO a #-}+    consM = Parallel.consM++    {-# INLINE (|:) #-}+    {-# SPECIALIZE (|:) :: IO a -> ParallelT IO a -> ParallelT IO a #-}+    (|:) = Parallel.consM++-------------------------------------------------------------------------------+-- Zip+-------------------------------------------------------------------------------++-- | Fix the type of a polymorphic stream as 'ZipSerialM'.+--+-- /Since: 0.2.0 ("Streamly")/+--+-- @since 0.8.0+fromZipSerial :: IsStream t => ZipSerialM m a -> t m a+fromZipSerial = adapt++-- | Same as 'fromZipSerial'.+--+-- @since 0.1.0+{-# DEPRECATED zipping "Please use fromZipSerial instead." #-}+zipping :: IsStream t => ZipSerialM m a -> t m a+zipping = fromZipSerial++instance IsStream ZipSerialM where+    toStream = getZipSerialM+    fromStream = ZipSerialM++    {-# INLINE consM #-}+    {-# SPECIALIZE consM :: IO a -> ZipSerialM IO a -> ZipSerialM IO a #-}+    consM :: Monad m => m a -> ZipSerialM m a -> ZipSerialM m a+    consM = Zip.consMZip++    {-# INLINE (|:) #-}+    {-# SPECIALIZE (|:) :: IO a -> ZipSerialM IO a -> ZipSerialM IO a #-}+    (|:) :: Monad m => m a -> ZipSerialM m a -> ZipSerialM m a+    (|:) = Zip.consMZip++-- | Fix the type of a polymorphic stream as 'ZipAsyncM'.+--+-- /Since: 0.2.0 ("Streamly")/+--+-- @since 0.8.0+fromZipAsync :: IsStream t => ZipAsyncM m a -> t m a+fromZipAsync = adapt++-- | Same as 'fromZipAsync'.+--+-- @since 0.1.0+{-# DEPRECATED zippingAsync "Please use fromZipAsync instead." #-}+zippingAsync :: IsStream t => ZipAsyncM m a -> t m a+zippingAsync = fromZipAsync++instance IsStream ZipAsyncM where+    toStream = getZipAsyncM+    fromStream = ZipAsyncM++    {-# INLINE consM #-}+    {-# SPECIALIZE consM :: IO a -> ZipAsyncM IO a -> ZipAsyncM IO a #-}+    consM :: Monad m => m a -> ZipAsyncM m a -> ZipAsyncM m a+    consM = Zip.consMZipAsync++    {-# INLINE (|:) #-}+    {-# SPECIALIZE (|:) :: IO a -> ZipAsyncM IO a -> ZipAsyncM IO a #-}+    (|:) :: Monad m => m a -> ZipAsyncM m a -> ZipAsyncM m a+    (|:) = Zip.consMZipAsync++-------------------------------------------------------------------------------+-- Construction+-------------------------------------------------------------------------------++infixr 5 `cons`++-- | Construct a stream by adding a pure value at the head of an existing+-- stream. For serial streams this is the same as @(return a) \`consM` r@ but+-- more efficient. For concurrent streams this is not concurrent whereas+-- 'consM' is concurrent. For example:+--+-- @+-- > toList $ 1 \`cons` 2 \`cons` 3 \`cons` nil+-- [1,2,3]+-- @+--+-- @since 0.1.0+{-# INLINE_NORMAL cons #-}+cons :: IsStream t => a -> t m a -> t m a+cons a r = fromStream $ K.cons a (toStream r)++infixr 5 .:++-- | Operator equivalent of 'cons'.+--+-- @+-- > toList $ 1 .: 2 .: 3 .: nil+-- [1,2,3]+-- @+--+-- @since 0.1.1+{-# INLINE (.:) #-}+(.:) :: IsStream t => a -> t m a -> t m a+(.:) = cons++{-# INLINE_NORMAL nil #-}+nil :: IsStream t => t m a+nil = fromStream K.nil++{-# INLINE_NORMAL nilM #-}+nilM :: (IsStream t, Monad m) => m b -> t m a+nilM = fromStream . K.nilM++{-# INLINE_NORMAL fromPure #-}+fromPure :: IsStream t => a -> t m a+fromPure = fromStream . K.fromPure++{-# INLINE_NORMAL fromEffect #-}+fromEffect :: (Monad m, IsStream t) => m a -> t m a+fromEffect = fromStream . K.fromEffect++{-# INLINE repeat #-}+repeat :: IsStream t => a -> t m a+repeat = fromStream . K.repeat++-------------------------------------------------------------------------------+-- Bind/Concat+-------------------------------------------------------------------------------++{-# INLINE bindWith #-}+bindWith+    :: IsStream t+    => (t m b -> t m b -> t m b)+    -> t m a+    -> (a -> t m b)+    -> t m b+bindWith par m1 f =+    fromStream+        $ K.bindWith+            (\s1 s2 -> toStream $ par (fromStream s1) (fromStream s2))+            (toStream m1)+            (toStream . f)++-- | @concatMapWith mixer generator stream@ is a two dimensional looping+-- combinator.  The @generator@ function is used to generate streams from the+-- elements in the input @stream@ and the @mixer@ function is used to merge+-- those streams.+--+-- 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 par f xs = bindWith par xs f++-- | 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.+--+-- @concatMapFoldableWith 'async' return [1..3]@+--+-- Equivalent to:+--+-- @+-- 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 concatMapFoldableWith #-}+concatMapFoldableWith :: (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) nil++-- | Like 'concatMapFoldableWith' but with the last two arguments reversed i.e. the+-- monadic streaming function is the last argument.+--+-- Equivalent to:+--+-- @+-- concatForFoldableWith f xs g = Prelude.foldr (f . g) S.nil xs+-- concatForFoldableWith f = flip (S.concatMapFoldableWith f)+-- @+--+-- /Since: 0.8.0 (Renamed forEachWith to concatForFoldableWith)/+--+-- /Since: 0.1.0 ("Streamly")/+{-# INLINE concatForFoldableWith #-}+concatForFoldableWith :: (IsStream t, Foldable f)+    => (t m b -> t m b -> t m b) -> f a -> (a -> t m b) -> t m b+concatForFoldableWith f = flip (concatMapFoldableWith f)++-- | A variant of 'Data.Foldable.fold' that allows you to fold a 'Foldable'+-- container of streams using the specified stream sum operation.+--+-- @concatFoldableWith 'async' $ map return [1..3]@+--+-- Equivalent to:+--+-- @+-- 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")/+{-# INLINE concatFoldableWith #-}+concatFoldableWith :: (IsStream t, Foldable f)+    => (t m a -> t m a -> t m a) -> f (t m a) -> t m a+concatFoldableWith f = concatMapFoldableWith f id
− src/Streamly/Internal/Data/Stream/IsStream/Types.hs 
@@ -1,74 +0,0 @@--- |--- 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,7 +1,5 @@ {-# LANGUAGE UndecidableInstances #-} -#include "inline.hs"- -- | -- Module      : Streamly.Internal.Data.Stream.Parallel -- Copyright   : (c) 2017 Composewell Technologies@@ -25,24 +23,22 @@ module Streamly.Internal.Data.Stream.Parallel     (     -- * Parallel Stream Type-      ParallelT+      ParallelT(..)     , Parallel-    , fromParallel+    , consM      -- * Merge Concurrently-    , parallel-    , parallelFst-    , parallelMin+    , parallelK+    , parallelFstK+    , parallelMinK      -- * Evaluate Concurrently-    , mkParallel     , mkParallelD     , mkParallelK      -- * Tap Concurrently-    , tapAsync+    , tapAsyncK     , tapAsyncF-    , distributeAsync_      -- * Callbacks     , newCallbackStream@@ -68,18 +64,20 @@  import qualified Data.Set as Set +import Streamly.Internal.Control.Concurrent (MonadAsync) import Streamly.Internal.Data.Fold.Type (Fold)+import Streamly.Internal.Data.Stream.Serial (SerialT(..)) 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 Streamly.Internal.Data.Stream.StreamK.Type (Stream) -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+import qualified Streamly.Internal.Data.Stream.SVar.Generate as SVar+import qualified Streamly.Internal.Data.Stream.SVar.Eliminate as SVar +import Streamly.Internal.Data.SVar++#include "inline.hs" #include "Instances.hs"  --@@ -114,7 +112,7 @@      go m = do         liftIO $ decrementBufferLimit sv-        foldStreamShared st yieldk single stop m+        K.foldStreamShared st yieldk single stop m      sv = fromJust $ streamVar st @@ -122,7 +120,7 @@         incrementBufferLimit sv         sendStop sv winfo     sendit a = liftIO $ void $ send sv (ChildYield a)-    single a = sendit a >> (liftIO $ sendStop sv winfo)+    single a = sendit a >> liftIO (sendStop sv winfo)     yieldk a r = sendit a >> go r  runOneLimited@@ -137,7 +135,7 @@         if yieldLimitOk         then do             liftIO $ decrementBufferLimit sv-            foldStreamShared st yieldk single stop m+            K.foldStreamShared st yieldk single stop m         else do             liftIO $ cleanupSVarFromWorker sv             liftIO $ sendStop sv winfo@@ -149,7 +147,7 @@         incrementYieldLimit sv         sendStop sv winfo     sendit a = liftIO $ void $ send sv (ChildYield a)-    single a = sendit a >> (liftIO $ sendStop sv winfo)+    single a = sendit a >> liftIO (sendStop sv winfo)     yieldk a r = sendit a >> go r  -------------------------------------------------------------------------------@@ -163,23 +161,23 @@ -- remember the past state.  {-# NOINLINE forkSVarPar #-}-forkSVarPar :: (IsStream t, MonadAsync m)-    => SVarStopStyle -> t m a -> t m a -> t m a-forkSVarPar ss m r = mkStream $ \st yld sng stp -> do+forkSVarPar :: MonadAsync m+    => SVarStopStyle -> Stream m a -> Stream m a -> Stream m a+forkSVarPar ss m r = K.mkStream $ \st yld sng stp -> do     sv <- newParallelVar ss st-    pushWorkerPar sv (runOne st{streamVar = Just sv} $ toStream m)+    pushWorkerPar sv (runOne st{streamVar = Just sv} m)     case ss of         StopBy -> liftIO $ do             set <- readIORef (workerThreads sv)             writeIORef (svarStopBy sv) $ Set.elemAt 0 set         _ -> return ()-    pushWorkerPar sv (runOne st{streamVar = Just sv} $ toStream r)-    foldStream st yld sng stp (SVar.fromSVar sv)+    pushWorkerPar sv (runOne st{streamVar = Just sv} r)+    K.foldStream st yld sng stp $ getSerialT (SVar.fromSVar sv)  {-# INLINE joinStreamVarPar #-}-joinStreamVarPar :: (IsStream t, MonadAsync m)-    => SVarStyle -> SVarStopStyle -> t m a -> t m a -> t m a-joinStreamVarPar style ss m1 m2 = mkStream $ \st yld sng stp ->+joinStreamVarPar :: MonadAsync m+    => SVarStyle -> SVarStopStyle -> Stream m a -> Stream m a -> Stream m a+joinStreamVarPar style ss m1 m2 = K.mkStream $ \st yld sng stp ->     case streamVar st of         Just sv | svarStyle sv == style && svarStopStyle sv == ss -> do             -- Here, WE ARE IN THE WORKER/PRODUCER THREAD, we know that because@@ -215,56 +213,28 @@             -- worker spawned by that worker would fork, thus creating layer             -- over layer of workers and a chain of threads leading to a very             -- inefficient execution.-            pushWorkerPar sv (runOne st $ toStream m1)-            foldStreamShared st yld sng stp m2+            pushWorkerPar sv (runOne st m1)+            K.foldStreamShared st yld sng stp m2         _ ->             -- Here WE ARE IN THE CONSUMER THREAD, we create a new SVar, fork             -- worker threads to execute m1 and m2 and this thread starts             -- pulling the stream from the SVar.-            foldStreamShared st yld sng stp (forkSVarPar ss m1 m2)+            K.foldStreamShared st yld sng stp (forkSVarPar ss m1 m2)  ------------------------------------------------------------------------------- -- User facing APIs ------------------------------------------------------------------------------- +{-# INLINE parallelK #-}+parallelK :: MonadAsync m => Stream m a -> Stream m a -> Stream m a+parallelK = joinStreamVarPar ParallelVar StopNone+ -- | XXX we can implement it more efficienty by directly implementing instead -- of combining streams using parallel.-{-# 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.fromEffect m `parallel` (toStream r)--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.------ >>> 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+{-# INLINE consM #-}+{-# SPECIALIZE consM :: IO a -> ParallelT IO a -> ParallelT IO a #-}+consM :: MonadAsync m => m a -> ParallelT m a -> ParallelT m a+consM m (ParallelT r) = ParallelT $ parallelK (K.fromEffect m) r  -- This is a co-parallel like combinator for streams, where first stream is the -- main stream and the rest are just supporting it, when the first ends@@ -273,9 +243,9 @@ -- | Like `parallel` but stops the output as soon as the first stream stops. -- -- /Pre-release/-{-# INLINE parallelFst #-}-parallelFst :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a-parallelFst = joinStreamVarPar ParallelVar StopBy+{-# INLINE parallelFstK #-}+parallelFstK :: MonadAsync m => Stream m a -> Stream m a -> Stream m a+parallelFstK = joinStreamVarPar ParallelVar StopBy  -- This is a race like combinator for streams. --@@ -283,9 +253,9 @@ -- stops. -- -- /Pre-release/-{-# INLINE parallelMin #-}-parallelMin :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a-parallelMin = joinStreamVarPar ParallelVar StopAny+{-# INLINE parallelMinK #-}+parallelMinK :: MonadAsync m => Stream m a -> Stream m a -> Stream m a+parallelMinK = joinStreamVarPar ParallelVar StopAny  ------------------------------------------------------------------------------ -- Convert a stream to parallel@@ -295,16 +265,12 @@ -- -- /Pre-release/ ---mkParallelK :: (IsStream t, MonadAsync m) => t m a -> t m a-mkParallelK m = mkStream $ \st yld sng stp -> do+mkParallelK :: MonadAsync m => Stream m a -> Stream m a+mkParallelK m = K.mkStream $ \st yld sng stp -> do     sv <- newParallelVar StopNone (adaptState st)     -- pushWorkerPar sv (runOne st{streamVar = Just sv} $ toStream m)-    SVar.toSVarParallel st sv $ D.toStreamD m-    foldStream st yld sng stp $ SVar.fromSVar sv------------------------------------------------------------------------------------ Concurrent application and fold--------------------------------------------------------------------------------+    SVar.toSVarParallel st sv $ D.fromStreamK m+    K.foldStream st yld sng stp $ getSerialT $ SVar.fromSVar sv  -- | Same as 'mkParallel' but for StreamD stream. --@@ -326,25 +292,6 @@             Skip s    -> Skip (Just $ D.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.------ @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- ------------------------------------------------------------------------------- -- Concurrent tap -------------------------------------------------------------------------------@@ -390,11 +337,12 @@ -- Compare with 'tap'. -- -- /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 <- SVar.newFoldSVar st f-    foldStreamShared st yld sng stp (SVar.teeToSVar sv m)+{-# INLINE tapAsyncK #-}+tapAsyncK :: MonadAsync m => (Stream m a -> m b) -> Stream m a -> Stream m a+tapAsyncK f m = K.mkStream $ \st yld sng stp -> do+    sv <- SVar.newFoldSVar st (f . getSerialT)+    K.foldStreamShared st yld sng stp+        $ getSerialT (SVar.teeToSVar sv $ SerialT m)  data TapState fs st a = TapInit | Tapping !fs st | TapDone st @@ -448,29 +396,6 @@             Skip s    -> Skip (TapDone s)             Stop      -> Stop --- | Concurrently distribute a stream to a collection of fold functions,--- discarding the outputs of the folds.------ @--- > Stream.drain $ Stream.distributeAsync_ [Stream.mapM_ print, Stream.mapM_ print] (Stream.enumerateFromTo 1 2)--- 1--- 2--- 1--- 2------ @------ @--- distributeAsync_ = flip (foldr tapAsync)--- @------ /Pre-release/----{-# INLINE distributeAsync_ #-}-distributeAsync_ :: (Foldable f, IsStream t, MonadAsync m)-    => f (t m a -> m b) -> t m a -> t m a-distributeAsync_ = flip (foldr tapAsync)- ------------------------------------------------------------------------------ -- ParallelT ------------------------------------------------------------------------------@@ -502,44 +427,24 @@ -- @since 0.8.0 type Parallel = ParallelT IO --- | Fix the type of a polymorphic stream as 'ParallelT'.------ /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-    fromStream = ParallelT--    {-# INLINE consM #-}-    {-# SPECIALIZE consM :: IO a -> ParallelT IO a -> ParallelT IO a #-}-    consM = consMParallel--    {-# INLINE (|:) #-}-    {-# SPECIALIZE (|:) :: IO a -> ParallelT IO a -> ParallelT IO a #-}-    (|:) = consM- ------------------------------------------------------------------------------ -- Semigroup ------------------------------------------------------------------------------ -{-# INLINE mappendParallel #-}-{-# SPECIALIZE mappendParallel :: ParallelT IO a -> ParallelT IO a -> ParallelT IO a #-}-mappendParallel :: MonadAsync m => ParallelT m a -> ParallelT m a -> ParallelT m a-mappendParallel m1 m2 = fromStream $ parallel (toStream m1) (toStream m2)+{-# INLINE append #-}+{-# SPECIALIZE append :: ParallelT IO a -> ParallelT IO a -> ParallelT IO a #-}+append :: MonadAsync m => ParallelT m a -> ParallelT m a -> ParallelT m a+append (ParallelT m1) (ParallelT m2) = ParallelT $ parallelK m1 m2  instance MonadAsync m => Semigroup (ParallelT m a) where-    (<>) = mappendParallel+    (<>) = append  ------------------------------------------------------------------------------ -- Monoid ------------------------------------------------------------------------------  instance MonadAsync m => Monoid (ParallelT m a) where-    mempty = K.nil+    mempty = ParallelT K.nil     mappend = (<>)  ------------------------------------------------------------------------------@@ -547,15 +452,18 @@ ------------------------------------------------------------------------------  {-# INLINE apParallel #-}-{-# SPECIALIZE apParallel :: ParallelT IO (a -> b) -> ParallelT IO a -> ParallelT IO b #-}-apParallel :: MonadAsync m => ParallelT m (a -> b) -> ParallelT m a -> ParallelT m b+{-# SPECIALIZE apParallel ::+    ParallelT IO (a -> b) -> ParallelT IO a -> ParallelT IO b #-}+apParallel :: MonadAsync m =>+    ParallelT m (a -> b) -> ParallelT m a -> ParallelT m b apParallel (ParallelT m1) (ParallelT m2) =-    let f x1 = K.concatMapBy parallel (pure . x1) m2-    in ParallelT $ K.concatMapBy parallel f m1+    let f x1 = K.concatMapWith parallelK (pure . x1) m2+    in ParallelT $ K.concatMapWith parallelK f m1  instance (Monad m, MonadAsync m) => Applicative (ParallelT m) where     {-# INLINE pure #-}     pure = ParallelT . K.fromPure+     {-# INLINE (<*>) #-}     (<*>) = apParallel @@ -563,15 +471,18 @@ -- Monad ------------------------------------------------------------------------------ -{-# INLINE bindParallel #-}-{-# SPECIALIZE bindParallel :: ParallelT IO a -> (a -> ParallelT IO b) -> ParallelT IO b #-}-bindParallel :: MonadAsync m => ParallelT m a -> (a -> ParallelT m b) -> ParallelT m b-bindParallel m f = fromStream $ K.bindWith parallel (K.adapt m) (\a -> K.adapt $ f a)+{-# INLINE bind #-}+{-# SPECIALIZE bind ::+    ParallelT IO a -> (a -> ParallelT IO b) -> ParallelT IO b #-}+bind :: MonadAsync m => ParallelT m a -> (a -> ParallelT m b) -> ParallelT m b+bind (ParallelT m) f = ParallelT $ K.bindWith parallelK m (getParallelT . f)  instance MonadAsync m => Monad (ParallelT m) where     return = pure-    (>>=) = bindParallel +    {-# INLINE (>>=) #-}+    (>>=) = bind+ ------------------------------------------------------------------------------ -- Other instances ------------------------------------------------------------------------------@@ -592,7 +503,7 @@ -- /Pre-release/ -- {-# INLINE_NORMAL newCallbackStream #-}-newCallbackStream :: (K.IsStream t, MonadAsync m) => m (a -> m (), t m a)+newCallbackStream :: MonadAsync m => m (a -> m (), Stream m a) newCallbackStream = do     sv <- newParallelVar StopNone defState @@ -604,4 +515,4 @@     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))+    return (callback, D.toStreamK (SVar.fromSVarD sv))
src/Streamly/Internal/Data/Stream/Prelude.hs view
@@ -1,25 +1,22 @@+{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -#include "inline.hs"- -- | -- Module      : Streamly.Internal.Data.Stream.Prelude -- Copyright   : (c) 2017 Composewell Technologies------ License     : BSD3+-- License     : BSD-3-Clause -- Maintainer  : streamly@composewell.com -- Stability   : experimental -- Portability : GHC --+-- Low level functions using StreamK as the intermediate stream type. These+-- functions are used in SerialT/AsyncT/AheadT/ParallelT stream modules to+-- implement their instances.. -- module Streamly.Internal.Data.Stream.Prelude     (-    -- * Stream Conversion-      fromStreamS-    , toStreamS-     -- * Running Effects-    , drain+      drain      -- * Conversion operations     , fromList@@ -35,318 +32,26 @@     , foldl'     , fold -    -- Lazy left folds are useful only for reversing the stream-    , foldlS-    , foldlT--    , scanlx'-    , scanlMx'-    , postscanlx'-    , postscanlMx'-    , postscanOnce-    , scanOnce-     -- * Zip style operations     , eqBy     , cmpBy--    -- * Foldable instance-    , minimum-    , maximum--    -- * Nesting-    , K.concatMapBy-    , K.concatMap--    -- * Fold Utilities-    , concatFoldableWith-    , concatMapFoldableWith-    , concatForFoldableWith     ) where -import Control.Monad.Trans.Class (MonadTrans(..))-import Prelude hiding (foldr, minimum, maximum)-import qualified Prelude+#include "inline.hs"  import Streamly.Internal.Data.Fold.Type (Fold (..))  #ifdef USE_STREAMK_ONLY import qualified Streamly.Internal.Data.Stream.StreamK as S+import qualified Streamly.Internal.Data.Stream.StreamK.Type as S #else-import qualified Streamly.Internal.Data.Stream.StreamD as S+import qualified Streamly.Internal.Data.Stream.StreamD.Type as S #endif -import Streamly.Internal.Data.Stream.StreamK (IsStream(..))-import qualified Streamly.Internal.Data.Stream.StreamK as K-import qualified Streamly.Internal.Data.Stream.StreamD as D----------------------------------------------------------------------------------- Conversion to and from direct style stream----------------------------------------------------------------------------------- These definitions are dependent on what is imported as S-{-# INLINE fromStreamS #-}-fromStreamS :: (IsStream t, Monad m) => S.Stream m a -> t m a-fromStreamS = fromStream . S.toStreamK--{-# INLINE toStreamS #-}-toStreamS :: (IsStream t, Monad m) => t m a -> S.Stream m a-toStreamS = S.fromStreamK . toStream----------------------------------------------------------------------------------- Conversions---------------------------------------------------------------------------------{-# INLINE_EARLY drain #-}-drain :: (IsStream t, Monad m) => t m a -> m ()-drain m = D.drain $ D.fromStreamK (toStream m)-{-# RULES "drain fallback to CPS" [1]-    forall a. D.drain (D.fromStreamK a) = K.drain a #-}----------------------------------------------------------------------------------- Conversions----------------------------------------------------------------------------------- |--- @--- fromList = 'Prelude.foldr' 'K.cons' 'K.nil'--- @------ Construct a stream from a list of pure values. This is more efficient than--- 'K.fromFoldable' for serial streams.------ @since 0.4.0-{-# INLINE_EARLY fromList #-}-fromList :: (Monad m, IsStream t) => [a] -> t m a-fromList = fromStreamS . S.fromList-{-# RULES "fromList fallback to StreamK" [1]-    forall a. S.toStreamK (S.fromList a) = K.fromFoldable a #-}---- | Convert a stream into a list in the underlying monad.------ @since 0.1.0-{-# INLINE toList #-}-toList :: (Monad m, IsStream t) => t m a -> m [a]-toList m = S.toList $ toStreamS m----------------------------------------------------------------------------------- Folds---------------------------------------------------------------------------------{-# INLINE foldrM #-}-foldrM :: (Monad m, IsStream t) => (a -> m b -> m b) -> m b -> t m a -> m b-foldrM step acc m = S.foldrM step acc $ toStreamS m--{-# INLINE foldrMx #-}-foldrMx :: (Monad m, IsStream t)-    => (a -> m x -> m x) -> m x -> (m x -> m b) -> t m a -> m b-foldrMx step final project m = D.foldrMx step final project $ D.toStreamD m--{-# INLINE foldr #-}-foldr :: (Monad m, IsStream t) => (a -> b -> b) -> b -> t m a -> m b-foldr f z = foldrM (\a b -> f a <$> b) (return z)---- | Like 'foldlx'', but with a monadic step function.------ @since 0.7.0-{-# INLINE foldlMx' #-}-foldlMx' :: (IsStream t, Monad m)-    => (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---- | 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.7.0-{-# INLINE foldlx' #-}-foldlx' :: (IsStream t, Monad m)-    => (x -> a -> x) -> x -> (x -> b) -> t m a -> m b-foldlx' step begin done m = S.foldlx' step begin done $ toStreamS m---- | Strict left associative fold.------ @since 0.2.0-{-# INLINE foldl' #-}-foldl' :: (Monad m, IsStream t) => (b -> a -> b) -> b -> t m a -> m b-foldl' step begin m = S.foldl' step begin $ toStreamS m--{-# INLINE foldlS #-}-foldlS :: IsStream t => (t m b -> a -> t m b) -> t m b -> t m a -> t m b-foldlS = K.foldlS---- | Lazy left fold to a transformer monad.------ For example, to reverse a stream:------ > S.toList $ S.foldlT (flip S.cons) S.nil $ (S.fromList [1..5] :: SerialT IO Int)----{-# INLINE foldlT #-}-foldlT :: (Monad m, IsStream t, Monad (s m), MonadTrans s)-    => (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 fold #-}-fold :: (Monad m, IsStream t) => Fold m a b -> t m a -> m b-fold fld m = S.fold fld $ toStreamS m----------------------------------------------------------------------------------- Scans----------------------------------------------------------------------------------- postscanlM' followed by mapM-{-# INLINE postscanlMx' #-}-postscanlMx' :: (IsStream t, Monad m)-    => (x -> a -> m x) -> m x -> (x -> m b) -> t m a -> t m b-postscanlMx' step begin done m =-    D.fromStreamD $ D.postscanlMx' step begin done $ D.toStreamD m---- postscanl' followed by map-{-# INLINE postscanlx' #-}-postscanlx' :: (IsStream t, Monad m)-    => (x -> a -> x) -> x -> (x -> b) -> t m a -> t m b-postscanlx' step begin done m =-    D.fromStreamD $ D.postscanlx' step begin done $ D.toStreamD m---- scanlM' followed by mapM----{-# INLINE scanlMx' #-}-scanlMx' :: (IsStream t, Monad m)-    => (x -> a -> m x) -> m x -> (x -> m b) -> t m a -> t m b-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--- 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-{-# INLINE scanlx' #-}-scanlx' :: (IsStream t, Monad m)-    => (x -> a -> x) -> x -> (x -> b) -> t m a -> t m b-scanlx' step begin done m =-    fromStreamS $ S.scanlx' step begin done $ toStreamS m----------------------------------------------------------------------------------- Comparison----------------------------------------------------------------------------------- | Compare two streams for equality------ @since 0.5.3-{-# INLINE eqBy #-}-eqBy :: (IsStream t, Monad m) => (a -> b -> Bool) -> t m a -> t m b -> m Bool-eqBy f m1 m2 = D.eqBy f (D.toStreamD m1) (D.toStreamD m2)---- | Compare two streams------ @since 0.5.3-{-# INLINE cmpBy #-}-cmpBy-    :: (IsStream t, Monad m)-    => (a -> b -> Ordering) -> t m a -> t m b -> m Ordering-cmpBy f m1 m2 = D.cmpBy f (D.toStreamD m1) (D.toStreamD m2)--{-# INLINE minimum #-}-minimum :: (IsStream t, Monad m, Ord a) => t m a -> m (Maybe a)-minimum m = S.minimum (toStreamS m)--{-# INLINE maximum #-}-maximum :: (IsStream t, Monad m, Ord a) => t m a -> m (Maybe a)-maximum m = S.maximum (toStreamS m)----------------------------------------------------------------------------------- Fold Utilities---------------------------------------------------------------------------------{---- XXX do we have facilities in Foldable to fold any Foldable in this manner?------ | Perform a pair wise bottom up hierarchical fold of elements in the--- container using the given function as the merge function.------ This will perform a balanced merge sort if the merge function is--- 'mergeBy compare'.------ @since 0.7.0-{-# INLINABLE foldbWith #-}-foldbWith :: IsStream t-    => (t m a -> t m a -> t m a) -> SerialT Identity (t m a) -> t m a-foldbWith f = K.foldb f K.nil--}----- | A variant of 'Data.Foldable.fold' that allows you to fold a 'Foldable'--- container of streams using the specified stream sum operation.------ @concatFoldableWith 'async' $ map return [1..3]@------ Equivalent to:------ @--- 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 concatFoldableWith #-}-concatFoldableWith :: (IsStream t, Foldable f)-    => (t m a -> t m a -> t m a) -> f (t m a) -> t m a-concatFoldableWith f = Prelude.foldr f K.nil+import qualified Streamly.Internal.Data.Stream.StreamK.Type as K+import qualified Streamly.Internal.Data.Stream.StreamD.Type as D --- | 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.------ @concatMapFoldableWith 'async' return [1..3]@------ Equivalent to:------ @--- 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 concatMapFoldableWith #-}-concatMapFoldableWith :: (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) K.nil+import Prelude hiding (foldr, repeat) --- | Like 'concatMapFoldableWith' but with the last two arguments reversed i.e. the--- monadic streaming function is the last argument.------ Equivalent to:------ @--- 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 concatForFoldableWith #-}-concatForFoldableWith :: (IsStream t, Foldable f)-    => (t m b -> t m b -> t m b) -> f a -> (a -> t m b) -> t m b-concatForFoldableWith f xs g = Prelude.foldr (f . g) K.nil xs+#include "PreludeCommon.hs"
+ src/Streamly/Internal/Data/Stream/PreludeCommon.hs view
@@ -0,0 +1,139 @@+------------------------------------------------------------------------------+-- Conversion to and from direct style stream+------------------------------------------------------------------------------++#ifdef USE_IS_STREAM+#define IS_STREAM IsStream t,+#define FROM_STREAM fromStream+#define TO_STREAM toStream+#define STREAM t+#else+#define IS_STREAM+#define FROM_STREAM id+#define TO_STREAM id+#define STREAM K.Stream+#endif++-- These definitions are dependent on what is imported as S+{-# INLINE fromStreamS #-}+fromStreamS :: (IS_STREAM Monad m) => S.Stream m a -> STREAM m a+fromStreamS = FROM_STREAM . S.toStreamK++{-# INLINE toStreamS #-}+toStreamS :: (IS_STREAM Monad m) => STREAM m a -> S.Stream m a+toStreamS = S.fromStreamK . TO_STREAM++{-# INLINE toStreamD #-}+toStreamD :: (IS_STREAM Monad m) => STREAM m a -> D.Stream m a+toStreamD = D.fromStreamK . TO_STREAM++------------------------------------------------------------------------------+-- Conversions+------------------------------------------------------------------------------++{-# INLINE_EARLY drain #-}+drain :: (IS_STREAM Monad m) => STREAM m a -> m ()+drain m = D.drain $ D.fromStreamK (TO_STREAM m)+{-# RULES "drain fallback to CPS" [1]+    forall a. D.drain (D.fromStreamK a) = K.drain a #-}++------------------------------------------------------------------------------+-- Conversions+------------------------------------------------------------------------------++-- |+-- @+-- fromList = 'Prelude.foldr' 'K.cons' 'K.nil'+-- @+--+-- Construct a stream from a list of pure values. This is more efficient than+-- 'K.fromFoldable' for serial streams.+--+-- @since 0.4.0+{-# INLINE_EARLY fromList #-}+#ifdef USE_IS_STREAM+fromList :: (Monad m, IsStream t) => [a] -> STREAM m a+#else+fromList :: Monad m => [a] -> STREAM m a+#endif+fromList = fromStreamS . S.fromList+{-# RULES "fromList fallback to StreamK" [1]+    forall a. S.toStreamK (S.fromList a) = K.fromFoldable a #-}++-- | Convert a stream into a list in the underlying monad.+--+-- @since 0.1.0+{-# INLINE toList #-}+toList :: (IS_STREAM Monad m) => STREAM m a -> m [a]+toList m = S.toList $ toStreamS m++------------------------------------------------------------------------------+-- Folds+------------------------------------------------------------------------------++{-# INLINE foldrM #-}+foldrM :: (IS_STREAM Monad m) => (a -> m b -> m b) -> m b -> STREAM m a -> m b+foldrM step acc m = S.foldrM step acc $ toStreamS m++{-# INLINE foldrMx #-}+foldrMx :: (IS_STREAM Monad m)+    => (a -> m x -> m x) -> m x -> (m x -> m b) -> STREAM m a -> m b+foldrMx step final project m = D.foldrMx step final project $ toStreamD m++{-# INLINE foldr #-}+foldr :: (IS_STREAM Monad m) => (a -> b -> b) -> b -> STREAM m a -> m b+foldr f z = foldrM (\a b -> f a <$> b) (return z)++-- | Like 'foldlx'', but with a monadic step function.+--+-- @since 0.7.0+{-# INLINE foldlMx' #-}+foldlMx' ::+    (IS_STREAM Monad m)+    => (x -> a -> m x) -> m x -> (x -> m b) -> STREAM m a -> m b+foldlMx' step begin done m = S.foldlMx' step begin done $ 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.7.0+{-# INLINE foldlx' #-}+foldlx' ::+    (IS_STREAM Monad m) => (x -> a -> x) -> x -> (x -> b) -> STREAM m a -> m b+foldlx' step begin done m = S.foldlx' step begin done $ toStreamS m++-- | Strict left associative fold.+--+-- @since 0.2.0+{-# INLINE foldl' #-}+foldl' ::+    (IS_STREAM Monad m) => (b -> a -> b) -> b -> STREAM m a -> m b+foldl' step begin m = S.foldl' step begin $ toStreamS m+++{-# INLINE fold #-}+fold :: (IS_STREAM Monad m) => Fold m a b -> STREAM m a -> m b+fold fld m = S.fold fld $ toStreamS m++------------------------------------------------------------------------------+-- Comparison+------------------------------------------------------------------------------++-- | Compare two streams for equality+--+-- @since 0.5.3+{-# INLINE eqBy #-}+eqBy :: (IS_STREAM Monad m) =>+    (a -> b -> Bool) -> STREAM m a -> STREAM m b -> m Bool+eqBy f m1 m2 = D.eqBy f (toStreamD m1) (toStreamD m2)++-- | Compare two streams+--+-- @since 0.5.3+{-# INLINE cmpBy #-}+cmpBy+    :: (IS_STREAM Monad m)+    => (a -> b -> Ordering) -> STREAM m a -> STREAM m b -> m Ordering+cmpBy f m1 m2 = D.cmpBy f (toStreamD m1) (toStreamD m2)
− src/Streamly/Internal/Data/Stream/SVar.hs 
@@ -1,689 +0,0 @@-#ifdef __HADDOCK_VERSION__-#undef INSPECTION-#endif--#ifdef INSPECTION-{-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}-#endif---- |--- Module      : Streamly.Internal.Data.Stream.SVar--- Copyright   : (c) 2017 Composewell Technologies------ License     : BSD3--- Maintainer  : streamly@composewell.com--- Stability   : experimental--- Portability : GHC-------module Streamly.Internal.Data.Stream.SVar-    (-    -- * 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--#if __GLASGOW_HASKELL__ < 810-#ifdef INSPECTION-import Control.Exception (Exception)-import Control.Monad.Catch (MonadThrow)-import Control.Monad.Trans.Control (MonadBaseControl)-import Data.Typeable (Typeable)-import Test.Inspection (inspect, hasNoTypeClassesExcept)-#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 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.-    K.foldStream st yld sng stp $ processEvents $ reverse list--    where--    allDone stp = do-        when (svarInspectMode sv) $ do-            t <- liftIO $ getTime Monotonic-            liftIO $ writeIORef (svarStopTime (svarStats sv)) (Just t)-            liftIO $ printSVar sv "SVar Done"-        stp--    {-# INLINE processEvents #-}-    processEvents [] = K.MkStream $ \st yld sng stp -> do-        done <- postProcess sv-        if done-        then allDone stp-        else K.foldStream st yld sng stp $ fromStreamVar sv--    processEvents (ev : es) = K.MkStream $ \st yld sng stp -> do-        let rest = processEvents es-        case ev of-            ChildYield a -> yld a rest-            ChildStop tid e -> do-                accountThread sv tid-                case e of-                    Nothing -> do-                        stop <- shouldStop tid-                        if stop-                        then liftIO (cleanupSVar sv) >> allDone stp-                        else K.foldStream st yld sng stp rest-                    Just ex ->-                        case fromException ex of-                            Just ThreadAbort ->-                                K.foldStream st yld sng stp rest-                            Nothing -> liftIO (cleanupSVar sv) >> throwM ex-    shouldStop tid =-        case svarStopStyle sv of-            StopNone -> return False-            StopAny -> return True-            StopBy -> do-                sid <- liftIO $ readIORef (svarStopBy sv)-                return $ tid == sid--#if __GLASGOW_HASKELL__ < 810-#ifdef INSPECTION--- Use of GHC constraint tuple (GHC.Classes.(%,,%)) in fromStreamVar leads to--- space leak because the tuple gets allocated in every recursive call and each--- allocation holds on to the previous allocation. This test is to make sure--- that we do not use the constraint tuple type class.----inspect $ hasNoTypeClassesExcept 'fromStreamVar-    [ ''Monad-    , ''Applicative-    , ''MonadThrow-    , ''Exception-    , ''MonadIO-    , ''MonadBaseControl-    , ''Typeable-    , ''Functor-    ]-#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, K.IsStream t) => SVar K.Stream m a -> t m a-fromSVar sv =-    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.-        K.foldStreamShared st yld sng stp $-            K.fromStream $ fromStreamVar sv{svarRef = Just ref}-    where--    hook = do-        when (svarInspectMode sv) $ do-            r <- liftIO $ readIORef (svarStopTime (svarStats sv))-            when (isNothing r) $-                printSVar sv "SVar Garbage Collected"-        cleanupSVar sv-        -- If there are any SVars referenced by this SVar a GC will prompt-        -- them to be cleaned up quickly.-        when (svarInspectMode sv) performMajorGC--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 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 :: 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.-    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-            liftIO $ writeIORef (svarStopTime (svarStats sv)) (Just t)-            liftIO $ printSVar sv "SVar Done"-        sendStopToProducer sv-        stp--    {-# INLINE processEvents #-}-    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) = K.mkStream $ \_ yld _ stp -> do-        let rest = processEvents es-        case ev of-            ChildYield a -> yld a rest-            ChildStop tid e -> do-                accountThread sv tid-                case e of-                    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------------------------------------------------------------------------------------ XXX currently only one event is sent by a fold consumer to the stream--- producer. But we can potentially have multiple events e.g. the fold step can--- 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 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-    -- outputs in the same order as they were generated by the constituent-    -- streams.-    processEvents $ reverse list--    where--    {-# INLINE processEvents #-}-    processEvents [] = return False-    processEvents (ev : _) = do-        case ev of-            ChildStop _ e -> do-                case e of-                    Nothing -> return True-                    Just ex -> throwM ex-            ChildYield _ -> error "Bug: fromConsumer: invalid ChildYield event"---- | 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 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.-    ---    -- We avoid a race between the consumer fold sending an event and we-    -- blocking on decrementBufferLimit by waking up the producer thread in-    -- sendToProducer before any event is sent by the fold to the producer-    -- stream.-    let qref = outputQueueFromConsumer sv-    done <- do-        (_, n) <- liftIO $ readIORef qref-        if (n > 0)-        then fromConsumer sv-        else return False-    if done-    then return True-    else liftIO $ do-        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/SVar/Eliminate.hs view
@@ -0,0 +1,399 @@+-- |+-- Module      : Streamly.Internal.Data.Stream.SVar.Eliminate+-- Copyright   : (c) 2017 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- Eliminate a stream by distributing it to multiple SVars concurrently.+--+module Streamly.Internal.Data.Stream.SVar.Eliminate+    (+    -- * Concurrent Function Application+      toSVarParallel++    -- * Concurrent folds+    -- $concurrentFolds+    , newFoldSVar+    , newFoldSVarF++    , fromConsumer+    , pushToFold+    , teeToSVar+    )+where++#include "inline.hs"++import Control.Concurrent (myThreadId, takeMVar)+import Control.Monad (when, void)+import Control.Monad.Catch (throwM)+import Control.Monad.IO.Class (MonadIO(liftIO))+import Data.IORef (newIORef, readIORef, writeIORef)+import Streamly.Internal.Control.Concurrent (MonadAsync, doFork)+import Streamly.Internal.Data.Atomics (atomicModifyIORefCAS_)+import Streamly.Internal.Data.Fold.SVar (write, writeLimited)+import Streamly.Internal.Data.Fold.Type (Fold(..))+import Streamly.Internal.Data.Stream.Serial (SerialT(..))+import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime)++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++-------------------------------------------------------------------------------+-- Concurrent function application+-------------------------------------------------------------------------------++-- 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 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 :: 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.+    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+            liftIO $ writeIORef (svarStopTime (svarStats sv)) (Just t)+            liftIO $ printSVar sv "SVar Done"+        sendStopToProducer sv+        stp++    {-# INLINE processEvents #-}+    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) = K.mkStream $ \_ yld _ stp -> do+        let rest = processEvents es+        case ev of+            ChildYield a -> yld a rest+            ChildStop tid e -> do+                accountThread sv tid+                case e of+                    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 :: MonadAsync m+    => State K.Stream m a -> (SerialT 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 $ SerialT $ fromProducer sv)+                  (svarMrun sv)+                  (handleFoldException sv)+    return sv++data FromSVarState t m a =+      FromSVarInit+    | FromSVarRead (SVar t m a)+    | FromSVarLoop (SVar t m a) [ChildEvent a]+    | FromSVarDone (SVar t m a)++-- | 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+-------------------------------------------------------------------------------++-- XXX currently only one event is sent by a fold consumer to the stream+-- producer. But we can potentially have multiple events e.g. the fold step can+-- 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 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+    -- outputs in the same order as they were generated by the constituent+    -- streams.+    processEvents $ reverse list++    where++    {-# INLINE processEvents #-}+    processEvents [] = return False+    processEvents (ev : _) = do+        case ev of+            ChildStop _ e -> do+                case e of+                    Nothing -> return True+                    Just ex -> throwM ex+            ChildYield _ -> error "Bug: fromConsumer: invalid ChildYield event"++-- | 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 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.+    --+    -- We avoid a race between the consumer fold sending an event and we+    -- blocking on decrementBufferLimit by waking up the producer thread in+    -- sendToProducer before any event is sent by the fold to the producer+    -- stream.+    let qref = outputQueueFromConsumer sv+    done <- do+        (_, n) <- liftIO $ readIORef qref+        if n > 0+        then fromConsumer sv+        else return False+    if done+    then return True+    else liftIO $ do+        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 :: MonadAsync m =>+    SVar K.Stream m a -> SerialT m a -> SerialT m a+teeToSVar svr (SerialT m) = SerialT $ 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/SVar/Generate.hs view
@@ -0,0 +1,291 @@+#ifdef __HADDOCK_VERSION__+#undef INSPECTION+#endif++#ifdef INSPECTION+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}+#endif++-- |+-- Module      : Streamly.Internal.Data.Stream.SVar.Generate+-- Copyright   : (c) 2017 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+--+module Streamly.Internal.Data.Stream.SVar.Generate+    (+    -- * Write to SVar+      toSVar++    -- * Read from SVar+    -- $concurrentEval+    , fromSVar+    , fromSVarD+    -- , fromStreamVar+    )+where++#include "inline.hs"++import Control.Exception (fromException)+import Control.Monad (when)+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.Control.Concurrent (MonadAsync, captureMonadState)+import Streamly.Internal.Data.Stream.Serial (SerialT(..))+import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime)+import System.Mem (performMajorGC)++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++#if __GLASGOW_HASKELL__ < 810+#ifdef INSPECTION+import Control.Exception (Exception)+import Control.Monad.Catch (MonadThrow)+import Control.Monad.Trans.Control (MonadBaseControl)+import Data.Typeable (Typeable)+import Test.Inspection (inspect, hasNoTypeClassesExcept)+#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.++-------------------------------------------------------------------------------+-- Write a stream to an SVar+-------------------------------------------------------------------------------++-- XXX this errors out for Parallel/Ahead SVars+-- | Write a stream to an 'SVar' in a non-blocking manner. The stream can then+-- be read back from the SVar using 'fromSVar'.+toSVar :: MonadAsync m => SVar SerialT m a -> SerialT m a -> m ()+toSVar sv m = do+    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+    -- consumer thread.+    -- XXX do this only if the work queue is not empty. The work may have been+    -- carried out by existing workers.+    when done $+        case yieldRateInfo sv of+            Nothing -> pushWorker 0 sv+            Just _  -> pushWorker 1 sv++-------------------------------------------------------------------------------+-- Read a stream from an SVar+-------------------------------------------------------------------------------++-- | Pull a stream from an SVar.+{-# NOINLINE fromStreamVar #-}+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.+    K.foldStream st yld sng stp $ processEvents $ reverse list++    where++    allDone stp = do+        when (svarInspectMode sv) $ do+            t <- liftIO $ getTime Monotonic+            liftIO $ writeIORef (svarStopTime (svarStats sv)) (Just t)+            liftIO $ printSVar sv "SVar Done"+        stp++    {-# INLINE processEvents #-}+    processEvents [] = K.MkStream $ \st yld sng stp -> do+        done <- postProcess sv+        if done+        then allDone stp+        else K.foldStream st yld sng stp $ fromStreamVar sv++    processEvents (ev : es) = K.MkStream $ \st yld sng stp -> do+        let rest = processEvents es+        case ev of+            ChildYield a -> yld a rest+            ChildStop tid e -> do+                accountThread sv tid+                case e of+                    Nothing -> do+                        stop <- shouldStop tid+                        if stop+                        then liftIO (cleanupSVar sv) >> allDone stp+                        else K.foldStream st yld sng stp rest+                    Just ex ->+                        case fromException ex of+                            Just ThreadAbort ->+                                K.foldStream st yld sng stp rest+                            Nothing -> liftIO (cleanupSVar sv) >> throwM ex+    shouldStop tid =+        case svarStopStyle sv of+            StopNone -> return False+            StopAny -> return True+            StopBy -> do+                sid <- liftIO $ readIORef (svarStopBy sv)+                return $ tid == sid++#if __GLASGOW_HASKELL__ < 810+#ifdef INSPECTION+-- Use of GHC constraint tuple (GHC.Classes.(%,,%)) in fromStreamVar leads to+-- space leak because the tuple gets allocated in every recursive call and each+-- allocation holds on to the previous allocation. This test is to make sure+-- that we do not use the constraint tuple type class.+--+inspect $ hasNoTypeClassesExcept 'fromStreamVar+    [ ''Monad+    , ''Applicative+    , ''MonadThrow+    , ''Exception+    , ''MonadIO+    , ''MonadBaseControl+    , ''Typeable+    , ''Functor+    ]+#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 => SVar K.Stream m a -> SerialT m a+fromSVar sv =+    SerialT $ 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.+        K.foldStreamShared st yld sng stp $+            fromStreamVar sv{svarRef = Just ref}+    where++    hook = do+        when (svarInspectMode sv) $ do+            r <- liftIO $ readIORef (svarStopTime (svarStats sv))+            when (isNothing r) $+                printSVar sv "SVar Garbage Collected"+        cleanupSVar sv+        -- If there are any SVars referenced by this SVar a GC will prompt+        -- them to be cleaned up quickly.+        when (svarInspectMode sv) performMajorGC++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
src/Streamly/Internal/Data/Stream/Serial.hs view
@@ -16,22 +16,29 @@ module Streamly.Internal.Data.Stream.Serial     (     -- * Serial appending stream-      SerialT+      SerialT(..)     , Serial-    , K.serial-    , fromSerial+    , serial      -- * Serial interleaving stream-    , WSerialT+    , WSerialT(..)     , WSerial+    , wSerialK     , wSerial     , wSerialFst     , wSerialMin-    , fromWSerial+    , consMWSerial      -- * Construction+    , cons+    , consM+    , repeat     , unfoldrM+    , fromList +    -- * Elimination+    , toList+     -- * Transformation     , map     , mapM@@ -39,8 +46,6 @@     -- * Deprecated     , StreamT     , InterleavedT-    , (<=>)-    , interleaving     ) where @@ -67,18 +72,16 @@        ( 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.Data.Stream.StreamK.Type+       (Stream, mkStream, foldStream)  import qualified Streamly.Internal.Data.Stream.Prelude as P-    (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.Generate as D import qualified Streamly.Internal.Data.Stream.StreamD.Type as D+import qualified Streamly.Internal.Data.Stream.StreamK.Type as K -import Prelude hiding (map, mapM, errorWithoutStackTrace)+import Prelude hiding (map, mapM, errorWithoutStackTrace, repeat)  #include "Instances.hs" #include "inline.hs"@@ -136,24 +139,33 @@ {-# DEPRECATED StreamT "Please use 'SerialT' instead." #-} type StreamT = SerialT --- | Fix the type of a polymorphic stream as 'SerialT'.------ /Since: 0.1.0 ("Streamly")/+------------------------------------------------------------------------------+-- Generation+------------------------------------------------------------------------------++{-# INLINE cons #-}+cons :: a -> SerialT m a -> SerialT m a+cons x (SerialT ms) = SerialT $ K.cons x ms++{-# INLINE consM #-}+{-# SPECIALIZE consM :: IO a -> SerialT IO a -> SerialT IO a #-}+consM :: Monad m => m a -> SerialT m a -> SerialT m a+consM m (SerialT ms) = SerialT $ K.consM m ms++-- |+-- Generate an infinite stream by repeating a pure value. ----- @since 0.8.0-fromSerial :: IsStream t => SerialT m a -> t m a-fromSerial = adapt+{-# INLINE_NORMAL repeat #-}+repeat :: Monad m => a -> SerialT m a+repeat = SerialT . D.toStreamK . D.repeat -{-# INLINE consMSerial #-}-{-# SPECIALIZE consMSerial :: IO a -> SerialT IO a -> SerialT IO a #-}-consMSerial :: Monad m => m a -> SerialT m a -> SerialT m a-consMSerial m ms = fromStream $ K.consMStream m (toStream ms)+------------------------------------------------------------------------------+-- Combining+------------------------------------------------------------------------------ -instance IsStream SerialT where-    toStream = getSerialT-    fromStream = SerialT-    consM = consMSerial-    (|:) = consMSerial+{-# INLINE serial #-}+serial :: SerialT m a -> SerialT m a -> SerialT m a+serial = (<>)  ------------------------------------------------------------------------------ -- Monad@@ -173,7 +185,7 @@     -- n binds, breakAfterSome, filterAllIn, state transformer (~2x)     --     {-# INLINE (>>=) #-}-    (>>=) = K.bindWith K.serial+    (>>=) (SerialT m) f = SerialT $ K.bindWith K.serial m (getSerialT . f)      {-# INLINE (>>) #-}     (>>)  = (*>)@@ -183,8 +195,8 @@ ------------------------------------------------------------------------------  {-# INLINE mapM #-}-mapM :: (IsStream t, Monad m) => (a -> m b) -> t m a -> t m b-mapM f m = D.fromStreamD $ D.mapM f $ D.toStreamD m+mapM :: Monad m => (a -> m b) -> SerialT m a -> SerialT m b+mapM f (SerialT m) = SerialT $ D.toStreamK $ D.mapM f $ D.fromStreamK m  -- | -- @@@ -200,23 +212,23 @@ -- -- @since 0.4.0 {-# INLINE map #-}-map :: (IsStream t, Monad m) => (a -> b) -> t m a -> t m b+map :: Monad m => (a -> b) -> SerialT m a -> SerialT m b map f = mapM (return . f)  {-# 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+    SerialT $ D.toStreamK $ D.fromStreamK m1 <*> D.fromStreamK 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+    SerialT $ D.toStreamK $ D.fromStreamK m1 *> D.fromStreamK 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+    SerialT $ D.toStreamK $ D.fromStreamK m1 <* D.fromStreamK m2  -- Note: we need to define all the typeclass operations because we want to -- INLINE them.@@ -285,7 +297,7 @@ -- @2@: -- -- >>> import Streamly.Prelude (wSerial)--- >>> Stream.toList $ Stream.fromList [(1,3),(1,4)] `wSerial` Stream.fromList [(2,3),(2,4)]+-- >>> Stream.toList $ Stream.fromList [(1,3),(1,4)] `Stream.wSerial` Stream.fromList [(2,3),(2,4)] -- [(1,3),(2,3),(1,4),(2,4)] -- -- The @W@ in the name stands for @wide@ or breadth wise scheduling in@@ -310,37 +322,10 @@ {-# DEPRECATED InterleavedT "Please use 'WSerialT' instead." #-} type InterleavedT = WSerialT --- | Fix the type of a polymorphic stream as 'WSerialT'.------ /Since: 0.2.0 ("Streamly")/------ @since 0.8.0-fromWSerial :: IsStream t => WSerialT m a -> t m a-fromWSerial = adapt---- | Same as 'fromWSerial'.------ @since 0.1.0-{-# DEPRECATED interleaving "Please use fromWSerial instead." #-}-interleaving :: IsStream t => WSerialT m a -> t m a-interleaving = fromWSerial-+{-# INLINE consMWSerial #-}+{-# SPECIALIZE consMWSerial :: IO a -> WSerialT IO a -> WSerialT IO a #-} consMWSerial :: Monad m => m a -> WSerialT m a -> WSerialT m a-consMWSerial m ms = fromStream $ K.consMStream m (toStream ms)--instance IsStream WSerialT where-    toStream = getWSerialT-    fromStream = WSerialT--    {-# INLINE consM #-}-    {-# SPECIALIZE consM :: IO a -> WSerialT IO a -> WSerialT IO a #-}-    consM :: Monad m => m a -> WSerialT m a -> WSerialT m a-    consM = consMWSerial--    {-# INLINE (|:) #-}-    {-# SPECIALIZE (|:) :: IO a -> WSerialT IO a -> WSerialT IO a #-}-    (|:) :: Monad m => m a -> WSerialT m a -> WSerialT m a-    (|:) = consMWSerial+consMWSerial m (WSerialT ms) = WSerialT $ K.consM m ms  ------------------------------------------------------------------------------ -- Semigroup@@ -355,25 +340,17 @@ -- -- Similar combinators can be implemented using WAhead style. +{-# INLINE wSerialK #-}+wSerialK :: Stream m a -> Stream m a -> Stream m a+wSerialK m1 m2 = mkStream $ \st yld sng stp -> do+    let stop       = foldStream st yld sng stp m2+        single a   = yld a m2+        yieldk a r = yld a (wSerialK m2 r)+    foldStream st yieldk single stop m1+ -- | 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.------ >>> 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: --@@ -387,19 +364,15 @@ -- 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-    let stop       = foldStream st yld sng stp m2-        single a   = yld a m2-        yieldk a r = yld a (wSerial m2 r)-    foldStream st yieldk single stop m1+wSerial :: WSerialT m a -> WSerialT m a -> WSerialT m a+wSerial (WSerialT m1) (WSerialT m2) = WSerialT $ wSerialK m1 m2  -- | Like `wSerial` but stops interleaving as soon as the first stream stops. -- -- @since 0.7.0-{-# INLINE wSerialFst #-}-wSerialFst :: IsStream t => t m a -> t m a -> t m a-wSerialFst m1 m2 = mkStream $ \st yld sng stp -> do+{-# INLINE wSerialFstK #-}+wSerialFstK :: Stream m a -> Stream m a -> Stream m a+wSerialFstK m1 m2 = mkStream $ \st yld sng stp -> do     let yieldFirst a r = yld a (yieldSecond r m2)      in foldStream st yieldFirst sng stp m1 @@ -408,49 +381,47 @@     yieldSecond s1 s2 = mkStream $ \st yld sng stp -> do             let stop       = foldStream st yld sng stp s1                 single a   = yld a s1-                yieldk a r = yld a (wSerial s1 r)+                yieldk a r = yld a (wSerialK s1 r)              in foldStream st yieldk single stop s2 +{-# INLINE wSerialFst #-}+wSerialFst :: WSerialT m a -> WSerialT m a -> WSerialT m a+wSerialFst (WSerialT m1) (WSerialT m2) = WSerialT $ wSerialFstK m1 m2+ -- | Like `wSerial` but stops interleaving as soon as any of the two streams -- stops. -- -- @since 0.7.0-{-# INLINE wSerialMin #-}-wSerialMin :: IsStream t => t m a -> t m a -> t m a-wSerialMin m1 m2 = mkStream $ \st yld _ stp -> do+{-# INLINE wSerialMinK #-}+wSerialMinK :: Stream m a -> Stream m a -> Stream m a+wSerialMinK m1 m2 = mkStream $ \st yld _ stp -> do     let stop       = stp         -- "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)+        single a   = yld a (wSerialMinK m2 K.nil)+        yieldk a r = yld a (wSerialMinK m2 r)     foldStream st yieldk single stop m1 +{-# INLINE wSerialMin #-}+wSerialMin :: WSerialT m a -> WSerialT m a -> WSerialT m a+wSerialMin (WSerialT m1) (WSerialT m2) = WSerialT $ wSerialMinK m1 m2+ instance Semigroup (WSerialT m a) where     (<>) = wSerial -infixr 5 <=>---- | Same as 'wSerial'.------ @since 0.1.0-{-# DEPRECATED (<=>) "Please use 'wSerial' instead." #-}-{-# INLINE (<=>) #-}-(<=>) :: IsStream t => t m a -> t m a -> t m a-(<=>) = wSerial- ------------------------------------------------------------------------------ -- Monoid ------------------------------------------------------------------------------  instance Monoid (WSerialT m a) where-    mempty = K.nil+    mempty = WSerialT K.nil     mappend = (<>)  {-# INLINE apWSerial #-} apWSerial :: Monad m => WSerialT m (a -> b) -> WSerialT m a -> WSerialT m b apWSerial (WSerialT m1) (WSerialT m2) =-    let f x1 = K.concatMapBy wSerial (pure . x1) m2-    in WSerialT $ K.concatMapBy wSerial f m1+    let f x1 = K.concatMapWith wSerialK (pure . x1) m2+    in WSerialT $ K.concatMapWith wSerialK f m1  instance Monad m => Applicative (WSerialT m) where     {-# INLINE pure #-}@@ -465,7 +436,7 @@ instance Monad m => Monad (WSerialT m) where     return = pure     {-# INLINE (>>=) #-}-    (>>=) = K.bindWith wSerial+    (>>=) (WSerialT m) f = WSerialT $ K.bindWith wSerialK m (getWSerialT . f)  ------------------------------------------------------------------------------ -- Other instances@@ -503,5 +474,5 @@ -- /Pre-release/ -- {-# INLINE unfoldrM #-}-unfoldrM :: (IsStream t, Monad m) => (b -> m (Maybe (a, b))) -> b -> t m a-unfoldrM step seed = D.fromStreamD (D.unfoldrM step seed)+unfoldrM :: Monad m => (b -> m (Maybe (a, b))) -> b -> SerialT m a+unfoldrM step seed = SerialT $ D.toStreamK (D.unfoldrM step seed)
src/Streamly/Internal/Data/Stream/StreamD/Eliminate.hs view
@@ -81,6 +81,7 @@ import GHC.Exts (SpecConstrAnnotation(..)) import GHC.Types (SPEC(..)) import Streamly.Internal.Data.Parser (ParseError(..))+import Streamly.Internal.Data.SVar.Type (defState)  import qualified Streamly.Internal.Data.Parser as PR import qualified Streamly.Internal.Data.Parser.ParserD as PRD@@ -90,7 +91,6 @@        ( 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@@ -228,30 +228,17 @@ -- 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+null = foldrM (\_ _ -> return False) (return True)  {-# INLINE_NORMAL head #-} head :: Monad m => Stream m a -> m (Maybe a)-head m = foldrM (\x _ -> return (Just x)) (return Nothing) m+head = foldrM (\x _ -> return (Just x)) (return Nothing)  {-# INLINE_NORMAL headElse #-} headElse :: Monad m => a -> Stream m a -> m a-headElse a m = foldrM (\x _ -> return x) (return a) m+headElse a = foldrM (\x _ -> return x) (return a)  -- Does not fuse, has the same performance as the StreamK version. {-# INLINE_NORMAL tail #-}@@ -407,13 +394,13 @@  {-# 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+lookup e = foldrM (\(a, b) xs -> if e == a then return (Just b) else xs)+                   (return Nothing)  {-# 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+findM p = foldrM (\x xs -> p x >>= \r -> if r then return (Just x) else xs)+                   (return Nothing)  {-# INLINE find #-} find :: Monad m => (a -> Bool) -> Stream m a -> m (Maybe a)
src/Streamly/Internal/Data/Stream/StreamD/Exception.hs view
@@ -14,12 +14,13 @@     , after_     , after     , bracket_-    , bracket+    , bracket'     , onException     , finally_     , finally     , ghandle     , handle+    , retry     ) where @@ -29,14 +30,16 @@ import Control.Monad.Catch (MonadCatch) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Control (MonadBaseControl, liftBaseOp_)+import Data.Map.Strict (Map) import GHC.Exts (inline)+import Streamly.Internal.Control.Concurrent (MonadAsync) import Streamly.Internal.Data.IOFinalizer     (newIOFinalizer, runIOFinalizer, clearingIOFinalizer)  import qualified Control.Monad.Catch as MC+import qualified Data.Map.Strict as Map  import Streamly.Internal.Data.Stream.StreamD.Type-import Streamly.Internal.Data.SVar  data GbracketState s1 s2 v     = GBracketInit@@ -101,7 +104,9 @@ -- 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 exception handler @c -> e -> Stream m b -> m (Stream m b)@. Note that+-- 'gbracket' does not rethrow the exception, it has to be done by the+-- exception handler if desired. -- -- The cleanup action @c -> m d@, runs whenever the stream ends normally, due -- to a sync or async exception or if it gets garbage collected after a partial@@ -115,13 +120,14 @@ {-# 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+    => m c -- ^ before+    -> (forall s. m s -> m (Either e s)) -- ^ try (exception handling)+    -> (c -> m d1) -- ^ on normal stop+    -> (c -> m d2) -- ^ on GC without normal stop or exception     -> (c -> e -> Stream m b -> m (Stream m b)) -- ^ on exception-    -> (c -> Stream m b)                    -- ^ stream generator+    -> (c -> Stream m b) -- ^ stream generator     -> Stream m b-gbracket bef exc aft fexc fnormal =+gbracket bef exc aft gc fexc fnormal =     Stream step GBracketIOInit      where@@ -137,7 +143,7 @@         -- Tutorial: https://markkarpov.com/tutorial/exceptions.html         (r, ref) <- liftBaseOp_ mask_ $ do             r <- bef-            ref <- newIOFinalizer (aft r)+            ref <- newIOFinalizer (gc r)             return (r, ref)         return $ Skip $ GBracketIONormal (fnormal r) r ref @@ -149,9 +155,8 @@                     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+                Stop ->+                    clearingIOFinalizer ref (aft v) >> return Stop             -- XXX Do not handle async exceptions, just rethrow them.             Left e -> do                 -- Clearing of finalizer and running of exception handler must@@ -234,7 +239,7 @@ onException action str =     gbracket_ (return ()) (inline MC.try) return         (\_ (e :: MC.SomeException) _ -> nilM (action >> MC.throwM e))-        (\_ -> str)+        (const str)  {-# INLINE_NORMAL _onException #-} _onException :: MonadCatch m => m b -> Stream m a -> Stream m a@@ -255,18 +260,23 @@ {-# INLINE_NORMAL bracket_ #-} bracket_ :: MonadCatch m     => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a-bracket_ bef aft bet =+bracket_ bef aft =     gbracket_ bef (inline MC.try) aft-        (\a (e :: SomeException) _ -> nilM (aft a >> MC.throwM e)) bet+        (\a (e :: SomeException) _ -> nilM (aft a >> MC.throwM e))  -- | 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+{-# INLINE_NORMAL bracket' #-}+bracket' :: (MonadAsync m, MonadCatch m) =>+       m b+    -> (b -> m c)+    -> (b -> m d)+    -> (b -> m e)+    -> (b -> Stream m a)+    -> Stream m a+bracket' bef aft exc gc =+    gbracket bef (inline MC.try) aft gc+        (\a (e :: SomeException) _ -> exc a >> return (nilM (MC.throwM e)))  data BracketState s v = BracketInit | BracketRun s v @@ -298,7 +308,7 @@ -- {-# INLINE finally_ #-} finally_ :: MonadCatch m => m b -> Stream m a -> Stream m a-finally_ action xs = bracket_ (return ()) (\_ -> action) (const xs)+finally_ action xs = bracket_ (return ()) (const action) (const xs)  -- | See 'Streamly.Internal.Data.Stream.IsStream.finally'. --@@ -306,7 +316,8 @@ -- {-# INLINE finally #-} finally :: (MonadAsync m, MonadCatch m) => m b -> Stream m a -> Stream m a-finally action xs = bracket (return ()) (\_ -> action) (const xs)+finally action xs = bracket' (return ()) act act act (const xs)+    where act _ = action  -- | See 'Streamly.Internal.Data.Stream.IsStream.ghandle'. --@@ -314,7 +325,7 @@ 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)+    gbracket_ (return ()) (inline MC.try) return (const f) (const str)  -- | See 'Streamly.Internal.Data.Stream.IsStream.handle'. --@@ -322,7 +333,7 @@ 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)+    gbracket_ (return ()) (inline MC.try) return (\_ e _ -> f e) (const str)  -- | Alternate (custom) implementation of 'handle'. --@@ -349,3 +360,55 @@             Yield x s -> return $ Yield x (Right (Stream step1 s))             Skip s    -> return $ Skip (Right (Stream step1 s))             Stop      -> return Stop++data RetryState emap s1 s2+    = RetryWithMap emap s1+    | RetryDefault s2++-- | See 'Streamly.Internal.Data.Stream.IsStream.retry'+--+{-# INLINE_NORMAL retry #-}+retry+    :: forall e m a. (Exception e, Ord e, MonadCatch m)+    => Map e Int+       -- ^ map from exception to retry count+    -> (e -> Stream m a)+       -- ^ default handler for those exceptions that are not in the map+    -> Stream m a+    -> Stream m a+retry emap0 defaultHandler (Stream step0 state0) = Stream step state++    where++    state = RetryWithMap emap0 state0++    {-# INLINE_LATE step #-}+    step gst (RetryWithMap emap st) = do+        eres <- MC.try $ step0 gst st+        case eres of+            Left e -> handler e emap st+            Right res ->+                return+                    $ case res of+                          Yield x st1 -> Yield x $ RetryWithMap emap st1+                          Skip st1 -> Skip $ RetryWithMap emap st1+                          Stop -> Stop+    step gst (RetryDefault (UnStream step1 state1)) = do+        res <- step1 gst state1+        return+            $ case res of+                  Yield x st1 -> Yield x $ RetryDefault (Stream step1 st1)+                  Skip st1 -> Skip $ RetryDefault (Stream step1 st1)+                  Stop -> Stop++    {-# INLINE handler #-}+    handler e emap st =+        return+            $ Skip+            $ case Map.lookup e emap of+                  Just i+                      | i > 0 ->+                          let emap1 = Map.insert e (i - 1) emap+                           in RetryWithMap emap1 st+                      | otherwise -> RetryDefault $ defaultHandler e+                  Nothing -> RetryDefault $ defaultHandler e
src/Streamly/Internal/Data/Stream/StreamD/Generate.hs view
@@ -53,8 +53,8 @@     , enumerateFromThenToIntegral      , enumerateFromStepNum-    , numFrom-    , numFromThen+    , enumerateFromNum+    , enumerateFromThenNum     , enumerateFromToFractional     , enumerateFromThenToFractional @@ -82,14 +82,13 @@     -- * Conversions     , fromStreamK     , toStreamK-    , fromStreamD-    , toStreamD     ) where  #include "inline.hs"  import Control.Monad.IO.Class (MonadIO(..))+import Streamly.Internal.Control.Concurrent (MonadAsync) import Streamly.Internal.Data.Time.Clock     (Clock(Monotonic), asyncClock, readClock) import Streamly.Internal.Data.Time.Units@@ -97,7 +96,6 @@  import Prelude hiding (iterate, repeat, replicate, takeWhile) import Streamly.Internal.Data.Stream.StreamD.Type-import Streamly.Internal.Data.SVar  ------------------------------------------------------------------------------ -- Primitives@@ -133,7 +131,7 @@ -- 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+unfoldrM next = Stream step   where     {-# INLINE_LATE step #-}     step _ st = do@@ -196,13 +194,13 @@     {-# 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 enumerateFromNum #-}+enumerateFromNum :: (Monad m, Num a) => a -> Stream m a+enumerateFromNum from = enumerateFromStepNum from 1 -{-# INLINE_NORMAL numFromThen #-}-numFromThen :: (Monad m, Num a) => a -> a -> Stream m a-numFromThen from next = enumerateFromStepNum from (next - from)+{-# INLINE_NORMAL enumerateFromThenNum #-}+enumerateFromThenNum :: (Monad m, Num a) => a -> a -> Stream m a+enumerateFromThenNum from next = enumerateFromStepNum from (next - from)  ------------------------------------------------------------------------------ -- Enumeration of Integrals@@ -259,6 +257,9 @@      step _ EnumStop = return Stop +-- XXX This can perhaps be simplified and written in terms of+-- enumeratFromStepIntegral as we have done in unfolds. But anyway we should be+-- replacing the stream generation module with unfolds. {-# INLINE_NORMAL enumerateFromThenToIntegral #-} enumerateFromThenToIntegral     :: (Monad m, Integral a)@@ -317,7 +318,7 @@     :: (Monad m, Fractional a, Ord a)     => a -> a -> a -> Stream m a enumerateFromThenToFractional from next to =-    takeWhile predicate $ numFromThen from next+    takeWhile predicate $ enumerateFromThenNum from next     where     mid = (next - from) / 2     predicate | next >= from  = (<= to + mid)
src/Streamly/Internal/Data/Stream/StreamD/Lift.hs view
@@ -28,7 +28,7 @@ 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 Streamly.Internal.Data.SVar.Type (adaptState)  import qualified Control.Monad.Trans.Reader as Reader import qualified Control.Monad.Trans.State.Strict as State@@ -41,7 +41,7 @@  {-# 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)+hoist f (Stream step state) = Stream step' state     where     {-# INLINE_LATE step' #-}     step' gst st = do
src/Streamly/Internal/Data/Stream/StreamD/Nesting.hs view
@@ -112,7 +112,9 @@     -- ** Folding     -- | Apply folds on a stream.     , foldMany+    , refoldMany     , foldIterateM+    , refoldIterateM      -- ** Parsing     -- | Parsing is opposite to flattening. 'parseMany' is dual to concatMap or@@ -126,7 +128,6 @@     -- ** Grouping     -- | Group segments of a stream and fold. Special case of parsing.     , chunksOf-    , groupsOf2     , groupsBy     , groupsRollingBy @@ -135,6 +136,7 @@     , wordsBy     , splitOnSeq     , splitOnSuffixSeq+    , sliceOnSuffix      -- * Transform (Nested Containers)     -- | Opposite to compact in ArrayStream@@ -158,18 +160,21 @@ import GHC.Types (SPEC(..))  import Streamly.Internal.Data.Array.Foreign.Type (Array(..))+import Streamly.Internal.Data.Fold.Step (Step(..)) import Streamly.Internal.Data.Fold.Type (Fold(..)) import Streamly.Internal.Data.Parser (ParseError(..))+import Streamly.Internal.Data.Refold.Type (Refold(..))+import Streamly.Internal.Data.SVar.Type (adaptState)+import Streamly.Internal.Data.Tuple.Strict (Tuple'(..)) import Streamly.Internal.Data.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.Fold 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) @@ -486,7 +491,8 @@     | ConcatUnfoldInterleaveInnerL [i] [i]     | ConcatUnfoldInterleaveInnerR [i] [i] --- XXX use arrays to store state instead of lists.+-- 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.@@ -502,11 +508,31 @@ -- Ideally, we need some scheduling bias to inner streams vs outer stream. -- Maybe we can configure the behavior. --+-- XXX Instead of using "concatPairsWith wSerial" we can implement an N-way+-- interleaving CPS combinator which behaves like unfoldManyInterleave. Intead+-- of pairing up the streams We just need to go yielding one element from each+-- stream and storing the remaining streams and then keep doing rounds through+-- those in a round robin fashion. This would be much like wAsync.+--+-- | This does not pair streams like concatPairsWith, instead, it goes through+-- each stream one by one and yields one element from each stream. After it+-- goes to the last stream it reverses the traversal to come back to the first+-- stream yielding elements from each stream on its way back to the first+-- stream and so on.+--+-- >>> input = Stream.fromList [[1,1],[2,2],[3,3],[4,4],[5,5]]+-- >>> Stream.toList $ Stream.unfoldManyInterleave Unfold.fromList input+-- [1,2,3,4,5,5,4,3,2,1]+--+-- Note that this is order of magnitude more efficient than "concatPairsWith+-- wSerial" {-# 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++    where+     {-# INLINE_LATE step #-}     step gst (ConcatUnfoldInterleaveOuter o ls) = do         r <- ostep (adaptState gst) o@@ -971,7 +997,7 @@  {-# INLINE_NORMAL foldIterateM #-} foldIterateM ::-       Monad m => (b -> m (FL.Fold m a b)) -> b -> Stream m a -> Stream m b+       Monad m => (b -> m (FL.Fold m a b)) -> m b -> Stream m a -> Stream m b foldIterateM func seed0 (Stream step state) =     Stream stepOuter (FIterInit state seed0) @@ -984,11 +1010,11 @@             $ Skip             $ case res of                   FL.Partial fs -> FIterStream st fstep fs extract-                  FL.Done fb -> FIterYield fb $ FIterInit st fb+                  FL.Done fb -> FIterYield fb $ FIterInit st (return fb)      {-# INLINE_LATE stepOuter #-}     stepOuter _ (FIterInit st seed) = do-        (FL.Fold fstep initial extract) <- func seed+        (FL.Fold fstep initial extract) <- seed >>= func         iterStep initial st fstep extract     stepOuter gst (FIterStream st fstep fs extract) = do         r <- step (adaptState gst) st@@ -1002,6 +1028,77 @@     stepOuter _ (FIterYield a next) = return $ Yield a next     stepOuter _ FIterStop = return Stop +{-# ANN type CIterState Fuse #-}+data CIterState s f fs b+    = CIterInit s f+    | CIterConsume s fs+    | CIterYield b (CIterState s f fs b)+    | CIterStop++-- | Like 'foldIterateM' but using the 'Refold' type instead. This could be+-- much more efficient due to stream fusion.+--+-- /Internal/+{-# INLINE_NORMAL refoldIterateM #-}+refoldIterateM ::+       Monad m => Refold m b a b -> m b -> Stream m a -> Stream m b+refoldIterateM (Refold fstep finject fextract) initial (Stream step state) =+    Stream stepOuter (CIterInit state initial)++    where++    {-# INLINE iterStep #-}+    iterStep st action = do+        res <- action+        return+            $ Skip+            $ case res of+                  FL.Partial fs -> CIterConsume st fs+                  FL.Done fb -> CIterYield fb $ CIterInit st (return fb)++    {-# INLINE_LATE stepOuter #-}+    stepOuter _ (CIterInit st action) = do+        iterStep st (action >>= finject)+    stepOuter gst (CIterConsume st fs) = do+        r <- step (adaptState gst) st+        case r of+            Yield x s -> iterStep s (fstep fs x)+            Skip s -> return $ Skip $ CIterConsume s fs+            Stop -> do+                b <- fextract fs+                return $ Skip $ CIterYield b CIterStop+    stepOuter _ (CIterYield a next) = return $ Yield a next+    stepOuter _ CIterStop = return Stop++-- "n" elements at the end are dropped by the fold.+{-# INLINE sliceBy #-}+sliceBy :: Monad m => Fold m a Int -> Int -> Refold m (Int, Int) a (Int, Int)+sliceBy (Fold step1 initial1 extract1) n = Refold step inject extract++    where++    inject (i, len) = do+        r <- initial1+        return $ case r of+            Partial s -> Partial $ Tuple' (i + len + n) s+            Done l -> Done (i, l)++    step (Tuple' i s) x = do+        r <- step1 s x+        return $ case r of+            Partial s1 -> Partial $ Tuple' i s1+            Done len -> Done (i, len)++    extract (Tuple' i s) = (i,) <$> extract1 s++{-# INLINE sliceOnSuffix #-}+sliceOnSuffix :: Monad m => (a -> Bool) -> Stream m a -> Stream m (Int, Int)+sliceOnSuffix predicate =+    -- Scan the stream with the given refold+    refoldIterateM+        (sliceBy (FL.takeEndBy_ predicate FL.length) 1)+        (return (-1, 0))+ ------------------------------------------------------------------------------ -- Parsing ------------------------------------------------------------------------------@@ -2173,7 +2270,7 @@                     r <- if withSep then fstep fs x else fstep fs old                     case r of                         FL.Partial fs1 ->-                            if (cksum1 /= patHash)+                            if cksum1 /= patHash                             then go SPEC fs1 s rh1 cksum1                             else skip $ SplitOnSuffixSeqKRCheck fs1 s rb rh1                         FL.Done b -> do@@ -2239,7 +2336,7 @@     -> Stream m (f a)     -> Stream m (f a) splitInnerBy splitter joiner (Stream step1 state1) =-    (Stream step (SplitInitial state1))+    Stream step (SplitInitial state1)      where @@ -2253,7 +2350,7 @@                     Nothing -> Skip (SplitBuffering s x1)                     Just x2 -> Skip (SplitYielding x1 (SplitSplitting s x2))             Skip s -> return $ Skip (SplitInitial s)-            Stop -> return $ Stop+            Stop -> return Stop      step gst (SplitBuffering st buf) = do         r <- step1 gst st@@ -2274,7 +2371,7 @@                 Just x2 -> Skip $ SplitYielding x1 (SplitSplitting st x2)      step _ (SplitYielding x next) = return $ Yield x next-    step _ SplitFinishing = return $ Stop+    step _ SplitFinishing = return Stop  -- | Performs infix separator style splitting. {-# INLINE_NORMAL splitInnerBySuffix #-}@@ -2285,7 +2382,7 @@     -> Stream m (f a)     -> Stream m (f a) splitInnerBySuffix splitter joiner (Stream step1 state1) =-    (Stream step (SplitInitial state1))+    Stream step (SplitInitial state1)      where @@ -2299,7 +2396,7 @@                     Nothing -> Skip (SplitBuffering s x1)                     Just x2 -> Skip (SplitYielding x1 (SplitSplitting s x2))             Skip s -> return $ Skip (SplitInitial s)-            Stop -> return $ Stop+            Stop -> return Stop      step gst (SplitBuffering st buf) = do         r <- step1 gst st
src/Streamly/Internal/Data/Stream/StreamD/Transform.hs view
@@ -99,7 +99,7 @@     -- * Reordering     -- | Produce strictly the same set but reordered.     , reverse-    , reverse'+    -- , reverse'      -- * Position Indexing     , indexed@@ -107,6 +107,7 @@      -- * Searching     , findIndices+    , slicesBy      -- * Rolling map     -- | Map using the previous element.@@ -129,28 +130,26 @@ 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.Control.Concurrent (MonadAsync, fork, forkManaged) import Streamly.Internal.Data.Fold.Type (Fold(..)) import Streamly.Internal.Data.Pipe.Type (Pipe(..), PipeState(..))+import Streamly.Internal.Data.SVar.Type (defState, adaptState) 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@@ -533,8 +532,8 @@ {-# 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+postscanlx' fstep begin done =+    postscanlMx' (\b a -> return (fstep b a)) (return begin) (return . done)  -- XXX do we need consM strict to evaluate the begin value? {-# INLINE scanlMx' #-}@@ -546,8 +545,8 @@ {-# 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+scanlx' fstep begin done =+    scanlMx' (\b a -> return (fstep b a)) (return begin) (return . done)  ------------------------------------------------------------------------------ -- postscans@@ -667,7 +666,7 @@                 y <- fstep acc x                 return $ Yield y (Just (s, y))             Skip s -> return $ Skip (Just (s, acc))-            Stop   -> return $ Stop+            Stop   -> return Stop  {-# INLINE scanl #-} scanl :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b@@ -1066,12 +1065,12 @@     step' _ (SuffixSpanSuffix st) = do         action >>= \r -> return $ Skip (SuffixSpanYield r (SuffixSpanElem st n)) -    step' _ (SuffixSpanLast) = do+    step' _ SuffixSpanLast = do         action >>= \r -> return $ Skip (SuffixSpanYield r SuffixSpanStop)      step' _ (SuffixSpanYield x next) = return $ Yield x next -    step' _ (SuffixSpanStop) = return Stop+    step' _ SuffixSpanStop = return Stop  ------------------------------------------------------------------------------ -- Reordering@@ -1098,12 +1097,12 @@     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+-- the chunked code in IsStream.Common.reverse' .  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.@@ -1128,12 +1127,6 @@             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@@ -1182,6 +1175,25 @@           Skip s -> Skip (s, i)           Stop   -> Stop +{-# INLINE_NORMAL slicesBy #-}+slicesBy :: Monad m => (a -> Bool) -> Stream m a -> Stream m (Int, Int)+slicesBy p (Stream step1 state1) = Stream step (Just (state1, 0, 0))++    where++    {-# INLINE_LATE step #-}+    step gst (Just (st, i, len)) = i `seq` len `seq` do+      r <- step1 (adaptState gst) st+      return+        $ case r of+              Yield x s ->+                if p x+                then Yield (i, len + 1) (Just (s, i + len + 1, 0))+                else Skip (Just (s, i, len + 1))+              Skip s -> Skip (Just (s, i, len))+              Stop -> if len == 0 then Stop else Yield (i, len) Nothing+    step _ Nothing = return Stop+ ------------------------------------------------------------------------------ -- Rolling map ------------------------------------------------------------------------------@@ -1206,7 +1218,7 @@                 !res <- f x x1                 return $ Yield res $ RollingMapGo s x             Skip s -> return $ Skip $ RollingMapGo s x1-            Stop   -> return $ Stop+            Stop   -> return Stop  {-# INLINE rollingMap #-} rollingMap :: Monad m => (a -> a -> b) -> Stream m a -> Stream m b
src/Streamly/Internal/Data/Stream/StreamD/Type.hs view
@@ -39,12 +39,11 @@     -- * Conversions From/To     , fromStreamK     , toStreamK-    , toStreamD-    , fromStreamD      -- * Running a 'Fold'     , fold     , fold_+    , foldOn      -- * Right Folds     , foldrT@@ -59,6 +58,9 @@     , foldlx'     , foldlMx' +    -- * Special Folds+    , drain+     -- * To Containers     , toList @@ -82,24 +84,25 @@     , FoldManyPost (..)     , foldMany     , foldManyPost-    , groupsOf2+    , refoldMany     , chunksOf     ) where  import Control.Applicative (liftA2)-import Control.Monad (when) import Control.Monad.Catch (MonadThrow, throwM) import Control.Monad.Trans.Class (lift, MonadTrans)+import Data.Functor (($>)) 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, takeWhile) -import Streamly.Internal.Data.Fold.Type (Fold(..), Fold2(..))+import Streamly.Internal.Data.Fold.Type (Fold(..))+import Streamly.Internal.Data.Refold.Type (Refold(..)) import Streamly.Internal.Data.Stream.StreamD.Step (Step (..))-import Streamly.Internal.Data.SVar (State, adaptState, defState)+import Streamly.Internal.Data.SVar.Type (State, adaptState, defState) import Streamly.Internal.Data.Unfold.Type (Unfold(..))  import qualified Streamly.Internal.Data.Fold.Type as FL@@ -133,22 +136,22 @@  -- | An empty 'Stream' with a side effect. {-# INLINE_NORMAL nilM #-}-nilM :: Monad m => m b -> Stream m a-nilM m = Stream (\_ _ -> m >> return Stop) ()+nilM :: Applicative m => m b -> Stream m a+nilM m = Stream (\_ _ -> m $> Stop) ()  {-# INLINE_NORMAL consM #-}-consM :: Monad m => m a -> Stream m a -> Stream m a+consM :: Applicative m => m a -> Stream m a -> Stream m a consM m (Stream step state) = Stream step1 Nothing+     where+     {-# INLINE_LATE step1 #-}-    step1 _ Nothing   = m >>= \x -> return $ Yield x (Just state)+    step1 _ Nothing = (`Yield` Just state) <$> m     step1 gst (Just st) = do-        r <- step gst st-        return $-          case r of+          (\case             Yield a s -> Yield a (Just s)             Skip  s   -> Skip (Just s)-            Stop      -> Stop+            Stop      -> Stop) <$> step gst st  -- | Does not fuse, has the same performance as the StreamK version. {-# INLINE_NORMAL uncons #-}@@ -171,17 +174,18 @@ -- | 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 :: Applicative m => Unfold m a b -> a -> Stream m b unfold (Unfold ustep inject) seed = Stream step UnfoldNothing-  where++    where+     {-# INLINE_LATE step #-}-    step _ UnfoldNothing = inject seed >>= return . Skip . UnfoldJust+    step _ UnfoldNothing = Skip . UnfoldJust <$> inject seed     step _ (UnfoldJust st) = do-        r <- ustep st-        return $ case r of+        (\case             Yield x s -> Yield x (UnfoldJust s)             Skip s    -> Skip (UnfoldJust s)-            Stop      -> Stop+            Stop      -> Stop) <$> ustep st  ------------------------------------------------------------------------------ -- From Values@@ -198,12 +202,14 @@  -- | Create a singleton 'Stream' from a monadic action. {-# INLINE_NORMAL fromEffect #-}-fromEffect :: Monad m => m a -> Stream m a+fromEffect :: Applicative m => m a -> Stream m a fromEffect m = Stream step True-  where++    where+     {-# INLINE_LATE step #-}-    step _ True  = m >>= \x -> return $ Yield x False-    step _ False = return Stop+    step _ True  = (`Yield` False) <$> m+    step _ False = pure Stop  ------------------------------------------------------------------------------ -- From Containers@@ -225,13 +231,13 @@  -- | 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 :: Applicative m => K.Stream m a -> Stream m a fromStreamK = Stream step     where     step gst m1 =-        let stop       = return Stop-            single a   = return $ Yield a K.nil-            yieldk a r = return $ Yield a r+        let stop       = pure Stop+            single a   = pure $ Yield a K.nil+            yieldk a r = pure $ Yield a r          in K.foldStreamShared gst yieldk single stop m1  -- | Convert a direct style step encoded StreamD to a CPS encoded StreamK@@ -239,7 +245,7 @@ toStreamK :: Monad m => Stream m a -> K.Stream m a toStreamK (Stream step state) = go state     where-    go st = K.mkStream $ \gst yld _ stp ->+    go st = K.MkStream $ \gst yld _ stp ->       let go' ss = do            r <- step gst ss            case r of@@ -255,22 +261,12 @@     forall s. fromStreamK (toStreamK s) = s #-} #endif --- 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- ------------------------------------------------------------------------------ -- Running a 'Fold' ------------------------------------------------------------------------------  {-# INLINE_NORMAL fold #-}-fold :: (Monad m) => Fold m a b -> Stream m a -> m b+fold :: Monad m => Fold m a b -> Stream m a -> m b fold fld strm = do     (b, _) <- fold_ fld strm     return b@@ -299,6 +295,31 @@                 b <- done fs                 return $! (b, Stream (\ _ _ -> return Stop) ()) +{-# INLINE_NORMAL foldOn #-}+foldOn :: Monad m => Fold m a b -> Stream m a -> Fold m a b+foldOn (Fold fstep finitial fextract) (Stream sstep state) =+    Fold fstep initial fextract++    where++    initial = do+        res <- finitial+        case res of+            FL.Partial fs -> go SPEC fs state+            FL.Done fb -> return $ FL.Done fb++    {-# INLINE go #-}+    go !_ !fs st = do+        r <- sstep defState st+        case r of+            Yield x s -> do+                res <- fstep fs x+                case res of+                    FL.Done b -> return $ FL.Done b+                    FL.Partial fs1 -> go SPEC fs1 s+            Skip s -> go SPEC fs s+            Stop -> return $ FL.Partial fs+ ------------------------------------------------------------------------------ -- Right Folds ------------------------------------------------------------------------------@@ -358,7 +379,7 @@ -- {-# INLINE_NORMAL foldr #-} 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)+foldr f z = foldrM (liftA2 f . return) (return z)  -- this performs horribly, should not be used {-# INLINE_NORMAL foldrS #-}@@ -418,8 +439,8 @@  {-# INLINE foldlx' #-} foldlx' :: Monad m => (x -> a -> x) -> x -> (x -> b) -> Stream m a -> m b-foldlx' fstep begin done m =-    foldlMx' (\b a -> return (fstep b a)) (return begin) (return . done) m+foldlx' fstep begin done =+    foldlMx' (\b a -> return (fstep b a)) (return begin) (return . done)  -- Adapted from the vector package. -- XXX implement in terms of foldlMx'?@@ -444,6 +465,23 @@ foldl' fstep begin = foldlM' (\b a -> return (fstep b a)) (return begin)  ------------------------------------------------------------------------------+-- Special 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 ()++------------------------------------------------------------------------------ -- To Containers ------------------------------------------------------------------------------ @@ -568,17 +606,18 @@  -- Adapted from the vector package. {-# INLINE_NORMAL take #-}-take :: Monad m => Int -> Stream m a -> Stream m a+take :: Applicative m => Int -> Stream m a -> Stream m a take n (Stream step state) = n `seq` Stream step' (state, 0)-  where++    where+     {-# INLINE_LATE step' #-}     step' gst (st, i) | i < n = do-        r <- step gst st-        return $ case r of+        (\case             Yield x s -> Yield x (s, i + 1)             Skip s    -> Skip (s, i)-            Stop      -> Stop-    step' _ (_, _) = return Stop+            Stop      -> Stop) <$> step gst st+    step' _ (_, _) = pure Stop  -- Adapted from the vector package. {-# INLINE_NORMAL takeWhileM #-}@@ -605,17 +644,20 @@  {-# 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+concatAp (Stream stepa statea) (Stream stepb stateb) =+    Stream step' (Left statea)++    where+     {-# INLINE_LATE step' #-}     step' gst (Left st) = fmap-        (\r -> case r of+        (\case             Yield f s -> Skip (Right (f, s, stateb))             Skip    s -> Skip (Left s)             Stop      -> Stop)         (stepa (adaptState gst) st)     step' gst (Right (f, os, st)) = fmap-        (\r -> case r of+        (\case             Yield a s -> Yield (f a) (Right (f, os, s))             Skip s    -> Skip (Right (f,os, s))             Stop      -> Skip (Left os))@@ -631,19 +673,17 @@     {-# 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)+            (\case+                 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))+            (\case+                 Yield b s -> Yield b (Right (ostate, s))+                 Skip s -> Skip (Right (ostate, s))+                 Stop -> Skip (Left ostate))             (stepb gst st)  {-# INLINE_NORMAL apDiscardSnd #-}@@ -656,19 +696,17 @@     {-# 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)+            (\case+                 Yield b s -> Skip (Right (s, stateb, b))+                 Skip s -> Skip (Left s)+                 Stop -> Stop)             (stepa gst st)     step gst (Right (ostate, st, b)) =         fmap-            (\r ->-                 case r of-                     Yield _ s -> Yield b (Right (ostate, s, b))-                     Skip s -> Skip (Right (ostate, s, b))-                     Stop -> Skip (Left ostate))+            (\case+                 Yield _ s -> Yield b (Right (ostate, s, b))+                 Skip s -> Skip (Right (ostate, s, b))+                 Stop -> Skip (Left ostate))             (stepb (adaptState gst) st)  instance Applicative f => Applicative (Stream f) where@@ -720,7 +758,7 @@                 i <- inject a                 i `seq` return (Skip (ConcatMapUInner o' i))             Skip o' -> return $ Skip (ConcatMapUOuter o')-            Stop -> return $ Stop+            Stop -> return Stop      step _ (ConcatMapUInner o i) = do         r <- istep i@@ -909,55 +947,52 @@ chunksOf :: Monad m => Int -> Fold m a b -> Stream m a -> Stream m b chunksOf n f = foldMany (FL.take n f) -data GroupState2 s fs-    = GroupStart2 s-    | GroupBuffer2 s fs Int-    | GroupYield2 fs (GroupState2 s fs)-    | GroupFinish2--{-# INLINE_NORMAL groupsOf2 #-}-groupsOf2-    :: Monad m-    => Int-    -> m c-    -> Fold2 m c a b-    -> Stream m a-    -> Stream m b-groupsOf2 n input (Fold2 fstep inject extract) (Stream step state) =-    n `seq` Stream step' (GroupStart2 state)+-- Keep the argument order consistent with consumeIterateM.+--+-- | Like 'foldMany' but for the 'Refold' type.  The supplied action is used as+-- the initial value for each refold.+--+-- /Internal/+{-# INLINE_NORMAL refoldMany #-}+refoldMany :: Monad m => Refold m x a b -> m x -> Stream m a -> Stream m b+refoldMany (Refold fstep inject extract) action (Stream step state) =+    Stream step' (FoldManyStart state)      where -    {-# INLINE_LATE step' #-}-    step' _ (GroupStart2 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 <- input >>= inject-        return $ Skip (GroupBuffer2 st fs 0)+    {-# 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 -    step' gst (GroupBuffer2 st fs i) = do+    {-# INLINE_LATE step' #-}+    step' _ (FoldManyStart st) = do+        r <- action >>= inject+        return+            $ Skip+            $ case r of+                  FL.Done b -> FoldManyYield b (FoldManyStart st)+                  FL.Partial fs -> FoldManyFirst fs st+    step' gst (FoldManyFirst fs st) = do         r <- step (adaptState gst) st         case r of-            Yield x s -> do-                !fs' <- fstep fs x-                let i' = i + 1-                return $-                    if i' >= n-                    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' _ (GroupYield2 fs next) = do-        r <- extract fs-        return $ Yield r next--    step' _ GroupFinish2 = return Stop+            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  ------------------------------------------------------------------------------ -- Other instances
src/Streamly/Internal/Data/Stream/StreamDK.hs view
@@ -112,7 +112,7 @@  {-# INLINE_LATE foldrM #-} foldrM :: Monad m => (a -> m b -> m b) -> m b -> Stream m a -> m b-foldrM fstep acc ys = go ys+foldrM fstep acc = go     where     go (Stream step) = do         r <- step
src/Streamly/Internal/Data/Stream/StreamDK/Type.hs view
@@ -101,4 +101,4 @@ -- XXX Use Cons and Nil instead of Yield and Stop? data Step m a = Yield a (Stream m a) | Stop -data Stream m a = Stream (m (Step m a))+newtype Stream m a = Stream (m (Step m a))
src/Streamly/Internal/Data/Stream/StreamK.hs view
@@ -21,12 +21,8 @@ -- module Streamly.Internal.Data.Stream.StreamK     (-    -- * A class for streams-      IsStream (..)-    , adapt-     -- * The stream type-    , Stream(..)+      Stream(..)      -- * Construction Primitives     , mkStream@@ -65,15 +61,12 @@     , fromEffect     , fromFoldable     , fromList-    , fromStreamK      -- * foldr/build     , foldrS     , foldrSM     , buildS-    , buildM     , augmentS-    , augmentSM      -- * Elimination     -- ** General Folds@@ -116,7 +109,6 @@      -- ** Conversions     , toList-    , toStreamK     , hoist      -- * Transformation@@ -134,7 +126,6 @@     -- ** Mapping     , map     , mapM-    , mapMSerial     , sequence      -- ** Inserting@@ -160,7 +151,7 @@     , mergeByM      -- ** Nesting-    , concatMapBy+    , concatMapWith     , concatMap     , bindWith     , concatPairsWith@@ -176,70 +167,36 @@     , serial      -- * Utilities-    , consMStream+    , consM     , withLocal     , mfix--    -- * Deprecated-    , Streaming -- deprecated-    , once      -- deprecated     ) where  import Control.Monad.Trans.Class (MonadTrans(lift)) import Control.Monad (void, join)-import Control.Monad.Reader.Class  (MonadReader(..))-import Data.Function (fix)+import Streamly.Internal.Data.SVar.Type (adaptState, defState)++import qualified Streamly.Internal.Data.Fold.Type as FL+ import Prelude        hiding (foldl, foldr, last, map, mapM, mapM_, repeat, sequence,                take, filter, all, any, takeWhile, drop, dropWhile, minimum,                maximum, elem, notElem, null, head, tail, init, zipWith, lookup,                foldr1, (!!), replicate, reverse, concatMap, iterate)-import qualified Prelude -import Streamly.Internal.Data.SVar import Streamly.Internal.Data.Stream.StreamK.Type -import qualified Streamly.Internal.Data.Fold.Type as FL- -- $setup -- >>> :m  ---------------------------------------------------------------------------------- Deconstruction----------------------------------------------------------------------------------{-# INLINE uncons #-}-uncons :: (IsStream t, Monad m) => t m a -> m (Maybe (a, t m a))-uncons m =-    let stop = return Nothing-        single a = return (Just (a, nil))-        yieldk a r = return (Just (a, r))-    in foldStream defState yieldk single stop m--------------------------------------------------------------------------------- -- Generation ------------------------------------------------------------------------------- -{-# INLINE unfoldr #-}-unfoldr :: IsStream t => (b -> Maybe (a, b)) -> b -> t m a-unfoldr next s0 = build $ \yld stp ->-    let go s =-            case next s of-                Just (a, b) -> yld a (go b)-                Nothing -> stp-    in go s0- {-# INLINE unfoldrM #-}-unfoldrM :: (IsStream t, MonadAsync m) => (b -> m (Maybe (a, b))) -> b -> t m a-unfoldrM step = go-    where-    go s = sharedM $ \yld _ stp -> do-                r <- step s-                case r of-                    Just (a, b) -> yld a (go b)-                    Nothing -> stp-+unfoldrM :: Monad m => (b -> m (Maybe (a, b))) -> b -> Stream m a+unfoldrM = unfoldrMWith consM {- -- Generalization of concurrent streams/SVar via unfoldr. --@@ -253,7 +210,8 @@ -- concurrent version could be async or ahead etc. Depending on how we queue -- back the feedback portion b, it could be DFS or BFS style. ---unfoldrA :: (IsStream t, MonadAsync m) => (b -> Maybe (m a, b)) -> b -> t m a+unfoldrA :: (IsStream t, MonadAsync m) =>+    (b -> Maybe (m a, b)) -> b -> Stream m a unfoldrA = undefined -} @@ -261,111 +219,59 @@ -- Special generation ------------------------------------------------------------------------------- --- | Same as fromEffect------ @since 0.2.0-{-# DEPRECATED once "Please use fromEffect instead." #-}-{-# INLINE once #-}-once :: (Monad m, IsStream t) => m a -> t m a-once = fromEffect---- |--- @--- repeatM = fix . cons--- repeatM = cycle1 . fromPure--- @------ Generate an infinite stream by repeating a monadic value.------ /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.------ /Pre-release/-{-# INLINE repeat #-}-repeat :: IsStream t => a -> t m a-repeat a = let x = cons a x in x+repeatM :: Monad m => m a -> Stream m a+repeatM = repeatMWith consM  {-# INLINE replicateM #-}-replicateM :: (IsStream t, MonadAsync m) => Int -> m a -> t m a-replicateM n m = go n-    where-    go cnt = if cnt <= 0 then nil else m |: go (cnt - 1)-+replicateM :: Monad m => Int -> m a -> Stream m a+replicateM = replicateMWith consM {-# INLINE replicate #-}-replicate :: IsStream t => Int -> a -> t m a+replicate :: Int -> a -> Stream m a replicate n a = go n     where     go cnt = if cnt <= 0 then nil else a `cons` go (cnt - 1)  {-# INLINE fromIndicesM #-}-fromIndicesM :: (IsStream t, MonadAsync m) => (Int -> m a) -> t m a-fromIndicesM gen = go 0-  where-    go i = mkStream $ \st stp sng yld -> do-        foldStreamShared st stp sng yld (gen i |: go (i + 1))-+fromIndicesM :: Monad m => (Int -> m a) -> Stream m a+fromIndicesM = fromIndicesMWith consM {-# INLINE fromIndices #-}-fromIndices :: IsStream t => (Int -> a) -> t m a+fromIndices :: (Int -> a) -> Stream m a fromIndices gen = go 0   where-    go n = (gen n) `cons` go (n + 1)+    go n = gen n `cons` go (n + 1)  {-# INLINE iterate #-}-iterate :: IsStream t => (a -> a) -> a -> t m a+iterate :: (a -> a) -> a -> Stream m a iterate step = go     where         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-        foldStreamShared st stp sng yld (return next |: go (step next))+iterateM :: Monad m => (a -> m a) -> m a -> Stream m a+iterateM = iterateMWith consM  ------------------------------------------------------------------------------- -- Conversions ------------------------------------------------------------------------------- --- |--- @--- fromFoldable = 'Prelude.foldr' 'cons' 'nil'--- @------ Construct a stream from a 'Foldable' containing pure values:------ @since 0.2.0-{-# INLINE fromFoldable #-}-fromFoldable :: (IsStream t, Foldable f) => f a -> t m a-fromFoldable = Prelude.foldr cons nil- {-# INLINE fromList #-}-fromList :: IsStream t => [a] -> t m a+fromList :: [a] -> Stream m a fromList = fromFoldable -{-# INLINE fromStreamK #-}-fromStreamK :: IsStream t => Stream m a -> t m a-fromStreamK = fromStream- ------------------------------------------------------------------------------- -- Elimination by Folding -------------------------------------------------------------------------------  -- | Lazy right associative fold. {-# INLINE foldr #-}-foldr :: (IsStream t, Monad m) => (a -> b -> b) -> b -> t m a -> m b+foldr :: Monad m => (a -> b -> b) -> b -> Stream m a -> m b foldr step acc = foldrM (\x xs -> xs >>= \b -> return (step x b)) (return acc)  -- | Right associative fold to an arbitrary transformer monad. {-# 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 step final m = go m+foldrT :: (Monad m, Monad (s m), MonadTrans s)+    => (a -> s m b -> s m b) -> s m b -> Stream m a -> s m b+foldrT step final = go   where     go m1 = do         res <- lift $ uncons m1@@ -374,7 +280,7 @@             Nothing -> final  {-# INLINE foldr1 #-}-foldr1 :: (IsStream t, Monad m) => (a -> a -> a) -> t m a -> m (Maybe a)+foldr1 :: Monad m => (a -> a -> a) -> Stream m a -> m (Maybe a) foldr1 step m = do     r <- uncons m     case r of@@ -390,9 +296,9 @@ -- XXX replace the recursive "go" with explicit continuations. -- | Like 'foldx', but with a monadic step function. {-# INLINABLE foldlMx' #-}-foldlMx' :: (IsStream t, Monad m)-    => (x -> a -> m x) -> m x -> (x -> m b) -> t m a -> m b-foldlMx' step begin done m = go begin m+foldlMx' :: Monad m+    => (x -> a -> m x) -> m x -> (x -> m b) -> Stream m a -> m b+foldlMx' step begin done = go begin     where     go !acc m1 =         let stop = acc >>= done@@ -401,7 +307,7 @@          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 :: Monad m => FL.Fold m a b -> Stream m a -> m b fold (FL.Fold step begin done) m = do     res <- begin     case res of@@ -423,26 +329,14 @@  -- | Like 'foldl'' but with a monadic step function. {-# INLINE foldlM' #-}-foldlM' :: (IsStream t, Monad m) => (b -> a -> m b) -> m b -> t m a -> m b+foldlM' :: Monad m => (b -> a -> m b) -> m b -> Stream m a -> m b foldlM' step begin = foldlMx' step begin return --- | Lazy left fold to a stream.-{-# INLINE foldlS #-}-foldlS :: IsStream t => (t m b -> a -> t m b) -> t m b -> t m a -> t m b-foldlS step begin m = go begin m-    where-    go acc rest = mkStream $ \st yld sng stp ->-        let run x = foldStream st yld sng stp x-            stop = run acc-            single a = run $ step acc a-            yieldk a r = run $ go (step acc a) r-         in foldStream (adaptState st) yieldk single stop rest- -- | Lazy left fold to an arbitrary transformer monad. {-# INLINE foldlT #-}-foldlT :: (IsStream t, Monad m, Monad (s m), MonadTrans s)-    => (s m b -> a -> s m b) -> s m b -> t m a -> s m b-foldlT step begin m = go begin m+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 step = go   where     go acc m1 = do         res <- lift $ uncons m1@@ -454,39 +348,8 @@ -- Specialized folds ------------------------------------------------------------------------------ --- XXX use foldrM to implement folds where possible--- XXX This (commented) definition of drain and mapM_ perform much better on--- some benchmarks but worse on others. Need to investigate why, may there is--- an optimization opportunity that we can exploit.--- drain = foldrM (\_ xs -> return () >> xs) (return ())---- |--- > drain = foldl' (\_ _ -> ()) ()--- > drain = mapM_ (\_ -> return ())-{-# INLINE drain #-}-drain :: (Monad m, IsStream t) => t m a -> m ()-drain = foldrM (\_ xs -> xs) (return ())-{--drain = go-    where-    go m1 =-        let stop = return ()-            single _ = return ()-            yieldk _ r = go r-         in foldStream defState yieldk single stop m1--}--{-# INLINE null #-}-null :: (IsStream t, Monad m) => t m a -> m Bool--- null = foldrM (\_ _ -> return True) (return False)-null m =-    let stop      = return True-        single _  = return False-        yieldk _ _ = return False-    in foldStream defState yieldk single stop m- {-# INLINE head #-}-head :: (IsStream t, Monad m) => t m a -> m (Maybe a)+head :: Monad m => Stream m a -> m (Maybe a) -- head = foldrM (\x _ -> return $ Just x) (return Nothing) head m =     let stop      = return Nothing@@ -494,113 +357,9 @@         yieldk a _ = return (Just a)     in foldStream defState yieldk single stop m -{-# INLINE tail #-}-tail :: (IsStream t, Monad m) => t m a -> m (Maybe (t m a))-tail m =-    let stop      = return Nothing-        single _  = return $ Just nil-        yieldk _ r = return $ Just r-    in foldStream defState yieldk single stop m--{-# INLINE headPartial #-}-headPartial :: (IsStream t, Monad m) => t m a -> m a-headPartial = foldrM (\x _ -> return x) (error "head of nil")--{-# INLINE tailPartial #-}-tailPartial :: IsStream t => t m a -> t m a-tailPartial m = mkStream $ \st yld sng stp ->-    let stop      = error "tail of nil"-        single _  = stp-        yieldk _ r = foldStream st yld sng stp r-    in foldStream st yieldk single stop m---- | We can define cyclic structures using @let@:------ >>> let (a, b) = ([1, b], head a) in (a, b)--- ([1,1],1)------ The function @fix@ defined as:------ > fix f = let x = f x in x------ ensures that the argument of a function and its output refer to the same--- lazy value @x@ i.e.  the same location in memory.  Thus @x@ can be defined--- in terms of itself, creating structures with cyclic references.------ >>> 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.Data.Stream.IsStream as Stream--- import System.IO.Unsafe (unsafeInterleaveIO)------ main = do---     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: you cannot achieve this by just changing the order of the monad--- statements because that would change the order in which the stream elements--- are generated.------ Note that the function @f@ must be lazy in its argument, that's why we use--- 'unsafeInterleaveIO' on @action@ because IO monad is strict.------ /Pre-release/--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--    -- 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-    where-    go1 m1 = do-        r <- uncons m1-        case r of-            Nothing -> return Nothing-            Just (h, t) -> return . Just $ go h t-    go p m1 = mkStream $ \_ yld sng stp ->-        let single _ = sng p-            yieldk a x = yld p $ go a x-         in foldStream defState yieldk single stp m1- {-# INLINE elem #-}-elem :: (IsStream t, Monad m, Eq a) => a -> t m a -> m Bool-elem e m = go m+elem :: (Monad m, Eq a) => a -> Stream m a -> m Bool+elem e = go     where     go m1 =         let stop      = return False@@ -609,8 +368,8 @@         in foldStream defState yieldk single stop m1  {-# INLINE notElem #-}-notElem :: (IsStream t, Monad m, Eq a) => a -> t m a -> m Bool-notElem e m = go m+notElem :: (Monad m, Eq a) => a -> Stream m a -> m Bool+notElem e = go     where     go m1 =         let stop      = return True@@ -619,8 +378,8 @@         in foldStream defState yieldk single stop m1  {-# INLINABLE all #-}-all :: (IsStream t, Monad m) => (a -> Bool) -> t m a -> m Bool-all p m = go m+all :: Monad m => (a -> Bool) -> Stream m a -> m Bool+all p = go     where     go m1 =         let single a   | p a       = return True@@ -630,8 +389,8 @@          in foldStream defState yieldk single (return True) m1  {-# INLINABLE any #-}-any :: (IsStream t, Monad m) => (a -> Bool) -> t m a -> m Bool-any p m = go m+any :: Monad m => (a -> Bool) -> Stream m a -> m Bool+any p = go     where     go m1 =         let single a   | p a       = return True@@ -642,12 +401,12 @@  -- | Extract the last element of the stream, if any. {-# INLINE last #-}-last :: (IsStream t, Monad m) => t m a -> m (Maybe a)+last :: Monad m => Stream m a -> m (Maybe a) last = foldlx' (\_ y -> Just y) Nothing id  {-# INLINE minimum #-}-minimum :: (IsStream t, Monad m, Ord a) => t m a -> m (Maybe a)-minimum m = go Nothing m+minimum :: (Monad m, Ord a) => Stream m a -> m (Maybe a)+minimum = go Nothing     where     go Nothing m1 =         let stop      = return Nothing@@ -669,9 +428,9 @@  {-# INLINE minimumBy #-} minimumBy-    :: (IsStream t, Monad m)-    => (a -> a -> Ordering) -> t m a -> m (Maybe a)-minimumBy cmp m = go Nothing m+    :: (Monad m)+    => (a -> a -> Ordering) -> Stream m a -> m (Maybe a)+minimumBy cmp = go Nothing     where     go Nothing m1 =         let stop      = return Nothing@@ -690,8 +449,8 @@         in foldStream defState yieldk single stop m1  {-# INLINE maximum #-}-maximum :: (IsStream t, Monad m, Ord a) => t m a -> m (Maybe a)-maximum m = go Nothing m+maximum :: (Monad m, Ord a) => Stream m a -> m (Maybe a)+maximum = go Nothing     where     go Nothing m1 =         let stop      = return Nothing@@ -712,8 +471,8 @@         in foldStream defState yieldk single stop m1  {-# INLINE maximumBy #-}-maximumBy :: (IsStream t, Monad m) => (a -> a -> Ordering) -> t m a -> m (Maybe a)-maximumBy cmp m = go Nothing m+maximumBy :: Monad m => (a -> a -> Ordering) -> Stream m a -> m (Maybe a)+maximumBy cmp = go Nothing     where     go Nothing m1 =         let stop      = return Nothing@@ -732,7 +491,7 @@         in foldStream defState yieldk single stop m1  {-# INLINE (!!) #-}-(!!) :: (IsStream t, Monad m) => t m a -> Int -> m (Maybe a)+(!!) :: Monad m => Stream m a -> Int -> m (Maybe a) m !! i = go i m     where     go n m1 =@@ -744,8 +503,8 @@       in foldStream defState yieldk single (return Nothing) m1  {-# INLINE lookup #-}-lookup :: (IsStream t, Monad m, Eq a) => a -> t m (a, b) -> m (Maybe b)-lookup e m = go m+lookup :: (Monad m, Eq a) => a -> Stream m (a, b) -> m (Maybe b)+lookup e = go     where     go m1 =         let single (a, b) | a == e = return $ Just b@@ -755,8 +514,8 @@         in foldStream defState yieldk single (return Nothing) m1  {-# INLINE findM #-}-findM :: (IsStream t, Monad m) => (a -> m Bool) -> t m a -> m (Maybe a)-findM p m = go m+findM :: Monad m => (a -> m Bool) -> Stream m a -> m (Maybe a)+findM p = go     where     go m1 =         let single a = do@@ -768,11 +527,11 @@         in foldStream defState yieldk single (return Nothing) m1  {-# INLINE find #-}-find :: (IsStream t, Monad m) => (a -> Bool) -> t m a -> m (Maybe a)+find :: Monad m => (a -> Bool) -> Stream m a -> m (Maybe a) find p = findM (return . p)  {-# INLINE findIndices #-}-findIndices :: IsStream t => (a -> Bool) -> t m a -> t m Int+findIndices :: (a -> Bool) -> Stream m a -> Stream m Int findIndices p = go 0     where     go offset m1 = mkStream $ \st yld sng stp ->@@ -790,8 +549,8 @@ -- | Apply a monadic action to each element of the stream and discard the -- output of the action. {-# INLINE mapM_ #-}-mapM_ :: (IsStream t, Monad m) => (a -> m b) -> t m a -> m ()-mapM_ f m = go m+mapM_ :: Monad m => (a -> m b) -> Stream m a -> m ()+mapM_ f = go     where     go m1 =         let stop = return ()@@ -799,22 +558,22 @@             yieldk a r = f a >> go r          in foldStream defState yieldk single stop m1 +{-# INLINE mapM #-}+mapM :: Monad m => (a -> m b) -> Stream m a -> Stream m b+mapM = mapMWith consM+ ------------------------------------------------------------------------------ -- Converting folds ------------------------------------------------------------------------------  {-# INLINABLE toList #-}-toList :: (IsStream t, Monad m) => t m a -> m [a]+toList :: Monad m => Stream m a -> m [a] toList = foldr (:) [] -{-# INLINE toStreamK #-}-toStreamK :: Stream m a -> Stream m a-toStreamK = id- -- Based on suggestions by David Feuer and Pranay Sashank {-# INLINE hoist #-}-hoist :: (IsStream t, Monad m, Monad n)-    => (forall x. m x -> n x) -> t m a -> t n a+hoist :: (Monad m, Monad n)+    => (forall x. m x -> n x) -> Stream m a -> Stream n a hoist f str =     mkStream $ \st yld sng stp ->             let single = return . sng@@ -828,7 +587,7 @@ -------------------------------------------------------------------------------  {-# INLINE scanlx' #-}-scanlx' :: IsStream t => (x -> a -> x) -> x -> (x -> b) -> t m a -> t m b+scanlx' :: (x -> a -> x) -> x -> (x -> b) -> Stream m a -> Stream m b scanlx' step begin done m =     cons (done begin) $ go m begin     where@@ -840,7 +599,7 @@         in foldStream (adaptState st) yieldk single stp m1  {-# INLINE scanl' #-}-scanl' :: IsStream t => (b -> a -> b) -> b -> t m a -> t m b+scanl' :: (b -> a -> b) -> b -> Stream m a -> Stream m b scanl' step begin = scanlx' step begin id  -------------------------------------------------------------------------------@@ -848,8 +607,8 @@ -------------------------------------------------------------------------------  {-# INLINE filter #-}-filter :: IsStream t => (a -> Bool) -> t m a -> t m a-filter p m = go m+filter :: (a -> Bool) -> Stream m a -> Stream m a+filter p = go     where     go m1 = mkStream $ \st yld sng stp ->         let single a   | p a       = sng a@@ -859,8 +618,8 @@          in foldStream st yieldk single stp m1  {-# INLINE take #-}-take :: IsStream t => Int -> t m a -> t m a-take n m = go n m+take :: Int -> Stream m a -> Stream m a+take = go     where     go n1 m1 = mkStream $ \st yld sng stp ->         let yieldk a r = yld a (go (n1 - 1) r)@@ -869,8 +628,8 @@            else foldStream st yieldk sng stp m1  {-# INLINE takeWhile #-}-takeWhile :: IsStream t => (a -> Bool) -> t m a -> t m a-takeWhile p m = go m+takeWhile :: (a -> Bool) -> Stream m a -> Stream m a+takeWhile p = go     where     go m1 = mkStream $ \st yld sng stp ->         let single a   | p a       = sng a@@ -880,8 +639,8 @@          in foldStream st yieldk single stp m1  {-# INLINE drop #-}-drop :: IsStream t => Int -> t m a -> t m a-drop n m = fromStream $ unShare (go n (toStream m))+drop :: Int -> Stream m a -> Stream m a+drop n m = unShare (go n m)     where     go n1 m1 = mkStream $ \st yld sng stp ->         let single _ = stp@@ -892,8 +651,8 @@            else foldStreamShared st yieldk single stp m1  {-# INLINE dropWhile #-}-dropWhile :: IsStream t => (a -> Bool) -> t m a -> t m a-dropWhile p m = go m+dropWhile :: (a -> Bool) -> Stream m a -> Stream m a+dropWhile p = go     where     go m1 = mkStream $ \st yld sng stp ->         let single a   | p a       = stp@@ -909,12 +668,12 @@ -- Be careful when modifying this, this uses a consM (|:) deliberately to allow -- other stream types to overload it. {-# INLINE sequence #-}-sequence :: (IsStream t, MonadAsync m) => t m (m a) -> t m a-sequence m = go m+sequence :: Monad m => Stream m (m a) -> Stream m a+sequence = go     where     go m1 = mkStream $ \st yld sng stp ->         let single ma = ma >>= sng-            yieldk ma r = foldStreamShared st yld sng stp $ ma |: go r+            yieldk ma r = foldStreamShared st yld sng stp $ ma `consM` go r          in foldStream (adaptState st) yieldk single stp m1  -------------------------------------------------------------------------------@@ -922,24 +681,27 @@ -------------------------------------------------------------------------------  {-# INLINE intersperseM #-}-intersperseM :: (IsStream t, MonadAsync m) => m a -> t m a -> t m a-intersperseM a m = prependingStart m+intersperseM :: Monad m => m a -> Stream m a -> Stream m a+intersperseM a = prependingStart     where     prependingStart m1 = mkStream $ \st yld sng stp ->-        let yieldk i x = foldStreamShared st yld sng stp $ return i |: go x+        let yieldk i x =+                foldStreamShared st yld sng stp $ return i `consM` go x          in foldStream st yieldk sng stp m1     go m2 = mkStream $ \st yld sng stp ->-        let single i = foldStreamShared st yld sng stp $ a |: fromPure i-            yieldk i x = foldStreamShared st yld sng stp $ a |: return i |: go x+        let single i = foldStreamShared st yld sng stp $ a `consM` fromPure i+            yieldk i x =+                foldStreamShared+                    st yld sng stp $ a `consM` return i `consM` go x          in foldStream st yieldk single stp m2  {-# INLINE intersperse #-}-intersperse :: (IsStream t, MonadAsync m) => a -> t m a -> t m a+intersperse :: Monad m => a -> Stream m a -> Stream m a intersperse a = intersperseM (return a)  {-# INLINE insertBy #-}-insertBy :: IsStream t => (a -> a -> Ordering) -> a -> t m a -> t m a-insertBy cmp x m = go m+insertBy :: (a -> a -> Ordering) -> a -> Stream m a -> Stream m a+insertBy cmp x = go   where     go m1 = mkStream $ \st yld _ _ ->         let single a = case cmp x a of@@ -956,8 +718,8 @@ ------------------------------------------------------------------------------  {-# INLINE deleteBy #-}-deleteBy :: IsStream t => (a -> a -> Bool) -> a -> t m a -> t m a-deleteBy eq x m = go m+deleteBy :: (a -> a -> Bool) -> a -> Stream m a -> Stream m a+deleteBy eq x = go   where     go m1 = mkStream $ \st yld sng stp ->         let single a = if eq x a then stp else sng a@@ -966,26 +728,16 @@               else yld a (go r)          in foldStream st yieldk single stp m1 ---------------------------------------------------------------------------------- Reordering---------------------------------------------------------------------------------{-# INLINE reverse #-}-reverse :: IsStream t => t m a -> t m a-reverse = foldlS (flip cons) nil- ------------------------------------------------------------------------------- -- Map and Filter -------------------------------------------------------------------------------  {-# INLINE mapMaybe #-}-mapMaybe :: IsStream t => (a -> Maybe b) -> t m a -> t m b-mapMaybe f m = go m+mapMaybe :: (a -> Maybe b) -> Stream m a -> Stream m b+mapMaybe f = go   where     go m1 = mkStream $ \st yld sng stp ->-        let single a = case f a of-                Just b  -> sng b-                Nothing -> stp+        let single a = maybe stp sng (f a)             yieldk a r = case f a of                 Just b  -> yld b $ go r                 Nothing -> foldStream (adaptState st) yieldk single stp r@@ -998,10 +750,12 @@ -- | Zip two streams serially using a pure zipping function. -- -- @since 0.1.0-{-# INLINABLE zipWith #-}-zipWith :: IsStream t => (a -> b -> c) -> t m a -> t m b -> t m c+{-# INLINE zipWith #-}+zipWith :: (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c zipWith f = go+     where+     go mx my = mkStream $ \st yld sng stp -> do         let merge a ra =                 let single2 b = sng (f a b)@@ -1014,15 +768,17 @@ -- | Zip two streams serially using a monadic zipping function. -- -- @since 0.1.0-{-# INLINABLE zipWithM #-}-zipWithM :: (IsStream t, Monad m) => (a -> b -> m c) -> t m a -> t m b -> t m c-zipWithM f m1 m2 = go m1 m2+{-# INLINE zipWithM #-}+zipWithM :: Monad m =>+    (a -> b -> m c) -> Stream m a -> Stream m b -> Stream m c+zipWithM f = go+     where+     go mx my = mkStream $ \st yld sng stp -> do         let merge a ra =-                let runIt x = foldStream st yld sng stp x-                    single2 b   = f a b >>= sng-                    yield2 b rb = f a b >>= \x -> runIt (x `cons` go ra rb)+                let single2 b   = f a b >>= sng+                    yield2 b rb = f a b >>= \x -> yld x (go ra rb)                  in foldStream (adaptState st) yield2 single2 stp my         let single1 a = merge a nil             yield1 = merge@@ -1033,42 +789,144 @@ ------------------------------------------------------------------------------  {-# INLINE mergeByM #-}-mergeByM-    :: (IsStream t, Monad m)-    => (a -> a -> m Ordering) -> t m a -> t m a -> t m a+mergeByM :: Monad m =>+    (a -> a -> m Ordering) -> Stream m a -> Stream m a -> Stream m a mergeByM cmp = go+     where+     go mx my = mkStream $ \st yld sng stp -> do-        let mergeWithY a ra =-                let stop2 = foldStream st yld sng stp mx-                    single2 b = do-                        r <- cmp a b-                        case r of-                            GT -> yld b (go (a `cons` ra) nil)-                            _  -> yld a (go ra (b `cons` nil))-                    yield2 b rb = do-                        r <- cmp a b-                        case r of-                            GT -> yld b (go (a `cons` ra) rb)-                            _  -> yld a (go ra (b `cons` rb))-                 in foldStream st yield2 single2 stop2 my-        let stopX = foldStream st yld sng stp my-            singleX a = mergeWithY a nil-            yieldX = mergeWithY-        foldStream st yieldX singleX stopX mx+        let stop = foldStream st yld sng stp my+            single x = foldStream st yld sng stp (goX0 x my)+            yield x rx = foldStream st yld sng stp (goX x rx my)+        foldStream st yield single stop mx -{-# INLINABLE mergeBy #-}-mergeBy-    :: (IsStream t, Monad m)-    => (a -> a -> Ordering) -> t m a -> t m a -> t m a-mergeBy cmp = mergeByM (\a b -> return $ cmp a b)+    goX0 x my = mkStream $ \st yld sng _ -> do+        let stop = sng x+            single y = do+                r <- cmp x y+                case r of+                    GT -> yld y (fromPure x)+                    _  -> yld x (fromPure y)+            yield y ry = do+                r <- cmp x y+                case r of+                    GT -> yld y (goX0 x ry)+                    _  -> yld x (y `cons` ry)+         in foldStream st yield single stop my +    goX x mx my = mkStream $ \st yld _ _ -> do+        let stop = yld x mx+            single y = do+                r <- cmp x y+                case r of+                    GT -> yld y (x `cons` mx)+                    _  -> yld x (goY0 mx y)+            yield y ry = do+                r <- cmp x y+                case r of+                    GT -> yld y (goX x mx ry)+                    _  -> yld x (goY mx y ry)+         in foldStream st yield single stop my++    goY0 mx y = mkStream $ \st yld sng _ -> do+        let stop = sng y+            single x = do+                r <- cmp x y+                case r of+                    GT -> yld y (fromPure x)+                    _  -> yld x (fromPure y)+            yield x rx = do+                r <- cmp x y+                case r of+                    GT -> yld y (x `cons` rx)+                    _  -> yld x (goY0 rx y)+         in foldStream st yield single stop mx++    goY mx y my = mkStream $ \st yld _ _ -> do+        let stop = yld y my+            single x = do+                r <- cmp x y+                case r of+                    GT -> yld y (goX0 x my)+                    _  -> yld x (y `cons` my)+            yield x rx = do+                r <- cmp x y+                case r of+                    GT -> yld y (goX x rx my)+                    _  -> yld x (goY rx y my)+         in foldStream st yield single stop mx++{-# INLINE mergeBy #-}+mergeBy :: (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a+-- XXX GHC: This has slightly worse performance than replacing "r <- cmp x y"+-- with "let r = cmp x y" in the monadic version. The definition below is+-- exactly the same as mergeByM except this change.+-- mergeBy cmp = mergeByM (\a b -> return $ cmp a b)+mergeBy cmp = go++    where++    go mx my = mkStream $ \st yld sng stp -> do+        let stop = foldStream st yld sng stp my+            single x = foldStream st yld sng stp (goX0 x my)+            yield x rx = foldStream st yld sng stp (goX x rx my)+        foldStream st yield single stop mx++    goX0 x my = mkStream $ \st yld sng _ -> do+        let stop = sng x+            single y = do+                case cmp x y of+                    GT -> yld y (fromPure x)+                    _  -> yld x (fromPure y)+            yield y ry = do+                case cmp x y of+                    GT -> yld y (goX0 x ry)+                    _  -> yld x (y `cons` ry)+         in foldStream st yield single stop my++    goX x mx my = mkStream $ \st yld _ _ -> do+        let stop = yld x mx+            single y = do+                case cmp x y of+                    GT -> yld y (x `cons` mx)+                    _  -> yld x (goY0 mx y)+            yield y ry = do+                case cmp x y of+                    GT -> yld y (goX x mx ry)+                    _  -> yld x (goY mx y ry)+         in foldStream st yield single stop my++    goY0 mx y = mkStream $ \st yld sng _ -> do+        let stop = sng y+            single x = do+                case cmp x y of+                    GT -> yld y (fromPure x)+                    _  -> yld x (fromPure y)+            yield x rx = do+                case cmp x y of+                    GT -> yld y (x `cons` rx)+                    _  -> yld x (goY0 rx y)+         in foldStream st yield single stop mx++    goY mx y my = mkStream $ \st yld _ _ -> do+        let stop = yld y my+            single x = do+                case cmp x y of+                    GT -> yld y (goX0 x my)+                    _  -> yld x (y `cons` my)+            yield x rx = do+                case cmp x y of+                    GT -> yld y (goX x rx my)+                    _  -> yld x (goY rx y my)+         in foldStream st yield single stop mx+ ------------------------------------------------------------------------------ -- Transformation comprehensions ------------------------------------------------------------------------------  {-# INLINE the #-}-the :: (Eq a, IsStream t, Monad m) => t m a -> m (Maybe a)+the :: (Eq a, Monad m) => Stream m a -> m (Maybe a) the m = do     r <- uncons m     case r of@@ -1090,18 +948,6 @@ _alt m1 m2 = mkStream $ \st yld sng stp ->     let stop  = foldStream st yld sng stp m2     in foldStream st yld sng stop m1----------------------------------------------------------------------------------- MonadReader---------------------------------------------------------------------------------{-# INLINABLE withLocal #-}-withLocal :: MonadReader r m => (r -> r) -> Stream m a -> Stream m a-withLocal f m =-    mkStream $ \st yld sng stp ->-        let single = local f . sng-            yieldk a r = local f $ yld a (withLocal f r)-        in foldStream st yieldk single (local f stp) m  ------------------------------------------------------------------------------ -- MonadError
src/Streamly/Internal/Data/Stream/StreamK/Type.hs view
@@ -17,26 +17,15 @@ -- module Streamly.Internal.Data.Stream.StreamK.Type     (-    -- * A class for streams-      IsStream (..)-    , adapt-     -- * The stream type-    , Stream (..)+      Stream (..)+    , toStreamK+    , fromStreamK -    -- * Construction+    -- * foldr/build     , mkStream-    , fromStopK-    , fromYieldK-    , consK--    -- * Elimination     , foldStream     , foldStreamShared-    , foldl'-    , foldlx'--    -- * foldr/build     , foldrM     , foldrS     , foldrSShared@@ -45,27 +34,51 @@     , buildS     , buildM     , buildSM-    , sharedM     , augmentS     , augmentSM -    -- instances+    -- * Construction+    , fromStopK+    , fromYieldK+    , consK     , cons     , (.:)-    , consMStream+    , consM     , consMBy+    , nil+    , nilM++    -- * Generation     , fromEffect     , fromPure+    , unfoldr+    , unfoldrMWith+    , repeat+    , repeatMWith+    , replicateMWith+    , fromIndicesMWith+    , iterateMWith+    , fromFoldable+    , fromFoldableM+    , mfix -    , nil-    , nilM+    -- * Elimination+    , uncons+    , foldl'+    , foldlx'+    , drain+    , null+    , tail+    , init++    -- * Transformation     , conjoin     , serial     , map-    , mapM+    , mapMWith     , mapMSerial     , unShare-    , concatMapBy+    , concatMapWith     , concatMap     , bindWith     , concatPairsWith@@ -73,24 +86,25 @@     , apSerial     , apSerialDiscardFst     , apSerialDiscardSnd+    , foldlS+    , reverse -    , Streaming   -- deprecated+    -- * Reader+    , withLocal     ) where  import Control.Monad (ap, (>=>))+import Control.Monad.Reader.Class (MonadReader(..)) import Control.Monad.Trans.Class (MonadTrans(lift))-import Data.Kind (Type)--#if __GLASGOW_HASKELL__ < 808+import Data.Function (fix)+#if __GLASGOW_HASKELL__ < 804 import Data.Semigroup (Semigroup(..)) #endif-import Prelude hiding (map, mapM, concatMap, foldr)--import Streamly.Internal.Data.SVar---- $setup--- >>> import Streamly.Prelude as Stream+import Streamly.Internal.Data.SVar.Type (State, adaptState, defState)+import Prelude hiding+    (map, mapM, concatMap, foldr, repeat, null, reverse, tail, init)+import qualified Prelude  ------------------------------------------------------------------------------ -- Basic stream type@@ -125,140 +139,22 @@             -> m r             ) ---------------------------------------------------------------------------------- Types that can behave as a Stream---------------------------------------------------------------------------------infixr 5 `consM`-infixr 5 |:---- XXX Use a different SVar based on the stream type. But we need to make sure--- that we do not lose performance due to polymorphism.------ | Class of types that can represent a stream of elements of some type 'a' in--- some monad 'm'.------ /Since: 0.2.0 ("Streamly")/------ @since 0.8.0-class-#if __GLASGOW_HASKELL__ >= 806-    ( 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)-    ) =>-#endif-      IsStream t where-    toStream :: t m a -> Stream m a-    fromStream :: Stream m a -> t m a-    -- | Constructs a stream by adding a monadic action at the head of an-    -- existing stream. For example:-    ---    -- @-    -- > toList $ getLine \`consM` getLine \`consM` nil-    -- hello-    -- world-    -- ["hello","world"]-    -- @-    ---    -- /Concurrent (do not use 'fromParallel' to construct infinite streams)/-    ---    -- @since 0.2.0-    consM :: MonadAsync m => m a -> t m a -> t m a-    -- | Operator equivalent of 'consM'. We can read it as "@parallel colon@"-    -- to remember that @|@ comes before ':'.-    ---    -- @-    -- > toList $ getLine |: getLine |: nil-    -- hello-    -- world-    -- ["hello","world"]-    -- @-    ---    -- @-    -- let delay = threadDelay 1000000 >> print 1-    -- drain $ fromSerial  $ delay |: delay |: delay |: nil-    -- drain $ fromParallel $ delay |: delay |: delay |: nil-    -- @-    ---    -- /Concurrent (do not use 'fromParallel' to construct infinite streams)/-    ---    -- @since 0.2.0-    (|:) :: MonadAsync m => m a -> t m a -> t m a-    -- We can define (|:) just as 'consM' but it is defined explicitly for each-    -- type because we want to use SPECIALIZE pragma on the definition.---- | Same as 'IsStream'.------ @since 0.1.0-{-# DEPRECATED Streaming "Please use IsStream instead." #-}-type Streaming = IsStream------------------------------------------------------------------------------------ Type adapting combinators------------------------------------------------------------------------------------ XXX Move/reset the State here by reconstructing the stream with cleared--- state. Can we make sure we do not do that when t1 = t2? If we do this then--- we do not need to do that explicitly using svarStyle.  It would act as--- unShare when the stream type is the same.------ | Adapt any specific stream type to any other specific stream type.------ /Since: 0.1.0 ("Streamly")/------ @since 0.8.0-adapt :: (IsStream t1, IsStream t2) => t1 m a -> t2 m a-adapt = fromStream . toStream----------------------------------------------------------------------------------- Building a stream----------------------------------------------------------------------------------- XXX The State is always parameterized by "Stream" which means State is not--- different for different stream types. So we have to manually make sure that--- when converting from one stream to another we migrate the state correctly.--- This can be fixed if we use a different SVar type for different streams.--- Currently we always use "SVar Stream" and therefore a different State type--- parameterized by that stream.------ XXX Since t is coercible we should be able to coerce k--- mkStream k = fromStream $ MkStream $ coerce k------ | Build a stream from an 'SVar', a stop continuation, a singleton stream--- continuation and a yield continuation.-{-# INLINE_EARLY mkStream #-}-mkStream :: IsStream t-    => (forall r. State Stream m a-        -> (a -> t m a -> m r)-        -> (a -> m r)-        -> m r-        -> m r)-    -> t m a-mkStream k = fromStream $ MkStream $ \st yld sng stp ->-    let yieldk a r = yld a (toStream r)-     in k st yieldk sng stp+{-# INLINE fromStreamK #-}+fromStreamK :: Stream m a -> Stream m a+fromStreamK = id -{-# RULES "mkStream from stream" mkStream = mkStreamFromStream #-}-mkStreamFromStream :: IsStream t-    => (forall r. State Stream m a-        -> (a -> Stream m a -> m r)-        -> (a -> m r)-        -> m r-        -> m r)-    -> t m a-mkStreamFromStream k = fromStream $ MkStream k+{-# INLINE toStreamK #-}+toStreamK :: Stream m a -> Stream m a+toStreamK = id -{-# RULES "mkStream stream" mkStream = mkStreamStream #-}-mkStreamStream+mkStream     :: (forall r. State Stream m a         -> (a -> Stream m a -> m r)         -> (a -> m r)         -> m r         -> m r)     -> Stream m a-mkStreamStream = MkStream+mkStream = MkStream  -- | A terminal function that has no continuation to follow. type StopK m = forall r. m r -> m r@@ -270,20 +166,20 @@ type YieldK m a = forall r. (a -> m r) -> m r  _wrapM :: Monad m => m a -> YieldK m a-_wrapM m = \k -> m >>= k+_wrapM m = (m >>=)  -- | Make an empty stream from a stop function.-fromStopK :: IsStream t => StopK m -> t m a+fromStopK :: StopK m -> Stream m a fromStopK k = mkStream $ \_ _ _ stp -> k stp  -- | Make a singleton stream from a callback function. The callback function -- calls the one-shot yield continuation to yield an element.-fromYieldK :: IsStream t => YieldK m a -> t m a+fromYieldK :: YieldK m a -> Stream m a fromYieldK k = mkStream $ \_ _ sng _ -> k sng  -- | Add a yield function at the head of the stream.-consK :: IsStream t => YieldK m a -> t m a -> t m a-consK k r = mkStream $ \_ yld _ _ -> k (\x -> yld x r)+consK :: YieldK m a -> Stream m a -> Stream m a+consK k r = mkStream $ \_ yld _ _ -> k (`yld` r)  -- XXX Build a stream from a repeating callback function. @@ -306,8 +202,8 @@ -- -- @since 0.1.0 {-# INLINE_NORMAL cons #-}-cons :: IsStream t => a -> t m a -> t m a-cons a r = mkStream $ \_ yld _ _ -> yld a r+cons :: a -> Stream m a -> Stream m a+cons a r = mkStream $ \_ yield _ _ -> yield a r  infixr 5 .: @@ -320,7 +216,7 @@ -- -- @since 0.1.1 {-# INLINE (.:) #-}-(.:) :: IsStream t => a -> t m a -> t m a+(.:) :: a -> Stream m a -> Stream m a (.:) = cons  -- | An empty stream.@@ -332,7 +228,7 @@ -- -- @since 0.1.0 {-# INLINE_NORMAL nil #-}-nil :: IsStream t => t m a+nil :: Stream m a nil = mkStream $ \_ _ _ stp -> stp  -- | An empty stream producing a side effect.@@ -345,22 +241,32 @@ -- -- /Pre-release/ {-# INLINE_NORMAL nilM #-}-nilM :: (IsStream t, Monad m) => m b -> t m a-nilM m = mkStream $ \_ _ _ stp -> m >> stp+nilM :: Applicative m => m b -> Stream m a+nilM m = mkStream $ \_ _ _ stp -> m *> stp  {-# INLINE_NORMAL fromPure #-}-fromPure :: IsStream t => a -> t m a+fromPure :: a -> Stream m a fromPure a = mkStream $ \_ _ single _ -> single a  {-# INLINE_NORMAL fromEffect #-}-fromEffect :: (Monad m, IsStream t) => m a -> t m a-fromEffect m = fromStream $ mkStream $ \_ _ single _ -> m >>= single+fromEffect :: Monad m => m a -> Stream m a+fromEffect m = mkStream $ \_ _ single _ -> m >>= single +infixr 5 `consM`++-- NOTE: specializing the function outside the instance definition seems to+-- improve performance quite a bit at times, even if we have the same+-- SPECIALIZE in the instance definition.+{-# INLINE consM #-}+{-# SPECIALIZE consM :: IO a -> Stream IO a -> Stream IO a #-}+consM :: Monad m => m a -> Stream m a -> Stream m a+consM m r = MkStream $ \_ yld _ _ -> m >>= (`yld` r)+ -- 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 $ fromEffect m) `f` r+consMBy :: Monad m =>+    (Stream m a -> Stream m a -> Stream m a) -> m a -> Stream m a -> Stream m a+consMBy f m r = fromEffect m `f` r  ------------------------------------------------------------------------------ -- Folding a stream@@ -371,78 +277,27 @@ -- SVar passed via the State. {-# INLINE_EARLY foldStreamShared #-} foldStreamShared-    :: IsStream t-    => State Stream m a-    -> (a -> t m a -> m r)-    -> (a -> m r)-    -> m r-    -> t m a-    -> m r-foldStreamShared st yld sng stp m =-    let yieldk a x = yld a (fromStream x)-        MkStream k = toStream m-     in k st yieldk sng stp---- XXX write a similar rule for foldStream as well?-{-# RULES "foldStreamShared from stream"-   foldStreamShared = foldStreamSharedStream #-}-foldStreamSharedStream     :: State Stream m a     -> (a -> Stream m a -> m r)     -> (a -> m r)     -> m r     -> Stream m a     -> m r-foldStreamSharedStream st yld sng stp m =-    let MkStream k = toStream m-     in k st yld sng stp+foldStreamShared s yield single stop (MkStream k) = k s yield single stop  -- | Fold a stream by providing a State, stop continuation, a singleton -- continuation and a yield continuation. The stream will not use the SVar -- passed via State. {-# INLINE foldStream #-} foldStream-    :: IsStream t-    => State Stream m a-    -> (a -> t m a -> m r)+    :: State Stream m a+    -> (a -> Stream m a -> m r)     -> (a -> m r)     -> m r-    -> t m a+    -> Stream m a     -> m r-foldStream st yld sng stp m =-    let yieldk a x = yld a (fromStream x)-        MkStream k = toStream m-     in k (adaptState st) yieldk sng stp------------------------------------------------------------------------------------ Instances------------------------------------------------------------------------------------ NOTE: specializing the function outside the instance definition seems to--- improve performance quite a bit at times, even if we have the same--- SPECIALIZE in the instance definition.-{-# INLINE consMStream #-}-{-# SPECIALIZE consMStream :: IO a -> Stream IO a -> Stream IO a #-}-consMStream :: (Monad m) => m a -> Stream m a -> Stream m a-consMStream m r = MkStream $ \_ yld _ _ -> m >>= \a -> yld a r------------------------------------------------------------------------------------ IsStream Stream----------------------------------------------------------------------------------instance IsStream Stream where-    toStream = id-    fromStream = id--    {-# INLINE consM #-}-    {-# SPECIALIZE consM :: IO a -> Stream IO a -> Stream IO a #-}-    consM :: Monad m => m a -> Stream m a -> Stream m a-    consM = consMStream--    {-# INLINE (|:) #-}-    {-# SPECIALIZE (|:) :: IO a -> Stream IO a -> Stream IO a #-}-    (|:) :: Monad m => m a -> Stream m a -> Stream m a-    (|:) = consMStream+foldStream s yield single stop (MkStream k) =+    k (adaptState s) yield single stop  ------------------------------------------------------------------------------- -- foldr/build fusion@@ -455,14 +310,17 @@ -- reconstruct using a shared state (SVar) or without sharing the state. -- {-# INLINE foldrSWith #-}-foldrSWith :: IsStream t-    => (forall r. State Stream m b-        -> (b -> t m b -> m r)+foldrSWith ::+    (forall r. State Stream m b+        -> (b -> Stream m b -> m r)         -> (b -> m r)         -> m r-        -> t m b+        -> Stream m b         -> m r)-    -> (a -> t m b -> t m b) -> t m b -> t m a -> t m b+    -> (a -> Stream m b -> Stream m b)+    -> Stream m b+    -> Stream m a+    -> Stream m b foldrSWith f step final m = go m     where     go m1 = mkStream $ \st yld sng stp ->@@ -481,7 +339,11 @@  -- | Fold sharing the SVar state within the reconstructed stream {-# INLINE_NORMAL foldrSShared #-}-foldrSShared :: IsStream t => (a -> t m b -> t m b) -> t m b -> t m a -> t m b+foldrSShared ::+       (a -> Stream m b -> Stream m b)+    -> Stream m b+    -> Stream m a+    -> Stream m b foldrSShared = foldrSWith foldStreamShared  -- XXX consM is a typeclass method, therefore rewritten already. Instead maybe@@ -496,7 +358,11 @@  -- | Lazy right associative fold to a stream. {-# INLINE_NORMAL foldrS #-}-foldrS :: IsStream t => (a -> t m b -> t m b) -> t m b -> t m a -> t m b+foldrS ::+       (a -> Stream m b -> Stream m b)+    -> Stream m b+    -> Stream m a+    -> Stream m b foldrS = foldrSWith foldStream  {-# RULES "foldrS/id"     foldrS cons nil = \x -> x #-}@@ -513,14 +379,17 @@ -------------------------------------------------------------------------------  {-# INLINE foldrSMWith #-}-foldrSMWith :: (IsStream t, Monad m)+foldrSMWith :: Monad m     => (forall r. State Stream m b-        -> (b -> t m b -> m r)+        -> (b -> Stream m b -> m r)         -> (b -> m r)         -> m r-        -> t m b+        -> Stream m b         -> m r)-    -> (m a -> t m b -> t m b) -> t m b -> t m a -> t m b+    -> (m a -> Stream m b -> Stream m b)+    -> Stream m b+    -> Stream m a+    -> Stream m b foldrSMWith f step final m = go m     where     go m1 = mkStream $ \st yld sng stp ->@@ -531,8 +400,11 @@          in foldStream (adaptState st) yieldk single stop m1  {-# INLINE_NORMAL foldrSM #-}-foldrSM :: (IsStream t, Monad m)-    => (m a -> t m b -> t m b) -> t m b -> t m a -> t m b+foldrSM :: Monad m+    => (m a -> Stream m b -> Stream m b)+    -> Stream m b+    -> Stream m a+    -> Stream m b foldrSM = foldrSMWith foldStream  -- {-# RULES "foldrSM/id"     foldrSM consM nil = \x -> x #-}@@ -543,8 +415,11 @@  -- Like foldrSM but sharing the SVar state within the recostructed stream. {-# INLINE_NORMAL foldrSMShared #-}-foldrSMShared :: (IsStream t, Monad m)-    => (m a -> t m b -> t m b) -> t m b -> t m a -> t m b+foldrSMShared :: Monad m+    => (m a -> Stream m b -> Stream m b)+    -> Stream m b+    -> Stream m a+    -> Stream m b foldrSMShared = foldrSMWith foldStreamShared  -- {-# RULES "foldrSM/id"     foldrSM consM nil = \x -> x #-}@@ -560,7 +435,7 @@ -------------------------------------------------------------------------------  {-# INLINE_NORMAL build #-}-build :: IsStream t => forall a. (forall b. (a -> b -> b) -> b -> b) -> t m a+build :: forall m a. (forall b. (a -> b -> b) -> b -> b) -> Stream m a build g = g cons nil  {-# RULES "foldrM/build"@@ -585,37 +460,46 @@  -- build a stream by applying cons and nil to a build function {-# INLINE_NORMAL buildS #-}-buildS :: IsStream t => ((a -> t m a -> t m a) -> t m a -> t m a) -> t m a+buildS ::+       ((a -> Stream m a -> Stream m a) -> Stream m a -> Stream m a)+    -> Stream m a buildS g = g cons nil  {-# RULES "foldrS/buildS"-      forall k z (g :: (a -> t m a -> t m a) -> t m a -> t m a).+      forall k z+        (g :: (a -> Stream m a -> Stream m a) -> Stream m a -> Stream m a).       foldrS k z (buildS g) = g k z #-}  {-# RULES "foldrS/cons/buildS"-      forall k z x (g :: (a -> t m a -> t m a) -> t m a -> t m a).+      forall k z x+        (g :: (a -> Stream m a -> Stream m a) -> Stream m a -> Stream m a).       foldrS k z (x `cons` buildS g) = k x (g k z) #-}  {-# RULES "foldrSShared/buildS"-      forall k z (g :: (a -> t m a -> t m a) -> t m a -> t m a).+      forall k z+        (g :: (a -> Stream m a -> Stream m a) -> Stream m a -> Stream m a).       foldrSShared k z (buildS g) = g k z #-}  {-# RULES "foldrSShared/cons/buildS"-      forall k z x (g :: (a -> t m a -> t m a) -> t m a -> t m a).+      forall k z x+        (g :: (a -> Stream m a -> Stream m a) -> Stream m a -> Stream m a).       foldrSShared k z (x `cons` buildS g) = k x (g k z) #-}  -- build a stream by applying consM and nil to a build function {-# INLINE_NORMAL buildSM #-}-buildSM :: (IsStream t, MonadAsync m)-    => ((m a -> t m a -> t m a) -> t m a -> t m a) -> t m a+buildSM :: Monad m+    => ((m a -> Stream m a -> Stream m a) -> Stream m a -> Stream m a)+    -> Stream m a buildSM g = g consM nil  {-# RULES "foldrSM/buildSM"-     forall k z (g :: (m a -> t m a -> t m a) -> t m a -> t m a).+     forall k z+        (g :: (m a -> Stream m a -> Stream m a) -> Stream m a -> Stream m a).      foldrSM k z (buildSM g) = g k z #-}  {-# RULES "foldrSMShared/buildSM"-     forall k z (g :: (m a -> t m a -> t m a) -> t m a -> t m a).+     forall k z+        (g :: (m a -> Stream m a -> Stream m a) -> Stream m a -> Stream m a).      foldrSMShared k z (buildSM g) = g k z #-}  -- Disabled because this may not fire as consM is a class Op@@ -630,71 +514,79 @@ -- Build using monadic build functions (continuations) instead of -- reconstructing a stream. {-# INLINE_NORMAL buildM #-}-buildM :: (IsStream t, MonadAsync m)-    => (forall r. (a -> t m a -> m r)+buildM :: Monad m+    => (forall r. (a -> Stream m a -> m r)         -> (a -> m r)         -> m r         -> m r        )-    -> t m a+    -> Stream m a buildM g = mkStream $ \st yld sng stp ->     g (\a r -> foldStream st yld sng stp (return a `consM` r)) sng stp  -- | Like 'buildM' but shares the SVar state across computations.-{-# INLINE_NORMAL sharedM #-}-sharedM :: (IsStream t, MonadAsync m)-    => (forall r. (a -> t m a -> m r)+{-# INLINE_NORMAL sharedMWith #-}+sharedMWith :: Monad m+    => (m a -> Stream m a -> Stream m a)+    -> (forall r. (a -> Stream m a -> m r)         -> (a -> m r)         -> m r         -> m r        )-    -> t m a-sharedM g = mkStream $ \st yld sng stp ->-    g (\a r -> foldStreamShared st yld sng stp (return a `consM` r)) sng stp+    -> Stream m a+sharedMWith cns g = mkStream $ \st yld sng stp ->+    g (\a r -> foldStreamShared st yld sng stp (return a `cns` r)) sng stp  ------------------------------------------------------------------------------- -- augment -------------------------------------------------------------------------------  {-# INLINE_NORMAL augmentS #-}-augmentS :: IsStream t-    => ((a -> t m a -> t m a) -> t m a -> t m a) -> t m a -> t m a+augmentS ::+       ((a -> Stream m a -> Stream m a) -> Stream m a -> Stream m a)+    -> Stream m a+    -> Stream m a augmentS g xs = g cons xs  {-# RULES "augmentS/nil"-    forall (g :: (a -> t m a -> t m a) -> t m a -> t m a).+    forall (g :: (a -> Stream m a -> Stream m a) -> Stream m a -> Stream m a).     augmentS g nil = buildS g     #-}  {-# RULES "foldrS/augmentS"-    forall k z xs (g :: (a -> t m a -> t m a) -> t m a -> t m a).+    forall k z xs+        (g :: (a -> Stream m a -> Stream m a) -> Stream m a -> Stream m a).     foldrS k z (augmentS g xs) = g k (foldrS k z xs)     #-}  {-# RULES "augmentS/buildS"-    forall (g :: (a -> t m a -> t m a) -> t m a -> t m a)-           (h :: (a -> t m a -> t m a) -> t m a -> t m a).+    forall (g :: (a -> Stream m a -> Stream m a) -> Stream m a -> Stream m a)+           (h :: (a -> Stream m a -> Stream m a) -> Stream m a -> Stream m a).     augmentS g (buildS h) = buildS (\c n -> g c (h c n))     #-}  {-# INLINE_NORMAL augmentSM #-}-augmentSM :: (IsStream t, MonadAsync m)-    => ((m a -> t m a -> t m a) -> t m a -> t m a) -> t m a -> t m a+augmentSM :: Monad m =>+       ((m a -> Stream m a -> Stream m a) -> Stream m a -> Stream m a)+    -> Stream m a -> Stream m a augmentSM g xs = g consM xs  {-# RULES "augmentSM/nil"-    forall (g :: (m a -> t m a -> t m a) -> t m a -> t m a).+    forall+        (g :: (m a -> Stream m a -> Stream m a) -> Stream m a -> Stream m a).     augmentSM g nil = buildSM g     #-}  {-# RULES "foldrSM/augmentSM"-    forall k z xs (g :: (m a -> t m a -> t m a) -> t m a -> t m a).+    forall k z xs+        (g :: (m a -> Stream m a -> Stream m a) -> Stream m a -> Stream m a).     foldrSM k z (augmentSM g xs) = g k (foldrSM k z xs)     #-}  {-# RULES "augmentSM/buildSM"-    forall (g :: (m a -> t m a -> t m a) -> t m a -> t m a)-           (h :: (m a -> t m a -> t m a) -> t m a -> t m a).+    forall+        (g :: (m a -> Stream m a -> Stream m a) -> Stream m a -> Stream m a)+        (h :: (m a -> Stream m a -> Stream m a) -> Stream m a -> Stream m a).     augmentSM g (buildSM h) = buildSM (\c n -> g c (h c n))     #-} @@ -704,7 +596,7 @@  -- | Lazy right fold with a monadic step function. {-# INLINE_NORMAL foldrM #-}-foldrM :: IsStream t => (a -> m b -> m b) -> m b -> t m a -> m b+foldrM :: (a -> m b -> m b) -> m b -> Stream m a -> m b foldrM step acc m = go m     where     go m1 =@@ -716,16 +608,16 @@ {-# INLINE_NORMAL foldrMKWith #-} foldrMKWith     :: (State Stream m a-        -> (a -> t m a -> m b)+        -> (a -> Stream m a -> m b)         -> (a -> m b)         -> m b-        -> t m a+        -> Stream m a         -> m b)     -> (a -> m b -> m b)     -> m b-    -> ((a -> t m a -> m b) -> (a -> m b) -> m b -> m b)+    -> ((a -> Stream m a -> m b) -> (a -> m b) -> m b -> m b)     -> m b-foldrMKWith f step acc g = go g+foldrMKWith f step acc = go     where     go k =         let stop = acc@@ -743,7 +635,7 @@ -- XXX in which case will foldrM/buildM fusion be useful? {-# RULES "foldrM/buildM"     forall step acc (g :: (forall r.-           (a -> t m a -> m r)+           (a -> Stream m a -> m r)         -> (a -> m r)         -> m r         -> m r@@ -751,15 +643,17 @@     foldrM step acc (buildM g) = foldrMKWith foldStream step acc g     #-} +{- {-# RULES "foldrM/sharedM"     forall step acc (g :: (forall r.-           (a -> t m a -> m r)+           (a -> Stream m a -> m r)         -> (a -> m r)         -> m r         -> m r        )).     foldrM step acc (sharedM g) = foldrMKWith foldStreamShared step acc g     #-}+-}  ------------------------------------------------------------------------------ -- Left fold@@ -772,12 +666,12 @@ -- -- 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' :: forall m a b x. Monad m+    => (x -> a -> x) -> x -> (x -> b) -> Stream m a -> m b foldlx' step begin done m = get $ go m begin     where     {-# NOINLINE get #-}-    get :: t m x -> m b+    get :: Stream m x -> m b     get m1 =         -- XXX we are not strictly evaluating the accumulator here. Is this         -- okay?@@ -789,7 +683,7 @@     -- 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 :: Stream m a -> x -> Stream m x     go m1 !acc = mkStream $ \_ yld sng _ ->         let stop = sng acc             single a = sng $ step acc a@@ -800,10 +694,45 @@  -- | Strict left associative fold. {-# INLINE foldl' #-}-foldl' :: (IsStream t, Monad m) => (b -> a -> b) -> b -> t m a -> m b+foldl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> m b foldl' step begin = foldlx' step begin id  ------------------------------------------------------------------------------+-- Specialized folds+------------------------------------------------------------------------------++-- XXX use foldrM to implement folds where possible+-- XXX This (commented) definition of drain and mapM_ perform much better on+-- some benchmarks but worse on others. Need to investigate why, may there is+-- an optimization opportunity that we can exploit.+-- drain = foldrM (\_ xs -> return () >> xs) (return ())++-- |+-- > drain = foldl' (\_ _ -> ()) ()+-- > drain = mapM_ (\_ -> return ())+{-# INLINE drain #-}+drain :: Monad m => Stream m a -> m ()+drain = foldrM (\_ xs -> xs) (return ())+{-+drain = go+    where+    go m1 =+        let stop = return ()+            single _ = return ()+            yieldk _ r = go r+         in foldStream defState yieldk single stop m1+-}++{-# INLINE null #-}+null :: Monad m => Stream m a -> m Bool+-- null = foldrM (\_ _ -> return True) (return False)+null m =+    let stop      = return True+        single _  = return False+        yieldk _ _ = return False+    in foldStream defState yieldk single stop m++------------------------------------------------------------------------------ -- Semigroup ------------------------------------------------------------------------------ @@ -812,19 +741,8 @@ -- | Appends two streams sequentially, yielding all elements from the first -- stream, and then all elements from the second stream. ----- >>> 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+serial :: Stream m a -> Stream m a -> Stream m a -- XXX This doubles the time of toNullAp benchmark, may not be fusing properly -- serial xs ys = augmentS (\c n -> foldrS c n xs) ys serial m1 m2 = go m1@@ -837,8 +755,8 @@  -- join/merge/append streams depending on consM {-# INLINE conjoin #-}-conjoin :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a-conjoin xs ys = augmentSM (\c n -> foldrSM c n xs) ys+conjoin :: Monad m => Stream m a -> Stream m a -> Stream m a+conjoin xs = augmentSM (\c n -> foldrSM c n xs)  instance Semigroup (Stream m a) where     (<>) = serial@@ -857,10 +775,13 @@  -- Note eta expanded {-# INLINE_LATE mapFB #-}-mapFB :: forall (t :: (Type -> Type) -> Type -> Type) b m a.-    (b -> t m b -> t m b) -> (a -> b) -> a -> t m b -> t m b+mapFB :: forall b m a.+       (b -> Stream m b -> Stream m b)+    -> (a -> b)+    -> a+    -> Stream m b+    -> Stream m b mapFB c f = \x ys -> c (f x) ys-#undef Type  {-# RULES "mapFB/mapFB" forall c f g. mapFB (mapFB c f) g = mapFB c (f . g)@@ -868,7 +789,7 @@     #-}  {-# INLINE map #-}-map :: IsStream t => (a -> b) -> t m a -> t m b+map :: (a -> b) -> Stream m a -> Stream m b map f xs = buildS (\c n -> foldrS (mapFB c f) n xs)  -- XXX This definition might potentially be more efficient, but the cost in the@@ -887,7 +808,7 @@  {-# INLINE_LATE mapMFB #-} mapMFB :: Monad m => (m b -> t m b -> t m b) -> (a -> m b) -> m a -> t m b -> t m b-mapMFB c f = \x ys -> c (x >>= f) ys+mapMFB c f x = c (x >>= f)  {-# RULES     "mapMFB/mapMFB" forall c f g. mapMFB (mapMFB c f) g = mapMFB c (f >=> g)@@ -899,21 +820,6 @@ "mapMFB/return"  forall c.     mapMFB c (\x -> return x) = c -} --- Be careful when modifying this, this uses a consM (|:) deliberately to allow--- other stream types to overload it.-{-# INLINE mapM #-}-mapM :: (IsStream t, MonadAsync m) => (a -> m b) -> t m a -> t m b-mapM f = foldrSShared (\x xs -> f x `consM` xs) nil--- See note under map definition above.-{--mapM f m = go m-    where-    go m1 = mkStream $ \st yld sng stp ->-        let single a  = f a >>= sng-            yieldk a r = foldStreamShared st yld sng stp $ f a |: go r-         in foldStream (adaptState st) yieldk single stp m1-         -}- -- This is experimental serial version supporting fusion. -- -- XXX what if we do not want to fuse two concurrent mapMs?@@ -922,9 +828,27 @@ -- XXX fusion would be easier for monomoprhic stream types. -- {-# RULES "mapM serial" mapM = mapMSerial #-} {-# INLINE mapMSerial #-}-mapMSerial :: MonadAsync m => (a -> m b) -> Stream m a -> Stream m b+mapMSerial :: Monad m => (a -> m b) -> Stream m a -> Stream m b mapMSerial f xs = buildSM (\c n -> foldrSMShared (mapMFB c f) n xs) +{-# INLINE mapMWith #-}+mapMWith ::+       (m b -> Stream m b -> Stream m b)+    -> (a -> m b)+    -> Stream m a+    -> Stream m b+mapMWith cns f = foldrSShared (\x xs -> f x `cns` xs) nil++{-+-- See note under map definition above.+mapMWith cns f = go+    where+    go m1 = mkStream $ \st yld sng stp ->+        let single a  = f a >>= sng+            yieldk a r = foldStreamShared st yld sng stp $ f a `cns` go r+         in foldStream (adaptState st) yieldk single stp m1+-}+ -- XXX in fact use the Stream type everywhere and only use polymorphism in the -- high level modules/prelude. instance Monad m => Functor (Stream m) where@@ -944,18 +868,17 @@  -- | Detach a stream from an SVar {-# INLINE unShare #-}-unShare :: IsStream t => t m a -> t m a+unShare :: Stream m a -> Stream m a unShare x = mkStream $ \st yld sng stp ->     foldStream st yld sng stp x  -- XXX the function stream and value stream can run in parallel {-# INLINE apWith #-}-apWith-    :: IsStream t-    => (t m b -> t m b -> t m b)-    -> t m (a -> b)-    -> t m a-    -> t m b+apWith ::+       (Stream m b -> Stream m b -> Stream m b)+    -> Stream m (a -> b)+    -> Stream m a+    -> Stream m b apWith par fstream stream = go1 fstream      where@@ -974,11 +897,10 @@             in foldStream (adaptState st) yieldk single stp m  {-# INLINE apSerial #-}-apSerial-    :: IsStream t-    => t m (a -> b)-    -> t m a-    -> t m b+apSerial ::+       Stream m (a -> b)+    -> Stream m a+    -> Stream m b apSerial fstream stream = go1 fstream      where@@ -1005,11 +927,10 @@             in foldStream (adaptState st) yieldk single stp m  {-# INLINE apSerialDiscardFst #-}-apSerialDiscardFst-    :: IsStream t-    => t m a-    -> t m b-    -> t m b+apSerialDiscardFst ::+       Stream m a+    -> Stream m b+    -> Stream m b apSerialDiscardFst fstream stream = go1 fstream      where@@ -1017,7 +938,7 @@     go1 m =         mkStream $ \st yld sng stp ->             let foldShared = foldStreamShared st yld sng stp-                single _   = foldShared $ stream+                single _   = foldShared stream                 yieldk _ r = foldShared $ go2 r stream             in foldStream (adaptState st) yieldk single stp m @@ -1030,11 +951,10 @@             in foldStream st yieldk single stop m  {-# INLINE apSerialDiscardSnd #-}-apSerialDiscardSnd-    :: IsStream t-    => t m a-    -> t m b-    -> t m a+apSerialDiscardSnd ::+       Stream m a+    -> Stream m b+    -> Stream m a apSerialDiscardSnd fstream stream = go1 fstream      where@@ -1060,17 +980,16 @@                 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+-- XXX This is just concatMapWith with arguments flipped. We need to keep this -- instead of using a concatMap style definition because the bind -- implementation in Async and WAsync streams show significant perf degradation -- if the argument order is changed. {-# INLINE bindWith #-}-bindWith-    :: IsStream t-    => (t m b -> t m b -> t m b)-    -> t m a-    -> (a -> t m b)-    -> t m b+bindWith ::+       (Stream m b -> Stream m b -> Stream m b)+    -> Stream m a+    -> (a -> Stream m b)+    -> Stream m b bindWith par m1 f = go m1     where         go m =@@ -1095,21 +1014,18 @@ -- function. -- -- @since 0.7.0-{-# INLINE concatMapBy #-}-concatMapBy-    :: IsStream t-    => (t m b -> t m b -> t m b)-    -> (a -> t m b)-    -> t m a-    -> t m b-concatMapBy par f xs = bindWith par xs f+{-# INLINE concatMapWith #-}+concatMapWith+    ::+       (Stream m b -> Stream m b -> Stream m b)+    -> (a -> Stream m b)+    -> Stream m a+    -> Stream m b+concatMapWith par f xs = bindWith par xs f  {-# INLINE concatMap #-}-concatMap :: IsStream t => (a -> t m b) -> t m a -> t m b-concatMap f m = fromStream $-    concatMapBy serial-        (\a -> adapt $ toStream $ f a)-        (adapt $ toStream m)+concatMap :: (a -> Stream m b) -> Stream m a -> Stream m b+concatMap = concatMapWith serial  {- -- Fused version.@@ -1134,46 +1050,62 @@ -- {-# 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+    ::+       (Stream m b -> Stream m b -> Stream m b)+    -> (a -> Stream m b)+    -> Stream m a+    -> Stream m b+concatPairsWith combine f str = go (leafPairs str)      where -    go Nothing stream =+    go 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+                single a   = foldShared $ unShare a+                yieldk a r = foldShared $ go1 a r             in foldStream (adaptState st) yieldk single stp stream-    go (Just a1) stream =++    go1 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+                stop = foldShared $ unShare a1+                single a = foldShared $ unShare a1 `combine` a                 yieldk a r =-                    foldShared-                        $ concatPairsWith combine-                            (\(x,y) -> combine (unShare x) y)-                        $ (f a1, f a) `cons` makePairs Nothing r+                    foldShared $ go $ combine a1 a `cons` nonLeafPairs r             in foldStream (adaptState st) yieldk single stop stream -    makePairs Nothing stream =+    -- Exactly the same as "go" except that stop continuation extracts the+    -- stream.+    leafPairs stream =         mkStream $ \st yld sng stp ->             let foldShared = foldStreamShared st yld sng stp-                single a   = sng (f a, nil)-                yieldk a r = foldShared $ makePairs (Just a) r+                single a   = sng (f a)+                yieldk a r = foldShared $ leafPairs1 a r             in foldStream (adaptState st) yieldk single stp stream-    makePairs (Just a1) stream =++    leafPairs1 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)+            let stop = sng (f a1)+                single a = sng (f a1 `combine` f a)+                yieldk a r = yld (f a1 `combine` f a) $ leafPairs r             in foldStream (adaptState st) yieldk single stop stream +    -- Exactly the same as "leafPairs" except that it does not map "f"+    nonLeafPairs stream =+        mkStream $ \st yld sng stp ->+            let foldShared = foldStreamShared st yld sng stp+                single a   = sng a+                yieldk a r = foldShared $ nonLeafPairs1 a r+            in foldStream (adaptState st) yieldk single stp stream++    nonLeafPairs1 a1 stream =+        mkStream $ \st yld sng _ ->+            let stop = sng a1+                single a = sng (a1 `combine` a)+                yieldk a r = yld (a1 `combine` a) $ nonLeafPairs r+            in foldStream (adaptState st) yieldk single stop stream+ instance Monad m => Applicative (Stream m) where     {-# INLINE pure #-}     pure = fromPure@@ -1196,3 +1128,193 @@     => (b -> t m (Maybe (a, b))) -> t m b -> t m a concatUnfoldr = undefined -}++------------------------------------------------------------------------------+-- MonadReader+------------------------------------------------------------------------------++{-# INLINABLE withLocal #-}+withLocal :: MonadReader r m => (r -> r) -> Stream m a -> Stream m a+withLocal f m =+    mkStream $ \st yld sng stp ->+        let single = local f . sng+            yieldk a r = local f $ yld a (withLocal f r)+        in foldStream st yieldk single (local f stp) m++-------------------------------------------------------------------------------+-- Generation+-------------------------------------------------------------------------------++{-# INLINE unfoldr #-}+unfoldr :: (b -> Maybe (a, b)) -> b -> Stream m a+unfoldr next s0 = build $ \yld stp ->+    let go s =+            case next s of+                Just (a, b) -> yld a (go b)+                Nothing -> stp+    in go s0++{-# INLINE unfoldrMWith #-}+unfoldrMWith :: Monad m =>+       (m a -> Stream m a -> Stream m a)+    -> (b -> m (Maybe (a, b)))+    -> b+    -> Stream m a+unfoldrMWith cns step = go++    where++    go s = sharedMWith cns $ \yld _ stp -> do+                r <- step s+                case r of+                    Just (a, b) -> yld a (go b)+                    Nothing -> stp++-- | Generate an infinite stream by repeating a pure value.+--+-- /Pre-release/+{-# INLINE repeat #-}+repeat :: a -> Stream m a+repeat a = let x = cons a x in x++-- | Like 'repeatM' but takes a stream 'cons' operation to combine the actions+-- in a stream specific manner. A serial cons would repeat the values serially+-- while an async cons would repeat concurrently.+--+-- /Pre-release/+repeatMWith :: (m a -> t m a -> t m a) -> m a -> t m a+repeatMWith cns = go++    where++    go m = m `cns` go m++{-# INLINE replicateMWith #-}+replicateMWith :: (m a -> Stream m a -> Stream m a) -> Int -> m a -> Stream m a+replicateMWith cns n m = go n++    where++    go cnt = if cnt <= 0 then nil else m `cns` go (cnt - 1)++{-# INLINE fromIndicesMWith #-}+fromIndicesMWith ::+    (m a -> Stream m a -> Stream m a) -> (Int -> m a) -> Stream m a+fromIndicesMWith cns gen = go 0++    where++    go i = mkStream $ \st stp sng yld -> do+        foldStreamShared st stp sng yld (gen i `cns` go (i + 1))++{-# INLINE iterateMWith #-}+iterateMWith :: Monad m =>+    (m a -> Stream m a -> Stream m a) -> (a -> m a) -> m a -> Stream m a+iterateMWith cns step = go++    where++    go s = mkStream $ \st stp sng yld -> do+        !next <- s+        foldStreamShared st stp sng yld (return next `cns` go (step next))++{-# INLINE headPartial #-}+headPartial :: Monad m => Stream m a -> m a+headPartial = foldrM (\x _ -> return x) (error "head of nil")++{-# INLINE tailPartial #-}+tailPartial :: Stream m a -> Stream m a+tailPartial m = mkStream $ \st yld sng stp ->+    let stop      = error "tail of nil"+        single _  = stp+        yieldk _ r = foldStream st yld sng stp r+    in foldStream st yieldk single stop m++{-# INLINE mfix #-}+mfix :: Monad m => (m a -> Stream m a) -> Stream m a+mfix f = mkStream $ \st yld sng stp ->+    let single a  = foldStream st yld sng stp $ a `cons` ys+        yieldk a _ = foldStream st yld sng stp $ a `cons` ys+    in foldStream st yieldk single stp xs++    where++    -- fix the head element of the stream+    xs = fix  (f . headPartial)++    -- now fix the tail recursively+    ys = mfix (tailPartial . f)++-------------------------------------------------------------------------------+-- Conversions+-------------------------------------------------------------------------------++-- |+-- @+-- fromFoldable = 'Prelude.foldr' 'cons' 'nil'+-- @+--+-- Construct a stream from a 'Foldable' containing pure values:+--+-- @since 0.2.0+{-# INLINE fromFoldable #-}+fromFoldable :: Foldable f => f a -> Stream m a+fromFoldable = Prelude.foldr cons nil++{-# INLINE fromFoldableM #-}+fromFoldableM :: (Foldable f, Monad m) => f (m a) -> Stream m a+fromFoldableM = Prelude.foldr consM nil++-------------------------------------------------------------------------------+-- Deconstruction+-------------------------------------------------------------------------------++{-# INLINE uncons #-}+uncons :: Applicative m => Stream m a -> m (Maybe (a, Stream m a))+uncons m =+    let stop = pure Nothing+        single a = pure (Just (a, nil))+        yieldk a r = pure (Just (a, r))+    in foldStream defState yieldk single stop m++{-# INLINE tail #-}+tail :: Applicative m => Stream m a -> m (Maybe (Stream m a))+tail =+    let stop      = pure Nothing+        single _  = pure $ Just nil+        yieldk _ r = pure $ Just r+    in foldStream defState yieldk single stop++{-# INLINE init #-}+init :: Applicative m => Stream m a -> m (Maybe (Stream m a))+init = go1+    where+    go1 m1 = do+        (\case+            Nothing -> Nothing+            Just (h, t) -> Just $ go h t) <$> uncons m1+    go p m1 = mkStream $ \_ yld sng stp ->+        let single _ = sng p+            yieldk a x = yld p $ go a x+         in foldStream defState yieldk single stp m1++------------------------------------------------------------------------------+-- Reordering+------------------------------------------------------------------------------++-- | Lazy left fold to a stream.+{-# INLINE foldlS #-}+foldlS ::+    (Stream m b -> a -> Stream m b) -> Stream m b -> Stream m a -> Stream m b+foldlS step = go+    where+    go acc rest = mkStream $ \st yld sng stp ->+        let run x = foldStream st yld sng stp x+            stop = run acc+            single a = run $ step acc a+            yieldk a r = run $ go (step acc a) r+         in foldStream (adaptState st) yieldk single stop rest++{-# INLINE reverse #-}+reverse :: Stream m a -> Stream m a+reverse = foldlS (flip cons) nil
src/Streamly/Internal/Data/Stream/Zip.hs view
@@ -15,23 +15,20 @@ -- module Streamly.Internal.Data.Stream.Zip     (-      ZipSerialM+      ZipSerialM (..)     , ZipSerial-    , fromZipSerial+    , consMZip+    , zipWithK+    , zipWithMK -    , ZipAsyncM+    , ZipAsyncM(..)     , ZipAsync-    , fromZipAsync--    , zipWith-    , zipWithM-    , zipAsyncWith-    , zipAsyncWithM+    , consMZipAsync+    , zipAsyncWithK+    , zipAsyncWithMK      -- * Deprecated     , ZipStream-    , zipping-    , zippingAsync     ) where @@ -52,22 +49,17 @@        ( 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.Control.Concurrent (MonadAsync) import Streamly.Internal.Data.Maybe.Strict (Maybe'(..), toMaybe)-import Streamly.Internal.Data.SVar (MonadAsync)+import Streamly.Internal.Data.Stream.Serial (SerialT(..))+import Streamly.Internal.Data.Stream.StreamK.Type (Stream)  import qualified Streamly.Internal.Data.Stream.Parallel as Par import qualified Streamly.Internal.Data.Stream.Prelude as P-    (cmpBy, eqBy, foldl', foldr, fromList, toList, fromStreamS, toStreamS)-import qualified Streamly.Internal.Data.Stream.StreamK as K (repeat)+    (cmpBy, eqBy, foldl', foldr, fromList, toList) 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 (zipWith, zipWithM)-#else-import qualified Streamly.Internal.Data.Stream.StreamD as S (zipWith, zipWithM)-#endif+import qualified Streamly.Internal.Data.Stream.StreamD as D+import qualified Streamly.Internal.Data.Stream.Serial as Serial  import Prelude hiding (map, repeat, zipWith, errorWithoutStackTrace) @@ -83,48 +75,50 @@ --      return n                    -- IO Int -- :} --- | Like 'zipWith' but using a monadic zipping function.------ @since 0.4.0-{-# INLINABLE zipWithM #-}-zipWithM :: (IsStream t, Monad m) => (a -> b -> m c) -> t m a -> t m b -> t m c-zipWithM f m1 m2 = P.fromStreamS $ S.zipWithM f (P.toStreamS m1) (P.toStreamS m2)+{-# INLINE zipWithMK #-}+zipWithMK :: Monad m =>+    (a -> b -> m c) -> Stream m a -> Stream m b -> Stream m c+zipWithMK f m1 m2 =+    D.toStreamK $ D.zipWithM f (D.fromStreamK m1) (D.fromStreamK m2) --- | Zip two streams serially using a pure zipping function.------ @--- > S.toList $ S.zipWith (+) (S.fromList [1,2,3]) (S.fromList [4,5,6])--- [5,7,9]--- @------ @since 0.1.0-{-# INLINABLE zipWith #-}-zipWith :: (IsStream t, Monad m) => (a -> b -> c) -> t m a -> t m b -> t m c-zipWith f m1 m2 = P.fromStreamS $ S.zipWith f (P.toStreamS m1) (P.toStreamS m2)+{-# INLINE zipWithK #-}+zipWithK :: Monad m+    => (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c+zipWithK f = zipWithMK (\a b -> return (f a b))  ------------------------------------------------------------------------------ -- Parallel Zipping ------------------------------------------------------------------------------ --- | Like 'zipWithM' but zips concurrently i.e. both the streams being zipped--- are generated concurrently.+-- | Like 'zipAsyncWith' but with a monadic zipping function. -- -- @since 0.4.0-{-# INLINE zipAsyncWithM #-}-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 (Par.mkParallelD $ D.toStreamD m1)-                 (Par.mkParallelD $ D.toStreamD m2)+{-# INLINE zipAsyncWithMK #-}+zipAsyncWithMK :: MonadAsync m+    => (a -> b -> m c) -> Stream m a -> Stream m b -> Stream m c+zipAsyncWithMK f m1 m2 = D.toStreamK $+    D.zipWithM f (Par.mkParallelD $ D.fromStreamK m1)+                 (Par.mkParallelD $ D.fromStreamK m2) +-- XXX Should we rename this to zipParWith or zipParallelWith? This can happen+-- along with the change of behvaior to end the stream concurrently.+-- -- | Like 'zipWith' but zips concurrently i.e. both the streams being zipped--- are generated concurrently.+-- are evaluated concurrently using the 'ParallelT' concurrent evaluation+-- style. The maximum number of elements of each stream evaluated in advance+-- can be controlled by 'maxBuffer'. --+-- The stream ends if stream @a@ or stream @b@ ends. However, if stream @b@+-- ends while we are still evaluating stream @a@ and waiting for a result then+-- stream will not end until after the evaluation of stream @a@ finishes. This+-- behavior can potentially be changed in future to end the stream immediately+-- as soon as any of the stream end is detected.+-- -- @since 0.1.0-{-# INLINE zipAsyncWith #-}-zipAsyncWith :: (IsStream t, MonadAsync m)-    => (a -> b -> c) -> t m a -> t m b -> t m c-zipAsyncWith f = zipAsyncWithM (\a b -> return (f a b))+{-# INLINE zipAsyncWithK #-}+zipAsyncWithK :: MonadAsync m+    => (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c+zipAsyncWithK f = zipAsyncWithMK (\a b -> return (f a b))  ------------------------------------------------------------------------------ -- Serially Zipping Streams@@ -163,49 +157,21 @@ -- @since 0.8.0 type ZipSerial = ZipSerialM IO --- | Fix the type of a polymorphic stream as 'ZipSerialM'.------ /Since: 0.2.0 ("Streamly")/------ @since 0.8.0-fromZipSerial :: IsStream t => ZipSerialM m a -> t m a-fromZipSerial = K.adapt---- | Same as 'fromZipSerial'.------ @since 0.1.0-{-# DEPRECATED zipping "Please use fromZipSerial instead." #-}-zipping :: IsStream t => ZipSerialM m a -> t m a-zipping = fromZipSerial- consMZip :: Monad m => m a -> ZipSerialM m a -> ZipSerialM m a-consMZip m ms = fromStream $ K.consMStream m (toStream ms)--instance IsStream ZipSerialM where-    toStream = getZipSerialM-    fromStream = ZipSerialM--    {-# INLINE consM #-}-    {-# SPECIALIZE consM :: IO a -> ZipSerialM IO a -> ZipSerialM IO a #-}-    consM :: Monad m => m a -> ZipSerialM m a -> ZipSerialM m a-    consM = consMZip--    {-# INLINE (|:) #-}-    {-# SPECIALIZE (|:) :: IO a -> ZipSerialM IO a -> ZipSerialM IO a #-}-    (|:) :: Monad m => m a -> ZipSerialM m a -> ZipSerialM m a-    (|:) = consMZip+consMZip m (ZipSerialM r) = ZipSerialM $ K.consM m r  LIST_INSTANCES(ZipSerialM) NFDATA1_INSTANCE(ZipSerialM)  instance Monad m => Functor (ZipSerialM m) where     {-# INLINE fmap #-}-    fmap f (ZipSerialM m) = D.fromStreamD $ D.mapM (return . f) $ D.toStreamD m+    fmap f (ZipSerialM m) = ZipSerialM $ getSerialT $ fmap f (SerialT m)  instance Monad m => Applicative (ZipSerialM m) where-    pure = ZipSerialM . K.repeat+    pure = ZipSerialM . getSerialT . Serial.repeat+     {-# INLINE (<*>) #-}-    (<*>) = zipWith id+    ZipSerialM m1 <*> ZipSerialM m2 = ZipSerialM $ zipWithK id m1 m2  FOLDABLE_INSTANCE(ZipSerialM) TRAVERSABLE_INSTANCE(ZipSerialM)@@ -242,43 +208,15 @@ -- @since 0.8.0 type ZipAsync = ZipAsyncM IO --- | Fix the type of a polymorphic stream as 'ZipAsyncM'.------ /Since: 0.2.0 ("Streamly")/------ @since 0.8.0-fromZipAsync :: IsStream t => ZipAsyncM m a -> t m a-fromZipAsync = K.adapt---- | Same as 'fromZipAsync'.------ @since 0.1.0-{-# DEPRECATED zippingAsync "Please use fromZipAsync instead." #-}-zippingAsync :: IsStream t => ZipAsyncM m a -> t m a-zippingAsync = fromZipAsync- consMZipAsync :: Monad m => m a -> ZipAsyncM m a -> ZipAsyncM m a-consMZipAsync m ms = fromStream $ K.consMStream m (toStream ms)--instance IsStream ZipAsyncM where-    toStream = getZipAsyncM-    fromStream = ZipAsyncM--    {-# INLINE consM #-}-    {-# SPECIALIZE consM :: IO a -> ZipAsyncM IO a -> ZipAsyncM IO a #-}-    consM :: Monad m => m a -> ZipAsyncM m a -> ZipAsyncM m a-    consM = consMZipAsync--    {-# INLINE (|:) #-}-    {-# SPECIALIZE (|:) :: IO a -> ZipAsyncM IO a -> ZipAsyncM IO a #-}-    (|:) :: Monad m => m a -> ZipAsyncM m a -> ZipAsyncM m a-    (|:) = consMZipAsync+consMZipAsync m (ZipAsyncM r) = ZipAsyncM $ K.consM m r  instance Monad m => Functor (ZipAsyncM m) where     {-# INLINE fmap #-}-    fmap f (ZipAsyncM m) = D.fromStreamD $ D.mapM (return . f) $ D.toStreamD m+    fmap f (ZipAsyncM m) = ZipAsyncM $ getSerialT $ fmap f (SerialT m)  instance MonadAsync m => Applicative (ZipAsyncM m) where-    pure = ZipAsyncM . K.repeat+    pure = ZipAsyncM . getSerialT . Serial.repeat+     {-# INLINE (<*>) #-}-    m1 <*> m2 = zipAsyncWith id m1 m2+    ZipAsyncM m1 <*> ZipAsyncM m2 = ZipAsyncM $ zipAsyncWithK id m1 m2
src/Streamly/Internal/Data/Unfold.hs view
@@ -110,10 +110,6 @@       Step(..)     , Unfold -    -- * Folding-    , fold-    -- pipe-     -- * Unfolds     -- One to one correspondence with     -- "Streamly.Internal.Data.Stream.IsStream.Generate"@@ -140,19 +136,36 @@     , iterateM      -- ** Enumerations-    -- *** Enumerate Num+    , Enumerable (..)++    -- ** Enumerate Num+    , enumerateFromNum+    , enumerateFromThenNum     , enumerateFromStepNum-    , numFrom -    -- *** Enumerate Integral-    , enumerateFromStepIntegral-    , enumerateFromToIntegral+    -- ** Enumerating 'Bounded 'Integral' Types+    , enumerateFromIntegralBounded+    , enumerateFromThenIntegralBounded+    , enumerateFromToIntegralBounded+    , enumerateFromThenToIntegralBounded++    -- ** Enumerating 'Unounded Integral' Types     , enumerateFromIntegral+    , enumerateFromThenIntegral+    , enumerateFromToIntegral+    , enumerateFromThenToIntegral -    -- *** Enumerate Fractional-    -- | Use 'Num' enumerations for fractional or floating point number-    -- enumerations.+    -- ** Enumerating 'Small Integral' Types+    , enumerateFromSmallBounded+    , enumerateFromThenSmallBounded+    , enumerateFromToSmall+    , enumerateFromThenToSmall++    -- ** Enumerating 'Fractional' Types+    , enumerateFromFractional+    , enumerateFromThenFractional     , enumerateFromToFractional+    , enumerateFromThenToFractional      -- ** From Containers     , fromList@@ -162,9 +175,6 @@     , fromStreamK     , fromStreamD -    , fromSVar-    , fromProducer-     -- * Combinators     -- ** Mapping on Input     , lmap@@ -178,11 +188,21 @@     -- coapply     -- comonad +    -- * Folding+    , fold+     -- ** Mapping on Output     , map     , mapM     , mapMWithInput+    , scanlM'+    , scan+    , foldMany+    -- pipe +    -- ** Either Wrapped Input+    , either+     -- ** Filtering     , takeWhileM     , takeWhile@@ -226,95 +246,39 @@     ) where -import Control.Exception (Exception, fromException, mask_)-import Control.Monad ((>=>), when)+import Control.Exception (Exception, mask_) 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 Data.Functor (($>)) import GHC.Types (SPEC(..))+import Streamly.Internal.Control.Concurrent (MonadAsync) import Streamly.Internal.Data.Fold.Type (Fold(..)) import Streamly.Internal.Data.IOFinalizer     (newIOFinalizer, runIOFinalizer, clearingIOFinalizer)+import Streamly.Internal.Data.Stream.IsStream.Type (IsStream) import Streamly.Internal.Data.Stream.StreamD.Type (Stream(..), Step(..))-import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime)-import System.Mem (performMajorGC)+import Streamly.Internal.Data.SVar.Type (defState) -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.IsStream.Type as IsStream 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.Enumeration import Streamly.Internal.Data.Unfold.Type import Prelude        hiding (map, mapM, takeWhile, take, filter, const, zipWith-              , drop, dropWhile)+              , drop, dropWhile, either)  -- $setup -- >>> import qualified Streamly.Data.Fold as Fold -- >>> import qualified Streamly.Internal.Data.Unfold as Unfold+-- >>> import qualified Streamly.Prelude as Stream ----------------------------------------------------------------------------------- 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.@@ -360,6 +324,8 @@ -- Output operations ------------------------------------------------------------------------------- +-- XXX Do we need this combinator or the stream based idiom is enough?+ -- | Compose an 'Unfold' and a 'Fold'. Given an @Unfold m a b@ and a -- @Fold m b c@, returns a monadic action @a -> m c@ representing the -- application of the fold on the unfolded stream.@@ -367,6 +333,8 @@ -- >>> Unfold.fold Fold.sum Unfold.fromList [1..100] -- 5050 --+-- >>> fold f u = Stream.fold f . Stream.unfold u+-- -- /Pre-release/ -- {-# INLINE_NORMAL fold #-}@@ -391,6 +359,13 @@             Skip s -> go SPEC fs s             Stop -> extract fs +-- | Apply a fold multiple times on the output of an unfold.+--+-- /Unimplemented/+foldMany :: -- Monad m =>+    Fold m b c -> Unfold m a b -> Unfold m a c+foldMany = undefined+ -- | Apply a monadic function to each element of the stream and replace it -- with the output of the resulting action. --@@ -425,37 +400,101 @@             Stop      -> return Stop  -------------------------------------------------------------------------------+-- Either+-------------------------------------------------------------------------------++-- | Make an unfold operate on values wrapped in an @Either a a@ type. 'Right+-- a' translates to 'Right b' and 'Left a' translates to 'Left b'.+--+-- /Internal/+{-# INLINE_NORMAL either #-}+either :: Applicative m => Unfold m a b -> Unfold m (Either a a) (Either b b)+either (Unfold step1 inject1) = Unfold step inject++    where++    inject (Left a) = (, Left) <$> inject1 a+    inject (Right a) = (, Right) <$> inject1 a++    {-# INLINE_LATE step #-}+    step (st, f) = do+        (\case+            Yield x s -> Yield (f x) (s, f)+            Skip s -> Skip (s, f)+            Stop -> Stop) <$> step1 st++-- | Scan the output of an 'Unfold' to change it in a stateful manner.+--+-- /Pre-release/+{-# INLINE_NORMAL scan #-}+scan :: Monad m => Fold m b c -> Unfold m a b -> Unfold m a c+scan (Fold stepF initial extract) (Unfold stepU injectU) =+    Unfold step inject++    where++    inject a =  do+        r <- initial+        case r of+            FL.Partial fs -> Just . (fs,) <$> injectU a+            FL.Done _ -> return Nothing++    {-# INLINE_LATE step #-}+    step (Just (fs, us)) = do+        ru <- stepU us+        case ru of+            Yield x s -> do+                rf <- stepF fs x+                case rf of+                    FL.Done v -> return $ Yield v Nothing+                    FL.Partial fs1 -> do+                        v <- extract fs1+                        return $ Yield v (Just (fs1, s))+            Skip s -> return $ Skip (Just (fs, s))+            Stop -> return Stop++    step Nothing = return Stop++-- | Scan the output of an 'Unfold' to change it in a stateful manner.+--+-- /Unimplemented/+{-# INLINE_NORMAL scanlM' #-}+scanlM' :: Monad m => (b -> a -> m b) -> m b -> Unfold m c a -> Unfold m c b+scanlM' f z = scan (FL.foldlM' f z)++------------------------------------------------------------------------------- -- Convert streams into unfolds -------------------------------------------------------------------------------  {-# INLINE_NORMAL fromStreamD #-}-fromStreamD :: Monad m => Unfold m (Stream m a) a-fromStreamD = Unfold step return+fromStreamD :: Applicative m => Unfold m (Stream m a) a+fromStreamD = Unfold step pure+     where      {-# INLINE_LATE step #-}-    step (UnStream step1 state1) = do-        r <- step1 defState state1-        return $ case r of+    step (UnStream step1 state1) =+        (\case             Yield x s -> Yield x (Stream step1 s)             Skip s    -> Skip (Stream step1 s)-            Stop      -> Stop+            Stop      -> Stop) <$> step1 defState state1  {-# INLINE_NORMAL fromStreamK #-}-fromStreamK :: Monad m => Unfold m (K.Stream m a) a-fromStreamK = Unfold step return+fromStreamK :: Applicative m => Unfold m (K.Stream m a) a+fromStreamK = Unfold step pure      where      {-# INLINE_LATE step #-}     step stream = do-        r <- K.uncons stream-        return $ case r of+        (\case             Just (x, xs) -> Yield x xs-            Nothing -> Stop+            Nothing -> Stop) <$> K.uncons stream  -- XXX Using Unfold.fromStreamD seems to be faster (using cross product test -- case) than using fromStream even if it is implemented using fromStreamD.+-- Check if StreamK to StreamD rewrite rules are working correctly when+-- implementing fromStream 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.@@ -463,8 +502,8 @@ -- /Since: 0.8.0/ -- {-# INLINE_NORMAL fromStream #-}-fromStream :: (K.IsStream t, Monad m) => Unfold m (t m a) a-fromStream = lmap K.toStream fromStreamK+fromStream :: (IsStream t, Monad m) => Unfold m (t m a) a+fromStream = lmap IsStream.toStream fromStreamK  ------------------------------------------------------------------------------- -- Unfolds@@ -474,46 +513,50 @@ -- effect. -- {-# INLINE nilM #-}-nilM :: Monad m => (a -> m c) -> Unfold m a b-nilM f = Unfold step return+nilM :: Applicative m => (a -> m c) -> Unfold m a b+nilM f = Unfold step pure+     where+     {-# INLINE_LATE step #-}-    step x = f x >> return Stop+    step x = f x $> 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 :: Applicative m => (a -> m b) -> Unfold m a b -> Unfold m a b consM action unf = Unfold step inject      where -    inject = return . Left+    inject = pure . Left      {-# INLINE_LATE step #-}-    step (Left a) =-        action a >>= \r -> return $ Yield r (Right (D.unfold unf a))+    step (Left a) = (`Yield` Right (D.unfold unf a)) <$> action 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+        (\case+            Yield x s -> Yield x (Right (Stream step1 s))+            Skip s -> Skip (Right (Stream step1 s))+            Stop -> Stop) <$> step1 defState st +-- XXX Check if "unfold (fromList [1..10])" fuses, if it doesn't we can use+-- rewrite rules to rewrite list enumerations to unfold enumerations.+-- -- | Convert a list of pure values to a 'Stream' -- -- /Since: 0.8.0/ -- {-# INLINE_LATE fromList #-} fromList :: Monad m => Unfold m [a] a-fromList = Unfold step inject-  where-    inject = return+fromList = Unfold step pure++    where+     {-# INLINE_LATE step #-}-    step (x:xs) = return $ Yield x xs-    step []     = return Stop+    step (x:xs) = pure $ Yield x xs+    step [] = pure Stop  -- | Convert a list of monadic values to a 'Stream' --@@ -521,12 +564,13 @@ -- {-# INLINE_LATE fromListM #-} fromListM :: Monad m => Unfold m [m a] a-fromListM = Unfold step inject-  where-    inject = return+fromListM = Unfold step pure++    where+     {-# INLINE_LATE step #-}-    step (x:xs) = x >>= \r -> return $ Yield r xs-    step []     = return Stop+    step (x:xs) = (`Yield` xs) <$> x+    step [] = pure Stop  ------------------------------------------------------------------------------ -- Specialized Generation@@ -542,15 +586,13 @@      where -    inject x = return (x, n)+    inject action = pure (action, n)      {-# INLINE_LATE step #-}-    step (x, i) =+    step (action, i) =         if i <= 0-        then return Stop-        else do-            x1 <- x-            return $ Yield x1 (x, i - 1)+        then pure Stop+        else (\x -> Yield x (action, i - 1)) <$> action  -- | Generates an infinite stream repeating the seed. --@@ -558,10 +600,12 @@ -- {-# INLINE repeatM #-} repeatM :: Monad m => Unfold m (m a) a-repeatM = Unfold step return+repeatM = Unfold step pure+     where+     {-# INLINE_LATE step #-}-    step x = x >>= \x1 -> return $ Yield x1 x+    step action = (`Yield` action) <$> action  -- | Generates an infinite stream starting with the given seed and applying the -- given function repeatedly.@@ -571,11 +615,11 @@ {-# 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+    step x = Yield x <$> f x  -- | @fromIndicesM gen@ generates an infinite stream of values using @gen@ -- starting from the seed.@@ -587,13 +631,13 @@ -- /Pre-release/ -- {-# INLINE_NORMAL fromIndicesM #-}-fromIndicesM :: Monad m => (Int -> m a) -> Unfold m Int a-fromIndicesM gen = Unfold step return-  where+fromIndicesM :: Applicative m => (Int -> m a) -> Unfold m Int a+fromIndicesM gen = Unfold step pure++    where+     {-# INLINE_LATE step #-}-    step i = do-         x <- gen i-         return $ Yield x (i + 1)+    step i = (`Yield` (i + 1)) <$> gen i  ------------------------------------------------------------------------------- -- Filtering@@ -609,45 +653,18 @@ {-# 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)++    where++    inject x = (, 0) <$> inject1 x+     {-# INLINE_LATE step #-}     step (st, i) | i < n = do-        r <- step1 st-        return $ case r of+        (\case             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)+            Stop   -> Stop) <$> step1 st+    step (_, _) = pure Stop  -- | Same as 'filter' but with a monadic predicate. --@@ -685,26 +702,20 @@      where -    inject' a = do-        b <- inject a-        return (b, n)+    inject' a = (, n) <$> inject a      {-# 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+            (\case+                  Yield _ s -> Skip (s, i - 1)+                  Skip s -> Skip (s, i)+                  Stop -> Stop) <$> step st         | otherwise = do-            r <- step st-            return-                $ case r of-                      Yield x s -> Yield x (s, 0)-                      Skip s -> Skip (s, 0)-                      Stop -> Stop+            (\case+                  Yield x s -> Yield x (s, 0)+                  Skip s -> Skip (s, 0)+                  Stop -> Stop) <$> step st  -- | @dropWhileM f unf@ drops elements from the stream generated by @unf@ while -- the condition holds true. The condition function @f@ is /monadic/ in nature.@@ -750,204 +761,6 @@ 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 ------------------------------------------------------------------------------ @@ -995,10 +808,10 @@                 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+        return $ case res of+            Yield x s -> Yield x (Left s)+            Skip s    -> Skip (Left s)+            Stop      -> Stop  -- | Run the alloc action @a -> m c@ with async exceptions disabled but keeping -- blocking operations interruptible (see 'Control.Exception.mask').  Use the@@ -1060,10 +873,10 @@                 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+        return $ case res of+            Yield x s -> Yield x (Left s)+            Skip s    -> Skip (Left s)+            Stop      -> Stop  -- | Run a side effect @a -> m c@ on the input @a@ before unfolding it using -- @Unfold m a b@.@@ -1166,10 +979,10 @@     {-# 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+        return $ case res of+            Yield x s -> Yield x (s, v)+            Skip s    -> Skip (s, v)+            Stop      -> Stop  {-# INLINE_NORMAL _finally #-} _finally :: MonadCatch m => (a -> m c) -> Unfold m a b -> Unfold m a b
+ src/Streamly/Internal/Data/Unfold/Enumeration.hs view
@@ -0,0 +1,573 @@+-- |+-- Module      : Streamly.Internal.Data.Unfold.Enumeration+-- Copyright   : (c) 2019, 2021 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- The functions defined in this module should be rarely needed for direct use,+-- try to use the operations from the 'Enumerable' type class+-- instances instead.+--+-- This module provides an 'Enumerable' type class to enumerate 'Enum' types+-- into a stream. The operations in this type class correspond to similar+-- operations in the 'Enum' type class, the only difference is that they produce+-- a stream instead of a list. These operations cannot be defined generically+-- based on the 'Enum' type class. We provide instances for commonly used+-- types. If instances for other types are needed convenience functions defined+-- in this module can be used to define them. Alternatively, these functions+-- can be used directly.+--+module Streamly.Internal.Data.Unfold.Enumeration+    (+      Enumerable (..)++    -- ** Enumerating 'Num' Types+    , enumerateFromStepNum+    , enumerateFromNum+    , enumerateFromThenNum++    -- ** Enumerating unbounded 'Integral' Types+    , enumerateFromStepIntegral+    , enumerateFromIntegral+    , enumerateFromThenIntegral+    , enumerateFromToIntegral+    , enumerateFromThenToIntegral++    -- ** Enumerating 'Bounded' 'Integral' Types+    , enumerateFromIntegralBounded+    , enumerateFromThenIntegralBounded+    , enumerateFromToIntegralBounded+    , enumerateFromThenToIntegralBounded++    -- ** Enumerating small 'Integral' Types+    -- | Small types are always bounded.+    , enumerateFromSmallBounded+    , enumerateFromThenSmallBounded+    , enumerateFromToSmall+    , enumerateFromThenToSmall++    -- ** Enumerating 'Fractional' Types+    -- | Enumeration of 'Num' specialized to 'Fractional' types.+    , enumerateFromFractional+    , enumerateFromThenFractional+    , enumerateFromToFractional+    , enumerateFromThenToFractional+    )+where++#include "inline.hs"+import Data.Fixed+import Data.Bifunctor (bimap)+import Data.Int+import Data.Ratio+import Data.Word+import Numeric.Natural+import Data.Functor.Identity (Identity(..))+import Streamly.Internal.Data.Stream.StreamD.Step (Step(..))+import Streamly.Internal.Data.Unfold.Type+import Prelude+       hiding (map, mapM, takeWhile, take, filter, const, zipWith+              , drop, dropWhile)++-- $setup+-- >>> :m+-- >>> import qualified Streamly.Prelude as Stream+-- >>> import qualified Streamly.Internal.Data.Unfold as Unfold+-- >>> import Streamly.Internal.Data.Unfold.Type+-- >>> import Data.Word++------------------------------------------------------------------------------+-- Enumeration of Num+------------------------------------------------------------------------------++-- | Unfolds @(from, stride)@ generating an infinite stream starting from+-- @from@ and incrementing every time by @stride@.  For 'Bounded' types, after+-- the value overflows it keeps enumerating in a cycle:+--+-- @+-- >>> Stream.toList $ Stream.take 10 $ Stream.unfold Unfold.enumerateFromStepNum (255::Word8,1)+-- [255,0,1,2,3,4,5,6,7,8]+--+-- @+--+-- The implementation is numerically stable for floating point values.+--+-- Note 'enumerateFromStepIntegral' is faster for integrals.+--+-- /Internal/+--+{-# INLINE enumerateFromStepNum #-}+enumerateFromStepNum :: (Monad m, Num a) => Unfold m (a, a) a+enumerateFromStepNum = Unfold step inject++    where++    inject (!from, !stride) = return (from, stride, 0)++    -- Note that the counter "i" is the same type as the type being enumerated.+    -- It may overflow, for example, if we are enumerating Word8, after 255 the+    -- counter will become 0, but the overflow does not affect the enumeration+    -- behavior.+    {-# INLINE_LATE step #-}+    step (from, stride, i) =+        return $+            (Yield $! (from + i * stride)) $! (from, stride, i + 1)++-- | Same as 'enumerateFromStepNum (from, next)' using a stride of @next - from@:+--+-- @+-- >>> enumerateFromThenNum = lmap (\(from, next) -> (from, next - from)) Unfold.enumerateFromStepNum+--+-- @+--+-- Example:+-- @+-- >>> Stream.toList $ Stream.take 10 $ Stream.unfold enumerateFromThenNum (255::Word8,0)+-- [255,0,1,2,3,4,5,6,7,8]+--+-- @+--+-- The implementation is numerically stable for floating point values.+--+-- Note that 'enumerateFromThenIntegral' is faster for integrals.+--+-- Note that in the strange world of floating point numbers, using+-- @enumerateFromThenNum (from, from + 1)@ is almost exactly the same as+-- @enumerateFromStepNum (from, 1) but not precisely the same. Because @(from ++-- 1) - from@ is not exactly 1, it may lose some precision, the loss may also+-- be aggregated in each step, if you want that precision then use+-- 'enumerateFromStepNum' instead.+--+-- /Internal/+--+{-# INLINE enumerateFromThenNum #-}+enumerateFromThenNum :: (Monad m, Num a) => Unfold m (a, a) a+enumerateFromThenNum =+    lmap (\(from, next) -> (from, next - from)) enumerateFromStepNum++-- | Same as 'enumerateFromStepNum' using a stride of 1:+--+-- @+-- >>> enumerateFromNum = lmap (\from -> (from, 1)) Unfold.enumerateFromStepNum+-- >>> Stream.toList $ Stream.take 6 $ Stream.unfold enumerateFromNum (0.9)+-- [0.9,1.9,2.9,3.9,4.9,5.9]+--+-- @+--+-- Also, same as 'enumerateFromThenNum' using a stride of 1 but see the note in+-- 'enumerateFromThenNum' about the loss of precision:+--+-- @+-- >>> enumerateFromNum = lmap (\from -> (from, from + 1)) Unfold.enumerateFromThenNum+-- >>> Stream.toList $ Stream.take 6 $ Stream.unfold enumerateFromNum (0.9)+-- [0.9,1.9,2.9,3.8999999999999995,4.8999999999999995,5.8999999999999995]+--+-- @+--+-- /Internal/+--+{-# INLINE enumerateFromNum #-}+enumerateFromNum :: (Monad m, Num a) => Unfold m a a+enumerateFromNum = lmap (\from -> (from, 1)) enumerateFromStepNum++------------------------------------------------------------------------------+-- Enumeration of Integrals+------------------------------------------------------------------------------++-- | Can be used to enumerate unbounded integrals. This does not check for+-- overflow or underflow for bounded integrals.+--+-- /Internal/+{-# INLINE_NORMAL enumerateFromStepIntegral #-}+enumerateFromStepIntegral :: (Monad m, Integral a) => Unfold m (a, a) a+enumerateFromStepIntegral = Unfold step inject++    where++    inject (from, stride) = from `seq` stride `seq` return (from, stride)++    {-# INLINE_LATE step #-}+    step (x, stride) = return $ Yield x $! (x + stride, stride)++-- Enumerate Unbounded Integrals ----------------------------------------------+{-# INLINE enumerateFromIntegral #-}+enumerateFromIntegral :: (Monad m, Integral a) => Unfold m a a+enumerateFromIntegral = lmap (\from -> (from, 1)) enumerateFromStepIntegral++{-# INLINE enumerateFromThenIntegral #-}+enumerateFromThenIntegral :: (Monad m, Integral a ) => Unfold m (a, a) a+enumerateFromThenIntegral =+    lmap (\(from, next) -> (from, next - from)) enumerateFromStepIntegral++{-# INLINE enumerateFromToIntegral #-}+enumerateFromToIntegral :: (Monad m, Integral a) => Unfold m (a, a) a+enumerateFromToIntegral =+    takeWhileMWithInput (\(_, to) b -> return $ b <= to)+        $ lmap (\(from, _) -> (from, 1)) enumerateFromStepIntegral++{-# INLINE enumerateFromThenToIntegral #-}+enumerateFromThenToIntegral :: (Monad m, Integral a) => Unfold m (a, a, a) a+enumerateFromThenToIntegral =+    takeWhileMWithInput cond $ lmap toFromStep enumerateFromStepIntegral++    where++    toFromStep (from, next, _) = (from, next - from)++    cond (from, next, to) b =+        return+            $ if next >= from+              then b <= to+              else b >= to++-- Enumerate Bounded Integrals ------------------------------------------------+{-# INLINE enumerateFromIntegralBounded #-}+enumerateFromIntegralBounded :: (Monad m, Integral a, Bounded a) =>+    Unfold m a a+enumerateFromIntegralBounded = supplySecond maxBound enumerateFromToIntegral++{-# INLINE enumerateFromThenIntegralBounded #-}+enumerateFromThenIntegralBounded :: (Monad m, Integral a, Bounded a ) =>+    Unfold m (a, a) a+enumerateFromThenIntegralBounded =+    takeWhileMWithInput cond $ lmap toFromStep enumerateFromStepIntegral++    where++    toFromStep (from, next) = (from, next - from)++    cond (from, next) b =+        return+            $ if next >= from+              then b <= maxBound+              else b >= minBound++{-# INLINE enumerateFromToIntegralBounded #-}+enumerateFromToIntegralBounded :: (Monad m, Integral a, Bounded a) =>+    Unfold m (a, a) a+enumerateFromToIntegralBounded =+    takeWhileMWithInput (\(_, to) b -> return $ b <= to)+        $ lmap fst enumerateFromIntegralBounded++{-# INLINE enumerateFromThenToIntegralBounded #-}+enumerateFromThenToIntegralBounded :: (Monad m, Integral a, Bounded a) =>+    Unfold m (a, a, a) a+enumerateFromThenToIntegralBounded =+    takeWhileMWithInput cond $ lmap toFromThen enumerateFromThenIntegralBounded++    where++    toFromThen (from, next, _) = (from, next)++    cond (from, next, to) b =+        return+            $ if next >= from+              then b <= to+              else b >= to++------------------------------------------------------------------------------+-- Enumeration of Fractionals+------------------------------------------------------------------------------++{-# INLINE_NORMAL enumerateFromFractional #-}+enumerateFromFractional :: (Monad m, Fractional a) => Unfold m a a+enumerateFromFractional = enumerateFromNum++{-# INLINE_NORMAL enumerateFromThenFractional #-}+enumerateFromThenFractional :: (Monad m, Fractional a) => Unfold m (a, a) a+enumerateFromThenFractional = enumerateFromThenNum++-- | Same as 'enumerateFromStepNum' with a step of 1 and enumerating up to the+-- specified upper limit rounded to the nearest integral value:+--+-- @+-- >>> Stream.toList $ Stream.unfold Unfold.enumerateFromToFractional (0.1, 6.3)+-- [0.1,1.1,2.1,3.1,4.1,5.1,6.1]+--+-- @+--+-- /Internal/+--+{-# INLINE_NORMAL enumerateFromToFractional #-}+enumerateFromToFractional :: (Monad m, Fractional a, Ord a) =>+    Unfold m (a, a) a+enumerateFromToFractional =+    takeWhileMWithInput (\(_, to) b -> return $ b <= to + 1 / 2)+        $ lmap (\(from, _) -> (from, 1)) enumerateFromStepNum++{-# INLINE enumerateFromThenToFractional #-}+enumerateFromThenToFractional :: (Monad m, Fractional a, Ord a) =>+    Unfold m (a, a, a) a+enumerateFromThenToFractional =+    takeWhileMWithInput cond $ lmap toFromStep enumerateFromStepNum++    where++    toFromStep (from, next, _) = (from, next - from)++    cond (from, next, to) b =+        let stride = next - from+         in return+                $ if next >= from+                  then b <= to + stride / 2+                  else b >= to + stride / 2++-------------------------------------------------------------------------------+-- Enumeration of Enum types not larger than Int+-------------------------------------------------------------------------------++-- | Enumerate from given starting Enum value 'from' and to Enum value 'to'+-- with stride of 1 till to value.+--+-- /Internal/+--+{-# INLINE enumerateFromToSmall #-}+enumerateFromToSmall :: (Monad m, Enum a) => Unfold m (a, a) a+enumerateFromToSmall =+    fmap toEnum (lmap (bimap fromEnum fromEnum) enumerateFromToIntegral)++-- | Enumerate from given starting Enum value 'from' and then Enum value 'next'+-- and to Enum value 'to' with stride of (fromEnum next - fromEnum from)+-- till to value.+--+-- /Internal/+--+{-# INLINE enumerateFromThenToSmall #-}+enumerateFromThenToSmall :: (Monad m, Enum a) => Unfold m (a, a, a) a+enumerateFromThenToSmall =+    let toInts (x, y, z) = (fromEnum x, fromEnum y, fromEnum z)+     in fmap toEnum (lmap toInts enumerateFromThenToIntegral)++-------------------------------------------------------------------------------+-- Bounded Enumeration of Enum types not larger than Int+-------------------------------------------------------------------------------++-- | Enumerate from given starting Enum value 'from' with stride of 1 till+-- maxBound+--+-- /Internal/+--+{-# INLINE enumerateFromSmallBounded #-}+enumerateFromSmallBounded :: (Monad m, Enum a, Bounded a) => Unfold m a a+enumerateFromSmallBounded = supplySecond maxBound enumerateFromToSmall++-- | Enumerate from given starting Enum value 'from' and next Enum value 'next'+-- with stride of (fromEnum next - fromEnum from) till maxBound.+--+-- /Internal/+--+{-# INLINE enumerateFromThenSmallBounded #-}+enumerateFromThenSmallBounded :: forall m a. (Monad m, Enum a, Bounded a) =>+    Unfold m (a, a) a+enumerateFromThenSmallBounded =+    let adapt (from, next) =+            let frm = fromEnum from+                nxt = fromEnum next+                stride = nxt - frm+                to = if stride >= 0+                     then fromEnum (maxBound :: a)+                     else fromEnum (minBound :: a)+             in (frm, nxt, to)+     in fmap toEnum (lmap adapt enumerateFromThenToIntegral)++-------------------------------------------------------------------------------+-- Enumerable type class+-------------------------------------------------------------------------------++-- | Types that can be enumerated as a stream. The operations in this type+-- class are equivalent to those in the 'Enum' type class, except that these+-- generate a stream instead of a list. Use the functions in+-- "Streamly.Internal.Data.Unfold.Enumeration" module to define new instances.+--+-- /Pre-release/+class Enum a => Enumerable a where++    -- | Unfolds @from@ generating a stream starting with the element+    -- @from@, enumerating up to 'maxBound' when the type is 'Bounded' or+    -- generating an infinite stream when the type is not 'Bounded'.+    --+    -- >>> import qualified Streamly.Prelude as Stream+    -- >>> import qualified Streamly.Internal.Data.Unfold as Unfold+    --+    -- @+    -- >>> Stream.toList $ Stream.take 4 $ Stream.unfold Unfold.enumerateFrom (0 :: Int)+    -- [0,1,2,3]+    --+    -- @+    --+    -- For 'Fractional' types, enumeration is numerically stable. However, no+    -- overflow or underflow checks are performed.+    --+    -- @+    -- >>> Stream.toList $ Stream.take 4 $ Stream.unfold Unfold.enumerateFrom 1.1+    -- [1.1,2.1,3.1,4.1]+    --+    -- @+    --+    -- /Pre-release/+    --+    enumerateFrom :: Monad m => Unfold m a a++    -- | Unfolds @(from, to)@ generating a finite stream starting with the element+    -- @from@, enumerating the type up to the value @to@. If @to@ is smaller than+    -- @from@ then an empty stream is returned.+    --+    -- >>> import qualified Streamly.Prelude as Stream+    -- >>> import qualified Streamly.Internal.Data.Unfold as Unfold+    --+    -- @+    -- >>> Stream.toList $ Stream.unfold Unfold.enumerateFromTo (0, 4)+    -- [0,1,2,3,4]+    --+    -- @+    --+    -- For 'Fractional' types, the last element is equal to the specified @to@+    -- value after rounding to the nearest integral value.+    --+    -- @+    -- >>> Stream.toList $ Stream.unfold Unfold.enumerateFromTo (1.1, 4)+    -- [1.1,2.1,3.1,4.1]+    --+    -- >>> Stream.toList $ Stream.unfold Unfold.enumerateFromTo (1.1, 4.6)+    -- [1.1,2.1,3.1,4.1,5.1]+    --+    -- @+    --+    -- /Pre-release/+    enumerateFromTo :: Monad m => Unfold m (a, a) a++    -- | Unfolds @(from, then)@ generating a stream whose first element is+    -- @from@ and the successive elements are in increments of @then@.  Enumeration+    -- can occur downwards or upwards depending on whether @then@ comes before or+    -- after @from@. For 'Bounded' types the stream ends when 'maxBound' is+    -- reached, for unbounded types it keeps enumerating infinitely.+    --+    -- >>> import qualified Streamly.Prelude as Stream+    -- >>> import qualified Streamly.Internal.Data.Unfold as Unfold+    --+    -- @+    -- >>> Stream.toList $ Stream.take 4 $ Stream.unfold Unfold.enumerateFromThen (0, 2)+    -- [0,2,4,6]+    --+    -- >>> Stream.toList $ Stream.take 4 $ Stream.unfold Unfold.enumerateFromThen (0,(-2))+    -- [0,-2,-4,-6]+    --+    -- @+    --+    -- /Pre-release/+    enumerateFromThen :: Monad m => Unfold m (a, a) a++    -- | Unfolds @(from, then, to)@ generating a finite stream whose first element+    -- is @from@ and the successive elements are in increments of @then@ up to+    -- @to@. Enumeration can occur downwards or upwards depending on whether @then@+    -- comes before or after @from@.+    --+    -- >>> import qualified Streamly.Prelude as Stream+    -- >>> import qualified Streamly.Internal.Data.Unfold as Unfold+    --+    -- @+    -- >>> Stream.toList $ Stream.unfold Unfold.enumerateFromThenTo (0, 2, 6)+    -- [0,2,4,6]+    --+    -- >>> Stream.toList $ Stream.unfold Unfold.enumerateFromThenTo (0, (-2), (-6))+    -- [0,-2,-4,-6]+    --+    -- @+    --+    -- /Pre-release/+    enumerateFromThenTo :: Monad m => Unfold m (a, a, a) a++-------------------------------------------------------------------------------+-- Enumerable Instances+-------------------------------------------------------------------------------+--+-- For Enum types smaller than or equal to Int size.+#define ENUMERABLE_BOUNDED_SMALL(SMALL_TYPE)           \+instance Enumerable SMALL_TYPE where {                 \+    {-# INLINE enumerateFrom #-};                      \+    enumerateFrom = enumerateFromSmallBounded;         \+    {-# INLINE enumerateFromThen #-};                  \+    enumerateFromThen = enumerateFromThenSmallBounded; \+    {-# INLINE enumerateFromTo #-};                    \+    enumerateFromTo = enumerateFromToSmall;            \+    {-# INLINE enumerateFromThenTo #-};                \+    enumerateFromThenTo = enumerateFromThenToSmall }++ENUMERABLE_BOUNDED_SMALL(())+ENUMERABLE_BOUNDED_SMALL(Bool)+ENUMERABLE_BOUNDED_SMALL(Ordering)+ENUMERABLE_BOUNDED_SMALL(Char)++-- For bounded Integral Enum types, may be larger than Int.+#define ENUMERABLE_BOUNDED_INTEGRAL(INTEGRAL_TYPE)          \+instance Enumerable INTEGRAL_TYPE where {                   \+    {-# INLINE enumerateFrom #-};                           \+    enumerateFrom = enumerateFromIntegralBounded;           \+    {-# INLINE enumerateFromThen #-};                       \+    enumerateFromThen = enumerateFromThenIntegralBounded;   \+    {-# INLINE enumerateFromTo #-};                         \+    enumerateFromTo = enumerateFromToIntegralBounded;       \+    {-# INLINE enumerateFromThenTo #-};                     \+    enumerateFromThenTo = enumerateFromThenToIntegralBounded }++ENUMERABLE_BOUNDED_INTEGRAL(Int)+ENUMERABLE_BOUNDED_INTEGRAL(Int8)+ENUMERABLE_BOUNDED_INTEGRAL(Int16)+ENUMERABLE_BOUNDED_INTEGRAL(Int32)+ENUMERABLE_BOUNDED_INTEGRAL(Int64)+ENUMERABLE_BOUNDED_INTEGRAL(Word)+ENUMERABLE_BOUNDED_INTEGRAL(Word8)+ENUMERABLE_BOUNDED_INTEGRAL(Word16)+ENUMERABLE_BOUNDED_INTEGRAL(Word32)+ENUMERABLE_BOUNDED_INTEGRAL(Word64)++-- For unbounded Integral Enum types.+#define ENUMERABLE_UNBOUNDED_INTEGRAL(INTEGRAL_TYPE)              \+instance Enumerable INTEGRAL_TYPE where {                         \+    {-# INLINE enumerateFrom #-};                                 \+    enumerateFrom = enumerateFromIntegral;                        \+    {-# INLINE enumerateFromThen #-};                             \+    enumerateFromThen = enumerateFromThenIntegral;                \+    {-# INLINE enumerateFromTo #-};                               \+    enumerateFromTo = enumerateFromToIntegral;                    \+    {-# INLINE enumerateFromThenTo #-};                           \+    enumerateFromThenTo = enumerateFromThenToIntegral }++ENUMERABLE_UNBOUNDED_INTEGRAL(Integer)+ENUMERABLE_UNBOUNDED_INTEGRAL(Natural)++#define ENUMERABLE_FRACTIONAL(FRACTIONAL_TYPE,CONSTRAINT)         \+instance (CONSTRAINT) => Enumerable FRACTIONAL_TYPE where {       \+    {-# INLINE enumerateFrom #-};                                 \+    enumerateFrom = enumerateFromFractional;                      \+    {-# INLINE enumerateFromThen #-};                             \+    enumerateFromThen = enumerateFromThenFractional;              \+    {-# INLINE enumerateFromTo #-};                               \+    enumerateFromTo = enumerateFromToFractional;                  \+    {-# INLINE enumerateFromThenTo #-};                           \+    enumerateFromThenTo = enumerateFromThenToFractional }++ENUMERABLE_FRACTIONAL(Float,)+ENUMERABLE_FRACTIONAL(Double,)+ENUMERABLE_FRACTIONAL((Fixed a),HasResolution a)+ENUMERABLE_FRACTIONAL((Ratio a),Integral a)++instance Enumerable a => Enumerable (Identity a) where+    {-# INLINE enumerateFrom #-}+    enumerateFrom =+        map Identity $ lmap runIdentity enumerateFrom+    {-# INLINE enumerateFromThen #-}+    enumerateFromThen =+        map Identity $ lmap (bimap runIdentity runIdentity) enumerateFromThen+    {-# INLINE enumerateFromTo #-}+    enumerateFromTo  =+        map Identity $ lmap (bimap runIdentity runIdentity) enumerateFromThen+    {-# INLINE enumerateFromThenTo #-}+    enumerateFromThenTo  =+        map Identity $+            lmap+            (\(from, next, to) ->+                 (runIdentity from, runIdentity next, runIdentity to))+            enumerateFromThenTo
+ src/Streamly/Internal/Data/Unfold/SVar.hs view
@@ -0,0 +1,164 @@+-- |+-- Module      : Streamly.Internal.Data.Unfold.SVar+-- Copyright   : (c) 2019 Composewell Technologies+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+module Streamly.Internal.Data.Unfold.SVar+    (+      fromSVar+    , fromProducer+    )+where++#include "inline.hs"++import Control.Exception (fromException)+import Control.Monad (when)+import Control.Monad.IO.Class (MonadIO(..))+import Data.IORef (newIORef, readIORef, mkWeakIORef, writeIORef)+import Data.Maybe (isNothing)+import Streamly.Internal.Control.Concurrent (MonadAsync)+import Streamly.Internal.Data.Stream.StreamD.Type (Step(..))+import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime)+import Streamly.Internal.Data.SVar (printSVar, cleanupSVar, sendStopToProducer)+import System.Mem (performMajorGC)++import qualified Control.Monad.Catch as MC++import Streamly.Internal.Data.SVar.Type+import Streamly.Internal.Data.Unfold.Type+import Prelude+       hiding (map, mapM, takeWhile, take, filter, const, zipWith+              , drop, dropWhile, either)++-------------------------------------------------------------------------------+-- 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
src/Streamly/Internal/Data/Unfold/Type.hs view
@@ -30,11 +30,21 @@      -- * Transformations     , lmap+    , lmapM     , map+    , supply+    , supplyFirst+    , supplySecond +    -- * Trimming+    , takeWhileMWithInput+    , takeWhileM+    , takeWhile+     -- * Nesting     , ConcatState (..)     , many+    , manyInterleave      -- Applicative     , apSequence@@ -58,10 +68,13 @@  -- import Control.Arrow (Arrow(..)) -- import Control.Category (Category(..))+import Control.Monad ((>=>))+import Data.Void (Void) import Fusion.Plugin.Types (Fuse(..))+import Streamly.Internal.Data.Tuple.Strict (Tuple'(..)) import Streamly.Internal.Data.Stream.StreamD.Step (Step(..)) -import Prelude hiding (const, map, concatMap, zipWith)+import Prelude hiding (map, concatMap, zipWith, takeWhile)  -- $setup -- >>> import qualified Streamly.Prelude as Stream@@ -75,6 +88,10 @@ -- The order of arguments allows 'Category' and 'Arrow' instances but precludes -- contravariant and contra-applicative. --+-- An unfold is akin to a reader. It is the streaming equivalent of a reader.+-- The argument @a@ is the environment of the reader. That's the reason the+-- default unfolds in various modules are called "read".+-- -- | 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@. --@@ -159,7 +176,114 @@ lmap :: (a -> c) -> Unfold m c b -> Unfold m a b lmap f (Unfold ustep uinject) = Unfold ustep (uinject Prelude.. f) +-- | Map an action on the input argument of the 'Unfold'.+--+-- @+-- lmapM f = Unfold.many (Unfold.functionM f)+-- @+--+-- /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)+ ------------------------------------------------------------------------------+-- Filter input+------------------------------------------------------------------------------++{-# INLINE_NORMAL takeWhileMWithInput #-}+takeWhileMWithInput :: Monad m =>+    (a -> b -> m Bool) -> Unfold m a b -> Unfold m a b+takeWhileMWithInput f (Unfold step1 inject1) = Unfold step inject++    where++    inject a = do+        s <- inject1 a+        return $ Tuple' a s++    {-# INLINE_LATE step #-}+    step (Tuple' a st) = do+        r <- step1 st+        case r of+            Yield x s -> do+                b <- f a x+                return $ if b then Yield x (Tuple' a s) else Stop+            Skip s -> return $ Skip (Tuple' a s)+            Stop   -> return Stop++-- | Same as 'takeWhile' but with a monadic predicate.+--+-- /Since: 0.8.0/+--+{-# INLINE_NORMAL takeWhileM #-}+takeWhileM :: Monad m => (b -> m Bool) -> Unfold m a b -> Unfold m a b+-- XXX Check if the compiler simplifies the following to the same as the custom+-- implementation below (the Tuple' should help eliminate the unused param):+--+-- takeWhileM f = takeWhileMWithInput (\_ b -> f b)+takeWhileM f (Unfold step1 inject1) = Unfold step inject1+  where+    {-# INLINE_LATE step #-}+    step st = do+        r <- step1 st+        case r of+            Yield x s -> do+                b <- f x+                return $ if b then Yield x s else Stop+            Skip s -> return $ Skip s+            Stop   -> return Stop++-- | End the stream generated by the 'Unfold' as soon as the predicate fails+-- on an element.+--+-- /Since: 0.8.0/+--+{-# INLINE takeWhile #-}+takeWhile :: Monad m => (b -> Bool) -> Unfold m a b -> Unfold m a b+takeWhile f = takeWhileM (return . f)++------------------------------------------------------------------------------ -- Functor ------------------------------------------------------------------------------ @@ -567,3 +691,87 @@     {-# INLINE (***) #-}     u1 *** u2 = zipWith (,) (lmap fst u1) (lmap snd u2) -}++------------------------------------------------------------------------------+-- Interleaving+------------------------------------------------------------------------------++-- We can possibly have an "interleave" operation to interleave the streams+-- from two seeds:+--+-- interleave :: Unfold m x a -> Unfold m x a -> Unfold m (x, x) a+--+-- Alternatively, we can use a signature like zipWith:+-- interleave :: Unfold m x a -> Unfold m x a -> Unfold m x a+--+-- We can implement this in terms of manyInterleave, but that may+-- not be as efficient as a custom implementation.+--+-- Similarly we can also have other binary combining ops like append, mergeBy.+-- We already have zipWith.+--++data ManyInterleaveState o i =+      ManyInterleaveOuter o [i]+    | ManyInterleaveInner o [i]+    | ManyInterleaveInnerL [i] [i]+    | ManyInterleaveInnerR [i] [i]++-- | 'Streamly.Internal.Data.Stream.IsStream.unfoldManyInterleave' for+-- documentation and notes.+--+-- This is almost identical to unfoldManyInterleave in StreamD module.+--+-- The 'many' combinator is in fact 'manyAppend' to be more explicit in naming.+--+-- /Internal/+{-# INLINE_NORMAL manyInterleave #-}+manyInterleave :: Monad m => Unfold m a b -> Unfold m c a -> Unfold m c b+manyInterleave (Unfold istep iinject) (Unfold ostep oinject) =+    Unfold step inject++    where++    inject x = do+        ost <- oinject x+        return (ManyInterleaveOuter ost [])++    {-# INLINE_LATE step #-}+    step (ManyInterleaveOuter o ls) = do+        r <- ostep o+        case r of+            Yield a o' -> do+                i <- iinject a+                i `seq` return (Skip (ManyInterleaveInner o' (i : ls)))+            Skip o' -> return $ Skip (ManyInterleaveOuter o' ls)+            Stop -> return $ Skip (ManyInterleaveInnerL ls [])++    step (ManyInterleaveInner _ []) = undefined+    step (ManyInterleaveInner o (st:ls)) = do+        r <- istep st+        return $ case r of+            Yield x s -> Yield x (ManyInterleaveOuter o (s:ls))+            Skip s    -> Skip (ManyInterleaveInner o (s:ls))+            Stop      -> Skip (ManyInterleaveOuter o ls)++    step (ManyInterleaveInnerL [] []) = return Stop+    step (ManyInterleaveInnerL [] rs) =+        return $ Skip (ManyInterleaveInnerR [] rs)++    step (ManyInterleaveInnerL (st:ls) rs) = do+        r <- istep st+        return $ case r of+            Yield x s -> Yield x (ManyInterleaveInnerL ls (s:rs))+            Skip s    -> Skip (ManyInterleaveInnerL (s:ls) rs)+            Stop      -> Skip (ManyInterleaveInnerL ls rs)++    step (ManyInterleaveInnerR [] []) = return Stop+    step (ManyInterleaveInnerR ls []) =+        return $ Skip (ManyInterleaveInnerL ls [])++    step (ManyInterleaveInnerR ls (st:rs)) = do+        r <- istep st+        return $ case r of+            Yield x s -> Yield x (ManyInterleaveInnerR (s:ls) rs)+            Skip s    -> Skip (ManyInterleaveInnerR ls (s:rs))+            Stop      -> Skip (ManyInterleaveInnerR ls rs)
src/Streamly/Internal/FileSystem/Dir.hs view
@@ -68,7 +68,7 @@ --        (Array(..), writeNUnsafe, defaultChunkSize, shrinkToFit, --         lpackArraysChunksOf) -- import Streamly.Internal.Data.Stream.Serial (SerialT)-import Streamly.Internal.Data.Stream.StreamK.Type (IsStream)+import Streamly.Internal.Data.Stream.IsStream.Type (IsStream) -- import Streamly.String (encodeUtf8, decodeUtf8, foldLines)  -- import qualified Streamly.Data.Fold as FL
+ src/Streamly/Internal/FileSystem/Event.hs view
@@ -0,0 +1,242 @@+-- |+-- Module      : Streamly.FileSystem.Event+-- Copyright   : (c) 2020 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : pre-release+-- Portability : GHC+--+-- File system event notification API portable across Linux, macOS and Windows+-- platforms.+--+-- Note that recursive directory tree watch does not work reliably on Linux+-- (see notes in the Linux module), therefore, recursive watch API is not+-- provided in this module. However, you can use it from the platform specific+-- modules.+--+-- For platform specific APIs please see the following modules:+--+-- * "Streamly.Internal.FileSystem.Event.Darwin"+-- * "Streamly.Internal.FileSystem.Event.Linux"+-- * "Streamly.Internal.FileSystem.Event.Windows"++module Streamly.Internal.FileSystem.Event+    (+    -- * Creating a Watch++      watch+    -- , watchRecursive++    -- * Handling Events+    , Event+    , getAbsPath++    -- ** Item CRUD events+    , isCreated+    , isDeleted+    , isMoved+    , isModified++    -- ** Exception Conditions+    , isEventsLost++    -- ** Debugging+    , showEvent+    )+where++import Data.List.NonEmpty (NonEmpty)+import Data.Word (Word8)+import Streamly.Internal.Data.Array.Foreign (Array)+import Streamly.Prelude (SerialT)++#if defined(CABAL_OS_DARWIN)+import Streamly.Internal.FileSystem.Event.Darwin (Event)+import qualified Streamly.Internal.FileSystem.Event.Darwin as Event+#elif defined(CABAL_OS_LINUX)+import Streamly.Internal.FileSystem.Event.Linux (Event)+import qualified Streamly.Internal.FileSystem.Event.Linux as Event+#elif defined(CABAL_OS_WINDOWS)+import Streamly.Internal.FileSystem.Event.Windows (Event)+import qualified Streamly.Internal.FileSystem.Event.Windows as Event+#else+#error "FS Events not supported on this platform"+#endif++-- XXX Ensure that defaultConfig is the same for all platforms.+--+-- XXX Ensure that equivalent events are generated on all platforms when same+-- operations are done. Document any differences in behavior on different+-- platforms. Any events that are not common to all platforms should be+-- filtered out.+--+-- XXX Only need to set common event types for macOS/Linux/Windows+-- XXX write a test, that generates all types of events that can possibly+-- occur on each platform. Then create a common test that only checks+-- for the common subset of those.++-------------------------------------------------------------------------------+-- Creating a watch+-------------------------------------------------------------------------------++-- macOS and Windows seem to do a path level watch i.e. they watch the path+-- rather than the underlying inode, possibly they can map the inode back to a+-- path?.  On Linux we cannot keep watching a watch root if the inode it is+-- pointing to has moved. However, the inode continues to be watched in this+-- case instead of the path, which is not the case for macOS.+--+-- To make the behavior same for all platforms, for the Linux case we will have+-- to stop watching the inode if it moves from under the path+-- (setUnwatchMoved).  And on macOS we can stop watching  a path if the inode+-- under it changes i.e. just filter out events for that path.+--+-- Also, to make the behavior of Linux same as macOS we need to set+-- setFollowSymLinks on Linux.++-- XXX Verify all the cases mentioned below using test cases.+-- XXX Make it fail if the watch root is a file. It works on macOS and Linux+-- but does not work on Windows.++-- | Start monitoring a list of directories or symbolic links to directories+-- for file system events.  Monitoring starts from the current time onwards.+-- The paths are specified as UTF-8 encoded 'Array' of 'Word8'.+--+-- If a watch root is a symbolic link then the target of the link is watched.+-- Fails if the watched path does not exist. If the user does not have+-- permissions (read and execute?) on the watch root then no events are+-- generated.  No events are generated if the watch root itself is renamed or+-- deleted.+--+-- This API watches for changes in the watch root directory only, any changes+-- in the subdirectories of the watch root are not watched. However, on macOS+-- the watch is always recursive, but do not rely on that behavior, it may+-- change without notice in future. If you want to use recursive watch please+-- use platform specific modules.+--+-- /Pre-release/+--+watch :: NonEmpty (Array Word8) -> SerialT IO Event+#if defined(CABAL_OS_DARWIN)+watch = Event.watchRecursive+#else+watch = Event.watch+#endif++-- | Like 'watch' except that if a watched path is a directory the whole+-- directory tree under it is watched recursively.+--+-- On Linux 'watchRecursive' may be more expensive than 'watch'.+--+-- /Pre-release/+--+_watchRecursive :: NonEmpty (Array Word8) -> SerialT IO Event+_watchRecursive = Event.watchRecursive++-------------------------------------------------------------------------------+-- Handling Events+-------------------------------------------------------------------------------++-- XXX Ensure that on all paltforms the path has same conventions. That is do+-- not have a trailing path separator on one platfrom and not on another.+--+-- XXX We should use getRelPath instead so that the behavior when the root is a+-- symlink becomes platform independent.+--+-- | 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.+--+-- When the watch root is a symlink the behavior is different on different+-- platforms:+--+-- * On Linux and Windows, the absolute path returned is via the original+-- symlink.+--+-- * On macOS the absolute path returned is via the real path of the root after+-- resolving the symlink.+--+-- This API is subject to removal in future, to be replaced by a platform+-- independent @getRelPath@.+--+-- /Pre-release/+--+getAbsPath :: Event -> Array Word8+getAbsPath = Event.getAbsPath++-- | Determine whether the event indicates creation of an object within the+-- monitored path. This event is generated when any file system object is+-- created.+--+-- For hard links the behavior is different on different operating systems. On+-- macOS hard linking does not generate a create event, it generates an+-- 'isInodeAttrsChanged' event on the directory instead (see the Darwin+-- module). On Linux and Windows hard linking generates a create event.+--+-- /Pre-release/+--+isCreated :: Event -> Bool+isCreated = Event.isCreated++-- XXX To make the behavior consistent, can we block the event on watch root on+-- macOS?+--+-- | Determine whether the event indicates deletion of an object within the+-- monitored path. On Linux and Windows hard link deletion generates a delete+-- event.+--+-- On Linux and Windows, this event does not occur when the watch root itself+-- is deleted. On macOS it occurs on deleting the watch root when it is not a+-- symbolic link.+--+-- See also 'isRootDeleted' event for Linux.+--+-- /Pre-release/+--+isDeleted :: Event -> Bool+isDeleted = Event.isDeleted++-- | Determine whether the event indicates rename of an object within the+-- monitored path. This event is generated when an object is renamed within the+-- watched directory or if it is moved out of or in the watched directory.+-- Moving hard links is no different than other types of objects.+--+-- /Pre-release/+--+isMoved :: Event -> Bool+isMoved = Event.isMoved++-- XXX Make the Windows behavior consistent with other platforms by removing+-- the event from directories.+--+-- | Determine whether the event indicates modification of an object within the+-- monitored path. This event is generated on file modification on all+-- platforms.+--+-- On Linux and macOS this event is never generated for directories.  On+-- Windows (in recursive watch mode) this event is generated for directories as+-- well when an object is created in or deleted from the directory.+--+-- /Pre-release/+--+isModified :: Event -> Bool+isModified = Event.isModified++-- | An event that indicates that some events before this may have been lost,+-- therefore, we need to take some recovery action.+--+-- /Pre-release/+--+isEventsLost :: Event -> Bool+isEventsLost = Event.isEventsLost++-------------------------------------------------------------------------------+-- Debugging+-------------------------------------------------------------------------------++-- | Convert an 'Event' record to a String representation. Note that the output+-- of this function may be different on different platforms because it may+-- contain platform specific details.+--+-- /Internal/+--+showEvent :: Event -> String+showEvent = Event.showEvent
src/Streamly/Internal/FileSystem/Event/Darwin.hs view
@@ -8,13 +8,13 @@ -- -- =Overview ----- Use 'watchTrees' with a list of file system paths you want to watch as+-- Use 'watchRecursive' 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"#]+-- Stream.mapM_ (putStrLn . 'showEvent') $ 'watchRecursive' [Array.fromCString\# "path"#] -- @ -- -- 'Event' is an opaque type. Accessor functions (e.g. 'showEvent' above)@@ -32,6 +32,9 @@ -- -- =BUGS --+-- XXX Check the behavior for Windows/Linux where applicable. Mention these in+-- the common module so that users are aware of the portability issues.+-- -- There may be some idiosyncrasies in event reporting. -- -- 1. Multiple events may be coalesced into a single event having multiple@@ -46,14 +49,21 @@ -- 3. Some events can go missing and only the latest one is reported. See -- 'isCreated' for one such case. --+-- XXX write a test case for this, and check on all platforms.+-- -- 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. --+-- XXX write a test case for this, and check on all platforms.+-- -- 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. --+-- XXX cloned event is specific to macOS.  Translate it to the same events as+-- on copying.+-- -- 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.@@ -81,7 +91,7 @@     -- * Creating a Watch      -- ** Default configuration-      Config+      Config (..)     , Toggle (..)     , defaultConfig @@ -90,41 +100,37 @@     , setEventBatching      -- ** Events of Interest-    , setRootChanged+    , setRootPathEvents     , setFileEvents     , setIgnoreSelf #if HAVE_DECL_KFSEVENTSTREAMCREATEFLAGFULLHISTORY     , setFullHistory #endif+    , setAllEvents      -- ** Watch APIs-    , watchTrees-    , watchTreesWith+    , watch+    , watchRecursive+    , watchWith      -- * 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+    -- items contained in it.+    , isMounted+    , isUnmounted     , isHistoryDone-    , isRootChanged+    , isRootPathEvent      -- ** Item Level Metadata change-    , isOwnerGroupModeChanged-    , isInodeAttrsChanged-    , isFinderInfoChanged-    , isXAttrsChanged+    , isAttrsModified+    , isSecurityModified+    , isXAttrsModified+    , isFinderInfoModified      -- ** Item Level CRUD events     , isCreated@@ -144,6 +150,12 @@     , isLastHardLink #endif +    -- ** Exception Conditions+    , isEventIdWrapped+    , isEventsLost+    , isKernelDropped+    , isUserDropped+     -- * Debugging     , showEvent     )@@ -179,6 +191,9 @@ -- Subscription to events ------------------------------------------------------------------------------- +-- XXX Add a recursive option to Config+-- Keep setRecursiveMode Off as undefined for now until we implement it.+-- -- | Watch configuration, used to specify the events of interest and the -- behavior of the watch. --@@ -197,6 +212,7 @@     "FileSystem/Event/Darwin.h FSEventStreamCreateFlagNoDefer"     kFSEventStreamCreateFlagNoDefer :: Word32 +-- | Determines how multiple events are batched or throttled. data BatchInfo =       Throttle Double -- ^ Deliver an event immediately but suppress the                       -- following events upto the specified time.@@ -214,7 +230,7 @@ -- /Pre-release/ -- setEventBatching :: BatchInfo -> Config -> Config-setEventBatching batchInfo cfg@Config{..} =+setEventBatching batchInfo cfg =     let (t, status) =             case batchInfo of                 Throttle sec | sec < 0 -> (0, On)@@ -245,18 +261,26 @@     "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.+-- XXX write a test case for this, and check on all platforms. The behavior on+-- macOS is slightly different as a create event is also generated. --+-- | Any changes to the path (delete, rename, or create) of an object are+-- reported as events for its parent directory. Such events are not reported+-- for the watch root itself because its parent is not being watched. When+-- 'setRootPathEvents' is 'On', an 'isRootPathEvent' event is generated with an+-- eventId 0 if the watch root is deleted, renamed or created.+--+-- Note: We have observed that an 'isDeleted' event occurs for the root path+-- (when it is a regular dir and not symlink) even when this option is off.+-- -- /default: Off/ -- -- /macOS 10.5+/ -- -- /Pre-release/ ---setRootChanged :: Toggle -> Config -> Config-setRootChanged = setFlag kFSEventStreamCreateFlagWatchRoot+setRootPathEvents :: Toggle -> Config -> Config+setRootPathEvents = setFlag kFSEventStreamCreateFlagWatchRoot  foreign import ccall safe     "FSEventStreamCreateFlagFileEvents"@@ -264,8 +288,11 @@  -- | 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.+-- event, the path name in the event is the path of the directory being watched+-- and not of the specific item for which the event occurred.  Events cannot be+-- distinguished based on the type of event.  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. -- -- 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@@ -313,6 +340,18 @@ setFullHistory = setFlag kFSEventStreamCreateFlagFullHistory #endif +-- | Set all tunable events 'On' or 'Off'. Equivalent to setting:+--+-- * setRootPathEvents+-- * setFileEvents+--+-- /Pre-release/+--+setAllEvents :: Toggle -> Config -> Config+setAllEvents s =+      setRootPathEvents s+    . setFileEvents s+ ------------------------------------------------------------------------------- -- Default config -------------------------------------------------------------------------------@@ -321,7 +360,7 @@ -- -- * 'setEventBatching' ('Batch' 0.0) -- * 'setFileEvents' 'On'--- * 'setRootChanged' 'Off'+-- * 'setRootPathEvents' 'Off' -- * 'setIgnoreSelf' 'Off' #if HAVE_DECL_KFSEVENTSTREAMCREATEFLAGFULLHISTORY -- * 'setFullHistory' 'Off'@@ -366,7 +405,7 @@     -> Word32     -> Word64     -> CDouble-    -> Ptr (CInt)+    -> Ptr CInt     -> Ptr (Ptr CWatch)     -> IO CInt @@ -394,6 +433,8 @@ -- openWatch :: Config -> NonEmpty (Array Word8) -> IO Watch openWatch Config{..} paths = do+    -- XXX write a test case when path does not exist+    -- XXX write a test case when there are no permissions     -- 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@@ -402,7 +443,7 @@         alloca $ \fdPtr -> do         alloca $ \watchPPtr -> do             let nArrays = fromIntegral (NonEmpty.length paths)-                seconds = (realToFrac latency)+                seconds = realToFrac latency             r <- createWatch                     arraysPtr nArrays createFlags 0 seconds fdPtr watchPPtr             when (r /= 0) $@@ -473,61 +514,80 @@ watchToStream (Watch handle _ _) =     S.parseMany readOneEvent $ S.unfold FH.read handle +-- XXX Write tests for all the points in macOS specific behavior.+-- -- | 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'.+-- the supplied configuration operation over the 'defaultConfig'. The paths+-- could be files or directories.  When the path is a directory and recursive+-- mode is set, 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.+-- Important notes for macOS specific behavior: ----- 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.+-- From the observed behavior it seems macOS watches the paths, whatever they+-- are pointing to at any given point of time: ----- 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.+-- /Watch root deletion:/ If the the watch root is deleted and then recreated,+-- the newly created file or directory is automatically watched. ----- 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.+-- /Watch root moved:/ If the watch root is moved to a new path, the object+-- will no longer be watched unless the new path is also being watched and was+-- pointing to an existing file at the time of starting the watch (see notes+-- about non-existing paths below). --+-- /Symbolic link watch root:/ 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. It is equivalent to as if the target of the symbolic link itself was+-- directly added to the watch API. That is, the symbolic link is resolved at+-- the time of adding the watch.+--+-- Note that if a watched path is deleted and recreated as a symbolic link+-- pointing to another path then the symbolic link file itself is watched, it+-- won't be resolved. The symbolic link resolution happens only at the time of+-- adding the watch.+--+-- /Non-existing Paths:/ 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 'setRootPathEvents' then an+-- 'isRootPathEvent' 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"#]+-- watchWith+--      ('setIgnoreSelf' 'On' . 'setRootPathEvents' 'On')+--      [Array.fromCString\# "path"#] -- @ -- -- /Pre-release/ ---watchTreesWith ::+watchWith ::     (Config -> Config) -> NonEmpty (Array Word8) -> SerialT IO Event-watchTreesWith f paths = S.bracket before after watchToStream+watchWith f paths = S.bracket before after watchToStream      where      before = liftIO $ openWatch (f defaultConfig) paths-    after = (liftIO . closeWatch)+    after = liftIO . closeWatch --- | Like 'watchTreesWith' but uses the 'defaultConfig' options.+-- | Same as 'watchWith' using 'defaultConfig' and recursive mode. ----- @--- watchTrees = watchTreesWith id--- @+-- >>> watchRecursive = watchWith id ---watchTrees :: NonEmpty (Array Word8) -> SerialT IO Event-watchTrees = watchTreesWith id+watchRecursive :: NonEmpty (Array Word8) -> SerialT IO Event+watchRecursive = watchWith id +-- | Same as 'watchWith' using defaultConfig and non-recursive mode.+--+-- /Unimplemented/+--+watch :: NonEmpty (Array Word8) -> SerialT IO Event+watch _paths = undefined+ ------------------------------------------------------------------------------- -- Examine the event stream -------------------------------------------------------------------------------@@ -559,6 +619,9 @@ -- | 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. --+-- When the watch root is a symlink, the absolute path returned is via the real+-- path of the root after resolving the symlink.+-- -- /Pre-release/ -- getAbsPath :: Event -> Array Word8@@ -582,7 +645,7 @@ -- | 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+-- 'isEventsLost' 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@@ -593,15 +656,15 @@ -- -- /Pre-release/ ---isMustScanSubdirs :: Event -> Bool-isMustScanSubdirs = getFlag kFSEventStreamEventFlagMustScanSubDirs+isEventsLost :: Event -> Bool+isEventsLost = 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.+-- 'isEventsLost' is also true. -- -- /macOS 10.5+/ --@@ -615,7 +678,7 @@     kFSEventStreamEventFlagUserDropped :: Word32  -- | Did an event get dropped due to a user process issue? Set only when--- 'isMustScanSubdirs' is also true.+-- 'isEventsLost' is also true. -- -- /macOS 10.5+/ --@@ -656,7 +719,7 @@ -- object itself. Note that the object may become unreachable or deleted after -- a change of path. ----- /Applicable only when 'setRootChanged' is 'On'/+-- /Applicable only when 'setRootPathEvents' is 'On'/ -- -- /Occurs only for the watched path/ --@@ -664,8 +727,8 @@ -- -- /Pre-release/ ---isRootChanged :: Event -> Bool-isRootChanged = getFlag kFSEventStreamEventFlagRootChanged+isRootPathEvent :: Event -> Bool+isRootPathEvent = getFlag kFSEventStreamEventFlagRootChanged  ------------------------------------------------------------------------------- -- Global events under the watched path@@ -682,8 +745,8 @@ -- -- /Pre-release/ ---isMount :: Event -> Bool-isMount = getFlag kFSEventStreamEventFlagMount+isMounted :: Event -> Bool+isMounted = getFlag kFSEventStreamEventFlagMount  foreign import ccall safe     "FSEventStreamEventFlagUnmount"@@ -696,8 +759,8 @@ -- -- /Pre-release/ ---isUnmount :: Event -> Bool-isUnmount = getFlag kFSEventStreamEventFlagUnmount+isUnmounted :: Event -> Bool+isUnmounted = getFlag kFSEventStreamEventFlagUnmount  ------------------------------------------------------------------------------- -- Metadata change Events (applicable only when 'setFileEvents' is 'On')@@ -721,8 +784,8 @@ -- -- /Pre-release/ ---isOwnerGroupModeChanged :: Event -> Bool-isOwnerGroupModeChanged = getFlag kFSEventStreamEventFlagItemChangeOwner+isSecurityModified :: Event -> Bool+isSecurityModified = getFlag kFSEventStreamEventFlagItemChangeOwner  foreign import ccall safe     "FSEventStreamEventFlagItemInodeMetaMod"@@ -742,8 +805,8 @@ -- -- /Pre-release/ ---isInodeAttrsChanged :: Event -> Bool-isInodeAttrsChanged = getFlag kFSEventStreamEventFlagItemInodeMetaMod+isAttrsModified :: Event -> Bool+isAttrsModified = getFlag kFSEventStreamEventFlagItemInodeMetaMod  foreign import ccall safe     "FSEventStreamEventFlagItemFinderInfoMod"@@ -758,8 +821,8 @@ -- -- /Pre-release/ ---isFinderInfoChanged :: Event -> Bool-isFinderInfoChanged = getFlag kFSEventStreamEventFlagItemFinderInfoMod+isFinderInfoModified :: Event -> Bool+isFinderInfoModified = getFlag kFSEventStreamEventFlagItemFinderInfoMod  foreign import ccall safe     "FSEventStreamEventFlagItemXattrMod"@@ -776,8 +839,8 @@ -- -- /Pre-release/ ---isXAttrsChanged :: Event -> Bool-isXAttrsChanged = getFlag kFSEventStreamEventFlagItemXattrMod+isXAttrsModified :: Event -> Bool+isXAttrsModified = getFlag kFSEventStreamEventFlagItemXattrMod  ------------------------------------------------------------------------------- -- CRUD Events (applicable only when 'setFileEvents' is 'On')@@ -789,7 +852,7 @@  -- | 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'+-- than a hard link is created.  On hard linking only an 'isAttrsModified' -- 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. --@@ -799,7 +862,7 @@ -- 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'+-- only an 'isAttrsModified' 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'/@@ -986,19 +1049,19 @@         ++ "\nPath = " ++ show path         ++ "\nFlags " ++ show eventFlags -        ++ showev isMustScanSubdirs "MustScanSubdirs"+        ++ showev isEventsLost "MustScanSubdirs"         ++ showev isKernelDropped "KernelDropped"         ++ showev isUserDropped "UserDropped" -        ++ showev isRootChanged "RootChanged"-        ++ showev isMount "Mount"-        ++ showev isUnmount "Unmount"+        ++ showev isRootPathEvent "RootPathEvent"+        ++ showev isMounted "Mounted"+        ++ showev isUnmounted "Unmounted"         ++ showev isHistoryDone "HistoryDone" -        ++ showev isOwnerGroupModeChanged "OwnerGroupModeChanged"-        ++ showev isInodeAttrsChanged "InodeAttrsChanged"-        ++ showev isFinderInfoChanged "FinderInfoChanged"-        ++ showev isXAttrsChanged "XAttrsChanged"+        ++ showev isSecurityModified "SecurityModified"+        ++ showev isAttrsModified "AttrsModified"+        ++ showev isFinderInfoModified "FinderInfoChanged"+        ++ showev isXAttrsModified "XAttrsModified"          ++ showev isCreated "Created"         ++ showev isDeleted "Deleted"
src/Streamly/Internal/FileSystem/Event/Linux.hs view
@@ -3,7 +3,7 @@ -- Copyright   : (c) 2020 Composewell Technologies -- License     : BSD-3-Clause -- Maintainer  : streamly@composewell.com--- Stability   : pre-release+-- Stability   : experimental -- Portability : GHC -- -- =Overview@@ -63,11 +63,12 @@     -- * Subscribing to events      -- ** Default configuration-      Config+      Config (..)     , Toggle (..)     , defaultConfig      -- ** Watch Behavior+    , setRecursiveMode     , setFollowSymLinks     , setUnwatchMoved     , setOneShot@@ -76,12 +77,13 @@     , setWhenExists      -- ** Events of Interest-    -- *** Root Level Events+    -- *** Root Path Events     , setRootDeleted     , setRootMoved+    , setRootPathEvents      -- *** Item Level Metadata change-    , setMetadataChanged+    , setAttrsModified      -- *** Item Level Access     , setAccessed@@ -99,12 +101,11 @@     , 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+    , watch+    , watchRecursive+    , watchWith++    -- Low level watch APIs     , addToWatch     , removeFromWatch @@ -115,17 +116,15 @@     , getAbsPath     , getCookie -    -- ** Exception Conditions-    , isOverflow-     -- ** Root Level Events+    , isRootPathEvent     , isRootUnwatched     , isRootDeleted     , isRootMoved     , isRootUnmounted      -- ** Item Level Metadata change-    , isMetadataChanged+    , isAttrsModified      -- ** Item Level Access     , isAccessed@@ -133,16 +132,20 @@     , isWriteClosed     , isNonWriteClosed -    -- ** Item CRUD events+    -- ** Item Level CRUD events     , isCreated     , isDeleted     , isMovedFrom     , isMovedTo+    , isMoved     , isModified      -- ** Item Path info     , isDir +    -- ** Exception Conditions+    , isEventsLost+     -- * Debugging     , showEvent     )@@ -157,7 +160,7 @@ 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))+#if !(MIN_VERSION_base(4,13,0)) import Data.Semigroup (Semigroup(..)) #endif import Data.Word (Word8, Word32)@@ -171,7 +174,8 @@ 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 Streamly.Internal.Data.Array.Foreign.Type (Array(..), byteLength)+import System.Directory (doesDirectoryExist) import System.IO (Handle, hClose, IOMode(ReadMode)) #if !MIN_VERSION_base(4,10,0) import Control.Concurrent.MVar (readMVar)@@ -211,11 +215,13 @@ -- Boolean settings ------------------------------------------------------------------------------- +-- XXX Change Toggle to "OnOff" or "Switch". The name Toggle may be confusing.+-- -- | Whether a setting is 'On' or 'Off'. -- -- /Pre-release/ ---data Toggle = On | Off+data Toggle = On | Off deriving (Show, Eq)  toggle :: Toggle -> Toggle toggle On = Off@@ -240,8 +246,8 @@ -- -- /Pre-release/ ---setRecursiveMode :: Bool -> Config -> Config-setRecursiveMode rec cfg@Config{} = cfg {watchRec = rec}+setRecursiveMode :: Toggle -> Config -> Config+setRecursiveMode rec cfg@Config{} = cfg {watchRec = rec == On}  foreign import capi     "sys/inotify.h value IN_DONT_FOLLOW" iN_DONT_FOLLOW :: Word32@@ -249,6 +255,9 @@ -- | If the pathname to be watched is a symbolic link then watch the target of -- the symbolic link instead of the symbolic link itself. --+-- Note that the path location in the events is through the original symbolic+-- link path rather than the resolved path.+-- -- /default: On/ -- -- /Pre-release/@@ -358,6 +367,15 @@ setRootMoved :: Toggle -> Config -> Config setRootMoved = setFlag iN_MOVE_SELF +-- | Report when the watched root path itself gets deleted or renamed.+--+-- /default: On/+--+-- /Pre-release/+--+setRootPathEvents :: Toggle -> Config -> Config+setRootPathEvents = setFlag (iN_DELETE_SELF .|. iN_MOVE_SELF)+ foreign import capi     "sys/inotify.h value IN_ATTRIB" iN_ATTRIB :: Word32 @@ -368,8 +386,8 @@ -- -- /Pre-release/ ---setMetadataChanged :: Toggle -> Config -> Config-setMetadataChanged = setFlag iN_ATTRIB+setAttrsModified :: Toggle -> Config -> Config+setAttrsModified = setFlag iN_ATTRIB  foreign import capi     "sys/inotify.h value IN_ACCESS" iN_ACCESS :: Word32@@ -479,17 +497,28 @@ setModified :: Toggle -> Config -> Config setModified = setFlag iN_MODIFY --- | Set all events 'On' or 'Off'.+-- | Set all tunable events 'On' or 'Off'. Equivalent to setting: ----- /default: On/+-- * setRootDeleted+-- * setRootMoved+-- * setAttrsModified+-- * setAccessed+-- * setOpened+-- * setWriteClosed+-- * setNonWriteClosed+-- * setCreated+-- * setDeleted+-- * setMovedFrom+-- * setMovedTo+-- * setModified -- -- /Pre-release/ -- setAllEvents :: Toggle -> Config -> Config-setAllEvents s cfg =-    ( setRootDeleted s+setAllEvents s =+      setRootDeleted s     . setRootMoved s-    . setMetadataChanged s+    . setAttrsModified s     . setAccessed s     . setOpened s     . setWriteClosed s@@ -499,7 +528,6 @@     . setMovedFrom s     . setMovedTo s     . setModified s-    ) cfg  ------------------------------------------------------------------------------- -- Default config@@ -508,23 +536,34 @@ -- The defaults are set in such a way that the behavior on macOS and Linux is -- as much compatible as possible. ----- | The default is:+-- | The default configuration settings are: -- -- * 'setFollowSymLinks' 'On' -- * 'setUnwatchMoved' 'On' -- * 'setOneShot' 'Off' -- * 'setOnlyDir' 'Off' -- * 'setWhenExists' 'AddIfExists'--- * 'setAllEvents' 'On' --+-- The tunable events enabled by default are:+--+-- * setCreated On+-- * setDeleted On+-- * setMovedFrom On+-- * setMovedTo On+-- * setModified On+-- -- /Pre-release/ -- defaultConfig :: Config defaultConfig =       setWhenExists AddIfExists-    $ setAllEvents On+    $ setCreated On+    $ setDeleted On+    $ setMovedFrom On+    $ setMovedTo On+    $ setModified On     $ Config-        { watchRec = True+        { watchRec = False         , createFlags = 0         } @@ -619,9 +658,9 @@ -- ensureTrailingSlash :: Array Word8 -> Array Word8 ensureTrailingSlash path =-    if A.length path /= 0+    if byteLength path /= 0     then-        let mx = A.getIndex path (A.length path - 1)+        let mx = A.getIndex path (byteLength path - 1)          in case mx of             Nothing -> error "ensureTrailingSlash: Bug: Invalid index"             Just x ->@@ -630,6 +669,26 @@                 else path     else path +removeTrailingSlash :: Array Word8 -> Array Word8+removeTrailingSlash path =+    if byteLength path /= 0+    then+        let n = byteLength path - 1+            mx = A.getIndex path n+         in case mx of+            Nothing -> error "removeTrailingSlash: Bug: Invalid index"+            Just x ->+                if x == fromIntegral (ord '/')+                then A.getSliceUnsafe 0 n path+                else path+    else path++appendPaths :: Array Word8 -> Array Word8 -> Array Word8+appendPaths a b+  | byteLength a == 0 = b+  | byteLength b == 0 = a+  | otherwise = ensureTrailingSlash a <> b+ -- | @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@.@@ -637,7 +696,7 @@ -- /Pre-release/ -- addToWatch :: Config -> Watch -> Array Word8 -> Array Word8 -> IO ()-addToWatch cfg@Config{..} watch@(Watch handle wdMap) root0 path0 = do+addToWatch cfg@Config{..} watch0@(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@@ -656,9 +715,11 @@     -- 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+    let root = removeTrailingSlash root0+        path = removeTrailingSlash path0+        absPath = appendPaths root path+    putStrLn $ "root = " ++ utf8ToString root ++ " path = " ++ utf8ToString path ++ " absPath = " ++ utf8ToString absPath+     fd <- handleToFd handle      -- XXX we need to tolerate an error where we are adding a watch for a@@ -681,12 +742,13 @@     -- 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.+    -- adding the dirs. That may generate spurious events though.     --     -- 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))+    pathIsDir <- doesDirectoryExist $ utf8ToString absPath+    when (watchRec && pathIsDir) $ do+        S.mapM_ (\p -> addToWatch cfg watch0 root (appendPaths path p))             $ S.mapM toUtf8             $ Dir.toDirs $ utf8ToString absPath @@ -710,7 +772,7 @@     where      step fd newMap (wd, v) = do-        if (fst v) == path+        if fst v == path         then do             let err = "removeFromWatch: " ++ show (utf8ToString path)                 rm = c_inotify_rm_watch (fdFD fd) (fromIntegral wd)@@ -727,7 +789,9 @@ openWatch :: Config -> NonEmpty (Array Word8) -> IO Watch openWatch cfg paths = do     w <- createWatch-    mapM_ (\p -> addToWatch cfg w p (A.fromList [])) $ NonEmpty.toList paths+    mapM_+        (\root -> addToWatch cfg w root (A.fromList []))+        $ NonEmpty.toList paths     return w  -- | Close a 'Watch' handle.@@ -772,7 +836,7 @@ -- readOneEvent :: Config -> Watch -> Parser IO Word8 Event readOneEvent cfg  wt@(Watch _ wdMap) = do-    let headerLen = (sizeOf (undefined :: CInt)) + 12+    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"@@ -788,7 +852,7 @@                 PR.fromFold                     $ FL.takeEndBy_ (== 0)                     $ FL.take pathLen (A.writeN pathLen)-            let remaining = pathLen - A.length pth - 1+            let remaining = pathLen - byteLength pth - 1             when (remaining /= 0) $ PR.takeEQ remaining FL.drain             return pth         else return $ A.fromList []@@ -800,8 +864,7 @@                         error $ "readOneEvent: "                                   <> "Unknown watch descriptor: "                                   <> show ewd-    let -- "sub" is guaranteed to have a trailing "/"-        sub1 = sub <> path+    let sub1 = appendPaths sub path         -- Check for "ISDIR" first because it is less likely         isDirCreate = eflags .&. iN_ISDIR /= 0 && eflags .&. iN_CREATE /= 0     when (watchRec cfg && isDirCreate)@@ -811,7 +874,7 @@     -- 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)+        { eventWd = fromIntegral ewd         , eventFlags = eflags         , eventCookie = cookie         , eventRelPath = sub1@@ -842,66 +905,44 @@     -- 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.+-- paths could be files or directories.  When recursive mode is set and 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'. ----- 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.+-- /Non-existing Paths:/ the API fails if a watch is started on a non-exsting+-- path. ----- 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.+-- /Performance:/ Note that recursive 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. --+-- /Bugs:/ 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. --+-- @+-- watchwith+--      ('setFollowSymLinks' On . 'setUnwatchMoved' Off)+--      [Array.fromCString\# "dir"#]+-- @+-- -- /Pre-release/ ---watchTreesWith ::-    (Config -> Config) -> NonEmpty (Array Word8) -> SerialT IO Event-watchTreesWith f paths = S.bracket before after (watchToStream cfg)+watchWith :: (Config -> Config) -> NonEmpty (Array Word8) -> SerialT IO Event+watchWith f paths = S.bracket before after (watchToStream cfg)      where @@ -909,15 +950,26 @@     before = liftIO $ openWatch cfg paths     after = liftIO . closeWatch --- | Like 'watchTreesWith' but uses the 'defaultConfig' options.+-- | Same as 'watchWith' using 'defaultConfig' and recursive mode. ----- @--- watchTrees = watchTreesWith id--- @+-- >>> watchRecursive = watchWith (setRecursiveMode On) ---watchTrees :: NonEmpty (Array Word8) -> SerialT IO Event-watchTrees = watchTreesWith id+-- See 'watchWith' for pitfalls and bugs when using recursive watch on Linux.+--+-- /Pre-release/+--+watchRecursive :: NonEmpty (Array Word8) -> SerialT IO Event+watchRecursive = watchWith (setRecursiveMode On) +-- | Same as 'watchWith' using defaultConfig and non-recursive mode.+--+-- >>> watch = watchWith id+--+-- /Pre-release/+--+watch :: NonEmpty (Array Word8) -> SerialT IO Event+watch = watchWith id+ ------------------------------------------------------------------------------- -- Examine event stream -------------------------------------------------------------------------------@@ -933,7 +985,7 @@ -- getRoot :: Event -> Array Word8 getRoot Event{..} =-    if (eventWd >= 1)+    if eventWd >= 1     then         case Map.lookup (fromIntegral eventWd) eventMap of             Just path -> fst path@@ -951,14 +1003,20 @@ 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. --+-- When the watch root is a symlink, the absolute path returned is via the+-- original symlink and not through the resolved path.+-- -- /Pre-release/ -- getAbsPath :: Event -> Array Word8-getAbsPath ev = getRoot ev <> getRelPath ev+getAbsPath ev =+    let relpath = getRelPath ev+        root = getRoot ev+    in  if byteLength relpath /= 0+        then ensureTrailingSlash root <> relpath+        else removeTrailingSlash root  -- XXX should we use a Maybe? -- | Cookie is set when a rename occurs. The cookie value can be used to@@ -995,8 +1053,8 @@ -- -- /Pre-release/ ---isOverflow :: Event -> Bool-isOverflow = getFlag iN_Q_OVERFLOW+isEventsLost :: Event -> Bool+isEventsLost = getFlag iN_Q_OVERFLOW  ------------------------------------------------------------------------------- -- Events affecting the watched path only@@ -1010,6 +1068,9 @@ -- | A path was removed from the watch explicitly using 'removeFromWatch' or -- automatically (file was deleted, or filesystem was unmounted). --+-- Note that in recursive watch mode all the subdirectories are watch roots,+-- therefore, they will all generate this event.+-- -- /Occurs only for a watched path/ -- -- /Pre-release/@@ -1023,6 +1084,9 @@ -- In addition, an 'isRootUnwatched' event will subsequently be generated -- for the watch descriptor. --+-- Note that in recursive watch mode all the subdirectories are watch roots,+-- therefore, they will all generate this event.+-- -- /Occurs only for a watched path/ -- -- /Pre-release/@@ -1032,6 +1096,9 @@  -- | Watched file/directory was itself moved within the file system. --+-- Note that in recursive watch mode all the subdirectories are watch roots,+-- therefore, they will all generate this event.+-- -- /Occurs only for a watched path/ -- -- /Pre-release/@@ -1053,6 +1120,17 @@ isRootUnmounted :: Event -> Bool isRootUnmounted = getFlag iN_UNMOUNT +-- | 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.+--+-- /Occurs only for a watched path/+--+-- /Pre-release/+--+isRootPathEvent :: Event -> Bool+isRootPathEvent = getFlag (iN_DELETE_SELF .|. iN_MOVE_SELF .|. iN_UNMOUNT)+ ------------------------------------------------------------------------------- -- Metadata change Events -------------------------------------------------------------------------------@@ -1071,8 +1149,8 @@ -- -- /Pre-release/ ---isMetadataChanged :: Event -> Bool-isMetadataChanged = getFlag iN_ATTRIB+isAttrsModified :: Event -> Bool+isAttrsModified = getFlag iN_ATTRIB  ------------------------------------------------------------------------------- -- Access@@ -1165,6 +1243,18 @@ isMovedTo :: Event -> Bool isMovedTo = getFlag iN_MOVED_TO +-- | Generated for a path that is moved from or moved to the monitored+-- directory.+--+-- >>> isMoved ev = isMovedFrom ev || isMovedTo ev+--+-- /Occurs only for an object inside the watched directory/+--+-- /Pre-release/+--+isMoved :: Event -> Bool+isMoved ev = isMovedFrom ev || isMovedTo ev+ -- | Determine whether the event indicates modification of an object within the -- monitored path. This event is generated only for files and not directories. --@@ -1199,19 +1289,18 @@        "--------------------------"     ++ "\nWd = " ++ show eventWd     ++ "\nRoot = " ++ show (utf8ToString $ getRoot ev)-    ++ "\nRelative Path = " ++ show (utf8ToString $ getRelPath ev)-    ++ "\nAbsolute Path = " ++ show (utf8ToString $ getAbsPath ev)+    ++ "\nPath = " ++ show (utf8ToString $ getRelPath ev)     ++ "\nCookie = " ++ show (getCookie ev)     ++ "\nFlags " ++ show eventFlags -    ++ showev isOverflow "Overflow"+    ++ showev isEventsLost "Overflow"      ++ showev isRootUnwatched "RootUnwatched"     ++ showev isRootDeleted "RootDeleted"     ++ showev isRootMoved "RootMoved"     ++ showev isRootUnmounted "RootUnmounted" -    ++ showev isMetadataChanged "MetadataChanged"+    ++ showev isAttrsModified "AttrsModified"      ++ showev isAccessed "Accessed"     ++ showev isOpened "Opened"
src/Streamly/Internal/FileSystem/Event/Windows.hs view
@@ -12,13 +12,13 @@ -- -- =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.+-- Use 'watchRecursive'or 'watch' with a list of file system dir 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"#]+-- Stream.mapM_ (putStrLn . 'showEvent') $ 'watchRecursive' [Array.fromCString\# "path"#] -- @ -- -- 'Event' is an opaque type. Accessor functions (e.g. 'showEvent' above)@@ -48,45 +48,42 @@      -- ** Default configuration       Config-    , Event (..)     , Toggle (..)-    , setFlag     , defaultConfig-    , getConfigFlag-    , setAllEvents      -- ** Watch Behavior     , setRecursiveMode      -- ** Events of Interest-    -- *** Root Level Events-    , setModifiedFileName-    , setModifiedDirName-    , setModifiedAttribute-    , setModifiedSize-    , setModifiedLastWrite-    , setModifiedSecurity+    , setFileNameEvents+    , setDirNameEvents+    , setAttrsModified+    , setSecurityModified+    , setSizeModified+    , setLastWriteTimeModified+    , setAllEvents      -- ** Watch APIs-    , watchPaths-    , watchPathsWith-    , watchTrees-    , watchTreesWith+    , watch+    , watchRecursive+    , watchWith      -- * Handling Events-    , getAbsPath-    , getRelPath+    , Event(..)     , getRoot+    , getRelPath+    , getAbsPath      -- ** Item CRUD events     , isCreated     , isDeleted+    , isModified+    , isMoved     , isMovedFrom     , isMovedTo-    , isModified      -- ** Exception Conditions-    , isOverflow+    , isEventsLost      -- * Debugging     , showEvent@@ -124,6 +121,7 @@ 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.Unicode.Utf8 as UTF8 import qualified Streamly.Internal.Data.Array.Foreign as A import Streamly.Internal.Data.Array.Foreign (Array) @@ -145,7 +143,7 @@ -- -- /Pre-release/ ---data Toggle = On | Off+data Toggle = On | Off deriving (Show, Eq)  setFlag :: DWORD -> Toggle -> Config -> Config setFlag mask status cfg@Config{..} =@@ -157,84 +155,127 @@  -- | Set watch event on directory recursively. ----- /default: On/+-- /default: Off/ -- -- /Pre-release/ ---setRecursiveMode :: BOOL -> Config -> Config-setRecursiveMode rec cfg@Config{} = cfg {watchRec = rec}+setRecursiveMode :: Toggle -> Config -> Config+setRecursiveMode rec cfg@Config{} = cfg {watchRec = rec == On} --- | Report when a file name is modified.+-- | Generate notify events on file create, rename or delete. --+-- From Windows API documentation: Any file name change in the watched+-- directory or subtree causes a change notification wait operation to return.+-- Changes include renaming, creating, or deleting a file.+-- -- /default: On/ -- -- /Pre-release/ ---setModifiedFileName :: Toggle -> Config -> Config-setModifiedFileName = setFlag fILE_NOTIFY_CHANGE_FILE_NAME+setFileNameEvents :: Toggle -> Config -> Config+setFileNameEvents = setFlag fILE_NOTIFY_CHANGE_FILE_NAME --- | Report when a directory name is modified.+-- | Generate notify events on directory create, rename or delete. --+-- From Windows API documentaiton: Any directory-name change in the watched+-- directory or subtree causes a change notification wait operation to return.+-- Changes include creating or deleting a directory.+-- -- /default: On/ -- -- /Pre-release/ ---setModifiedDirName :: Toggle -> Config -> Config-setModifiedDirName = setFlag fILE_NOTIFY_CHANGE_DIR_NAME+setDirNameEvents :: Toggle -> Config -> Config+setDirNameEvents = setFlag fILE_NOTIFY_CHANGE_DIR_NAME --- | Report when a file attribute is modified.+-- | Generate an 'isModified' event on any attribute change in the watched+-- directory or subtree. ----- /default: On/+-- /default: Off/ -- -- /Pre-release/ ---setModifiedAttribute :: Toggle -> Config -> Config-setModifiedAttribute = setFlag fILE_NOTIFY_CHANGE_ATTRIBUTES+setAttrsModified :: Toggle -> Config -> Config+setAttrsModified = setFlag fILE_NOTIFY_CHANGE_ATTRIBUTES --- | Report when a file size is changed.+-- | Generate an 'isModified' event when the file size is changed. ----- /default: On/+-- From Windows API documentation: Any file-size change in the watched+-- directory or subtree causes a change notification wait operation to return.+-- The operating system detects a change in file size only when the file is+-- written to the disk. For operating systems that use extensive caching,+-- detection occurs only when the cache is sufficiently flushed. --+-- /default: Off/+-- -- /Pre-release/ ---setModifiedSize :: Toggle -> Config -> Config-setModifiedSize = setFlag fILE_NOTIFY_CHANGE_SIZE+setSizeModified :: Toggle -> Config -> Config+setSizeModified = setFlag fILE_NOTIFY_CHANGE_SIZE --- | Report when a file last write time is changed.+-- | Generate an 'isModified' event when the last write timestamp of the file+-- inode is changed. ----- /default: On/+-- From Windows API documentation: Any change to the last write-time of files+-- in the watched directory or subtree causes a change notification wait+-- operation to return. The operating system detects a change to the last+-- write-time only when the file is written to the disk. For operating systems+-- that use extensive caching, detection occurs only when the cache is+-- sufficiently flushed. --+-- /default: Off/+-- -- /Pre-release/ ---setModifiedLastWrite :: Toggle -> Config -> Config-setModifiedLastWrite = setFlag fILE_NOTIFY_CHANGE_LAST_WRITE+setLastWriteTimeModified :: Toggle -> Config -> Config+setLastWriteTimeModified = setFlag fILE_NOTIFY_CHANGE_LAST_WRITE --- | Report when a file Security attributes is changed.+-- | Generate an 'isModified' event when any security-descriptor change occurs+-- in the watched directory or subtree. ----- /default: On/+-- /default: Off/ -- -- /Pre-release/ ---setModifiedSecurity :: Toggle -> Config -> Config-setModifiedSecurity = setFlag fILE_NOTIFY_CHANGE_SECURITY+setSecurityModified :: Toggle -> Config -> Config+setSecurityModified = setFlag fILE_NOTIFY_CHANGE_SECURITY --- | Set all events 'On' or 'Off'.+-- | Set all tunable events 'On' or 'Off'. Equivalent to setting: ----- /default: On/+-- * setFileNameEvents+-- * setDirNameEvents+-- * setAttrsModified+-- * setSizeModified+-- * setLastWriteTimeModified+-- * setSecurityModified -- -- /Pre-release/ -- setAllEvents :: Toggle -> Config -> Config setAllEvents s =-     setModifiedFileName s-    . setModifiedDirName s-    . setModifiedAttribute s-    . setModifiedSize s-    . setModifiedLastWrite s-    . setModifiedSecurity s+      setFileNameEvents s+    . setDirNameEvents s+    . setAttrsModified s+    . setSizeModified s+    . setLastWriteTimeModified s+    . setSecurityModified s +-- | The tunable events that are enabled by default are:+--+-- * setFileNameEvents On+-- * setDirNameEvents On+-- * setSizeModified On+-- * setLastWriteTimeModified On+--+-- /Pre-release/+-- defaultConfig :: Config-defaultConfig = setAllEvents On $ Config {watchRec = True, createFlags = 0}+defaultConfig =+      setFileNameEvents On+    $ setDirNameEvents On+    $ setSizeModified On+    $ setLastWriteTimeModified On+    $ Config {watchRec = False, createFlags = 0}  getConfigFlag :: Config -> DWORD getConfigFlag Config{..} = createFlags@@ -351,6 +392,7 @@             bytesRet <- peekByteOff bret 0             readChangeEvents buffer root bytesRet +-- XXX Try to get these from windows header files type FileAction = DWORD  fILE_ACTION_ADDED             :: FileAction@@ -394,37 +436,9 @@  -- | 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@@ -433,49 +447,55 @@ -- 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.+-- | Start monitoring a list of directory paths for file system events with the+-- supplied configuration modifier operation over the' defaultConfig'. The+-- paths could be directories or symbolic links to directories. --+-- When recursive mode is True, the whole directory tree under the path is+-- watched recursively.  When recursive mode is False, 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 UTF-8 encoded 'Array' of 'Word8'.+--+-- /Symbolic Links:/ If the pathname to be watched is a symbolic link then+-- watch the target of the symbolic link instead of the symbolic link itself.+-- Note that the path location in the events is through the original symbolic+-- link path rather than the resolved path.+--+-- @+-- watchWith+--  ('setAttrsModified' On . 'setLastWriteTimeModified' Off)+--  [Array.fromCString\# "dir"#]+-- @+-- -- /Pre-release/ ---watchTreesWith ::-       (Config -> Config)-    -> NonEmpty (Array Word8)-    -> SerialT IO Event-watchTreesWith f paths =+watchWith :: (Config -> Config) -> NonEmpty (Array Word8) -> SerialT IO Event+watchWith f paths =      S.bracket before after (S.concatMapWith parallel eventStreamAggr)      where -    before =-        let cfg = f $ setRecursiveMode True defaultConfig-         in return $ pathsToHandles (utf8ToStringList paths) cfg+    before = return $ pathsToHandles (utf8ToStringList paths) $ f defaultConfig     after = liftIO . closePathHandleStream --- | Like 'watchTreesWith' but uses the 'defaultConfig' options.+-- | Same as 'watchWith' using 'defaultConfig' and recursive mode. ----- @--- watchTrees = watchTreesWith id--- @+-- >>> watchRecursive = watchWith (setRecursiveMode On) ---watchTrees :: NonEmpty (Array Word8) -> SerialT IO Event-watchTrees = watchTreesWith id+-- /Pre-release/+--+watchRecursive :: NonEmpty (Array Word8) -> SerialT IO Event+watchRecursive = watchWith (setRecursiveMode On) --- | Add a trailing "\" at the end of the path if there is none. Do not add a--- "\" if the path is empty.+-- | Same as 'watchWith' using defaultConfig and non-recursive mode. ---ensureTrailingSlash :: String -> String-ensureTrailingSlash path =-    if null path-    then path-    else-        let x = last path-        in if x /= '\\' && x /= '/'-            then path ++ "\\"-            else path+-- >>> watch = watchWith id+--+-- /Pre-release/+--+watch :: NonEmpty (Array Word8) -> SerialT IO Event+watch = watchWith id  getFlag :: DWORD -> Event -> Bool getFlag mask Event{..} = eventFlags == mask@@ -487,8 +507,8 @@ -- -- /Pre-release/ ---getRelPath :: Event -> String-getRelPath Event{..} = eventRelPath+getRelPath :: Event -> Array Word8+getRelPath Event{..} = (UTF8.toArray . UTF8.pack) eventRelPath  -- XXX Change the type to Array Word8 to make it compatible with other APIs. --@@ -496,30 +516,38 @@ -- -- /Pre-release/ ---getRoot :: Event -> String-getRoot Event{..} = ensureTrailingSlash eventRootPath+getRoot :: Event -> Array Word8+getRoot Event{..} = (UTF8.toArray . UTF8.pack) 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. --+-- When the watch root is a symlink, the absolute path returned is via the+-- original symlink and not through the resolved path.+-- -- /Pre-release/ ---getAbsPath :: Event -> String-getAbsPath ev = getRoot ev <> getRelPath ev+getAbsPath :: Event -> Array Word8+getAbsPath ev = getRoot ev <> A.fromCString# "\\"# <> getRelPath ev  -- XXX need to document the exact semantics of these. ----- | File/directory created in watched directory.+-- | This event is generated when a file or directory is created in a watched+-- directory or directory tree when in recursive watch mode.  Creating a hard+-- link also generates this event. --+-- /Occurs when either 'setFileNameEvents' or 'setDirNameEvents' is enabled/+-- -- /Pre-release/ -- isCreated :: Event -> Bool isCreated = getFlag fILE_ACTION_ADDED --- | File/directory deleted from watched directory.+-- | This event is generated when a file or directory is deleted from the+-- watched directory or directory tree when in recursive mode. This event is+-- generated even when a hard link is deleted. --+-- /Occurs when either 'setFileNameEvents' or 'setDirNameEvents' is enabled/+-- -- /Pre-release/ -- isDeleted :: Event -> Bool@@ -528,6 +556,8 @@ -- | Generated for the original path when an object is moved from under a -- monitored directory. --+-- /Occurs when either 'setFileNameEvents' or 'setDirNameEvents' is enabled/+-- -- /Pre-release/ -- isMovedFrom :: Event -> Bool@@ -536,29 +566,53 @@ -- | Generated for the new path when an object is moved under a monitored -- directory. --+-- /Occurs when either 'setFileNameEvents' or 'setDirNameEvents' is enabled/+-- -- /Pre-release/ -- isMovedTo :: Event -> Bool isMovedTo = getFlag fILE_ACTION_RENAMED_NEW_NAME +-- | Generated for a path that is moved from or moved to the monitored+-- directory.+--+-- >>> isMoved ev = isMovedFrom ev || isMovedTo ev+--+-- /Occurs when either 'setFileNameEvents' or 'setDirNameEvents' is enabled/+-- /Occurs only for an object inside the watched directory/+--+-- /Pre-release/+--+isMoved :: Event -> Bool+isMoved ev = isMovedFrom ev || isMovedTo ev+ -- XXX This event is generated only for files and not directories? ----- | Determine whether the event indicates modification of an object within the--- monitored path.+-- | This event occurs when a file or directory contents, timestamps or+-- attributes are modified.  Since it can occur on multiple changes, you may+-- have to check the attributes to know what exactly changed when multiple type+-- of modified events are enabled. --+-- In non-recursive mode this event does not occur for directories.  In+-- recursive mode this event occurs for the parent directory if a file or+-- directory inside it is created or renamed.+--+-- /Occurs when one of the @set*Modified@ events is enabled/+-- -- /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.+-- | If the kernel event 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 of the file+-- system tree. -- -- /Pre-release/ ---isOverflow :: Event -> Bool-isOverflow Event{..} = totalBytes == 0+isEventsLost :: Event -> Bool+isEventsLost Event{..} = totalBytes == 0  ------------------------------------------------------------------------------- -- Debugging@@ -568,11 +622,11 @@ showEvent :: Event -> String showEvent ev@Event{..} =         "--------------------------"-    ++ "\nRoot = " ++ show (getRoot ev)-    ++ "\nRelative Path = " ++ show (getRelPath ev)-    ++ "\nAbsolute Path = " ++ show (getAbsPath ev)+    ++ "\nRoot = " ++ utf8ToString (getRoot ev)+    ++ "\nPath = " ++ utf8ToString (getRelPath ev)+    ++ "\ngetAbsPath = " ++ utf8ToString (getAbsPath ev)     ++ "\nFlags " ++ show eventFlags-    ++ showev isOverflow "Overflow"+    ++ showev isEventsLost "Overflow"     ++ showev isCreated "Created"     ++ showev isDeleted "Deleted"     ++ showev isModified "Modified"
src/Streamly/Internal/FileSystem/FD.hs view
@@ -130,17 +130,19 @@ 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.Array.Foreign.Type+    (Array(..), byteLength, unsafeFreeze)+import Streamly.Internal.Data.Array.Foreign.Mut.Type+    (fromForeignPtrUnsafe, unsafeWithArrayContents)+import Streamly.Internal.System.IO (defaultChunkSize) import Streamly.Internal.Data.Stream.Serial (SerialT)-import Streamly.Internal.Data.Stream.StreamK.Type (IsStream, mkStream)-+import Streamly.Internal.Data.Stream.IsStream.Type+    (IsStream, mkStream, fromStreamD) #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 Streamly.Internal.Data.Stream.IsStream.Type (toStreamD)+import Streamly.Internal.System.IOVec (groupIOVecsOf) import qualified Streamly.Internal.FileSystem.FDIO as RawIO hiding (write)+import qualified Streamly.Internal.System.IOVec.Type as RawIO #endif -- import Streamly.Data.Fold (Fold) -- import Streamly.String (encodeUtf8, decodeUtf8, foldLines)@@ -224,8 +226,9 @@ #endif         -- XXX shrink only if the diff is significant         -- Use unsafeFreezeWithShrink-        return $-            unsafeFreeze $ mutableArray ptr (p `plusPtr` n) (p `plusPtr` size)+        return+            $ unsafeFreeze+            $ fromForeignPtrUnsafe ptr (p `plusPtr` n) (p `plusPtr` size)  ------------------------------------------------------------------------------- -- Array IO (output)@@ -237,7 +240,8 @@ {-# INLINABLE writeArray #-} writeArray :: Storable a => Handle -> Array a -> IO () writeArray _ arr | A.length arr == 0 = return ()-writeArray (Handle fd) arr = withForeignPtr (aStart arr) $ \p ->+writeArray (Handle fd) arr =+    unsafeWithArrayContents (arrContents arr) (arrStart arr) $ \p ->     -- RawIO.writeAll fd (castPtr p) aLen #if MIN_VERSION_base(4,15,0)     RawIO.write fd (castPtr p) 0 aLen@@ -262,7 +266,7 @@ writeIOVec :: Handle -> Array RawIO.IOVec -> IO () writeIOVec _ iov | A.length iov == 0 = return () writeIOVec (Handle fd) iov =-    withForeignPtr (aStart iov) $ \p ->+    unsafeWithArrayContents (arrContents iov) (arrStart iov) $ \p ->         RawIO.writevAll fd p (A.length iov) #endif @@ -288,7 +292,7 @@ {-# INLINE_NORMAL readArraysOfUpto #-} readArraysOfUpto :: (IsStream t, MonadIO m)     => Int -> Handle -> t m (Array Word8)-readArraysOfUpto size h = D.fromStreamD (D.Stream step ())+readArraysOfUpto size h = fromStreamD (D.Stream step ())   where     {-# INLINE_LATE step #-}     step _ _ = do
src/Streamly/Internal/FileSystem/FDIO.hs view
@@ -16,13 +16,13 @@ module Streamly.Internal.FileSystem.FDIO     ( write     , writeAll-    , IOVec (..)     , writev     , writevAll     ) where  import Control.Monad (when)+import Streamly.Internal.System.IOVec.Type (IOVec) #if !defined(mingw32_HOST_OS) import Control.Concurrent (threadWaitWrite) import Data.Int (Int64)@@ -31,7 +31,7 @@ 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)+import Streamly.Internal.System.IOVec.Type (c_writev, c_safe_writev) #endif  import Foreign.C.Types (CSize(..), CInt(..))@@ -39,8 +39,6 @@ import Foreign.Ptr (plusPtr, Ptr)  import GHC.IO.FD (FD(..))--import Streamly.Internal.FileSystem.IOVec (IOVec(..))  ------------------------------------------------------------------------------- -- IO Routines
src/Streamly/Internal/FileSystem/File.hs view
@@ -55,6 +55,7 @@      -- -- * Array Read     , readChunksWithBufferOf+    , readChunksFromToWith     , readChunks      , toChunksWithBufferOf@@ -71,7 +72,7 @@     , fromBytesWithBufferOf      -- -- * Array Write-    , writeArray+    , putChunk     , writeChunks     , fromChunks @@ -94,22 +95,22 @@ import qualified Control.Monad.Catch as MC import qualified System.IO as SIO +import Streamly.Internal.Control.Concurrent (MonadAsync) 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.Array.Foreign.Type (Array(..), writeNUnsafe) import Streamly.Internal.Data.Stream.Serial (SerialT)-import Streamly.Internal.Data.Stream.StreamK.Type (IsStream)-import Streamly.Internal.Data.SVar (MonadAsync)+import Streamly.Internal.Data.Stream.IsStream.Type (IsStream) -- import Streamly.Data.Fold (Fold) -- import Streamly.String (encodeUtf8, decodeUtf8, foldLines)+import Streamly.Internal.System.IO (defaultChunkSize) +import qualified Streamly.Internal.Data.Array.Foreign as A 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.Data.Array.Stream.Foreign as AS import qualified Streamly.Internal.Data.Stream.IsStream as S-import qualified Streamly.Data.Array.Foreign as A  ------------------------------------------------------------------------------- -- References@@ -170,6 +171,19 @@      after (_, h) = liftIO $ hClose h +{-# INLINABLE usingFile3 #-}+usingFile3 :: (MonadCatch m, MonadAsync m)+    => Unfold m (x, y, z, Handle) a -> Unfold m (x, y, z, FilePath) a+usingFile3 = UF.bracket before after++    where++    before (x, y, z, file) =  do+        h <- liftIO $ openFile file ReadMode+        return (x, y, z, h)++    after (_, _, _, h) = liftIO $ hClose h+ ------------------------------------------------------------------------------- -- Array IO (Input) -------------------------------------------------------------------------------@@ -183,16 +197,16 @@ -- | Write an array to a file. Overwrites the file if it exists. -- -- @since 0.7.0-{-# INLINABLE writeArray #-}-writeArray :: Storable a => FilePath -> Array a -> IO ()-writeArray file arr = SIO.withFile file WriteMode (`FH.writeArray` arr)+{-# INLINABLE putChunk #-}+putChunk :: Storable a => FilePath -> Array a -> IO ()+putChunk file arr = SIO.withFile file WriteMode (`FH.putChunk` arr)  -- | append an array to a file. -- -- @since 0.7.0 {-# INLINABLE appendArray #-} appendArray :: Storable a => FilePath -> Array a -> IO ()-appendArray file arr = SIO.withFile file AppendMode (`FH.writeArray` arr)+appendArray file arr = SIO.withFile file AppendMode (`FH.putChunk` arr)  ------------------------------------------------------------------------------- -- Stream of Arrays IO@@ -241,6 +255,19 @@     => Unfold m (Int, FilePath) (Array Word8) readChunksWithBufferOf = usingFile2 FH.readChunksWithBufferOf +-- | Unfold the tuple @(from, to, bufsize, filepath)@ into a stream+-- of 'Word8' arrays.+-- Read requests to the IO device are performed using a buffer of size+-- @bufsize@ starting from absolute offset of @from@ till the absolute+-- position of @to@. The size of an array in the resulting stream is always+-- less than or equal to @bufsize@.+--+-- /Pre-release/+{-# INLINE readChunksFromToWith #-}+readChunksFromToWith :: (MonadCatch m, MonadAsync m) =>+    Unfold m (Int, Int, Int, FilePath) (Array Word8)+readChunksFromToWith = usingFile3 FH.readChunksFromToWith+ -- | 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@@ -298,7 +325,7 @@ fromChunksMode :: (MonadAsync m, MonadCatch m, Storable a)     => IOMode -> FilePath -> SerialT m (Array a) -> m () fromChunksMode mode file xs = S.drain $-    withFile file mode (\h -> S.mapM (liftIO . FH.writeArray h) xs)+    withFile file mode (\h -> S.mapM (FH.putChunk h) xs)  -- | Write a stream of arrays to a file. Overwrites the file if it exists. --@@ -359,7 +386,7 @@                 `MC.onException` liftIO (hClose h)         return $ FL.Partial (fld, h)     step (fld, h) x = do-        r <- FL.runStep fld x `MC.onException` liftIO (hClose h)+        r <- FL.snoc fld x `MC.onException` liftIO (hClose h)         return $ FL.Partial (r, h)     extract (Fold _ initial1 extract1, h) = do         liftIO $ hClose h
src/Streamly/Internal/FileSystem/Handle.hs view
@@ -8,11 +8,30 @@ -- Maintainer  : streamly@composewell.com -- Stability   : experimental -- Portability : GHC+--+-- The fundamental singleton IO APIs are 'getChunk' and 'putChunk' and the+-- fundamental stream IO APIs built on top of those are+-- 'readChunksWithBufferOf' and 'writeChunks'. Rest of this module is just+-- combinatorial programming using these.+--+-- We can achieve line buffering by folding lines in the input stream into a+-- stream of arrays using Stream.splitOn or Fold.takeEndBy_ and similar+-- operations. One can wrap the input stream in 'Maybe' type and then use+-- 'writeMaybesWithBufferOf' to achieve user controlled buffering. +-- TODO: Need a separate module for pread/pwrite based reading writing for+-- seekable devices.  Stateless read/write can be helpful in multithreaded+-- applications.+-- module Streamly.Internal.FileSystem.Handle     (-    -- ** Read from Handle-      read+    -- * Singleton APIs+      getChunk+    , getChunkOf+    , putChunk++    -- * Byte Stream Read+    , read     -- , readUtf8     -- , readLines     -- , readFrames@@ -21,48 +40,40 @@     , toBytes     , toBytesWithBufferOf -    -- -- * Array Read-    -- , readArrayUpto-    -- , readArrayOf+    -- * Chunked Stream Read     , readChunks     , readChunksWithBufferOf      , toChunksWithBufferOf     , toChunks -    -- ** Write to Handle+    -- * Byte Stream Write     -- Byte stream write (Folds)     , write-    , write2+    , consumer     -- , writeUtf8     -- , writeUtf8ByLines     -- , writeByFrames     -- , writeLines     , writeWithBufferOf+    , writeMaybesWithBufferOf -    -- Byte stream write (Streams)     , putBytes     , putBytesWithBufferOf -    -- -- * Array Write-    , writeArray+    -- * Chunked Stream Write     , writeChunks     , writeChunksWithBufferOf -    -- -- * Array stream Write     , putChunksWithBufferOf     , putChunks -    -- -- * Random Access (Seek)-    -- -- | Unlike the streaming APIs listed above, these APIs apply to devices or+    -- * 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.-    ---    -- XXX need to decide whether to use readFromStepN style or readFromThenTo-    -- style. The latter is consistent with list enumeration. The former may be-    -- more unambiguous and it is easier and clearer to specify 0 elements.-    --+     -- We can also generate the request pattern using a funciton.     --     -- , readIndex@@ -75,8 +86,8 @@      -- , readChunksFrom     -- , readChunksFromTo-    -- , readChunksFromToWithBufferOf-    -- , readChunksFromThenToWithBufferOf+    , readChunksFromToWith+    -- , readChunksFromThenToWith      -- , writeIndex     -- , writeFrom -- start writing at the given position@@ -88,41 +99,58 @@     --     -- , writeChunksFrom     -- , writeChunksFromTo-    -- , writeChunksFromToWithBufferOf-    -- , writeChunksFromThenToWithBufferOf+    -- , writeChunksFromToWith+    -- , writeChunksFromThenToWith     ) where +import Control.Exception (assert) import Control.Monad.IO.Class (MonadIO(..))+import Data.Function ((&))+import Data.Maybe (isNothing, fromJust) import Data.Word (Word8)-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)+import System.IO (Handle, SeekMode(..), hGetBufSome, hPutBuf, hSeek) import Prelude hiding (read) -import Streamly.Internal.BaseCompat-import Streamly.Data.Fold (Fold)-import Streamly.Internal.Data.Fold.Type (Fold2(..))+import Streamly.Internal.Data.Array.Foreign.Mut.Type (touch)+import Streamly.Internal.Data.Fold (Fold)+import Streamly.Internal.Data.Refold.Type (Refold(..)) import Streamly.Internal.Data.Unfold.Type (Unfold(..)) import Streamly.Internal.Data.Array.Foreign.Type-       (Array(..), writeNUnsafe, defaultChunkSize , unsafeFreezeWithShrink)-import Streamly.Internal.Data.Array.Foreign.Mut.Type (mutableArray)+       (Array(..), writeNUnsafe, unsafeFreezeWithShrink, byteLength)+import Streamly.Internal.Data.Array.Foreign.Mut.Type (fromForeignPtrUnsafe) import Streamly.Internal.Data.Stream.Serial (SerialT)-import Streamly.Internal.Data.Stream.StreamK.Type (IsStream, mkStream)+import Streamly.Internal.Data.Stream.IsStream.Type+    (IsStream, mkStream, fromStreamD) import Streamly.Internal.Data.Array.Stream.Foreign (lpackArraysChunksOf) -- import Streamly.String (encodeUtf8, decodeUtf8, foldLines)+import Streamly.Internal.System.IO (defaultChunkSize) -import qualified Streamly.Data.Fold as FL-import qualified Streamly.Internal.Data.Fold.Type as FL-import qualified Streamly.Internal.Data.Unfold as UF+import qualified Streamly.Internal.Data.Array.Foreign as A import qualified Streamly.Internal.Data.Array.Stream.Foreign as AS+import qualified Streamly.Internal.Data.Refold.Type as Refold+import qualified Streamly.Internal.Data.Fold as FL+import qualified Streamly.Internal.Data.Fold.Type as FL 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 Streamly.Internal.Data.Unfold as UF +-- $setup+-- >>> import qualified Streamly.Data.Array.Foreign as Array+-- >>> import qualified Streamly.Data.Fold as Fold+-- >>> import qualified Streamly.Data.Unfold as Unfold+-- >>> import qualified Streamly.FileSystem.Handle as Handle+-- >>> import qualified Streamly.Prelude as Stream+--+-- >>> import qualified Streamly.Internal.Data.Stream.IsStream as Stream+-- >>> import qualified Streamly.Internal.Data.Unfold as Unfold (supplyFirst)+-- >>> import qualified Streamly.Internal.FileSystem.Handle as Handle+-- >>> import qualified Streamly.Internal.System.IO as IO (defaultChunkSize)+ ------------------------------------------------------------------------------- -- References -------------------------------------------------------------------------------@@ -140,13 +168,16 @@ -- 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 h = do+-- | Read a 'ByteArray' consisting of one or more bytes from a file handle. If+-- no data is available on the handle it blocks until at least one byte becomes+-- available. If any data is available then it immediately returns that data+-- without blocking. As a result of this behavior, it may read less than or+-- equal to the size requested.+--+-- @since 0.8.1+{-# INLINABLE getChunk #-}+getChunk :: MonadIO m => Int -> Handle -> m (Array Word8)+getChunk size h = liftIO $ do     ptr <- mallocPlainForeignPtrBytes size     -- ptr <- mallocPlainForeignPtrAlignedBytes size (alignment (undefined :: Word8))     withForeignPtr ptr $ \p -> do@@ -154,8 +185,20 @@         -- XXX shrink only if the diff is significant         return $             unsafeFreezeWithShrink $-            mutableArray ptr (p `plusPtr` n) (p `plusPtr` size)+            fromForeignPtrUnsafe ptr (p `plusPtr` n) (p `plusPtr` size) +-- This could be useful in implementing the "reverse" read APIs or if you want+-- to read arrays of exact size instead of compacting them later. Compacting+-- later requires more copying.+--+-- | Read a 'ByteArray' consisting of exactly the specified number of bytes+-- from a file handle.+--+-- /Unimplemented/+{-# INLINABLE getChunkOf #-}+getChunkOf :: Int -> Handle -> IO (Array Word8)+getChunkOf = undefined+ ------------------------------------------------------------------------------- -- Stream of Arrays IO -------------------------------------------------------------------------------@@ -170,8 +213,8 @@   where     -- XXX use cons/nil instead     go = mkStream $ \_ yld _ stp -> do-        arr <- liftIO $ readArrayUpto size h-        if A.length arr == 0+        arr <- getChunk size h+        if byteLength arr == 0         then stp         else yld arr go @@ -179,16 +222,24 @@ -- handle @handle@.  The maximum size of a single array is limited to @size@. -- The actual size read may be less than or equal to @size@. --+-- >>> toChunksWithBufferOf size h = Stream.unfold Handle.readChunksWithBufferOf (size, h)+-- -- @since 0.7.0 {-# INLINE_NORMAL toChunksWithBufferOf #-}-toChunksWithBufferOf :: (IsStream t, MonadIO m) => Int -> Handle -> t m (Array Word8)-toChunksWithBufferOf size h = D.fromStreamD (D.Stream step ())+toChunksWithBufferOf :: (IsStream t, MonadIO m) =>+    Int -> Handle -> t m (Array Word8)+{-+toChunksWithBufferOf size h =+     S.repeatM (getChunk size h)+   & S.takeWhile ((/= 0) . byteLength)+-}+toChunksWithBufferOf size h = fromStreamD (D.Stream step ())   where     {-# INLINE_LATE step #-}     step _ _ = do-        arr <- liftIO $ readArrayUpto size h+        arr <- getChunk size h         return $-            case A.length arr of+            case byteLength arr of                 0 -> D.Stop                 _ -> D.Yield arr () @@ -200,16 +251,60 @@ -- @since 0.7.0 {-# INLINE_NORMAL readChunksWithBufferOf #-} readChunksWithBufferOf :: MonadIO m => Unfold m (Int, Handle) (Array Word8)+readChunksWithBufferOf =+     UF.lmap (uncurry getChunk) UF.repeatM+   & UF.takeWhile ((/= 0) . byteLength)+{- readChunksWithBufferOf = Unfold step return+     where+     {-# INLINE_LATE step #-}     step (size, h) = do-        arr <- liftIO $ readArrayUpto size h+        arr <- getChunk size h         return $-            case A.length arr of+            case byteLength arr of                 0 -> D.Stop                 _ -> D.Yield arr (size, h)+-} +-- There are two ways to implement this.+--+-- 1. Idiomatic: use a scan on the output of readChunksWithBufferOf to total+-- the array lengths and trim the last array to correct size.+-- 2. Simply implement it from scratch like readChunksWithBufferOf.+--+-- XXX Change this to readChunksWithFromTo (bufferSize, from, to, h)?+--+-- | The input to the unfold is @(from, to, bufferSize, handle)@. It starts+-- reading from the offset `from` in the file and reads up to the offset `to`.+--+--+{-# INLINE_NORMAL readChunksFromToWith #-}+readChunksFromToWith :: MonadIO m =>+    Unfold m (Int, Int, Int, Handle) (Array Word8)+readChunksFromToWith = Unfold step inject++    where++    inject (from, to, bufSize, h) = do+        liftIO $ hSeek h AbsoluteSeek $ fromIntegral from+        -- XXX Use a strict Tuple?+        return (to - from + 1, bufSize, h)++    {-# INLINE_LATE step #-}+    step (remaining, bufSize, h) =+        if remaining <= 0+        then return D.Stop+        else do+            arr <- getChunk (min bufSize remaining) h+            return $+                case byteLength arr of+                    0 -> D.Stop+                    len ->+                        assert (len <= remaining)+                            $ D.Yield arr (remaining - len, bufSize, h)+ -- XXX read 'Array a' instead of Word8 -- -- | @toChunks handle@ reads a stream of arrays from the specified file@@ -217,7 +312,7 @@ -- @defaultChunkSize@. The actual size read may be less than or equal to -- @defaultChunkSize@. ----- > toChunks = toChunksWithBufferOf defaultChunkSize+-- >>> toChunks = Handle.toChunksWithBufferOf IO.defaultChunkSize -- -- @since 0.7.0 {-# INLINE toChunks #-}@@ -230,6 +325,8 @@ -- size of arrays in the resulting stream are therefore less than or equal to -- 'Streamly.Internal.Data.Array.Foreign.Type.defaultChunkSize'. --+-- >>> readChunks = Unfold.supplyFirst IO.defaultChunkSize Handle.readChunksWithBufferOf+-- -- @since 0.7.0 {-# INLINE readChunks #-} readChunks :: MonadIO m => Unfold m Handle (Array Word8)@@ -246,6 +343,8 @@ -- | Unfolds the tuple @(bufsize, handle)@ into a byte stream, read requests -- to the IO device are performed using buffers of @bufsize@. --+-- >>> readWithBufferOf = Unfold.many Handle.readChunksWithBufferOf Array.read+-- -- @since 0.7.0 {-# INLINE readWithBufferOf #-} readWithBufferOf :: MonadIO m => Unfold m (Int, Handle) Word8@@ -254,10 +353,12 @@ -- | @toBytesWithBufferOf bufsize handle@ reads a byte stream from a file -- handle, reads are performed in chunks of up to @bufsize@. --+-- >>> toBytesWithBufferOf size h = Stream.unfoldMany Array.read $ Handle.toChunksWithBufferOf size h+-- -- /Pre-release/ {-# INLINE toBytesWithBufferOf #-} toBytesWithBufferOf :: (IsStream t, MonadIO m) => Int -> Handle -> t m Word8-toBytesWithBufferOf chunkSize h = AS.concat $ toChunksWithBufferOf chunkSize h+toBytesWithBufferOf size h = AS.concat $ toChunksWithBufferOf size h  -- TODO -- Generate a stream of elements of the given type from a file 'Handle'.@@ -267,13 +368,17 @@ -- performed in sizes of -- 'Streamly.Internal.Data.Array.Foreign.Type.defaultChunkSize'. --+-- >>> read = Unfold.many Handle.readChunks Array.read+-- -- @since 0.7.0 {-# INLINE read #-} read :: MonadIO m => Unfold m Handle Word8-read = UF.supplyFirst defaultChunkSize readWithBufferOf+read = UF.many readChunks A.read  -- | Generate a byte stream from a file 'Handle'. --+-- >>> toBytes h = Stream.unfoldMany Array.read $ Handle.toChunks h+-- -- /Pre-release/ {-# INLINE toBytes #-} toBytes :: (IsStream t, MonadIO m) => Handle -> t m Word8@@ -289,16 +394,17 @@  -- | Write an 'Array' to a file handle. ----- @since 0.7.0-{-# INLINABLE writeArray #-}-writeArray :: Storable a => Handle -> Array a -> IO ()-writeArray _ arr | A.length arr == 0 = return ()-writeArray h Array{..} = unsafeWithForeignPtr aStart $ \p -> hPutBuf h p aLen+-- @since 0.8.1+{-# INLINABLE putChunk #-}+putChunk :: (MonadIO m, Storable a) => Handle -> Array a -> m ()+putChunk _ arr | A.length arr == 0 = return ()+putChunk h Array{..} =+    liftIO $ hPutBuf h arrStart aLen >> touch arrContents+     where-    aLen =-        let p = unsafeForeignPtrToPtr aStart-        in aEnd `minusPtr` p +    aLen = aEnd `minusPtr` arrStart+ ------------------------------------------------------------------------------- -- Stream of Arrays IO -------------------------------------------------------------------------------@@ -310,12 +416,18 @@ -- XXX use an unfold to fromObjects or fromUnfold so that we can put any object -- | Write a stream of arrays to a handle. --+-- >>> putChunks h = Stream.mapM_ (Handle.putChunk h)+-- -- @since 0.7.0 {-# INLINE putChunks #-} putChunks :: (MonadIO m, Storable a)     => Handle -> SerialT m (Array a) -> m ()-putChunks h = S.mapM_ (liftIO . writeArray h)+putChunks h = S.mapM_ (putChunk h) +-- XXX AS.compact can be written idiomatically in terms of foldMany, just like+-- AS.concat is written in terms of foldMany. Once that is done we can write+-- idiomatic def in the docs.+-- -- | @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@@ -331,20 +443,22 @@ -- in chunks of @bufsize@.  A write is performed to the IO device as soon as we -- collect the required input size. --+-- >>> putBytesWithBufferOf n h m = Handle.putChunks h $ Stream.arraysOf n m+-- -- @since 0.7.0 {-# 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.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. --+-- >>> putBytes = Handle.putBytesWithBufferOf IO.defaultChunkSize+-- -- @since 0.7.0 {-# INLINE putBytes #-} putBytes :: MonadIO m => Handle -> SerialT m Word8 -> m ()@@ -353,15 +467,22 @@ -- | Write a stream of arrays to a handle. Each array in the stream is written -- to the device as a separate IO request. --+-- writeChunks h = Fold.drainBy (Handle.putChunk h)+-- -- @since 0.7.0 {-# INLINE writeChunks #-} writeChunks :: (MonadIO m, Storable a) => Handle -> Fold m (Array a) ()-writeChunks h = FL.drainBy (liftIO . writeArray h)+writeChunks h = FL.drainBy (putChunk h) -{-# INLINE writeChunks2 #-}-writeChunks2 :: (MonadIO m, Storable a) => Fold2 m Handle (Array a) ()-writeChunks2 = Fold2 (\h arr -> liftIO $ writeArray h arr >> return h) return (\_ -> return ())+-- | Like writeChunks but uses the experimental 'Refold' API.+--+-- /Internal/+{-# INLINE consumeChunks #-}+consumeChunks :: (MonadIO m, Storable a) => Refold m Handle (Array a) ()+consumeChunks = Refold.drainBy putChunk +-- XXX lpackArraysChunksOf should be written idiomatically+-- -- | @writeChunksWithBufferOf bufsize handle@ writes a stream of arrays -- to @handle@ after coalescing the adjacent arrays in chunks of @bufsize@. -- We never split an array, if a single array is bigger than the specified size@@ -382,33 +503,57 @@ -- do not want buffering to occur at GHC level as well. Same thing applies to -- writes as well. +-- XXX Maybe we should have a Fold.arraysOf like we have Stream.arraysOf+-- -- | @writeWithBufferOf reqSize handle@ writes the input stream to @handle@. -- Bytes in the input stream are collected into a buffer until we have a chunk -- of @reqSize@ and then written to the IO device. --+-- >>> writeWithBufferOf n h = Fold.chunksOf n (Array.writeNUnsafe n) (Handle.writeChunks h)+-- -- @since 0.7.0 {-# INLINE writeWithBufferOf #-} writeWithBufferOf :: MonadIO m => Int -> Handle -> Fold m Word8 () writeWithBufferOf n h = FL.chunksOf n (writeNUnsafe n) (writeChunks h) -{-# INLINE writeWithBufferOf2 #-}-writeWithBufferOf2 :: MonadIO m => Int -> Fold2 m Handle Word8 ()-writeWithBufferOf2 n = FL.chunksOf2 n (writeNUnsafe n) writeChunks2+-- | Write a stream of 'Maybe' values. Keep buffering the just values in an+-- array until a 'Nothing' is encountered or the buffer size exceeds the+-- specified limit, at that point flush the buffer to the handle.+--+-- /Pre-release/+{-# INLINE writeMaybesWithBufferOf #-}+writeMaybesWithBufferOf :: (MonadIO m )+    => Int -> Handle -> Fold m (Maybe Word8) ()+writeMaybesWithBufferOf n h =+    let writeNJusts = FL.lmap fromJust $ A.writeN n+        writeOnNothing = FL.takeEndBy_ isNothing writeNJusts+    in FL.many writeOnNothing (writeChunks h) --- > write = 'writeWithBufferOf' A.defaultChunkSize+-- | Like 'writeWithBufferOf'  but uses the experimental 'Refold' API. --+-- /Internal/+{-# INLINE consumerWithBufferOf #-}+consumerWithBufferOf :: MonadIO m => Int -> Refold m Handle Word8 ()+consumerWithBufferOf n =+    FL.refoldMany (FL.take n $ writeNUnsafe n) consumeChunks+ -- | Write a byte stream to a file handle. Accumulates the input in chunks of -- up to 'Streamly.Internal.Data.Array.Foreign.Type.defaultChunkSize' before writing -- to the IO device. --+-- >>> write = Handle.writeWithBufferOf IO.defaultChunkSize+-- -- @since 0.7.0 {-# INLINE write #-} write :: MonadIO m => Handle -> Fold m Word8 () write = writeWithBufferOf defaultChunkSize -{-# INLINE write2 #-}-write2 :: MonadIO m => Fold2 m Handle Word8 ()-write2 = writeWithBufferOf2 defaultChunkSize+-- | Like 'write'  but uses the experimental 'Refold' API.+--+-- /Internal/+{-# INLINE consumer #-}+consumer :: MonadIO m => Refold m Handle Word8 ()+consumer = consumerWithBufferOf defaultChunkSize  {- {-# INLINE write #-}
− src/Streamly/Internal/FileSystem/IOVec.hsc 
@@ -1,83 +0,0 @@-#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/Network/Inet/TCP.hs view
@@ -103,15 +103,15 @@         socket) import Prelude hiding (read) -import Streamly.Internal.Data.Array.Foreign.Type (Array(..), defaultChunkSize, writeNUnsafe)+import Streamly.Internal.Control.Concurrent (MonadAsync, fork)+import Streamly.Internal.Data.Array.Foreign.Type (Array(..), 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.Stream.IsStream.Type (IsStream) import Streamly.Internal.Data.Stream.Serial (SerialT)-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 Streamly.Internal.System.IO (defaultChunkSize)  import qualified Control.Monad.Catch as MC import qualified Network.Socket as Net@@ -121,7 +121,6 @@ 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  -------------------------------------------------------------------------------@@ -356,10 +355,11 @@     where     initial = do         skt <- liftIO (connect addr port)-        fld <- FL.initialize (SK.writeChunks skt) `MC.onException` liftIO (Net.close skt)+        fld <- FL.initialize (ISK.writeChunks skt)+                    `MC.onException` liftIO (Net.close skt)         return $ FL.Partial (Tuple' fld skt)     step (Tuple' fld skt) x = do-        r <- FL.runStep fld x `MC.onException` liftIO (Net.close skt)+        r <- FL.snoc fld x `MC.onException` liftIO (Net.close skt)         return $ FL.Partial (Tuple' r skt)     extract (Tuple' (Fold _ initial1 extract1) skt) = do         liftIO $ Net.close skt
src/Streamly/Internal/Network/Socket.hs view
@@ -47,6 +47,7 @@     -- , writeUtf8ByLines     -- , writeByFrames     , writeWithBufferOf+    , writeMaybesWithBufferOf      , putChunks     , putBytesWithBufferOf@@ -66,9 +67,8 @@ import Control.Monad.Catch (MonadCatch, finally, MonadMask) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad (forM_, when)+import Data.Maybe (isNothing, fromJust) import Data.Word (Word8)--import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) import Foreign.Ptr (minusPtr, plusPtr, Ptr, castPtr) import Foreign.Storable (Storable(..)) import GHC.ForeignPtr (mallocPlainForeignPtrBytes)@@ -86,23 +86,26 @@ import qualified Network.Socket as Net  import Streamly.Internal.BaseCompat-import Streamly.Internal.Data.Unfold.Type (Unfold(..))-import Streamly.Internal.Data.Array.Stream.Foreign (lpackArraysChunksOf)+import Streamly.Internal.Control.Concurrent (MonadAsync)+import Streamly.Internal.Data.Array.Foreign.Mut.Type+    (fromForeignPtrUnsafe, touch) 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.Array.Stream.Foreign (lpackArraysChunksOf)+import Streamly.Internal.Data.Fold (Fold)+import Streamly.Internal.Data.Stream.IsStream.Type+    (IsStream, mkStream, fromStreamD) import Streamly.Internal.Data.Stream.Serial (SerialT)-import Streamly.Internal.Data.Stream.StreamK.Type (IsStream, mkStream)-import Streamly.Data.Fold (Fold)+import Streamly.Internal.Data.Unfold.Type (Unfold(..)) -- import Streamly.String (encodeUtf8, decodeUtf8, foldLines)+import Streamly.Internal.System.IO (defaultChunkSize) -import qualified Streamly.Data.Fold as FL-import qualified Streamly.Internal.Data.Unfold as UF-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 as A import qualified Streamly.Internal.Data.Array.Foreign.Type as A+import qualified Streamly.Internal.Data.Array.Stream.Foreign as AS+import qualified Streamly.Internal.Data.Fold as FL import qualified Streamly.Internal.Data.Stream.IsStream as S import qualified Streamly.Internal.Data.Stream.StreamD.Type as D+import qualified Streamly.Internal.Data.Unfold as UF  -- | @'forSocketM' action socket@ runs the monadic computation @action@ passing -- the socket handle to it.  The handle will be closed on exit from@@ -257,7 +260,7 @@     unsafeWithForeignPtr ptr $ \p -> do         n <- f h p size         let v = A.unsafeFreeze-                $ mutableArray ptr (p `plusPtr` n) (p `plusPtr` size)+                $ fromForeignPtrUnsafe ptr (p `plusPtr` n) (p `plusPtr` size)          -- XXX shrink only if the diff is significant         -- A.shrinkToFit v@@ -303,13 +306,13 @@     -> Array a     -> IO () writeArrayWith _ _ arr | A.length arr == 0 = return ()-writeArrayWith f h Array{..} = unsafeWithForeignPtr aStart $ \p ->-    f h (castPtr p) aLen+writeArrayWith f h Array{..} =+    f h (castPtr arrStart) aLen >> touch arrContents+     where-    aLen =-        let p = unsafeForeignPtrToPtr aStart-        in aEnd `minusPtr` p +    aLen = aEnd `minusPtr` arrStart+ -- | Write an Array to a file handle. -- -- @since 0.8.0@@ -342,7 +345,7 @@ toChunksWithBufferOf :: (IsStream t, MonadIO m)     => Int -> Socket -> t m (Array Word8) -- toChunksWithBufferOf = _readChunksUptoWith readChunk-toChunksWithBufferOf size h = D.fromStreamD (D.Stream step ())+toChunksWithBufferOf size h = fromStreamD (D.Stream step ())     where     {-# INLINE_LATE step #-}     step _ _ = do@@ -360,7 +363,7 @@ -- @since 0.7.0 {-# INLINE toChunks #-} toChunks :: (IsStream t, MonadIO m) => Socket -> t m (Array Word8)-toChunks = toChunksWithBufferOf A.defaultChunkSize+toChunks = toChunksWithBufferOf defaultChunkSize  -- | Unfold the tuple @(bufsize, socket)@ into a stream of 'Word8' arrays. -- Read requests to the socket are performed using a buffer of size @bufsize@.@@ -389,7 +392,7 @@ -- @since 0.7.0 {-# INLINE readChunks #-} readChunks :: MonadIO m => Unfold m Socket (Array Word8)-readChunks = UF.supplyFirst A.defaultChunkSize readChunksWithBufferOf+readChunks = UF.supplyFirst defaultChunkSize readChunksWithBufferOf  ------------------------------------------------------------------------------- -- Read File to Stream@@ -412,7 +415,7 @@ -- TODO -- read :: (IsStream t, MonadIO m, Storable a) => Handle -> t m a ----- > read = 'readByChunks' A.defaultChunkSize+-- > read = 'readByChunks' defaultChunkSize -- | Generate a stream of elements of the given type from a socket. The -- stream ends when EOF is encountered. --@@ -436,7 +439,7 @@ -- @since 0.7.0 {-# INLINE read #-} read :: MonadIO m => Unfold m Socket Word8-read = UF.supplyFirst A.defaultChunkSize readWithBufferOf+read = UF.supplyFirst defaultChunkSize readWithBufferOf  ------------------------------------------------------------------------------- -- Writing@@ -495,33 +498,46 @@ writeWithBufferOf :: MonadIO m => Int -> Socket -> Fold m Word8 () writeWithBufferOf n h = FL.chunksOf n (A.writeNUnsafe n) (writeChunks h) --- > write = 'writeWithBufferOf' A.defaultChunkSize+-- | Write a stream of 'Maybe' values. Keep buffering the 'Just' values in an+-- array. Write the array to the 'Handle' as soon as a 'Nothing' is encountered+-- or the buffer size exceeds the specified limit. --+-- /Pre-release/+{-# INLINE writeMaybesWithBufferOf #-}+writeMaybesWithBufferOf :: (MonadIO m )+    => Int -> Socket -> Fold m (Maybe Word8) ()+writeMaybesWithBufferOf n h =+    let writeNJusts = FL.lmap fromJust $ A.writeN n+        writeOnNothing = FL.takeEndBy_ isNothing writeNJusts+    in FL.many writeOnNothing (writeChunks h)++-- > write = 'writeWithBufferOf' 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+-- up to '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 putBytes #-} putBytes :: MonadIO m => Socket -> SerialT m Word8 -> m ()-putBytes = putBytesWithBufferOf A.defaultChunkSize+putBytes = putBytesWithBufferOf defaultChunkSize  -- | Write a byte stream to a socket. Accumulates the input in chunks of--- up to 'A.defaultChunkSize' bytes before writing.+-- up to 'defaultChunkSize' bytes before writing. -- -- @--- write = 'writeWithBufferOf' 'A.defaultChunkSize'+-- write = 'writeWithBufferOf' 'defaultChunkSize' -- @ -- -- @since 0.7.0 {-# INLINE write #-} write :: MonadIO m => Socket -> Fold m Word8 ()-write = writeWithBufferOf A.defaultChunkSize+write = writeWithBufferOf defaultChunkSize  {- {-# INLINE write #-} write :: (MonadIO m, Storable a) => Handle -> SerialT m a -> m ()-write = toHandleWith A.defaultChunkSize+write = toHandleWith defaultChunkSize -}  -------------------------------------------------------------------------------
src/Streamly/Internal/Ring/Foreign.hs view
@@ -40,6 +40,8 @@ import Prelude hiding (length, concat)  import Control.Monad.IO.Class (MonadIO(..))+import Streamly.Internal.Data.Array.Foreign.Mut.Type (memcmp)+import Streamly.Internal.System.IO (unsafeInlineIO)  import qualified Streamly.Internal.Data.Array.Foreign.Type as A @@ -115,7 +117,7 @@     -- touchForeignPtr (ringStart rb)     return $ advance rb ringHead --- XXX remove all usage of A.unsafeInlineIO+-- XXX remove all usage of unsafeInlineIO -- -- | Like 'unsafeEqArray' but compares only N bytes instead of entire length of -- the ring buffer. This is unsafe because the ringHead Ptr is not checked to@@ -123,14 +125,14 @@ {-# INLINE unsafeEqArrayN #-} unsafeEqArrayN :: Ring a -> Ptr a -> A.Array a -> Int -> Bool unsafeEqArrayN Ring{..} rh A.Array{..} n =-    let !res = A.unsafeInlineIO $ do+    let !res = unsafeInlineIO $ do             let rs = unsafeForeignPtrToPtr ringStart-                as = unsafeForeignPtrToPtr aStart+                as = arrStart             assert (aEnd `minusPtr` as >= ringBound `minusPtr` rs) (return ())             let len = ringBound `minusPtr` rh-            r1 <- A.memcmp (castPtr rh) (castPtr as) (min len n)+            r1 <- memcmp (castPtr rh) (castPtr as) (min len n)             r2 <- if n > len-                then A.memcmp (castPtr rs) (castPtr (as `plusPtr` len))+                then memcmp (castPtr rs) (castPtr (as `plusPtr` len))                               (min (rh `minusPtr` rs) (n - len))                 else return True             -- XXX enable these, check perf impact@@ -149,14 +151,14 @@ {-# INLINE unsafeEqArray #-} unsafeEqArray :: Ring a -> Ptr a -> A.Array a -> Bool unsafeEqArray Ring{..} rh A.Array{..} =-    let !res = A.unsafeInlineIO $ do+    let !res = unsafeInlineIO $ do             let rs = unsafeForeignPtrToPtr ringStart-            let as = unsafeForeignPtrToPtr aStart+            let as = arrStart             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))+            r1 <- memcmp (castPtr rh) (castPtr as) len+            r2 <- memcmp (castPtr rs) (castPtr (as `plusPtr` len))                            (rh `minusPtr` rs)             -- XXX enable these, check perf impact             -- touchForeignPtr ringStart@@ -175,7 +177,7 @@ 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 ->+    let !res = unsafeInlineIO $ withForeignPtr ringStart $ \p ->                     go z p ptr     in res     where@@ -202,7 +204,7 @@     go !acc !start !end         | start == end = return acc         | otherwise = do-            let !x = A.unsafeInlineIO $ peek start+            let !x = unsafeInlineIO $ peek start             acc' <- f acc x             go acc' (start `plusPtr` sizeOf (undefined :: a)) end @@ -220,7 +222,7 @@     withForeignPtrM ringStart $ \_ -> go z rh   where     go !acc !start = do-        let !x = A.unsafeInlineIO $ peek start+        let !x = unsafeInlineIO $ peek start         acc' <- f acc x         let ptr = advance rb start         if ptr == rh@@ -242,7 +244,7 @@      go 0 acc _ = return acc     go !n !acc !start = do-        let !x = A.unsafeInlineIO $ peek start+        let !x = unsafeInlineIO $ peek start         acc' <- f acc x         let ptr = advance rb start         if ptr == rh || n == 0
+ src/Streamly/Internal/System/IO.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE UnboxedTuples #-}++-- |+-- Module      : Streamly.Internal.System.IO+-- Copyright   : (c) 2020 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--++module Streamly.Internal.System.IO+    ( defaultChunkSize+    , arrayPayloadSize+    , unsafeInlineIO+    )++where++-------------------------------------------------------------------------------+-- Imports+-------------------------------------------------------------------------------++import Foreign.Storable (Storable(sizeOf))+import GHC.Base (realWorld#)+import GHC.IO (IO(IO))++-------------------------------------------------------------------------------+-- API+-------------------------------------------------------------------------------++{-# INLINE unsafeInlineIO #-}+unsafeInlineIO :: IO a -> a+unsafeInlineIO (IO m) = case m realWorld# of (# _, r #) -> r++-- | Returns the heap allocation overhead for allocating a byte array. Each+-- heap object contains a one word header. Byte arrays contain the size of the+-- array after the header.+--+-- See https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/rts/storage/heap-objects#arrays+--+byteArrayOverhead :: Int+byteArrayOverhead = 2 * sizeOf (undefined :: Word)++-- | When we allocate a byte array of size @k@ the allocator actually allocates+-- memory of size @k + byteArrayOverhead@. @arrayPayloadSize n@ returns the+-- size of the array in bytes that would result in an allocation of @n@ bytes.+--+arrayPayloadSize :: Int -> Int+arrayPayloadSize n = let size = n - byteArrayOverhead in max size 0++-- | Default maximum buffer size in bytes, for reading from and writing to IO+-- devices, the value is 32KB minus GHC allocation overhead, which is a few+-- bytes, so that the actual allocation is 32KB.+defaultChunkSize :: Int+defaultChunkSize = arrayPayloadSize (32 * 1024)
+ src/Streamly/Internal/System/IOVec.hs view
@@ -0,0 +1,126 @@+-- |+-- Module      : Streamly.Internal.System.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.System.IOVec+    ( IOVec(..)+    , c_writev+    , c_safe_writev+#if !defined(mingw32_HOST_OS)+    , groupIOVecsOf+    , groupIOVecsOfMut+#endif+    )+where++#include "inline.hs"++#if !defined(mingw32_HOST_OS)+import Control.Monad (when)+import Control.Monad.IO.Class (MonadIO(..))+import Foreign.Ptr (castPtr)+import Streamly.Internal.Data.Array.Foreign.Mut.Type (length)+import Streamly.Internal.Data.SVar (adaptState)+import Streamly.Internal.Data.Array.Foreign.Mut.Type (Array(..))++import qualified Streamly.Internal.Data.Array.Foreign.Type as Array+import qualified Streamly.Internal.Data.Array.Foreign.Mut.Type as MArray+import qualified Streamly.Internal.Data.Stream.StreamD as D+#endif++import Streamly.Internal.System.IOVec.Type++import Prelude hiding (length)++#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 groupIOVecsOfMut #-}+groupIOVecsOfMut :: MonadIO m+    => Int -> Int -> D.Stream m (Array a) -> D.Stream m (Array IOVec)+groupIOVecsOfMut 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 = arrStart arr+                    len = MArray.byteLength arr+                iov <- liftIO $ MArray.newArray maxIOVLen+                iov' <- liftIO $ MArray.snocUnsafe 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 = arrStart arr+                    alen = MArray.byteLength arr+                    len' = len + alen+                if len' > n || length iov >= maxIOVLen+                then do+                    iov' <- liftIO $ MArray.newArray maxIOVLen+                    iov'' <- liftIO $ MArray.snocUnsafe iov' (IOVec (castPtr p)+                                                      (fromIntegral alen))+                    return $ D.Skip (GatherYielding iov+                                        (GatherBuffering s iov'' alen))+                else do+                    iov' <- liftIO $ MArray.snocUnsafe 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++-- | @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.Array a) -> D.Stream m (Array.Array IOVec)+groupIOVecsOf n maxIOVLen str =+    D.map Array.unsafeFreeze+        $ groupIOVecsOfMut n maxIOVLen+        $ D.map Array.unsafeThaw str+#endif
+ src/Streamly/Internal/System/IOVec/Type.hsc view
@@ -0,0 +1,83 @@+#include "MachDeps.h"++-- |+-- Module      : Streamly.Internal.System.IOVec.Type+-- 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.System.IOVec.Type+    ( 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/Unicode/Char.hs view
@@ -19,13 +19,25 @@     , toUpper     , toTitle     -}++    -- * Unicode normalization+    , NormalizationMode(..)+    , normalize     ) where -import Data.Char (isAsciiUpper, isAsciiLower)+#include "inline.hs" --- import Streamly.Prelude (IsStream)+import Data.Char (isAsciiUpper, isAsciiLower, chr, ord)+import Data.Typeable (Typeable) +import Unicode.Char (DecomposeMode(..))+import Streamly.Internal.Data.Stream.IsStream.Type+    (IsStream, fromStreamD, toStreamD)+import Streamly.Internal.Data.Stream.StreamD (Stream(..), Step (..))++import qualified Unicode.Char as Char+ ------------------------------------------------------------------------------- -- Unicode aware operations on strings -------------------------------------------------------------------------------@@ -63,3 +75,245 @@ toTitle :: IsStream t => Char -> t m Char toTitle = undefined -}++-------------------------------------------------------------------------------+-- Unicode normalization+-------------------------------------------------------------------------------++data NormalizationMode+    = NFD    -- ^ Canonical decomposition.+    | NFKD   -- ^ Compatibility decomposition.+    | NFC    -- ^ Canonical decomposition followed by canonical composition.+    | NFKC   -- ^ Compatibility decomposition followed by canonical composition.+      deriving (Eq, Show, Enum, Typeable)++-------------------------------------------------------------------------------+-- Normalization combinators+-------------------------------------------------------------------------------++type ReBuf = [Char]++{-# INLINE insertIntoReBuf #-}+insertIntoReBuf :: Char -> ReBuf -> ReBuf+insertIntoReBuf c [] = [c]+insertIntoReBuf c xxs@(x:xs)+    | Char.combiningClass c < Char.combiningClass x = c : xxs+    | otherwise = x : insertIntoReBuf c xs++-- {-# ANN type DecomposeState Fuse #-}+data DecomposeState st+    = YieldCharList [Char] (DecomposeState st)+    | ReadInputChar ReBuf st+    | IsHangul Char st+    | IsDecomposable [Char] ReBuf st+    | DecomposeStop++{-# INLINE_NORMAL decomposeD #-}+decomposeD ::+       Monad m => Bool -> DecomposeMode -> Stream m Char -> Stream m Char+decomposeD decomposeHangul mode (Stream step state) =+    Stream sstep (ReadInputChar [] state)++    where++    {-# INLINE_LATE sstep #-}+    -- XXX Does this cause any problem?+    sstep _ (YieldCharList [] ns) = return $ Skip ns+    sstep _ (YieldCharList (ch:chs) ns) =+        return $ Yield ch (YieldCharList chs ns)+    sstep gst (ReadInputChar rebuf st) = do+        res <- step gst st+        return+          $ Skip+          $ case res of+                Yield ch st1+                    | Char.isHangul ch ->+                        if decomposeHangul+                        then YieldCharList rebuf (IsHangul ch st1)+                        else YieldCharList+                                 (rebuf ++ [ch])+                                 (ReadInputChar [] st1)+                    | Char.isDecomposable mode ch ->+                        IsDecomposable (Char.decompose mode ch) rebuf st1+                    | otherwise ->+                        if Char.isCombining ch+                        then ReadInputChar (insertIntoReBuf ch rebuf) st1+                        else YieldCharList+                                 (rebuf ++ [ch])+                                 (ReadInputChar [] st1)+                Skip st1 -> ReadInputChar rebuf st1+                Stop -> YieldCharList rebuf DecomposeStop+    sstep _ (IsHangul ch st) =+        return+          $ Skip+          $ let (l, v, t) = Char.decomposeHangul ch+             in if t == chr Char.jamoTFirst+                then YieldCharList [l, v] (ReadInputChar [] st)+                else YieldCharList [l, v, t] (ReadInputChar [] st)+    sstep _ (IsDecomposable [] rebuf st) =+        return $ Skip $ ReadInputChar rebuf st+    sstep _ (IsDecomposable (ch:chs) rebuf st)+        | Char.isDecomposable mode ch =+            return+              $ Skip $ IsDecomposable (Char.decompose mode ch ++ chs) rebuf st+        | otherwise =+            return+              $ Skip+              $ if Char.isCombining ch+                then IsDecomposable chs (insertIntoReBuf ch rebuf) st+                else YieldCharList (rebuf ++ [ch]) (IsDecomposable chs [] st)+    sstep _ DecomposeStop = return Stop++-- Hold an L to wait for V, hold an LV to wait for T.+data JamoBuf+    = Jamo !Char -- Jamo L, V or T+    | Hangul !Char -- Hangul Syllable LV or LVT+    | HangulLV !Char++{-# INLINE fromJamoBuf #-}+fromJamoBuf :: JamoBuf -> Char+fromJamoBuf (Jamo ch) = ch+fromJamoBuf (Hangul ch) = ch+fromJamoBuf (HangulLV ch) = ch++-- {-# ANN type ComposeState Fuse #-}+data ComposeState st+    = YieldChar Char (ComposeState st)+    | YieldList [Char] (ComposeState st)+    | ComposeNone st+    | ComposeReg Int [Char] st+    | ComposeJamo JamoBuf st+    | ComposeStop++-- Assumes every character except hangul characters are fully decomposed and the+-- combining characters are reordered. Hangul characters may or may not be+-- decomposed.+{-# INLINE_EARLY partialComposeD #-}+partialComposeD :: Monad m => Stream m Char -> Stream m Char+partialComposeD (Stream step state) = Stream step' (ComposeNone state)++    where++    {-# INLINE_NORMAL step' #-}+    step' _ ComposeStop = return Stop+    step' _ (YieldChar ch ns) = return $ Yield ch ns+    step' _ (YieldList [] ns) = return $ Skip ns+    step' _ (YieldList (x:xs) ns) = return $ Yield x $ YieldList xs ns+    step' gst (ComposeNone st) = do+        r <- step gst st+        return+          $ case r of+                Yield x st1 -> Skip $ composeNone x st1+                Skip st1 -> Skip $ ComposeNone st1+                Stop -> Stop+    step' gst (ComposeJamo jbuf st) = do+        r <- step gst st+        return+          $ case r of+                Yield x st1 -> Skip $ composeJamo jbuf x st1+                Skip st1 -> Skip $ ComposeJamo jbuf st1+                Stop -> Skip $ YieldChar (fromJamoBuf jbuf) ComposeStop+    step' gst (ComposeReg i rbuf st) = do+        r <- step gst st+        return+          $ case r of+                Yield x st1 -> Skip $ composeReg i rbuf x st1+                Skip st1 -> Skip $ ComposeReg i rbuf st1+                Stop -> Skip $ YieldList rbuf ComposeStop++    {-# INLINE initHangul #-}+    initHangul c st = ComposeJamo (Hangul c) st++    {-# INLINE initJamo #-}+    initJamo c st = ComposeJamo (Jamo c) st++    {-# INLINE initReg #-}+    initReg !c st = ComposeReg 0 [c] st++    {-# INLINE composeNone #-}+    composeNone ch st+        | Char.isHangul ch = initHangul ch st+        | Char.isJamo ch = initJamo ch st+        | otherwise = initReg ch st++    {-# INLINE composeCharHangul #-}+    composeCharHangul jbuf ch st =+        YieldChar (fromJamoBuf jbuf) $ ComposeJamo (Hangul ch) st++    {-# INLINE composeCharJamo #-}+    composeCharJamo jbuf ch st+        | ich <= Char.jamoLLast =+            YieldChar (fromJamoBuf jbuf) $ ComposeJamo (Jamo ch) st+        | ich < Char.jamoVFirst = flushAndWrite jbuf ch st+        | ich <= Char.jamoVLast =+            case jbuf of+                Jamo c ->+                    case Char.jamoLIndex c of+                        Just li ->+                            let vi = ich - Char.jamoVFirst+                                lvi = li * Char.jamoNCount + vi * Char.jamoTCount+                                lv = chr (Char.hangulFirst + lvi)+                             in ComposeJamo (HangulLV lv) st+                        Nothing -> writeTwo c ch st+                Hangul c -> writeTwo c ch st+                HangulLV c -> writeTwo c ch st+        | ich <= Char.jamoTFirst = flushAndWrite jbuf ch st+        | otherwise = do+            let ti = ich - Char.jamoTFirst+            case jbuf of+                Jamo c -> writeTwo c ch st+                Hangul c+                    | Char.isHangulLV c -> writeLVT c ti st+                    | otherwise -> writeTwo c ch st+                HangulLV c -> writeLVT c ti st++        where++        flushAndWrite jb c s = YieldList [fromJamoBuf jb, c] $ ComposeNone s++        writeLVT lv ti s =+            let lvt = chr $ ord lv + ti+             in YieldChar lvt $ ComposeNone s++        writeTwo c1 c2 s = YieldList [c1, c2] $ ComposeNone s++        ich = ord ch++    {-# INLINE composeJamo #-}+    composeJamo jbuf ch st+        | Char.isJamo ch = composeCharJamo jbuf ch st+        | Char.isHangul ch = composeCharHangul jbuf ch st+        | otherwise = YieldChar (fromJamoBuf jbuf) (ComposeReg 0 [ch] st)++    -- i ~ Char.combiningClass (last rbuf)+    {-# INLINE composeCharCombining #-}+    composeCharCombining i rbuf ch st =+        if cch > i+        then case Char.compose str ch of+                 Nothing -> ComposeReg cch (rbuf ++ [ch]) st+                 Just x -> ComposeReg i (x : tail rbuf) st+        else ComposeReg i (rbuf ++ [ch]) st++        where++        str = head rbuf+        cch = Char.combiningClass ch++    {-# INLINE composeReg #-}+    composeReg i rbuf !ch !st+        | Char.isHangul ch = YieldList rbuf $ initHangul ch st+        | Char.isJamo ch = YieldList rbuf $ initJamo ch st+        | Char.isCombining ch = composeCharCombining i rbuf ch st+        | [s] <- rbuf+        , Char.isCombiningStarter ch+        , Just x <- Char.composeStarters s ch = ComposeReg 0 [x] st+        | otherwise = YieldList rbuf $ ComposeReg 0 [ch] st++normalizeD :: Monad m => NormalizationMode -> Stream m Char -> Stream m Char+normalizeD NFD = decomposeD True Canonical+normalizeD NFKD = decomposeD True Kompat+normalizeD NFC = partialComposeD . decomposeD False Canonical+normalizeD NFKC = partialComposeD . decomposeD False Kompat++normalize :: (IsStream t, Monad m) => NormalizationMode -> t m Char -> t m Char+normalize mode = fromStreamD . normalizeD mode  . toStreamD
+ src/Streamly/Internal/Unicode/Char/Parser.hs view
@@ -0,0 +1,187 @@+-- |+-- Module      : Streamly.Internal.Unicode.Char.Parser+-- Copyright   : (c) 2021 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- To parse a text input, use the decode routines from+-- "Streamly.Unicode.Stream" module to convert an input byte stream to a+-- Unicode Char stream and then use these parsers on the Char stream.++-- XXX Add explicit export list.+module Streamly.Internal.Unicode.Char.Parser where++import Control.Applicative (Alternative(..))+import Control.Monad.Catch (MonadCatch)+import Data.Bits (Bits, (.|.), shiftL)+import Data.Char (ord)+import Streamly.Internal.Data.Parser (Parser)++import qualified Data.Char as Char+import qualified Streamly.Internal.Data.Parser as Parser+import qualified Streamly.Internal.Data.Fold as Fold++--------------------------------------------------------------------------------+-- Character classification+--------------------------------------------------------------------------------++-- XXX It may be possible to implement faster predicates for ASCII byte stream.+-- We can measure if there is a signficant difference and if so we can add such+-- predicates to Streamly.Unicode.Char.Parser.Latin1.+--+#define CHAR_PARSER_SIG(NAME)         NAME :: MonadCatch m => Parser m Char Char+-- XXX Need to use the predicates from Unicode.Char module/unicode-data package+#define CHAR_PARSER(NAME, PREDICATE)  NAME = Parser.satisfy Char.PREDICATE++-- XXX Add haddock documentation+-- XXX Add INLINE pragmas++CHAR_PARSER_SIG(space)+CHAR_PARSER(space,isSpace)++CHAR_PARSER_SIG(lower)+CHAR_PARSER(lower,isLower)++CHAR_PARSER_SIG(upper)+CHAR_PARSER(upper,isUpper)++CHAR_PARSER_SIG(alpha)+CHAR_PARSER(alpha,isAlpha)++CHAR_PARSER_SIG(alphaNum)+CHAR_PARSER(alphaNum,isAlphaNum)++CHAR_PARSER_SIG(print)+CHAR_PARSER(print,isPrint)++CHAR_PARSER_SIG(digit)+CHAR_PARSER(digit,isDigit)++CHAR_PARSER_SIG(octDigit)+CHAR_PARSER(octDigit,isOctDigit)++CHAR_PARSER_SIG(hexDigit)+CHAR_PARSER(hexDigit,isHexDigit)++CHAR_PARSER_SIG(letter)+CHAR_PARSER(letter,isLetter)++CHAR_PARSER_SIG(mark)+CHAR_PARSER(mark,isMark)++CHAR_PARSER_SIG(number)+CHAR_PARSER(number,isNumber)++CHAR_PARSER_SIG(punctuation)+CHAR_PARSER(punctuation,isPunctuation)++CHAR_PARSER_SIG(symbol)+CHAR_PARSER(symbol,isSymbol)++CHAR_PARSER_SIG(separator)+CHAR_PARSER(separator,isSeparator)++CHAR_PARSER_SIG(ascii)+CHAR_PARSER(ascii,isAscii)++CHAR_PARSER_SIG(latin1)+CHAR_PARSER(latin1,isLatin1)++CHAR_PARSER_SIG(asciiUpper)+CHAR_PARSER(asciiUpper,isAsciiUpper)++CHAR_PARSER_SIG(asciiLower)+CHAR_PARSER(asciiLower,isAsciiLower)++--------------------------------------------------------------------------------+-- Character parsers+--------------------------------------------------------------------------------++-- | Match a specific character.+{-# INLINE char #-}+char :: MonadCatch m => Char -> Parser m Char Char+char c = Parser.satisfy (== c)++--------------------------------------------------------------------------------+-- Numeric parsers+--------------------------------------------------------------------------------++-- XXX It should fail if the number is larger than the size of the type.+--+-- | Parse and decode an unsigned integral decimal number.+{-# INLINE decimal #-}+decimal :: (MonadCatch m, Integral a) => Parser m Char a+decimal = Parser.takeWhile1 Char.isDigit (Fold.foldl' step 0)++    where++    step a c = a * 10 + fromIntegral (ord c - 48)++-- | Parse and decode an unsigned integral hexadecimal number.  The hex digits+-- @\'a\'@ through @\'f\'@ may be upper or lower case.+--+-- Note: This parser does not accept a leading @\"0x\"@ string.+{-# INLINE hexadecimal #-}+hexadecimal :: (MonadCatch m, Integral a, Bits a) => Parser m Char a+hexadecimal = Parser.takeWhile1 isHexDigit (Fold.foldl' step 0)++    where++    isHexDigit c =+           (c >= '0' && c <= '9')+        || (c >= 'a' && c <= 'f')+        || (c >= 'A' && c <= 'F')++    step a c+        | w >= 48 && w <= 57 =+            (a `shiftL` 4) .|. fromIntegral (w - 48)+        | w >= 97 =+            (a `shiftL` 4) .|. fromIntegral (w - 87)+        | otherwise =+            (a `shiftL` 4) .|. fromIntegral (w - 55)++        where++        w = ord c++-- | Allow an optional leading @\'+\'@ or @\'-\'@ sign character before any+-- parser.+{-# INLINE signed #-}+signed :: (Num a, MonadCatch m) => Parser m Char a -> Parser m Char a+signed p = (negate <$> (char '-' *> p)) <|> (char '+' *> p) <|> p++-- | Parse a 'Double'.+--+-- This parser accepts an optional leading sign character, followed by+-- at most one decimal digit.  The syntax is similar to that accepted by+-- the 'read' function, with the exception that a trailing @\'.\'@ is+-- consumed.+--+-- === Examples+--+-- Examples with behaviour identical to 'read', if you feed an empty+-- continuation to the first result:+--+-- > IS.parse double (IS.fromList "3")     == 3.0+-- > IS.parse double (IS.fromList "3.1")   == 3.1+-- > IS.parse double (IS.fromList "3e4")   == 30000.0+-- > IS.parse double (IS.fromList "3.1e4") == 31000.0+-- > IS.parse double (IS.fromList "3e")    == 30+--+-- Examples with behaviour identical to 'read':+--+-- > IS.parse (IS.fromList ".3")    == error "Parse failed"+-- > IS.parse (IS.fromList "e3")    == error "Parse failed"+--+-- Example of difference from 'read':+--+-- > IS.parse double (IS.fromList "3.foo") == 3.0+--+-- This function does not accept string representations of \"NaN\" or+-- \"Infinity\".+--+-- /Unimplemented/+double :: Parser m Char Double+double = undefined
src/Streamly/Internal/Unicode/Stream.hs view
@@ -81,23 +81,23 @@ 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.Array.Foreign (Array)+import Streamly.Internal.Data.Array.Foreign.Mut.Type (ArrayContents, touch)+import Streamly.Internal.Data.Fold (Fold)+import Streamly.Internal.Data.Stream.IsStream.Type+    (IsStream, fromStreamD, toStreamD, adapt) import Streamly.Internal.Data.Stream.Serial (SerialT) import Streamly.Internal.Data.Stream.StreamD (Stream(..), Step (..))+import Streamly.Internal.Data.SVar (adaptState) import Streamly.Internal.Data.Tuple.Strict (Tuple'(..))+import Streamly.Internal.Data.Unfold (Unfold)+import Streamly.Internal.System.IO (unsafeInlineIO)  import qualified Streamly.Internal.Data.Unfold as Unfold import qualified Streamly.Internal.Data.Stream.Serial as Serial@@ -236,7 +236,7 @@ -- 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+unsafePeekElemOff p i = let !x = 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@@ -256,9 +256,8 @@     where      utf8table =-        let !(Ptr addr) = table-            end = table `plusPtr` 364-        in A.Array (ForeignPtr addr undefined) end :: A.Array Word8+        let end = table `plusPtr` 364+        in A.Array undefined table end :: A.Array Word8     showByte = "Streamly: decode0: byte: " ++ show byte     showTable = " table: " ++ show utf8table @@ -283,9 +282,8 @@     where      utf8table =-        let !(Ptr addr) = table-            end = table `plusPtr` 364-        in A.Array (ForeignPtr addr undefined) end :: A.Array Word8+        let end = table `plusPtr` 364+        in A.Array undefined table end :: A.Array Word8     showByte = "Streamly: decode1: byte: " ++ show byte     showState st cp =         " state: " ++ show st ++@@ -296,7 +294,10 @@ -- Resumable UTF-8 decoding ------------------------------------------------------------------------------- +-- Strangely, GHCJS hangs linking template-haskell with this+#ifndef __GHCJS__ {-# ANN type UTF8DecodeState Fuse #-}+#endif data UTF8DecodeState s a     = UTF8DecodeInit s     | UTF8DecodeInit1 s Word8@@ -313,8 +314,8 @@     -> Stream m Word8     -> Stream m (Either DecodeError Char) resumeDecodeUtf8EitherD dst codep (Stream step state) =-    let A.Array p _ = utf8d-        !ptr = unsafeForeignPtrToPtr p+    let A.Array _ p _ = utf8d+        !ptr = p         stt =             if dst == 0             then UTF8DecodeInit state@@ -392,7 +393,7 @@ {-# INLINE decodeUtf8Either #-} decodeUtf8Either :: (Monad m, IsStream t)     => t m Word8 -> t m (Either DecodeError Char)-decodeUtf8Either = D.fromStreamD . decodeUtf8EitherD . D.toStreamD+decodeUtf8Either = fromStreamD . decodeUtf8EitherD . toStreamD  -- | --@@ -405,7 +406,7 @@     -> t m Word8     -> t m (Either DecodeError Char) resumeDecodeUtf8Either st cp =-    D.fromStreamD . resumeDecodeUtf8EitherD st cp . D.toStreamD+    fromStreamD . resumeDecodeUtf8EitherD st cp . toStreamD  ------------------------------------------------------------------------------- -- One shot decoding@@ -432,8 +433,7 @@ decodeUtf8WithD :: Monad m     => CodingFailureMode -> Stream m Word8 -> Stream m Char decodeUtf8WithD cfm (Stream step state) =-    let A.Array p _ = utf8d-        !ptr = unsafeForeignPtrToPtr p+    let A.Array _ ptr _ = utf8d     in Stream (step' ptr) (UTF8DecodeInit state)      where@@ -529,7 +529,7 @@ -- /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+decodeUtf8 = fromStreamD . decodeUtf8D . toStreamD  {-# INLINE decodeUtf8D' #-} decodeUtf8D' :: Monad m => Stream m Word8 -> Stream m Char@@ -541,7 +541,7 @@ -- @since 0.8.0 {-# INLINE decodeUtf8' #-} decodeUtf8' :: (Monad m, IsStream t) => t m Word8 -> t m Char-decodeUtf8' = D.fromStreamD . decodeUtf8D' . D.toStreamD+decodeUtf8' = fromStreamD . decodeUtf8D' . toStreamD  {-# INLINE decodeUtf8D_ #-} decodeUtf8D_ :: Monad m => Stream m Word8 -> Stream m Char@@ -553,7 +553,7 @@ -- @since 0.8.0 {-# INLINE decodeUtf8_ #-} decodeUtf8_ :: (Monad m, IsStream t) => t m Word8 -> t m Char-decodeUtf8_ = D.fromStreamD . decodeUtf8D_ . D.toStreamD+decodeUtf8_ = fromStreamD . decodeUtf8D_ . toStreamD  -- | Same as 'decodeUtf8' --@@ -566,12 +566,14 @@ -- Decoding Array Streams ------------------------------------------------------------------------------- +#ifndef __GHCJS__ {-# ANN type FlattenState Fuse #-}+#endif 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)+    | InnerLoopDecodeInit s ArrayContents !(Ptr a) !(Ptr a)+    | InnerLoopDecodeFirst s ArrayContents !(Ptr a) !(Ptr a) Word8+    | InnerLoopDecoding s ArrayContents !(Ptr a) !(Ptr a)         !DecodeState !CodePoint     | YAndC !Char (FlattenState s a) -- These constructors can be                                      -- encoded in the UTF8DecodeState@@ -592,8 +594,7 @@     -> Stream m (A.Array Word8)     -> Stream m Char decodeUtf8ArraysWithD cfm (Stream step state) =-    let A.Array p _ = utf8d-        !ptr = unsafeForeignPtrToPtr p+    let A.Array _ ptr _ = utf8d     in Stream (step' ptr) (OuterLoop state Nothing)   where     {-# INLINE transliterateOrError #-}@@ -617,8 +618,7 @@         return $             case r of                 Yield A.Array {..} s ->-                    let p = unsafeForeignPtrToPtr aStart-                     in Skip (InnerLoopDecodeInit s aStart p aEnd)+                     Skip (InnerLoopDecodeInit s arrContents arrStart aEnd)                 Skip s -> Skip (OuterLoop s Nothing)                 Stop -> Skip D     step' _ gst (OuterLoop st dst@(Just (ds, cp))) = do@@ -626,13 +626,12 @@         return $             case r of                 Yield A.Array {..} s ->-                    let p = unsafeForeignPtrToPtr aStart-                     in Skip (InnerLoopDecoding s aStart p aEnd ds cp)+                     Skip (InnerLoopDecoding s arrContents arrStart aEnd ds cp)                 Skip s -> Skip (OuterLoop s dst)                 Stop -> Skip inputUnderflow     step' _ _ (InnerLoopDecodeInit st startf p end)         | p == end = do-            liftIO $ touchForeignPtr startf+            liftIO $ touch startf             return $ Skip $ OuterLoop st Nothing     step' _ _ (InnerLoopDecodeInit st startf p end) = do         x <- liftIO $ peek p@@ -668,7 +667,7 @@                 _ -> Skip (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)     step' _ _ (InnerLoopDecoding st startf p end sv cp)         | p == end = do-            liftIO $ touchForeignPtr startf+            liftIO $ touch startf             return $ Skip $ OuterLoop st (Just (sv, cp))     step' table _ (InnerLoopDecoding st startf p end statePtr codepointPtr) = do         x <- liftIO $ peek p@@ -709,7 +708,7 @@ decodeUtf8Arrays ::        (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char decodeUtf8Arrays =-    D.fromStreamD . decodeUtf8ArraysD . D.toStreamD+    fromStreamD . decodeUtf8ArraysD . toStreamD  {-# INLINE decodeUtf8ArraysD' #-} decodeUtf8ArraysD' ::@@ -723,7 +722,7 @@ -- /Pre-release/ {-# INLINE decodeUtf8Arrays' #-} decodeUtf8Arrays' :: (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char-decodeUtf8Arrays' = D.fromStreamD . decodeUtf8ArraysD' . D.toStreamD+decodeUtf8Arrays' = fromStreamD . decodeUtf8ArraysD' . toStreamD  {-# INLINE decodeUtf8ArraysD_ #-} decodeUtf8ArraysD_ ::@@ -739,7 +738,7 @@ decodeUtf8Arrays_ ::        (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char decodeUtf8Arrays_ =-    D.fromStreamD . decodeUtf8ArraysD_ . D.toStreamD+    fromStreamD . decodeUtf8ArraysD_ . toStreamD  ------------------------------------------------------------------------------- -- Encoding Unicode (UTF-8) Characters@@ -776,10 +775,14 @@     x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80     x4 = fromIntegral $ (n .&. 0x3F) + 0x80 +#ifndef __GHCJS__ {-# ANN type EncodeState Fuse #-}+#endif data EncodeState s = EncodeState s !WList +#ifndef __GHCJS__ {-# ANN type InvalidAction Fuse #-}+#endif data InvalidAction =     DropInvalid | ErrorInvalid | IgnoreInvalid | ReplaceInvalid @@ -857,7 +860,7 @@ -- @since 0.8.0 {-# INLINE encodeUtf8' #-} encodeUtf8' :: (Monad m, IsStream t) => t m Char -> t m Word8-encodeUtf8' = D.fromStreamD . encodeUtf8D' . D.toStreamD+encodeUtf8' = fromStreamD . encodeUtf8D' . toStreamD  -- | See section "3.9 Unicode Encoding Forms" in -- https://www.unicode.org/versions/Unicode13.0.0/UnicodeStandard-13.0.pdf@@ -875,7 +878,7 @@ -- /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+encodeUtf8 = fromStreamD . encodeUtf8D . toStreamD  {-# INLINE_NORMAL encodeUtf8D_ #-} encodeUtf8D_ :: Monad m => Stream m Char -> Stream m Word8@@ -887,7 +890,7 @@ -- @since 0.8.0 {-# INLINE encodeUtf8_ #-} encodeUtf8_ :: (Monad m, IsStream t) => t m Char -> t m Word8-encodeUtf8_ = D.fromStreamD . encodeUtf8D_ . D.toStreamD+encodeUtf8_ = fromStreamD . encodeUtf8D_ . toStreamD  -- | Same as 'encodeUtf8' --@@ -922,7 +925,7 @@     -> Unfold m a Char     -> t m a     -> t m (Array Word8)-encodeObjects encode u = Serial.mapM (encodeObject encode u)+encodeObjects encode u = adapt . Serial.mapM (encodeObject encode u) . adapt  -- | Encode a stream of 'String' using the supplied encoding scheme. Each -- string is encoded as an @Array Word8@.
+ src/Streamly/Internal/Unicode/Utf8.hs view
@@ -0,0 +1,67 @@+-- |+-- Module      : Streamly.Internal.Unicode.Utf8+-- Copyright   : (c) 2021 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+module Streamly.Internal.Unicode.Utf8+    (+    -- * Type+      Utf8++    -- * Creation and elimination+    , pack+    , unpack+    , toArray+    )+where++--------------------------------------------------------------------------------+-- Imports+--------------------------------------------------------------------------------++import Control.DeepSeq (NFData)+import Data.Word (Word8)+import Streamly.Internal.Data.Array.Foreign.Type (Array)+import System.IO.Unsafe (unsafePerformIO)++import qualified Streamly.Internal.Data.Array.Foreign as Array+import qualified Streamly.Internal.Data.Stream.IsStream as Stream+import qualified Streamly.Internal.Unicode.Stream as Unicode++--------------------------------------------------------------------------------+-- Type+--------------------------------------------------------------------------------++-- | A space efficient, packed, unboxed Unicode container.+newtype Utf8 =+    Utf8 (Array Word8)+    deriving (NFData)++--------------------------------------------------------------------------------+-- Functions+--------------------------------------------------------------------------------++{-# INLINE toArray #-}+toArray :: Utf8 -> Array Word8+toArray (Utf8 arr) = arr+++{-# INLINEABLE pack #-}+pack :: String -> Utf8+pack s =+    Utf8+        $ unsafePerformIO+        $ Array.fromStreamN len $ Unicode.encodeUtf8' $ Stream.fromList s++    where++    len = length s++{-# INLINEABLE unpack #-}+unpack :: Utf8 -> String+unpack u =+    unsafePerformIO+        $ Stream.toList $ Unicode.decodeUtf8' $ Array.toStream $ toArray u
src/Streamly/Network/Inet/TCP.hs view
@@ -22,11 +22,11 @@     -- * Connect to Servers     , connect +    {-     -- XXX Expose this as a pipe when we have pipes.     -- * Transformation     -- , processBytes -    {-     -- ** Sink Servers      -- These abstractions can be applied to any setting where we need to do a
src/Streamly/Prelude.hs view
@@ -936,6 +936,7 @@     ) where +import Streamly.Internal.Control.Concurrent (MonadAsync) import Prelude        hiding (filter, drop, dropWhile, take, takeWhile, zipWith, foldr,                foldl, map, mapM, mapM_, sequence, all, any, sum, product, elem,
src/config.h.in view
@@ -30,12 +30,12 @@ /* 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 <stdio.h> header file. */+#undef HAVE_STDIO_H+ /* Define to 1 if you have the <stdlib.h> header file. */ #undef HAVE_STDLIB_H @@ -75,5 +75,7 @@ /* Define to the version of this package. */ #undef PACKAGE_VERSION -/* Define to 1 if you have the ANSI C header files. */+/* 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
streamly.cabal view
@@ -1,6 +1,6 @@ cabal-version:      2.2 name:               streamly-version:            0.8.0+version:            0.8.1 synopsis:           Dataflow programming and declarative concurrency description:   Browse the documentation at https://streamly.composewell.com.@@ -35,8 +35,9 @@                    , GHC==8.4.4                    , GHC==8.6.5                    , GHC==8.8.4-                   , GHC==8.10.4+                   , GHC==8.10.7                    , GHC==9.0.1+                   , GHC==9.2.1 author:              Composewell Technologies maintainer:          streamly@composewell.com copyright:           2017 Composewell Technologies@@ -48,22 +49,12 @@ 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/bin/bench-runner.sh+    benchmark/bench-report/bin/build-lib.sh     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@@ -77,39 +68,17 @@     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/bench-config.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/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-    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/Stream/PreludeCommon.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@@ -117,25 +86,53 @@     src/Streamly/Internal/FileSystem/Event/Darwin.h     src/config.h.in     src/inline.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/Array/Stream/Foreign.hs     test/Streamly/Test/Data/Parser/ParserD.hs     test/Streamly/Test/FileSystem/Event.hs+    test/Streamly/Test/FileSystem/Event/Common.hs+    test/Streamly/Test/FileSystem/Event/Darwin.hs+    test/Streamly/Test/FileSystem/Event/Windows.hs+    test/Streamly/Test/FileSystem/Event/Linux.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/Streamly/Test/Unicode/*.hs     test/lib/Streamly/Test/Common.hs     test/lib/Streamly/Test/Prelude/Common.hs     test/streamly-tests.cabal     test/version-bounds.hs+    test/Streamly/Test/Unicode/ucd/NormalizationTest.txt+    test/Streamly/Test/Unicode/extra/NormalizationTest.txt+    benchmark/Streamly/Benchmark/Unicode/data/AllChars.txt+    benchmark/Streamly/Benchmark/Unicode/data/Devanagari.txt+    benchmark/Streamly/Benchmark/Unicode/data/Japanese.txt+    benchmark/Streamly/Benchmark/Unicode/data/Vietnamese.txt+    benchmark/Streamly/Benchmark/Unicode/data/Deutsch.txt+    benchmark/Streamly/Benchmark/Unicode/data/English.txt+    benchmark/Streamly/Benchmark/Unicode/data/Korean.txt +extra-doc-files:+    CONTRIBUTING.md+    Changelog.md+    README.md+    benchmark/README.md+    dev/*.md+    dev/*.png+    dev/*.rst+    docs/*.md+    docs/*.link+    docs/*.rst+    docs/*.svg+    docs/API-changelog.txt+    test/README.md+ extra-tmp-files:     config.log     config.status@@ -191,6 +188,11 @@   manual: True   default: True +flag limit-build-mem+  description: Limits memory when building+  manual: True+  default: False+ ------------------------------------------------------------------------------- -- Common stanzas -------------------------------------------------------------------------------@@ -239,8 +241,8 @@       ghc-options:    -Wmissed-specialisations                       -Wall-missed-specialisations -    if flag(dev) || flag(debug)-      ghc-options:    -fno-ignore-asserts+    if flag(limit-build-mem)+        ghc-options: +RTS -M1000M -RTS  common default-extensions     default-extensions:@@ -265,6 +267,7 @@         RecordWildCards         ScopedTypeVariables         TupleSections+        TypeApplications         TypeFamilies         ViewPatterns @@ -283,6 +286,10 @@                  -fspec-constr-recursive=16                  -fmax-worker-args=16 +  -- For this to be effective it must come after the -O2 option+  if flag(dev) || flag(debug) || !flag(opt)+    ghc-options: -fno-ignore-asserts+ common threading-options   ghc-options:  -threaded                 -with-rtsopts=-N@@ -303,13 +310,11 @@ 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+    include-dirs:    src, src/Streamly/Internal/Data/Stream     if os(windows)       c-sources:     src/Streamly/Internal/Data/Time/Clock/Windows.c       exposed-modules: Streamly.Internal.FileSystem.Event.Windows@@ -376,10 +381,18 @@                      , Streamly.Internal.Data.Time.Units                      , Streamly.Internal.Data.Time.Clock.Type                      , Streamly.Internal.Data.Time.Clock+                     , Streamly.Internal.System.IO+                     , Streamly.Internal.System.IOVec.Type                       -- streamly-core-stream+                     , Streamly.Internal.Data.SVar.Type+                     , Streamly.Internal.Data.SVar.Worker+                     , Streamly.Internal.Data.SVar.Dispatch+                     , Streamly.Internal.Data.SVar.Pull                      , Streamly.Internal.Data.SVar                      , Streamly.Internal.Data.Stream.StreamK.Type+                     , Streamly.Internal.Data.Fold.Step+                     , Streamly.Internal.Data.Refold.Type                      , Streamly.Internal.Data.Fold.Type                      , Streamly.Internal.Data.Stream.StreamD.Step                      , Streamly.Internal.Data.Stream.StreamD.Type@@ -399,6 +412,7 @@                      -- streamly-core-array                      -- May depend on streamly-core-stream                      , Streamly.Internal.Data.Array.Foreign.Mut.Type+                     , Streamly.Internal.Data.Array.Foreign.Mut                      , Streamly.Internal.Data.Array.Foreign.Type                      , Streamly.Internal.Data.Array.Prim.Mut.Type                      , Streamly.Internal.Data.Array.Prim.Type@@ -407,7 +421,6 @@                      , 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@@ -424,21 +437,28 @@                       -- streamly-core                      , Streamly.Internal.Data.Unfold+                     , Streamly.Internal.Data.Unfold.SVar+                     , Streamly.Internal.Data.Unfold.Enumeration                      , Streamly.Internal.Data.Fold.Tee                      , Streamly.Internal.Data.Fold+                     , Streamly.Internal.Data.Fold.SVar+                     , Streamly.Internal.Data.Fold.Async                      , Streamly.Internal.Data.Sink                      , Streamly.Internal.Data.Parser                      , Streamly.Internal.Data.Pipe -                     , Streamly.Internal.Data.Stream.SVar+                     , Streamly.Internal.Data.Stream.SVar.Generate+                     , Streamly.Internal.Data.Stream.SVar.Eliminate                      , 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.List++                     , Streamly.Internal.Data.Stream.IsStream.Type                      , 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@@ -449,7 +469,6 @@                      , 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@@ -464,10 +483,16 @@                      -- Memory storage                      , Streamly.Internal.Ring.Foreign+                     , Streamly.Internal.Data.Ring +                     -- IOVec (depends on arrays/streams)+                     , Streamly.Internal.System.IOVec+                      -- streamly-unicode                      , Streamly.Internal.Unicode.Stream+                     , Streamly.Internal.Unicode.Utf8                      , Streamly.Internal.Unicode.Char+                     , Streamly.Internal.Unicode.Char.Parser                      , Streamly.Internal.Unicode.Array.Char                      , Streamly.Internal.Unicode.Array.Prim.Pinned @@ -478,9 +503,9 @@                      , Streamly.Internal.FileSystem.Handle                      , Streamly.Internal.FileSystem.Dir                      , Streamly.Internal.FileSystem.File-                     , Streamly.Internal.FileSystem.IOVec                      , Streamly.Internal.FileSystem.FDIO                      , Streamly.Internal.FileSystem.FD+                     , Streamly.Internal.FileSystem.Event                       -- streamly-console                      , Streamly.Internal.Console.Stdio@@ -489,6 +514,9 @@                      , Streamly.Internal.Network.Socket                      , Streamly.Internal.Network.Inet.TCP +                     -- Only used for benchmarks+                     , Streamly.Internal.Data.Stream.StreamK+     build-depends:                     -- Core libraries shipped with ghc, the min and max                     -- constraints of these libraries should match with@@ -501,12 +529,13 @@                      , deepseq           >= 1.4.1 && < 1.5                      , directory         >= 1.2.2 && < 1.4                      , exceptions        >= 0.8   && < 0.11-                     , ghc-prim          >= 0.2   && < 0.8+                     , ghc-prim          >= 0.2   && < 0.9                      , mtl               >= 2.2   && < 3                      , primitive         >= 0.5.4 && < 0.8-                     , transformers      >= 0.4   && < 0.6+                     , transformers      >= 0.4   && < 0.7                       , heaps             >= 0.3     && < 0.5+                     , filepath          >= 1.2.0.0 && < 1.4.3.0                      -- concurrency                      , atomic-primops    >= 0.8   && < 0.9@@ -517,6 +546,7 @@                      , transformers-base >= 0.4   && < 0.5                       , fusion-plugin-types >= 0.1 && < 0.2+                     , unicode-data      >= 0.1   && < 0.3                      -- Network                      , network           >= 2.6   && < 4
test/Streamly/Test/Common/Array.hs view
@@ -10,6 +10,13 @@  -- This is a common array test module that gets included in different -- Array test modules with the corresponding macro defined.+--+-- Meanings of CPP macros:+-- Default => Data.Array+-- TEST_ARRAY => Data.Array.Foreign+-- TEST_SMALL_ARRAY => Data.SmallArray+-- DATA_ARRAY_PRIM => Data.Array.Prim+-- DATA_ARRAY_PRIM_PINNED => Data.Array.Prim.Pinned  import Foreign.Storable (Storable(..)) @@ -18,10 +25,18 @@ import Test.QuickCheck.Monadic (monadicIO, assert, run) import Test.Hspec as H +import Streamly.Data.Fold (Fold) import Streamly.Prelude (SerialT) import Streamly.Test.Common (listEquals)  import qualified Streamly.Prelude as S++#if defined(TEST_ARRAY) ||\+    defined(DATA_ARRAY_PRIM) ||\+    defined(DATA_ARRAY_PRIM_PINNED)+import qualified Streamly.Internal.Data.Fold as Fold+#endif+ #ifdef TEST_SMALL_ARRAY import qualified Streamly.Internal.Data.SmallArray as A type Array = A.SmallArray@@ -31,18 +46,15 @@ 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@@ -166,33 +178,25 @@                     assert (xs == list) #endif -#if defined(TEST_ARRAY) ||\-    defined(DATA_ARRAY_PRIM) ||\-    defined(DATA_ARRAY_PRIM_PINNED)--testArraysOf :: Property-testArraysOf =+foldManyWith :: (Int -> Fold IO Int (Array Int)) -> Property+foldManyWith f =     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.foldMany (f 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+    arr <- MA.fromList xs+    MA.putIndexUnsafe arr i x+    x1 <- MA.getIndexUnsafe arr i     return $ x1 == x  lastN :: Int -> [a] -> [a]@@ -230,7 +234,7 @@ 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+        arr = A.toList $ A.getSliceUnsafe i n $ A.fromList list      in arr == lst  #endif@@ -261,8 +265,11 @@ #if defined(TEST_ARRAY) ||\     defined(DATA_ARRAY_PRIM) ||\     defined(DATA_ARRAY_PRIM_PINNED)-            prop "arraysOf concats to original" testArraysOf+            prop "foldMany with writeNUnsafe concats to original"+                (foldManyWith (\n -> Fold.take n (A.writeNUnsafe n))) #endif+            prop "foldMany with writeN concats to original"+                (foldManyWith A.writeN)  #ifdef TEST_ARRAY             prop "AS.concat . (A.fromList . (:[]) <$>) === id" $ concatArrayW8
+ test/Streamly/Test/Data/Array/Stream/Foreign.hs view
@@ -0,0 +1,72 @@+module Main (main) where++import Streamly.Test.Common (listEquals, chooseInt)+import Test.Hspec (hspec, describe)+import Test.Hspec.QuickCheck+import Test.QuickCheck (forAll, Property, vectorOf, Gen)+import Test.QuickCheck.Monadic (monadicIO, run)++import qualified Streamly.Internal.Data.Array.Foreign as Array+import qualified Streamly.Internal.Data.Array.Stream.Foreign as ArrayStream+import qualified Streamly.Internal.Data.Fold as Fold+import qualified Streamly.Internal.Data.Parser.ParserD as ParserD+import qualified Streamly.Internal.Data.Stream.IsStream as Stream+import qualified Test.Hspec as Hspec++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++parse :: Property+parse = 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 (0, len))+        $ \(ls, clen, tlen) ->+            monadicIO $ do+                (ls1, str) <-+                    let input =+                            Stream.chunksOf+                                clen (Array.writeN clen) (Stream.fromList ls)+                        parser = ParserD.fromFold (Fold.take tlen Fold.toList)+                     in run $ ArrayStream.parse parser input+                ls2 <- run $ Stream.toList $ ArrayStream.concat str+                listEquals (==) (ls1 ++ ls2) ls++-------------------------------------------------------------------------------+-- Main+-------------------------------------------------------------------------------++moduleName :: String+moduleName = "Data.Array.Stream.Foreign"++main :: IO ()+main =+    hspec $+    Hspec.parallel $+    modifyMaxSuccess (const maxTestCount) $ do+        describe moduleName $ do+            describe "Stream parsing" $ do+                prop "parse" parse
test/Streamly/Test/Data/Fold.hs view
@@ -16,6 +16,7 @@     ) import Test.QuickCheck.Monadic (monadicIO, assert, run) +import qualified Data.Map import qualified Prelude import qualified Streamly.Internal.Data.Fold as F import qualified Streamly.Prelude as S@@ -53,7 +54,8 @@ rollingHashFirstN =     forAll (choose (0, maxStreamLen)) $ \len ->         forAll (choose (0, len)) $ \n ->-            forAll (vectorOf len (arbitrary :: Gen Int)) $ \vec -> monadicIO $ do+            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@@ -110,6 +112,9 @@ toList :: [Int] -> Expectation toList ls = S.fold FL.toList (S.fromList ls) `shouldReturn` ls +toListRev :: [Int] -> Expectation+toListRev ls = S.fold FL.toListRev (S.fromList ls) `shouldReturn` reverse ls+ safeLast :: [a] -> Maybe a safeLast [] = Nothing safeLast (x:[]) = Just x@@ -124,7 +129,7 @@             if even x             then Just x             else Nothing-        f = F.mapMaybe maybeEven FL.toList+        f = FL.mapMaybe maybeEven FL.toList     in S.fold f (S.fromList ls) `shouldReturn` filter even ls  nth :: Int -> [a] -> Maybe a@@ -179,7 +184,8 @@             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)+            let fld =+                    S.fold (FL.any (== elm)) (S.fromList $ Prelude.take idx ls)             in fld `shouldReturn` False  null :: [Int] -> Expectation@@ -218,14 +224,14 @@ take :: [Int] -> Property take ls =     forAll (chooseInt (-1, Prelude.length ls + 2)) $ \n ->-            S.fold (F.take n FL.toList) (S.fromList ls)+            S.fold (FL.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+            f = FL.takeEndBy_ p FL.toList             ys = Prelude.takeWhile (not . p) ls          in case S.fold f (S.fromList ls) of             Right xs -> checkListEqual xs ys@@ -236,7 +242,7 @@     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)+                f = FL.takeEndBy_ p (FL.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@@ -335,10 +341,11 @@     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")]+        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)@@ -370,6 +377,101 @@             v3 = Prelude.length ls         assert (v1 == (v2, v3)) +teeWithFstLength :: Property+teeWithFstLength =+    forAll (listOf1 (chooseInt (intMin, intMax)))+        $ \ls0 -> monadicIO $ action ls0++    where++    action ls = do+        v1 <- run $ S.fold (F.teeWithFst (,) (FL.take 5 FL.sum) FL.length) $ S.fromList ls+        let v2 = Prelude.sum (Prelude.take 5 ls)+            v3 = Prelude.length (Prelude.take 5 ls)+        assert (v1 == (v2, v3))++partitionByM :: Property+partitionByM =+    forAll (listOf1 (chooseInt (intMin, intMax)))+        $ \ls0 -> monadicIO $ action ls0++    where++    action ls = do+        let f = \x -> if odd x then return (Left x) else return (Right x)+        v1 <- run $ S.fold (F.partitionByM f FL.length FL.length) $ S.fromList ls+        let v2 = foldl (\b a -> if odd a then b+1 else b) 0 ls+            v3 = foldl (\b a -> if even a then b+1 else b) 0 ls+        assert (v1 == (v2, v3))++partitionByFstM :: Property+partitionByFstM =+    forAll (listOf1 (chooseInt (intMin, intMax)))+        $ \ls0 -> monadicIO $ action ls0++    where++    action _ = do+        let f = \x -> if odd x then return (Left x) else return (Right x)+        v1 <- run $ S.fold (F.partitionByFstM f (FL.take 25 FL.length) FL.length) (S.fromList ([1..100]:: [Int]))+        let v2 = foldl (\b a -> if odd a then b+1 else b) 0 ([1..49] :: [Int])+            v3 = foldl (\b a -> if even a then b+1 else b) 0 ([1..49] :: [Int])+        assert (v1 == (v2, v3))++partitionByMinM1 :: Property+partitionByMinM1 =+    forAll (listOf1 (chooseInt (intMin, intMax)))+        $ \ls0 -> monadicIO $ action ls0++    where++    action _ = do+        let f = \x -> if odd x then return (Left x) else return (Right x)+        v1 <- run $ S.fold (F.partitionByMinM f  FL.length (FL.take 25 FL.length)) (S.fromList ([1..100]:: [Int]))+        let v2 = foldl (\b a -> if odd a then b+1 else b) 0 ([1..50] :: [Int])+            v3 = foldl (\b a -> if even a then b+1 else b) 0 ([1..50] :: [Int])+        assert (v1 == (v2, v3))++partitionByMinM2 :: Property+partitionByMinM2 =+    forAll (listOf1 (chooseInt (intMin, intMax)))+        $ \ls0 -> monadicIO $ action ls0++    where++    action _ = do+        let f = \x -> if odd x then return (Left x) else return (Right x)+        v1 <- run $ S.fold (F.partitionByMinM f (FL.take 25 FL.length) FL.length) (S.fromList ([1..100]:: [Int]))+        let v2 = foldl (\b a -> if odd a then b+1 else b) 0 ([1..49] :: [Int])+            v3 = foldl (\b a -> if even a then b+1 else b) 0 ([1..49] :: [Int])+        assert (v1 == (v2, v3))++teeWithMinLength1 :: Property+teeWithMinLength1 =+    forAll (listOf1 (chooseInt (intMin, intMax)))+        $ \ls0 -> monadicIO $ action ls0++    where++    action ls = do+        v1 <- run $ S.fold (F.teeWithMin (,) (FL.take 5 FL.sum)  FL.length) $ S.fromList ls+        let v2 = Prelude.sum (Prelude.take 5 ls)+            v3 = Prelude.length (Prelude.take 5 ls)+        assert (v1 == (v2, v3))+++teeWithMinLength2 :: Property+teeWithMinLength2 =+    forAll (listOf1 (chooseInt (intMin, intMax)))+        $ \ls0 -> monadicIO $ action ls0++    where++    action ls = do+        v1 <- run $ S.fold (F.teeWithMin (,) FL.sum  (FL.take 5 FL.length)) $ S.fromList ls+        let v2 = Prelude.sum (Prelude.take 5 ls)+            v3 = Prelude.length (Prelude.take 5 ls)+        assert (v1 == (v2, v3)) teeWithMax :: Property teeWithMax =     forAll (listOf1 (chooseInt (intMin, intMax)))@@ -423,13 +525,13 @@     forAll (chooseInt (1, 100)) $ \i ->         monadicIO $ do             let strm = S.fromList lst-            r1 <- S.fold (F.many (split i) F.toList) strm+            r1 <- S.fold (FL.many (split i) FL.toList) strm             r2 <- S.toList $ Stream.foldMany (split i) strm             assert $ r1 == r2      where -    split i = F.take i F.toList+    split i = FL.take i FL.toList  headAndRest :: [Int] -> Property headAndRest ls = monadicIO $ do@@ -444,6 +546,126 @@     taill [] = []     taill (_:xs) = xs +demux :: Expectation+demux =+    let table = Data.Map.fromList [("SUM", FL.sum), ("PRODUCT", FL.product)]+        input = Stream.fromList (+                [ ("SUM", 1)+                , ("PRODUCT", 2)+                , ("SUM",3)+                , ("PRODUCT", 4)+                ] :: [(String, Int)])+    in Stream.fold+        (F.demux table)+        input+        `shouldReturn`+        Data.Map.fromList [("PRODUCT", 8),("SUM", 4)]+++demuxWithSum :: Expectation+demuxWithSum =+    let f x = ("SUM", x::Int)+        table = Data.Map.fromList [("SUM", FL.sum)]+        input = Stream.fromList [1, 4]+    in Stream.fold+        (F.demuxWith f table)+        input+        `shouldReturn`+        Data.Map.fromList [("SUM", 5)]++demuxWithProduct :: Expectation+demuxWithProduct =+    let f x = ("PRODUCT", x::Int)+        table = Data.Map.fromList [("PRODUCT", FL.product)]+        input = Stream.fromList [2, 4]+    in Stream.fold+        (F.demuxWith f table)+        input+        `shouldReturn`+        Data.Map.fromList [("PRODUCT", 8)]++demuxDefaultWithSum :: Expectation+demuxDefaultWithSum =+    let f x = ("SUM", x::Int)+        table = Data.Map.fromList [("SUM", FL.sum)]+        input = Stream.fromList [2, 4]+    in Stream.fold+        (F.demuxDefaultWith f table (FL.lmap snd FL.sum))+        input+        `shouldReturn`+        (Data.Map.fromList [("SUM" , 6)] , 0)++demuxDefaultWithProduct :: Expectation+demuxDefaultWithProduct =+    let f x = ("PRODUCT", x::Int)+        table = Data.Map.fromList [("PRODUCT", FL.product)]+        input = Stream.fromList [2, 4]+    in Stream.fold+        (F.demuxDefaultWith f table (FL.lmap snd FL.product))+        input+        `shouldReturn`+        (Data.Map.fromList [("PRODUCT" , 8)] , 1)++demuxDefault :: Expectation+demuxDefault =+    let table =  Data.Map.fromList [("SUM", FL.sum), ("PRODUCT", FL.product)]+        input = Stream.fromList+            [ ("SUM", 1::Int)+            , ("PRODUCT", 2::Int)+            , ("SUM",3)+            , ("PRODUCT", 4::Int)+            ]+    in Stream.fold+        (F.demuxDefault table (FL.lmap snd FL.product))+        input+        `shouldReturn`+        (Data.Map.fromList [("PRODUCT", 8), ("SUM", 4)], 1)++demuxDefaultEmpty :: Expectation+demuxDefaultEmpty =+    let table =  Data.Map.empty+        input = Stream.fromList []+    in Stream.fold+        (F.demuxDefault table (FL.lmap snd FL.product))+        input+        `shouldReturn`+        (Data.Map.fromList ([]::[(String, Int)]), 1)++classifyWith :: Expectation+classifyWith =+    let input = Stream.fromList [("ONE",1),("ONE",1.1),("TWO",2), ("TWO",2.2)]+    in Stream.fold+        (F.classifyWith fst (FL.lmap snd FL.toList))+        input+        `shouldReturn`+        Data.Map.fromList+        [("ONE",[1.0, 1.1 :: Double]), ("TWO",[2.0, 2.2])]++classify :: Expectation+classify =+    let input =+            Stream.fromList+            [+              ("ONE", (1::Int, 1))+            , ("ONE", (1, 1.1:: Double))+            , ("TWO", (2, 2))+            , ("TWO",(2, 2.2))+            ]+    in Stream.fold+        (F.classify (FL.lmap snd FL.toList))+        input+        `shouldReturn`+        Data.Map.fromList+        [("ONE",[1.0, 1.1 :: Double]), ("TWO",[2.0, 2.2])]++splitAt :: Expectation+splitAt =+    Stream.fold+    (F.splitAt 6 FL.toList FL.toList)+    (Stream.fromList "Hello World!")+    `shouldReturn`+    ("Hello ","World!")+ moduleName :: String moduleName = "Data.Fold" @@ -472,6 +694,16 @@         prop "rollingHashFirstN" rollingHashFirstN          prop "toList" toList+        prop "toListRev" toListRev+        prop "demux" demux+        prop "demuxWithSum" demuxWithSum+        prop "demuxWithProduct" demuxWithProduct+        prop "demuxDefaultWithSum" demuxDefaultWithSum+        prop "demuxDefaultWithProduct" demuxDefaultWithProduct+        prop "demuxDefault" demuxDefault+        prop "demuxDefaultEmpty" demuxDefaultEmpty+        prop "classifyWith" classifyWith+        prop "classify" classify          -- Terminating folds         prop "index" index@@ -513,14 +745,23 @@         -- Distributing         -- tee         prop "teeWithLength" Main.teeWithLength+        prop "teeWithFstLength" Main.teeWithFstLength+        prop "teeWithMinLength1" Main.teeWithMinLength1+        prop "teeWithMinLength2" Main.teeWithMinLength2         prop "teeWithMax" Main.teeWithMax+        prop "partitionByM" Main.partitionByM+        prop "partitionByFstM" Main.partitionByFstM+        prop "partitionByMinM1" Main.partitionByMinM1+        prop "partitionByMinM2" Main.partitionByMinM2         prop "distribute" Main.distribute          -- Partitioning         prop "partition" Main.partition+        prop "partitionByM" partitionByM          -- Unzipping         prop "unzip" Main.unzip+        prop "splitAt" Main.splitAt          -- Nesting         prop "many" Main.many
test/Streamly/Test/Data/Parser.hs view
@@ -155,6 +155,19 @@         where             predicate = (>= mid_value) +nextPass :: Property+nextPass =+    forAll (chooseInt (1, max_value)) $ \int ->+        property (case S.parse P.next (S.fromList [int]) of+            Right (Just i) -> i  == int+            _ -> False)++next :: Property+next =+    property (case S.parse P.next (S.fromList []) of+        Right Nothing -> True+        _ -> False)+ -- Sequence Parsers Tests takeBetweenPass :: Property takeBetweenPass =@@ -175,22 +188,22 @@ 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)+            forAll (listOf (chooseInt (min_value, max_value))) $ \ls ->+                go m n ls +    where +    go m n ls =+        let inputLen = Prelude.length ls+         in case S.parse (P.takeBetween m n FL.toList) (S.fromList ls) of+                Right xs ->+                    let parsedLen = Prelude.length xs+                     in if inputLen >= m && parsedLen >= m && parsedLen <= n+                        then checkListEqual xs $ Prelude.take parsedLen ls+                        else property False+                Left _ ->+                    property ((m >= 0 && n >= 0 && m > n) || inputLen < m)+ takeEQPass :: Property takeEQPass =     forAll (chooseInt (min_value, max_value)) $ \n ->@@ -353,6 +366,19 @@         where             predicate = (== 0) +takeP :: Property+takeP =+    forAll+        ((,) <$> chooseInt (min_value, max_value)+             <*> listOf (chooseInt (0, 1)))+        $ \(takeNum, ls) ->+              case S.parse+                       (P.takeP takeNum (P.fromFold FL.toList))+                       (S.fromList ls) of+                  Right parsed_list ->+                      checkListEqual parsed_list (Prelude.take takeNum ls)+                  Left _ -> property False+ takeWhile1 :: Property takeWhile1 =     forAll (listOf (chooseInt (0, 1))) $ \ ls ->@@ -372,6 +398,22 @@         where             predicate = (== 0) +choice :: Property+choice =+    forAll+        ((,,) <$> chooseInt (min_value, max_value)+             <*> chooseInt (min_value, max_value)+             <*> listOf (chooseInt (0, 1)))+        $ \(i, j, ls) ->+              case S.parse (P.choice [parser i, parser j]) (S.fromList ls) of+                  Right parsed_list ->+                      checkListEqual parsed_list $ take (min i j) ls+                  Left _ -> property False++    where++    parser i = P.fromFold (FL.take i FL.toList)+ groupBy :: Property groupBy =     forAll (listOf (chooseInt (0, 1)))@@ -388,7 +430,6 @@         | null lst = []         | otherwise = head $ List.groupBy cmp lst - wordBy :: Property wordBy =     forAll (listOf (elements [' ', 's']))@@ -717,6 +758,8 @@         prop "eof pass on []" eofPass         prop "eof fail on non-empty list" eofFail         prop "first element exists and >= mid_value" satisfyPass+        prop "next pass on [Int]" nextPass+        prop "next fail on []" next         prop "check first element exists and satisfies predicate" satisfy      describe "test for sequence parser" $ do@@ -739,8 +782,10 @@         prop "P.takeWhile = Prelude.takeWhile" Main.takeWhile         prop ("P.takeWhile1 = Prelude.takeWhile if taken something,"                 ++ " else check why failed") takeWhile1+        prop ("P.takeP = Prelude.take") takeP         prop "P.groupBy = Prelude.head . Prelude.groupBy" groupBy         prop "many (P.wordBy ' ') = words'" wordBy+        prop "choice" choice         -- prop "" splitWithPass         -- prop "" splitWithFailLeft         -- prop "" splitWithFailRight
test/Streamly/Test/Data/Unfold.hs view
@@ -195,38 +195,256 @@                   unf = UF.take 100 $ UF.fromIndicesM indFM                in testUnfoldMD unf 1 0 (length list) list -enumerateFromStepNum :: Property-enumerateFromStepNum =+-------------------------------------------------------------------------------+-- Test for Num type+-------------------------------------------------------------------------------+enumerateFromNum :: Property+enumerateFromNum =     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+        $ \f ->+                let unf = UF.take 50 UF.enumerateFromNum+                in testUnfold unf (f :: Int) $+                    Prelude.take 50 $ Prelude.enumFrom f -#if MIN_VERSION_base(4,12,0)-enumerateFromToFractional :: Property-enumerateFromToFractional =+enumerateFromThenNum :: Property+enumerateFromThenNum =     property-        $ \f t ->-              let unf = UF.enumerateFromToFractional (t :: Double)-               in testUnfold unf (f :: Double) [f..(t :: Double)]-#endif+        $ \f th ->+                let unf = UF.take 50 UF.enumerateFromThenNum+                in testUnfold unf (f :: Int, th) $+                    Prelude.take 50 $ Prelude.enumFromThen f th -enumerateFromStepIntegral :: Property-enumerateFromStepIntegral =+-------------------------------------------------------------------------------+-- Test for Integral type+-------------------------------------------------------------------------------+enumerateFromIntegral :: Property+enumerateFromIntegral =     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+        $ \f ->+                let unf = UF.take 50 UF.enumerateFromIntegral+                in testUnfold unf (f :: Integer) $+                    Prelude.take 50 $ Prelude.enumFrom f +enumerateFromThenIntegral :: Property+enumerateFromThenIntegral =+    property+        $ \f th ->+                let unf = UF.take 50 UF.enumerateFromThenIntegral+                in testUnfold unf (f :: Integer, th) $+                    Prelude.take 50 $ Prelude.enumFromThen f th++enumerateFromThenToIntegral :: Property+enumerateFromThenToIntegral =+    property+        $ \f th to ->+                let unf = UF.take 50 UF.enumerateFromThenToIntegral+                in testUnfold unf (f :: Integer, th, to) $+                    Prelude.take 50 $ Prelude.enumFromThenTo f th to+ enumerateFromToIntegral :: Property enumerateFromToIntegral =     property+        $ \f to ->+                let unf = UF.take 50 UF.enumerateFromToIntegral+                in testUnfold unf (f :: Integer, to) $+                    Prelude.take 50 $ Prelude.enumFromTo f to++enumerateFromIntegralBounded :: Property+enumerateFromIntegralBounded =+    property+        $ \f ->+                let unf = UF.take 50 UF.enumerateFromIntegralBounded+                in testUnfold unf (f :: Int) $+                    Prelude.take 50 $ Prelude.enumFrom f++enumerateFromThenIntegralBounded :: Property+enumerateFromThenIntegralBounded =+    property+        $ \f th ->+                let unf = UF.take 50 UF.enumerateFromThenIntegralBounded+                in testUnfold unf (f :: Int, th) $+                    Prelude.take 50 $ Prelude.enumFromThen f th++enumerateFromToIntegralBounded :: Property+enumerateFromToIntegralBounded =+    property+        $ \f to ->+                let unf = UF.take 50 UF.enumerateFromToIntegralBounded+                in testUnfold unf (f :: Int, to) $+                    Prelude.take 50 $ Prelude.enumFromTo f to++enumerateFromThenToIntegralBounded :: Property+enumerateFromThenToIntegralBounded =+    property+        $ \f th to ->+                let unf = UF.take 50 UF.enumerateFromThenToIntegralBounded+                in testUnfold unf (f :: Int, th, to) $+                    Prelude.take 50 $ Prelude.enumFromThenTo f th to++enumerateFromSmallBounded :: Property+enumerateFromSmallBounded =+    property+        $ \f ->+                let unf = UF.take 50 UF.enumerateFromSmallBounded+                in testUnfold unf (f :: Char) $+                    Prelude.take 50 $ Prelude.enumFrom f++enumerateFromThenSmallBounded :: Property+enumerateFromThenSmallBounded =+    property+        $ \f th ->+                let unf = UF.take 50 UF.enumerateFromThenSmallBounded+                in testUnfold unf (f :: Char, th) $+                    Prelude.take 50 $ Prelude.enumFromThen f th++enumerateFromToSmall :: Property+enumerateFromToSmall =+    property+        $ \f to ->+                let unf = UF.take 50 UF.enumerateFromToSmall+                in testUnfold unf (f :: Char, to) $+                    Prelude.take 50 $ Prelude.enumFromTo f to++enumerateFromThenToSmall :: Property+enumerateFromThenToSmall =+    property+        $ \f th to ->+                let unf = UF.take 50 UF.enumerateFromThenToSmall+                in testUnfold unf (f :: Char, th, to) $+                    Prelude.take 50 $ Prelude.enumFromThenTo f th to++enumerateFromSmallBoundedOrd :: Property+enumerateFromSmallBoundedOrd =+    property+        $ \f ->+                let unf = UF.take 3 UF.enumerateFromSmallBounded+                in testUnfold unf (f :: Ordering) $+                    Prelude.take 3 $ Prelude.enumFrom f++enumerateFromThenSmallBoundedOrd :: Property+enumerateFromThenSmallBoundedOrd =+    property+        $ \f th  ->+                let unf = UF.take 3 UF.enumerateFromThenSmallBounded+                in testUnfold unf (f :: Ordering, th) $+                    Prelude.take 3 $ Prelude.enumFromThen f th++enumerateFromToSmallOrd :: Property+enumerateFromToSmallOrd =+    property+        $ \f to ->+                let unf = UF.take 3 UF.enumerateFromToSmall+                in testUnfold unf (f :: Ordering, to) $+                    Prelude.take 3 $ Prelude.enumFromTo f to++enumerateFromThenToSmallOrd :: Property+enumerateFromThenToSmallOrd =+    property+        $ \f th to ->+                let unf = UF.take 3 UF.enumerateFromThenToSmall+                in testUnfold unf (f :: Ordering, th, to) $+                    Prelude.take 3 $ Prelude.enumFromThenTo f th to++-------------------------------------------------------------------------------+enumerateFromSmallBoundedBool :: Property+enumerateFromSmallBoundedBool =+    property+        $ \f ->+                let unf = UF.take 2 UF.enumerateFromSmallBounded+                in testUnfold unf (f :: Bool) $+                    Prelude.take 2 $ Prelude.enumFrom f++enumerateFromThenSmallBoundedBool :: Property+enumerateFromThenSmallBoundedBool =+    property+        $ \f th  ->+                let unf = UF.take 2 UF.enumerateFromThenSmallBounded+                in testUnfold unf (f :: Bool, th) $+                    Prelude.take 2 $ Prelude.enumFromThen f th++enumerateFromToSmallBool :: Property+enumerateFromToSmallBool =+    property+        $ \f to ->+                let unf = UF.take 2 UF.enumerateFromToSmall+                in testUnfold unf (f :: Bool, to) $+                    Prelude.take 2 $ Prelude.enumFromTo f to++enumerateFromThenToSmallBool :: Property+enumerateFromThenToSmallBool =+    property+        $ \f th to ->+                let unf = UF.take 2 UF.enumerateFromThenToSmall+                in testUnfold unf (f :: Bool, th, to) $+                    Prelude.take 2 $ Prelude.enumFromThenTo f th to+-------------------------------------------------------------------------------+enumerateFromSmallBoundedUnit :: Property+enumerateFromSmallBoundedUnit =+    property+        $ \f ->+                let unf = UF.take 1 UF.enumerateFromSmallBounded+                in testUnfold unf (f :: ()) $+                    Prelude.take 1 $ Prelude.enumFrom f++enumerateFromThenSmallBoundedUnit :: Property+enumerateFromThenSmallBoundedUnit =+    property+        $ \f th  ->+                let unf = UF.take 1 UF.enumerateFromThenSmallBounded+                in testUnfold unf (f :: (), th) $+                    Prelude.take 1 $ Prelude.enumFromThen f th++enumerateFromToSmallUnit :: Property+enumerateFromToSmallUnit =+    property+        $ \f to ->+                let unf = UF.take 1 UF.enumerateFromToSmall+                in testUnfold unf (f :: (), to) $+                    Prelude.take 1 $ Prelude.enumFromTo f to++enumerateFromThenToSmallUnit :: Property+enumerateFromThenToSmallUnit =+    property+        $ \f th to ->+                let unf = UF.take 1 UF.enumerateFromThenToSmall+                in testUnfold unf (f :: (), th, to) $+                    Prelude.take 1 $ Prelude.enumFromThenTo f th to+++#if MIN_VERSION_base(4,12,0)+enumerateFromFractional :: Property+enumerateFromFractional =+    property+        $ \f ->+                let unf = UF.take 50 UF.enumerateFromFractional+                in testUnfold unf (f :: Double) $+                    Prelude.take 50 $ Prelude.enumFrom f++enumerateFromThenFractional :: Property+enumerateFromThenFractional =+    property+        $ \f th ->+                let unf = UF.take 50 UF.enumerateFromThenFractional+                in testUnfold unf (f :: Double, th) $+                    Prelude.take 50 $ Prelude.enumFromThen f th++enumerateFromThenToFractional :: Property+enumerateFromThenToFractional =+    property+        $ \f th to ->+                let unf = UF.take 50 UF.enumerateFromThenToFractional+                in testUnfold  unf (f :: Double, th, to) $+                    Prelude.take 50 $ Prelude.enumFromThenTo f th to++enumerateFromToFractional :: Property+enumerateFromToFractional =+    property         $ \f t ->-              let unf = UF.enumerateFromToIntegral t-               in testUnfoldD unf f [f .. t]+                let unf = UF.enumerateFromToFractional+                in testUnfold unf (f :: Double, t) [f..(t :: Double)] +#endif+ ------------------------------------------------------------------------------- -- Stream transformation -------------------------------------------------------------------------------@@ -315,29 +533,29 @@ 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+            let unf1 = UF.enumerateFromToIntegral+                unf2 = UF.enumerateFromToIntegral+                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,10), (1,20)) 0 10 lst  concat :: Bool concat =     let unfIn = UF.replicateM 10-        unfOut = UF.map return $ UF.enumerateFromToIntegral 10+        unfOut = UF.map return UF.enumerateFromToIntegral         unf = UF.many unfOut unfIn         lst = Prelude.concat $ Prelude.map (Prelude.replicate 10) [1 .. 10]-     in testUnfoldD unf 1 lst+     in testUnfoldD unf (1, 10) lst  outerProduct :: Bool outerProduct =-    let unf1 = UF.enumerateFromToIntegral 10-        unf2 = UF.enumerateFromToIntegral 20+    let unf1 = UF.enumerateFromToIntegral+        unf2 = UF.enumerateFromToIntegral         unf = crossProduct unf1 unf2         lst = [(a, b) :: (Int, Int) | a <- [0 .. 10], b <- [0 .. 20]]-     in testUnfold unf ((0, 0) :: (Int, Int)) lst+     in testUnfold unf (((0,10) ,(0,20)) :: ((Int, Int), (Int, Int))) lst      where @@ -348,9 +566,9 @@     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)+        unf = UF.concatMapM inner UF.enumerateFromToIntegral         list = List.concatMap (replicate 10) [1 .. 10]-     in testUnfoldMD unf 1 0 110 list+     in testUnfoldMD unf (1, 10) 0 110 list  ------------------------------------------------------------------------------- -- Test groups@@ -391,13 +609,45 @@             prop "repeatM" repeatM             prop "iterateM" iterateM             prop "fromIndicesM" fromIndicesM-            prop "enumerateFromStepIntegral" enumerateFromStepIntegral+            ----------- Enumerate from Num ------------------------------------+            prop "enumerateFromNum" enumerateFromNum+            prop "enumerateFromThenNum" enumerateFromThenNum+            ----------- Enumerate from Integral -------------------------------+            prop "enumerateFromIntegral" enumerateFromIntegral+            prop "enumerateFromThenIntegral" enumerateFromThenIntegral             prop "enumerateFromToIntegral" enumerateFromToIntegral-            -- prop "enumerateFromIntegral" enumerateFromIntegral-            prop "enumerateFromStepNum" enumerateFromStepNum-            -- prop "numFrom" numFrom+            prop "enumerateFromThenToIntegral" enumerateFromThenToIntegral++            prop "enumerateFromIntegralBounded" enumerateFromIntegralBounded+            prop "enumerateFromThenIntegralBounded" enumerateFromThenIntegralBounded+            prop "enumerateFromToIntegralBounded" enumerateFromToIntegralBounded+            prop "enumerateFromThenToIntegralBounded" enumerateFromThenToIntegralBounded+            ----------- Enumerate from Small Integral -------------------------+            prop "enumerateFromSmallBounded" enumerateFromSmallBounded+            prop "enumerateFromThenSmallBounded" enumerateFromThenSmallBounded+            prop "enumerateFromToSmall" enumerateFromToSmall+            prop "enumerateFromThenToSmall" enumerateFromThenToSmall+            --+            prop "enumerateFromSmallBoundedOrd" enumerateFromSmallBoundedOrd+            prop "enumerateFromThenSmallBoundedOrd" enumerateFromThenSmallBoundedOrd+            prop "enumerateFromToSmallOrd" enumerateFromToSmallOrd+            prop "enumerateFromThenToSmallOrd" enumerateFromThenToSmallOrd++            prop "enumerateFromSmallBoundedUnit" enumerateFromSmallBoundedUnit+            prop "enumerateFromThenSmallBoundedUnit" enumerateFromThenSmallBoundedUnit+            prop "enumerateFromToSmallUnit" enumerateFromToSmallUnit+            prop "enumerateFromThenToSmallUnit" enumerateFromThenToSmallUnit++            prop "enumerateFromSmallBoundedUnit" enumerateFromSmallBoundedBool+            prop "enumerateFromThenSmallBoundedBool" enumerateFromThenSmallBoundedBool+            prop "enumerateFromToSmallBool" enumerateFromToSmallBool+            prop "enumerateFromThenToSmallBool" enumerateFromThenToSmallBool+ #if MIN_VERSION_base(4,12,0)+            prop "enumerateFromFractional" enumerateFromFractional+            prop "enumerateFromThenFractional" enumerateFromThenFractional             prop "enumerateFromToFractional" enumerateFromToFractional+            prop "enumerateFromThenToFractional" enumerateFromThenToFractional #endif  testTransformation :: Spec
test/Streamly/Test/FileSystem/Event.hs view
@@ -1,402 +1,28 @@ -- | -- Module      : Streamly.Test.FileSystem.Event--- Copyright   : (c) 2020 Composewell Technologies+-- Copyright   : (c) 2021 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--------------------------------------------------------------------------------+module Streamly.Test.FileSystem.Event (main) where -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-      )-    ]+import qualified Streamly.Internal.FileSystem.Event as Event+import Streamly.Test.FileSystem.Event.Common  moduleName :: String moduleName = "FileSystem.Event"  main :: IO () main = do-    hSetBuffering stdout NoBuffering-    hspec $ describe moduleName $ sequence_ $ map driver testDesc+    let run = runTests moduleName "non-recursive" Event.watch+    run DirType commonTests+    run+#if defined(CABAL_OS_DARWIN)+        SymLinkResolvedPath+#else+        SymLinkOrigPath+#endif+        commonTests
+ test/Streamly/Test/FileSystem/Event/Common.hs view
@@ -0,0 +1,418 @@+-- |+-- Module      : Streamly.Test.FileSystem.Event.Common+-- Copyright   : (c) 2020 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+module Streamly.Test.FileSystem.Event.Common+    ( TestDesc++    -- * Running tests+    , runTests+    , WatchRootType (..)++    -- * Event predicates+    , dirEvent+    , fileEvent++    -- * Tests+    , dirCreate+    , dirCreateWithParent+    , dirDelete+    , dirMove+    , rootDirMove++    , fileCreate+    , fileCreateWithParent+    , fileDelete+    , fileModify+    , fileMove+    , rootFileMove++    , commonTests+    , commonRecTests+    )++where++import Debug.Trace (trace)+import Control.Concurrent (MVar, newEmptyMVar, putMVar, takeMVar, threadDelay)+import Control.Monad (when)+import Control.Monad.IO.Class (MonadIO)+import Data.Bifunctor (first)+import Data.Function ((&))+import Data.Functor.Identity (runIdentity)+import Data.List.NonEmpty (NonEmpty)+import Data.Word (Word8)+import Streamly.Data.Array.Foreign (Array)+import System.Directory+    ( createDirectory+    , createDirectoryIfMissing+    , createDirectoryLink+    , removeFile+    , removePathForcibly+    , renameDirectory+    , renamePath+    )+import System.FilePath ((</>), takeDirectory)+import System.IO+    ( BufferMode(..), hSetBuffering, stdout, IOMode (WriteMode), openFile+    , hClose)+import System.IO.Temp (withSystemTempDirectory)++import qualified Data.List.NonEmpty as NonEmpty+import qualified Streamly.Internal.Data.Array.Foreign as Array+import qualified Streamly.Internal.Data.Stream.IsStream as Stream+import qualified Streamly.Unicode.Stream as Unicode++#if defined(FILESYSTEM_EVENT_LINUX)+import Streamly.Internal.FileSystem.Event.Linux (Event)+import qualified Streamly.Internal.FileSystem.Event.Linux as Event+#elif defined(FILESYSTEM_EVENT_DARWIN)+import Streamly.Internal.FileSystem.Event.Darwin (Event)+import qualified Streamly.Internal.FileSystem.Event.Darwin as Event+#elif defined(FILESYSTEM_EVENT_WINDOWS)+import Streamly.Internal.FileSystem.Event.Windows (Event)+import qualified Streamly.Internal.FileSystem.Event.Windows as Event+#else+import Streamly.Internal.FileSystem.Event (Event)+import qualified Streamly.Internal.FileSystem.Event as Event+#endif++import Test.Hspec++-------------------------------------------------------------------------------+-- Check generated events+-------------------------------------------------------------------------------++type EventChecker =+       FilePath  -- watch root+    -> FilePath  -- watch target, target dir if root is a symlink+    -> MVar ()   -- mvar to sync file system ops and the watch+    -> [(String, Event -> Bool)] -- expected events+    -> IO ()+type EventWatcher = NonEmpty (Array Word8) -> Stream.SerialT IO Event.Event++eventMatches :: Event -> (String, Event -> Bool) -> Bool+eventMatches ev (expectedPath, f) =+    trace ("paths: " ++ show evPath ++ " " ++ show expectedPath)+        (evPath == expectedPath && f ev)++    where++    utf8ToString :: Array Word8 -> String+    utf8ToString =+        runIdentity . Stream.toList . Unicode.decodeUtf8' . Array.toStream++    evPath = utf8ToString (Event.getAbsPath ev)++toUtf8 :: MonadIO m => String -> m (Array Word8)+toUtf8 = Array.fromStream . Unicode.encodeUtf8' . Stream.fromList++checkEvents :: EventWatcher -> EventChecker+checkEvents watcher rootPath targetPath mvar matchList = do+    putStrLn ("Watching on root [" <> rootPath+             <> "] for [" <> targetPath <> "]")++    let matchList1 = fmap (first (targetPath </>)) matchList+        finder xs ev = filter (not . eventMatches ev) xs++    paths <- mapM toUtf8 [rootPath]+    watcher (NonEmpty.fromList paths)+        & Stream.before (putMVar mvar ())+        & Stream.trace (putStrLn . Event.showEvent)+        & Stream.scanl' finder matchList1+        & Stream.takeWhile (not . null)+        & Stream.drain++-------------------------------------------------------------------------------+-- Run tests+-------------------------------------------------------------------------------++type TestDesc =+    ( String            -- test description+    , FilePath -> IO () -- pre test operation, arg is path of the watch root.+    , FilePath -> IO () -- file system action, arg is path of the watch root.+    , [(String, Event -> Bool)] -- expected events (Absolute Path, predicate)+    )++-- | Whether watch root is a symlink and if so then what's the behavior+data WatchRootType =+      DirType             -- watch root is a directory+    | FileType            -- watch root is a file+    | SymLinkResolvedPath -- symlink to a directory,+                          -- Event contains path via the resolved dir+    | SymLinkOrigPath     -- symlink to a directory,+                          -- Event contains path via the original symlink+    deriving Show++driver :: EventChecker -> WatchRootType -> TestDesc -> SpecWith ()+driver checker symlinkStyle (desc, pre, ops, expected) =+    it desc $ runOneTest `shouldReturn` ()++    where++    fseventDir :: String+    fseventDir = "fsevent_dir"++    runOneTest = do+            sync <- newEmptyMVar+            withSystemTempDirectory fseventDir $ \fp -> do+                let root = fp </> "watch-root"+                target <-+                    case symlinkStyle of+                        DirType -> do+                            createDirectory root+                            return root+                        FileType -> do+                            openFile root WriteMode >>= hClose+                            return root+                        SymLinkResolvedPath -> do+                            let tgt = fp </> "watch-root-real"+                            createDirectory tgt+                            createDirectoryLink tgt root+                            return tgt+                        SymLinkOrigPath -> do+                            let tgt = fp </> "watch-root-real"+                            createDirectory tgt+                            createDirectoryLink tgt root+                            return root++                -- XXX On macOS we seem to get the watch root create events+                -- even though they occur before the watch is started.  Even if+                -- we add a delay here.+                startWatchAndCheck root target sync++    startWatchAndCheck root target sync = do+            pre root+            -- XXX On macOS the events from pre ops also seem to be bundled+            -- with the events occurred after the watch is started.+            let check = checker root target sync expected+                fsOps = Stream.fromEffect $ runFSOps root sync+            Stream.drain $ Stream.fromEffect check `Stream.parallelFst` fsOps++    runFSOps fp sync = do+        -- We put the MVar before the event watcher starts to run but that does+        -- not ensure that the event watcher has actually started. So we need a+        -- delay as well. Do we?+        takeMVar sync >> threadDelay 200000+        ops fp+        threadDelay 10000000+        error "Time out occurred before event watcher could terminate"++-------------------------------------------------------------------------------+-- Test descriptions+-------------------------------------------------------------------------------++dirEvent, fileEvent :: (Event -> Bool) -> Event -> Bool++#if defined(FILESYSTEM_EVENT_DARWIN)+dirEvent f ev = Event.isDir ev && f ev+fileEvent f ev = Event.isFile ev && f ev+#elif defined(FILESYSTEM_EVENT_LINUX)+dirEvent f ev = Event.isDir ev && f ev+fileEvent f ev = not (Event.isDir ev) && f ev+#else+dirEvent = id+fileEvent = id+#endif++-- XXX Tests for root as a regular file instead of dir?+-- XXX Add symlink and hardlink tests+-- XXX Add exception condition tests++-------------------------------------------------------------------------------+-- Dir tests+-------------------------------------------------------------------------------++createParent :: FilePath -> FilePath -> IO ()+createParent file parent = do+    createDirectoryIfMissing True (parent </> takeDirectory file)++createDirWithParent :: FilePath -> FilePath -> IO ()+createDirWithParent dir parent =+    when (not (null dir)) $ createDirectoryIfMissing True (parent </> dir)++createDir :: FilePath -> FilePath -> IO ()+createDir dir parent =+    when (not (null dir)) $ createDirectory (parent </> dir)++-- | Create the dir along with its parent dir during the test. This is+-- especially useful to detect a race in Linux case where the watch for a+-- directory is added in event processing, so if the the child directory is+-- created before the watch was installed then we may miss some events.+dirCreateWithParent ::+    String -> (String -> [([Char], Event -> Bool)]) -> TestDesc+dirCreateWithParent dir events =+    ( "dir created (" ++ dir ++ ")"+    , const (return ())+    , createDirWithParent dir+    , events dir+    )++dirCreate :: String -> (String -> [([Char], Event -> Bool)]) -> TestDesc+dirCreate dir events =+    ( "dir created (" ++ dir ++ ")"+    , createParent dir+    , createDir dir+    , events dir+    )++dirDelete :: String -> (String -> [([Char], Event -> Bool)]) -> TestDesc+dirDelete dir events =+      ( "dir deleted (" ++ dir ++ ")"+      , createDirWithParent dir+      , \fp -> removePathForcibly (fp </> dir)+      , events dir+      )++dirMove ::+       String+    -> String+    -> (String -> String -> [(String, Event -> Bool)])+    -> TestDesc+dirMove dir1 dir2 events =+      ( "dir moved (" ++ dir1 ++ " " ++ dir2 ++ ")"+      , createDirWithParent dir1+      , \fp -> renameDirectory (fp </> dir1) (fp </> dir2)+      , events dir1 dir2+      )++rootDirMove ::+       String+    -> (String -> [(String, Event -> Bool)])+    -> TestDesc+rootDirMove suffix events =+      ( "root dir moved" ++ "(" ++ suffix ++ ")"+      , const (return ())+      , \fp -> renameDirectory fp (fp <> suffix)+      , events ""+      )++-------------------------------------------------------------------------------+-- File tests+-------------------------------------------------------------------------------++createFileWithParent :: FilePath -> FilePath -> IO ()+createFileWithParent file parent = do+    when (not (null file)) $+        createDirectoryIfMissing True (parent </> takeDirectory file)+    openFile (parent </> file) WriteMode >>= hClose++createFile :: FilePath -> FilePath -> IO ()+createFile file parent =+    openFile (parent </> file) WriteMode >>= hClose++fileCreate :: String -> (String -> [(String, Event -> Bool)]) -> TestDesc+fileCreate file1 events =+    ( "File created (" ++ file1 ++ ")"+    , createParent file1+    , createFile file1+    , (file1, fileEvent Event.isCreated) : events file1+    )++-- | See comments in dirCreateWithParent+fileCreateWithParent ::+    String -> (String -> [(String, Event -> Bool)]) -> TestDesc+fileCreateWithParent file1 events =+    ( "File created (" ++ file1 ++ ")"+    , const (return ())+    , createFileWithParent  file1+    , (file1, fileEvent Event.isCreated) : events file1+    )++fileDelete :: String -> (String -> [(String, Event -> Bool)]) -> TestDesc+fileDelete file1 events =+    ( "File deleted (" ++ file1 ++ ")"+    , createFileWithParent file1+    , \fp -> removeFile (fp </> file1)+    , events file1+    )++fileModify :: String -> (String -> [(String, Event -> Bool)]) -> TestDesc+fileModify file1 events =+    ( "File modified (" ++ file1 ++ ")"+    , createFileWithParent file1+    , \fp -> writeFile (fp </> file1) "Test Data"+    , (file1, fileEvent Event.isModified) : events file1+    )++fileMove ::+       String+    -> String+    -> (String -> String -> [(String, Event -> Bool)])+    -> TestDesc+fileMove file1 file2 events =+    ( "File moved (" ++ file1 ++ " " ++ file2 ++ ")"+    , createFileWithParent file1+    , \fp -> renamePath (fp </> file1) (fp </> file2)+    ,     (file1, fileEvent Event.isMoved)+        : (file2, fileEvent Event.isMoved)+        : events file1 file2+    )++rootFileMove :: String -> (String -> [(String, Event -> Bool)]) -> TestDesc+rootFileMove suffix events =+    ( "File moved (" ++ suffix ++ ")"+    , const (return ())+    , \fp -> renamePath fp (fp <> suffix)+    , events ""+    )++-------------------------------------------------------------------------------+-- Common test bundles+-------------------------------------------------------------------------------++withParent :: [Char] -> [Char] -> [Char]+withParent parent file = if null parent then file else parent </> file++testsWithParent :: String -> [TestDesc]+testsWithParent p =+    [ dirCreate+        (withParent p "dir") (\dir -> [(dir, dirEvent Event.isCreated)])+    , dirDelete+        (withParent p "dir") (\dir -> [(dir, dirEvent Event.isDeleted)])+    , dirMove+        (withParent p "dir1")+        (withParent p "dir2")+        (\dir1 dir2 ->+            [ (dir1, dirEvent Event.isMoved)+            , (dir2, dirEvent Event.isMoved)+            ]+        )+    , fileCreate (withParent p "file1") (const [])+    , fileDelete+        (withParent p "file1")+        (\file -> [(file, fileEvent Event.isDeleted)])+    , fileModify (withParent p "file1") (const [])+    , fileMove (withParent p "file1") (withParent p "file2") (\_ _ -> [])+    ]++commonTests :: [TestDesc]+commonTests = testsWithParent ""++commonRecTests :: [TestDesc]+commonRecTests = testsWithParent "subdir"++-------------------------------------------------------------------------------+-- Running tests+-------------------------------------------------------------------------------++runTests ::+       String+    -> String+    -> EventWatcher+    -> WatchRootType+    -> [TestDesc]+    -> IO ()+runTests modName watchType watcher rootType tests = do+    hSetBuffering stdout NoBuffering+    hspec+        $ describe modName+        $ describe watchType+        $ do+            let checker = checkEvents watcher+            describe ("Root type " ++ show rootType)+                    $ mapM_ (driver checker rootType) tests
+ test/Streamly/Test/FileSystem/Event/Darwin.hs view
@@ -0,0 +1,85 @@+-- |+-- Module      : Streamly.Test.FileSystem.Event.Darwin+-- Copyright   : (c) 2020 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+module Streamly.Test.FileSystem.Event.Darwin (main) where++import qualified Streamly.Internal.FileSystem.Event.Darwin as Event++import Streamly.Test.FileSystem.Event.Common++moduleName :: String+moduleName = "FileSystem.Event.Darwin"++-- TODO:+-- Creation/deletion/move of hard links+-- Deletion of last hard link+-- If a directory is a symlink is it followed in recursive mode?++main :: IO ()+main = do+    let symLinkRootTests =+              dirCreateWithParent "subdir/dir"+                (\dir -> [(dir, dirEvent Event.isCreated)])+            : fileCreateWithParent "subdir/file"+                (\file ->+                    [ (file, fileEvent Event.isCreated)+                    , (file, fileEvent Event.isAttrsModified)+                    ]+                )+            : fileCreate "file-create-attrs"+                (\file ->+                    [ (file, fileEvent Event.isCreated)+                    , (file, fileEvent Event.isAttrsModified)+                    ]+                )+            : fileModify+                    "file-mod-attrs"+                    (\file -> [(file, fileEvent Event.isAttrsModified)])+            : dirDelete "dir-sec" (\dir ->+                [ (dir, dirEvent Event.isDeleted)+                , (dir, dirEvent Event.isSecurityModified)+                ]+                )+            : commonTests+            ++ commonRecTests+    let regularRootTests =+              dirDelete "" (\dir ->+                [ (dir, dirEvent Event.isDeleted)+                , (dir, dirEvent Event.isSecurityModified)+                , (dir, Event.isRootPathEvent)+                ]+                )+            -- The watch root create event always seems to come even though the+            -- root is created before the watch is started. That may be because+            -- of batching?+            -- XXX Need to create watch root after adding the watch+            : dirCreate "" (\dir -> [(dir, dirEvent Event.isCreated)])+            : rootDirMove "moved" (\src ->+                [ (src, Event.isRootPathEvent)+                , (src, Event.isMoved)+                ])+            : symLinkRootTests++    let fileRootTests =+            [ fileDelete "" (\path ->+                [ (path, Event.isRootPathEvent)+                , (path, Event.isDeleted)+                ])+            , rootFileMove "moved" (\path ->+                [(path, Event.isRootPathEvent)+                , (path, Event.isMoved)+                ])+            , fileModify "" (const [])+            ]++    let w = Event.watchWith (Event.setAllEvents Event.On)+        run = runTests moduleName "recursive" w++    run DirType regularRootTests+    run SymLinkResolvedPath symLinkRootTests+    run FileType fileRootTests
+ test/Streamly/Test/FileSystem/Event/Linux.hs view
@@ -0,0 +1,150 @@+-- |+-- Module      : Streamly.Test.FileSystem.Event.Linux+-- Copyright   : (c) 2020 Composewell Technologies+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+module Streamly.Test.FileSystem.Event.Linux (main) where++import Streamly.Internal.FileSystem.Event.Linux (Event)+import qualified Streamly.Internal.FileSystem.Event.Linux as Event++import Streamly.Test.FileSystem.Event.Common++moduleName :: String+moduleName = "FileSystem.Event.Linux"++dirTouchEvents :: String -> [([Char], Event -> Bool)]+dirTouchEvents dir =+    [ (dir, dirEvent Event.isOpened)+    , (dir, dirEvent Event.isAccessed)+    , (dir, dirEvent Event.isNonWriteClosed)+    ]++dirDelEvents :: String -> [([Char], Event -> Bool)]+dirDelEvents dir =+      (dir, dirEvent Event.isDeleted)+    : (dir, dirEvent Event.isAttrsModified)+    : dirTouchEvents dir++rootDirDelEvents :: String -> [([Char], Event -> Bool)]+rootDirDelEvents root =+      (root, Event.isRootUnwatched)+    : (root, Event.isRootDeleted)+    : (root, dirEvent Event.isAttrsModified)+    : dirTouchEvents root++dirMoveEvents :: [Char] -> [Char] -> [([Char], Event -> Bool)]+dirMoveEvents src dst =+    [ (src, dirEvent Event.isMoved)+    , (src, dirEvent Event.isMovedFrom)+    , (dst, dirEvent Event.isMoved)+    , (dst, dirEvent Event.isMovedTo)+    ]++-- In recursive mode all subdirectories are roots therefore they will generate+-- isRootMoved.+rootDirMoveEvents :: [Char] -> [Char] -> [([Char], Event -> Bool)]+rootDirMoveEvents root _ =+      (root, Event.isRootMoved)+    : dirTouchEvents root++recDirMoveEvents :: [Char] -> [Char] -> [([Char], Event -> Bool)]+recDirMoveEvents src dst = dirMoveEvents src dst ++ rootDirMoveEvents src dst++fileTouchEvents :: String -> [([Char], Event -> Bool)]+fileTouchEvents file =+    [ (file, fileEvent Event.isOpened)+    , (file, fileEvent Event.isModified)+    , (file, fileEvent Event.isWriteClosed)+    ]++fileMoveEvents :: [Char] -> [Char] -> [([Char], Event -> Bool)]+fileMoveEvents src dst =+    [ (src, fileEvent Event.isMoved)+    , (src, fileEvent Event.isMovedFrom)+    , (dst, fileEvent Event.isMoved)+    , (dst, fileEvent Event.isMovedTo)+    ]++-- TODO: add fileRoot tests from macOS test suite++main :: IO ()+main = do+    -- We ignore the events on root/parent dir during regular non-root dir/file+    -- tests.++    -- Tests common to regular root and symlink root cases+    let regSymTests =+              fileCreate "file" fileTouchEvents+            : fileMove "file1" "file2" fileMoveEvents+            : dirMove "dir1" "dir2" dirMoveEvents+            : dirDelete "dir" dirDelEvents+            : commonTests++    let regTests =+              dirDelete "" rootDirDelEvents+            : rootDirMove "moved" (\src -> [(src, Event.isRootMoved)])+            : regSymTests++    let symTests =+             -- when root is a symlinked dir, it does not recv touch, isDeleted+             -- or rootDeleted, rootUnwatched events.+              dirDelete "" (\dir -> [(dir, dirEvent Event.isAttrsModified)])+            -- No events occur when a symlink root is moved+            : regSymTests++    let w = Event.watchWith (Event.setAllEvents Event.On)+        run = runTests moduleName "non-recursive" w++    run DirType regTests+    run SymLinkOrigPath symTests++    let fileRootTests =+            [ fileDelete "" (\path ->+                [ (path, Event.isAttrsModified)+                , (path, Event.isRootDeleted)+                , (path, Event.isRootUnwatched)+                ])+            , rootFileMove "moved" (\path -> [(path, Event.isRootMoved)])+            , fileModify "" (\path -> [(path, Event.isOpened)])+            ]++    run FileType fileRootTests++    -- In recursive mode all subdirectories are roots therefore they will+    -- generate isRootDeleted/isRootUnwatched. Also, for subdirectories+    -- multiple events are generated, once in the parent watch and once in the+    -- self watch as a root of the watch. Therefore, additional touchEvents are+    -- generated in this case.+    --+    -- XXX We can possibly filter out the duplicate events either from the+    -- parent or self.+    let regSymRecTests =+            -- XXX Nested file create misses the create event due to a race+            -- : fileCreateWithParent "subdir/file" fileTouchEvents+              fileCreate "subdir/file" fileTouchEvents+            : fileMove "subdir/file1" "subdir/file2" fileMoveEvents+            : dirMove "dir1" "dir2" recDirMoveEvents+            : dirMove "subdir/dir1" "subdir/dir2" recDirMoveEvents+            : dirDelete "dir" (\d -> rootDirDelEvents d ++ dirDelEvents d)+            : dirDelete "subdir/dir" (\d -> rootDirDelEvents d ++ dirDelEvents d)+            -- XXX Nested dir create misses the create event due to a race+            -- : dirCreateWithParent "subdir/dir" dirTouchEvents+            : dirCreate "subdir/dir"+                (\dir -> (dir, dirEvent Event.isCreated) : dirTouchEvents dir)+            : dirCreate "dir"+                (\dir -> (dir, dirEvent Event.isCreated) : dirTouchEvents dir)+            : commonRecTests+        recRegTests = regTests ++ regSymRecTests+        recSymTests = symTests ++ regSymRecTests++    let recw = Event.watchWith+                (Event.setAllEvents Event.On . Event.setRecursiveMode Event.On)+        runRec = runTests moduleName "recursive" recw++    runRec DirType recRegTests+    runRec SymLinkOrigPath recSymTests+    runRec FileType fileRootTests
+ test/Streamly/Test/FileSystem/Event/Windows.hs view
@@ -0,0 +1,51 @@+-- |
+-- Module      : Streamly.Test.FileSystem.Event.Windows
+-- Copyright   : (c) 2020 Composewell Technologies
+-- License     : BSD-3-Clause
+-- Maintainer  : streamly@composewell.com
+-- Stability   : experimental
+-- Portability : GHC
+--
+module Streamly.Test.FileSystem.Event.Windows (main) where
+
+import qualified Streamly.Internal.FileSystem.Event.Windows as Event
+import Streamly.Test.FileSystem.Event.Common
+
+moduleName :: String
+moduleName = "FileSystem.Event.Windows"
+
+-- TODO Test isModified event for parent directories when a file is created or
+-- deleted.
+
+main :: IO ()
+main = do
+    let regularRootTests =
+            commonTests
+        -- The following watch-root deletion test results in:
+        -- C:\tmp\fsevent_dir-e061f0b0a00e1696\watch-root:
+        -- removePathForcibly:RemoveDirectory
+        -- "\\\\?\\C:\\tmp\\fsevent_dir-e061f0b0a00e1696\\watch-root":
+        -- permission denied (The process cannot access the file because it is
+        -- being used by another process.)
+        --
+        -- ++ dirDelete "" (\dir -> [(dir, Event.isDeleted)])
+
+    let w = Event.watchWith (Event.setAllEvents Event.On)
+        run = runTests moduleName "non-recursive" w
+
+    run DirType regularRootTests
+    run SymLinkOrigPath commonTests
+
+    let recTests =
+            [ dirCreateWithParent "subdir\\dir"
+                (\dir -> [(dir, dirEvent Event.isCreated)])
+            , fileCreateWithParent "subdir\\file"
+                (\file -> [(file, fileEvent Event.isCreated)])
+            ] ++ commonRecTests
+
+    let recw = Event.watchWith
+                (Event.setAllEvents Event.On . Event.setRecursiveMode Event.On)
+        runRec = runTests moduleName "recursive" recw
+
+    runRec DirType (regularRootTests ++ recTests)
+    runRec SymLinkOrigPath (commonTests ++ recTests)
test/Streamly/Test/FileSystem/Handle.hs view
@@ -27,7 +27,7 @@ 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.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@@ -61,6 +61,9 @@ testDataLarge :: String testDataLarge = concat $ replicate 6000 testData +testBinData :: String+testBinData = "01234567890123456789012345678901234567890123456789"+ executor :: (Handle -> SerialT IO Char) -> IO (SerialT IO Char) executor f =     withSystemTempDirectory "fs_handle" $ \fp -> do@@ -152,6 +155,49 @@                 let arr = Array.fromList ls                 return (testDataLarge == utf8ToString arr) +testReadChunksFromToWith :: Int -> Int -> Int -> [[Word8]] -> Property+testReadChunksFromToWith from to buffSize res = monadicIO $ run go++    where++    go =+        withSystemTempDirectory "fs_handle" $ \fp -> do+            let fpathRead = fp </> "tmp_read.txt"+            writeFile fpathRead testBinData+            h <- openFile fpathRead ReadMode+            ls <-+                Stream.toList+                    $ Stream.unfold+                        Handle.readChunksFromToWith (from, to, buffSize, h)+            return (res `shouldBe` fmap Array.toList ls)++-- Test for first byte+testReadChunksFromToWithFirstByte :: Property+testReadChunksFromToWithFirstByte = testReadChunksFromToWith 0 0 15 [[48]]++-- Test for second byte+testReadChunksFromToWithSecondByte :: Property+testReadChunksFromToWithSecondByte = testReadChunksFromToWith 1 1 15 [[49]]++-- Test for second to 10th bytes+testReadChunksFromToWithSecondToTenthBytes :: Property+testReadChunksFromToWithSecondToTenthBytes =+    testReadChunksFromToWith 1 10 15 [[49,50,51,52,53,54,55,56,57,48]]++-- Test for offset of buffer size+testReadChunksFromToWithBuffSizeOffset :: Property+testReadChunksFromToWithBuffSizeOffset =+    testReadChunksFromToWith 15 25 15 [[53,54,55,56,57,48,49,50,51,52,53]]++-- Test with multi buffer size+testReadChunksFromToWithMultiBuff :: Property+testReadChunksFromToWithMultiBuff =+    testReadChunksFromToWith+        5 22 5 [[53,54,55,56,57],[48,49,50,51,52],[53,54,55,56,57],[48,49,50]]++testReadChunksFromToWithRangeInvalid :: Property+testReadChunksFromToWithRangeInvalid = testReadChunksFromToWith 15 5 15 []+ moduleName :: String moduleName = "FileSystem.Handle" @@ -166,8 +212,21 @@             prop "readWithBufferOf" $ testRead readWithBufferFromHandle             prop "readChunks" $ testRead readChunksFromHandle             prop "readChunksWithBufferOf" $ testRead readChunksWithBuffer+            prop "readChunksFromToWith (0,0,n)"+                testReadChunksFromToWithFirstByte+            prop "readChunksFromToWith (1,1,n)"+                testReadChunksFromToWithSecondByte+            prop "readChunksFromToWith (1,10,n)"+                testReadChunksFromToWithSecondToTenthBytes+            prop "readChunksFromToWith (n,<2n,n)"+                testReadChunksFromToWithBuffSizeOffset+            prop "readChunksFromToWith (n,>2n,n)"+                testReadChunksFromToWithMultiBuff+            prop "readChunksFromToWith (n,<n,n)"+                testReadChunksFromToWithRangeInvalid         describe "Write To Handle" $ do             prop "write" $ testWrite Handle.write-            prop "writeWithBufferOf" $ testWrite $ Handle.writeWithBufferOf 1024+            prop "writeWithBufferOf"+                $ testWrite $ Handle.writeWithBufferOf 1024             -- XXX This test needs a lot of stack when built with -O0             prop "writeChunks" testWriteWithChunk
test/Streamly/Test/Network/Inet/TCP.hs view
@@ -15,11 +15,11 @@ import Data.Word (Word8) import Network.Socket (Socket, PortNumber) import Streamly.Internal.Control.Monad (discard)+import Streamly.Internal.System.IO (defaultChunkSize) 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@@ -106,8 +106,8 @@ validateOnPort = monadicIO $ do     res <- run $ do         ls2 <--            execute TCP.acceptOnPort basePort Array.defaultChunkSize handlerRW-        let dataChunk = take Array.defaultChunkSize testDataSource+            execute TCP.acceptOnPort basePort defaultChunkSize handlerRW+        let dataChunk = take defaultChunkSize testDataSource         Stream.eqBy (==) (Stream.fromList dataChunk) ls2     assert res @@ -118,9 +118,9 @@             execute                 TCP.acceptOnPortLocal                 (basePort + 1)-                Array.defaultChunkSize+                defaultChunkSize                 handlerRW-        let dataChunk = take Array.defaultChunkSize testDataSource+        let dataChunk = take defaultChunkSize testDataSource         Stream.eqBy (==) (Stream.fromList dataChunk) ls2     assert res
test/Streamly/Test/Network/Socket.hs view
@@ -15,11 +15,11 @@ import Data.Word (Word8) import Network.Socket (Socket, PortNumber) import Streamly.Internal.Control.Monad (discard)+import Streamly.Internal.System.IO (defaultChunkSize) 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@@ -118,8 +118,8 @@ validateRW :: Property validateRW = monadicIO $ do     res <- run $ do-        ls2 <- execute (basePort + 1) Array.defaultChunkSize handlerRW-        let dataChunk = take Array.defaultChunkSize testDataSource+        ls2 <- execute (basePort + 1) defaultChunkSize handlerRW+        let dataChunk = take defaultChunkSize testDataSource         Stream.eqBy (==) (Stream.fromList dataChunk) ls2     assert res
test/Streamly/Test/Prelude/Concurrent.hs view
@@ -164,6 +164,10 @@         concurrentMapM constr eq $ \n mv stream ->             t $ S.mapM (mvarSequenceOp mv n) stream +    prop1 (desc <> " sequence") $+        concurrentMapM constr eq $ \n mv stream ->+            t $ S.sequence $ S.map (mvarSequenceOp mv n) stream+ ------------------------------------------------------------------------------- -- Concurrent Application -------------------------------------------------------------------------------
test/Streamly/Test/Prelude/Fold.hs view
@@ -13,12 +13,13 @@ import Control.Concurrent (threadDelay) #endif import Control.Exception (ErrorCall(..), catch)-import Data.IORef ( newIORef, readIORef, writeIORef, IORef )+import Data.IORef (newIORef, readIORef, writeIORef, IORef) #ifdef COVERAGE_BUILD import Test.Hspec.QuickCheck (modifyMaxSuccess) #endif import Test.Hspec as H #ifdef DEVBUILD+import Data.IORef (modifyIORef) import System.Mem (performMajorGC) #endif @@ -63,22 +64,30 @@     -> (SerialT IO Int -> IO (Maybe Int))     -> IO () checkCleanupFold t op = do-    r <- newIORef (-1 :: Int)+    r <- newIORef ([] :: [Int])     _ <- op $ t $ delay r 0 S.|: delay r 2 S.|: delay r 3 S.|: S.nil     performMajorGC-    threadDelay 700000+    -- In case the actions are not killed let them fire before we check so that+    -- the test fails.+    threadDelay (4 * delayUnit)     res <- readIORef r-    res `shouldBe` 0+    res `shouldBe` [0]+     where-    delay ref i = threadDelay (i*200000) >> writeIORef ref i >> return i +    delayUnit = 400000+    delay ref i =+        threadDelay (i * delayUnit) >> modifyIORef 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)+#ifdef INCLUDE_FLAKY_TESTS     it (name <> " parallely") $ checkCleanupFold S.fromParallel (testOp f)+#endif #endif  checkFoldMStrictness :: (IORef Int -> SerialT IO Int -> IO ()) -> IO ()
test/Streamly/Test/Prelude/Rate.hs view
@@ -177,9 +177,11 @@             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+    -- Producer delay causes a lot of threads to be created, consuming large+    -- amounts of memory at higher rates.+    let rates = [1, 10, 100+#if !defined(__GHCJS__) && defined USE_LARGE_MEMORY+                1000, 10000, 25000 #endif                 ]      in describe "asyncly no consumer delay and 1 sec producer delay" $@@ -187,12 +189,12 @@      -- 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+    let rates = [1, 10, 100+#if !defined(__GHCJS__) && defined USE_LARGE_MEMORY+                , 1000, 10000, 25000 #endif                 ]-     in describe "asyncly no consumer delay and variable producer delay" $+     in describe "asyncly, no consumer delay and variable producer delay" $             forM_ rates $ \r ->                 measureRateVariable "asyncly" fromAsync r 0 (0.1, 3) range @@ -201,15 +203,15 @@                 , 100000, 1000000 #endif                 ]-     in describe "fromWAsync no consumer delay no producer delay" $+     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__+#if !defined(__GHCJS__) && defined USE_LARGE_MEMORY                 , 10000, 25000 #endif                 ]-     in describe "fromWAsync no consumer delay and 1 sec producer delay" $+     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@@ -217,20 +219,20 @@                 , 100000, 1000000 #endif                 ]-     in describe "aheadly no consumer delay no producer delay" $+     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__+#if !defined(__GHCJS__) && defined USE_LARGE_MEMORY                 , 10000, 12500 #endif                 ]-     in describe "aheadly no consumer delay and 1 sec producer delay" $+     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+    describe "asyncly, some consumer delay and 1 sec producer 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@@ -238,7 +240,7 @@         -- 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+    describe "aheadly, some consumer delay and 1 sec producer 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
@@ -14,7 +14,7 @@ import Data.Function ( (&) ) import Data.IORef ( newIORef, readIORef, writeIORef, modifyIORef' ) import Data.Int (Int64)-import Data.List (group, intercalate)+import Data.List (sort, group, intercalate) import Data.Maybe ( isJust, fromJust ) import Foreign.Storable (Storable) #if __GLASGOW_HASKELL__ < 808@@ -449,7 +449,7 @@ unfold = monadicIO $ do     a <- pick $ choose (0, max_length `div` 2)     b <- pick $ choose (0, max_length)-    let unf = UF.enumerateFromToIntegral b+    let unf = UF.supplySecond b UF.enumerateFromToIntegral     ls <- S.toList $ S.unfold unf a     return $ ls == [a..b] @@ -457,7 +457,7 @@ 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)+    let unf = UF.supply a (UF.supplySecond b UF.enumerateFromToIntegral)     ls <- S.toList $ IS.unfold0 unf     return $ ls == [a..b] @@ -496,12 +496,18 @@                 $ S.map getSum                 $ IS.foldIterateM                       (return . FL.take 1 . FL.sconcat)-                      (Sum 0)+                      (return (Sum 0))                 $ S.map Sum strm         case ms2 of             Nothing -> assert $ s1 == 0             Just s2 -> assert $ s1 == s2 +sortBy :: Property+sortBy = forAll (listOf (chooseInt (0, max_length))) $ \lst -> monadicIO $ do+        let s1 = sort lst+        s2 <- run $ S.toList $ IS.sortBy compare $ S.fromList lst+        assert $ s1 == s2+ moduleName :: String moduleName = "Prelude.Serial" @@ -636,6 +642,26 @@             it "takeInterval" (testTakeInterval `shouldReturn` True)             it "dropInterval" (testDropInterval `shouldReturn` True) #endif++    -- Just some basic sanity tests for now+    let input = [[1,1] :: [Int],[2,2],[3,3],[4,4],[5,5],[6,6],[7,7],[8,8]]+        mustBe g inp out =+            S.toList (IS.concatPairsWith g S.fromList (S.fromList inp))+                `shouldReturn` out+     in do+        it "concatPairsWith serial"+            $ mustBe S.serial input [1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8]+        it "concatPairsWith wSerial"+            $ mustBe S.wSerial input [1,5,3,7,2,6,4,8,1,5,3,7,2,6,4,8]+        it "concatPairsWith mergeBy sorted"+            $ mustBe+                (S.mergeBy compare) input [1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8]+        it "concatPairsWith mergeBy reversed"+            $ mustBe+                (S.mergeBy compare)+                (reverse input)+                [1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8]+        prop "sortBy" sortBy      describe "Stream group and split operations" $ do         groupSplitOps "serially"
test/Streamly/Test/Prelude/WSerial.hs view
@@ -60,7 +60,8 @@ wSerialMinLengthProp :: Property wSerialMinLengthProp =     forAll (chooseInt (0, 10))-        $ \len -> S.length (combined len) `shouldReturn` 2 * len + 1+        $ \len ->+            S.length (fromWSerial $ combined len) `shouldReturn` 2 * len + 1      where
+ test/Streamly/Test/Unicode/Char.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections     #-}++-- |+-- Copyright   : (c) 2020 Composewell Technologies+--+-- License     : BSD-3-Clause+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--++module Streamly.Test.Unicode.Char (main) where++import Control.Monad (when)+import Data.Char (chr, isSpace, ord, toUpper)+import Data.List (intercalate, isPrefixOf)+#if MIN_VERSION_base(4,8,0)+import Data.Function ((&))+#endif+import Streamly.Internal.Unicode.Char+    ( NormalizationMode(NFC, NFD, NFKC, NFKD)+    , normalize+    )+import Streamly.Internal.Data.Stream.IsStream (SerialT)+import Text.Printf (printf)+import System.FilePath.Posix ((</>))++import qualified Streamly.Internal.Data.Stream.IsStream as S+import qualified Streamly.Internal.Data.Fold as FL+import qualified System.Directory as Dir++#if !MIN_VERSION_base(4,8,0)+(&) :: a -> (a -> b) -> b+x & f = f x+#endif++chrToHex :: Char -> [Char]+chrToHex = map toUpper . printf "%.4x" . ord++strToHex :: [Char] -> String+strToHex = unwords . map chrToHex++type Text = SerialT IO Char++checkEqual :: String -> (Text -> Text) -> (Text, Text) -> IO Bool+checkEqual opName op (mc1, mc2) = do+    c1 <- S.toList mc1+    c2 <- S.toList mc2+    opc2 <- S.toList $ op mc2+    if c1 /= opc2 then do+        putStrLn $ opName ++ " "            ++ strToHex c2+                          ++ " = "          ++ strToHex opc2+                          ++ "; Expected: " ++ strToHex c1+        return False+    else return True++checkOp :: String -> NormalizationMode -> [(Text, Text)] -> IO Bool+checkOp name op pairs = do+    res <- mapM (checkEqual name (normalize op)) pairs+    return $ all (== True) res++checkNFC :: (Text, Text, Text, Text, Text) -> IO Bool+checkNFC (c1, c2, c3, c4, c5) =+    checkOp "toNFC" NFC $ map (c2, ) [c1, c2, c3] ++ map (c4, ) [c4, c5]++checkNFD :: (Text, Text, Text, Text, Text) -> IO Bool+checkNFD (c1, c2, c3, c4, c5) =+    checkOp "toNFD" NFD $ map (c3, ) [c1, c2, c3] ++ map (c5, ) [c4, c5]++checkNFKC :: (Text, Text, Text, Text, Text) -> IO Bool+checkNFKC (c1, c2, c3, c4, c5) =+    checkOp "toNFKC" NFKC $ map (c4,) [c1, c2, c3, c4, c5]++checkNFKD :: (Text, Text, Text, Text, Text) -> IO Bool+checkNFKD (c1, c2, c3, c4, c5) =+    checkOp "toNFKD" NFKD $ map (c5,) [c1, c2, c3, c4, c5]++checkAllTestCases :: Int -> String -> IO ()+checkAllTestCases lineno line = do+    cs <- S.toList $ S.splitOn (== ';') FL.toList $ S.fromList line+    case cs of+        c1 : c2 : c3 : c4 : c5 : _ -> do+            let cps = map cpToText [c1, c2, c3, c4, c5]+            mapM_ (checkOneTestCase cps)+                  [checkNFD, checkNFKD, checkNFC, checkNFKC]+        _ -> error $ "Unrecognized line: " ++ line+    where+        cpToText xs = S.fromList $ map (chr . read . ("0x" ++)) (words xs)++        checkOneTestCase cps f = do+            res <- f (tuplify cps)+            when (not res) $ do+                strs <- mapM S.toList cps+                let codes = intercalate ";" $ map strToHex strs+                    txt = intercalate "; " strs+                putStrLn ("Failed at line: " ++ show lineno)+                putStrLn line+                putStrLn $ codes ++ "; # (" ++ txt+                error "Bailing out"++        tuplify [c1, c2, c3, c4, c5] = (c1, c2, c3, c4, c5)+        tuplify _ = error "tuplify bad arguments"++checkLine :: (Int, String) -> IO ()+checkLine (lineno, line) = do+    -- marker lines indicating a test block start with @+    if "@" `isPrefixOf` line+        then+            putStrLn line+        else+            checkAllTestCases lineno line++testNormalize :: FilePath -> IO ()+testNormalize file = do+    contents <- readFile file+    let ls = lines contents                        -- split into lines+         & map (dropWhile isSpace)                 -- trim leading spaces+         & zip [1..]                               -- add numbering+         & filter (not . null . snd)               -- remove blank lines+         & filter (not . ("#" `isPrefixOf`) . snd) -- remove comments+    checkAll ls+    where+        checkAll (x:xs) = checkLine x >> checkAll xs+        checkAll []     = return ()++filesDir :: String+filesDir = "test/Streamly/Test/Unicode"++main :: IO ()+main = do+    cdir <- Dir.getCurrentDirectory+    testNormalize $ cdir </> filesDir </> "ucd/NormalizationTest.txt"+    -- Additional test cases not in the unicode standard suite+    testNormalize $ cdir </> filesDir </> "extra/NormalizationTest.txt"
+ test/Streamly/Test/Unicode/extra/NormalizationTest.txt view
@@ -0,0 +1,9 @@+#   Columns (c1, c2,...) are separated by semicolons+#   They have the following meaning:+#      source; NFC; NFD; NFKC; NFKD++@Extra test cases not in the unicode standard test suite+AC00 11A7;AC00 11A7;1100 1161 11A7;AC00 11A7;1100 1161 11A7; # 11A7 is not a valid T and should not be combined with LV AC00 to give AC00 as NFC.+AC00 11A8;AC01;1100 1161 11A8;AC01;1100 1161 11A8; # Combine precomposed LV and a T i.e <LV,T> sequence.+1100 11A8;1100 11A8;1100 11A8;1100 11A8;1100 11A8; # Invalid <L,T> sequence+2FA1E;2FA1E;2FA1E;2FA1E;2FA1E; # Beyond decomposable max
+ test/Streamly/Test/Unicode/ucd/NormalizationTest.txt view

file too large to diff

test/lib/Streamly/Test/Prelude/Common.hs view
@@ -136,6 +136,8 @@ import qualified Streamly.Internal.Data.Stream.IsStream as S import qualified Streamly.Internal.Data.Unfold as UF +import qualified Data.Map.Strict as Map+ import Streamly.Test.Common  maxStreamLen :: Int@@ -1498,6 +1500,37 @@         refValue <- run $ readIORef ioRef         assert $ refValue == 1 +retry :: Spec+retry = do+    ref <- runIO $ newIORef (0 :: Int)+    res <- runIO $ S.toList (S.retry emap handler (stream1 ref))+    refVal <- runIO $ readIORef ref+    spec res refVal++    where++    emap = Map.singleton (ExampleException "E") 10++    stream1 ref =+        S.fromListM+            [ return 1+            , return 2+            , atomicModifyIORef' ref (\a -> (a + 1, ()))+                  >> throwM (ExampleException "E")+                  >> return 3+            , return 4+            ]++    stream2 = S.fromList [5, 6, 7 :: Int]+    handler = const stream2+    expectedRes = [1, 2, 5, 6, 7]+    expectedRefVal = 11++    spec res refVal = do+        it "Runs the exception handler properly" $ res `shouldBe` expectedRes+        it "Runs retires the exception correctly"+            $ refVal `shouldBe` expectedRefVal+ #ifdef DEVBUILD finallyPartialStreamProp ::        (IsStream t) => (t IO Int -> SerialT IO Int) -> [Int] -> Property@@ -1595,23 +1628,24 @@     prop (desc <> " before") $ beforeProp t     prop (desc <> " after") $ afterProp t     prop (desc <> " bracket end of stream") $ bracketProp t-#ifdef DEVBUILD+#ifdef INCLUDE_FLAKY_TESTS     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+#ifdef INCLUDE_FLAKY_TESTS     prop (desc <> " finally partial stream") $ finallyPartialStreamProp t #endif     prop (desc <> " finally exception in stream") $ finallyExceptionProp t     prop (desc <> " handle") $ handleProp t+    retry  ------------------------------------------------------------------------------- -- Compose with MonadThrow ------------------------------------------------------------------------------- -newtype ExampleException = ExampleException String deriving (Eq, Show)+newtype ExampleException = ExampleException String deriving (Eq, Show, Ord)  instance Exception ExampleException @@ -1720,7 +1754,9 @@             , ("maxBuffer 0", t . maxBuffer 0)             , ("maxThreads 0", t . maxThreads 0)             , ("maxThreads 1", t . maxThreads 1)+#ifdef USE_LARGE_MEMORY             , ("maxThreads -1", t . maxThreads (-1))+#endif #endif             ]
test/streamly-tests.cabal view
@@ -15,6 +15,16 @@   manual: True   default: False +flag use-large-mem+  description: Include tests that require large amount of memory+  manual: True+  default: False++flag include-flaky-tests+  description: Include tests that are unpredictable+  manual: True+  default: False+ flag dev   description: Development build   manual: True@@ -58,7 +68,6 @@                       -Wredundant-constraints                       -Wnoncanonical-monad-instances                       -Rghc-timing-                      -fno-ignore-asserts      if flag(has-llvm)       ghc-options: -fllvm@@ -70,6 +79,12 @@     if flag(limit-build-mem)       ghc-options: +RTS -M512M -RTS +    if flag(use-large-mem)+      cpp-options: -DUSE_LARGE_MEMORY++    if flag(include-flaky-tests)+      cpp-options: -DINCLUDE_FLAKY_TESTS+ common default-extensions     default-extensions:         BangPatterns@@ -114,6 +129,8 @@                  -fdicts-strict                  -fmax-worker-args=16                  -fspec-constr-recursive=16+                 -- This must come after -O2+                 -fno-ignore-asserts     if flag(fusion-plugin) && !impl(ghcjs) && !impl(ghc < 8.6)       ghc-options: -fplugin Fusion.Plugin   else@@ -129,7 +146,7 @@     , hspec             >= 2.0   && < 3     , mtl               >= 2.2   && < 3     , random            >= 1.0.0 && < 2-    , transformers      >= 0.4   && < 0.6+    , transformers      >= 0.4   && < 0.7     , QuickCheck        >= 2.13  && < 2.15     , directory         >= 1.2.2 && < 1.4     , filepath          >= 1.4.1 && < 1.5@@ -158,7 +175,6 @@     if flag(limit-build-mem)       ghc-options: +RTS -M1500M -RTS - ------------------------------------------------------------------------------- -- Test suite options -------------------------------------------------------------------------------@@ -166,7 +182,7 @@ common test-options   import: lib-options         , threading-options-  ghc-options: -rtsopts+  ghc-options: -rtsopts -fno-ignore-asserts   include-dirs: .   build-depends: streamly-tests @@ -180,6 +196,7 @@                -fmax-worker-args=16                -fspec-constr-recursive=16                -rtsopts+               -fno-ignore-asserts   if flag(fusion-plugin) && !impl(ghcjs) && !impl(ghc < 8.6)     ghc-options: -fplugin Fusion.Plugin @@ -222,6 +239,11 @@   main-is: Streamly/Test/Data/Array/Foreign.hs   ghc-options: -main-is Streamly.Test.Data.Array.Foreign.main +test-suite Data.Array.Stream.Foreign+  import: test-options+  type: exitcode-stdio-1.0+  main-is: Streamly/Test/Data/Array/Stream/Foreign.hs+ test-suite Data.Fold   import: test-options   type: exitcode-stdio-1.0@@ -255,10 +277,40 @@ test-suite FileSystem.Event   import: test-options   type: exitcode-stdio-1.0+  ghc-options: -main-is Streamly.Test.FileSystem.Event   main-is: Streamly/Test/FileSystem/Event.hs-  if os(darwin)+  other-modules: Streamly.Test.FileSystem.Event.Common++test-suite FileSystem.Event.Darwin+  import: test-options+  type: exitcode-stdio-1.0+  main-is: Streamly/Test/FileSystem/Event/Darwin.hs+  other-modules: Streamly.Test.FileSystem.Event.Common+  cpp-options: -DFILESYSTEM_EVENT_DARWIN+  ghc-options: -main-is Streamly.Test.FileSystem.Event.Darwin+  if !os(darwin)     buildable: False +test-suite FileSystem.Event.Linux+  import: test-options+  type: exitcode-stdio-1.0+  main-is: Streamly/Test/FileSystem/Event/Linux.hs+  other-modules: Streamly.Test.FileSystem.Event.Common+  cpp-options: -DFILESYSTEM_EVENT_LINUX+  ghc-options: -main-is Streamly.Test.FileSystem.Event.Linux+  if !os(linux)+    buildable: False++test-suite FileSystem.Event.Windows+  import: test-options+  type: exitcode-stdio-1.0+  main-is: Streamly/Test/FileSystem/Event/Windows.hs+  other-modules: Streamly.Test.FileSystem.Event.Common+  cpp-options: -DFILESYSTEM_EVENT_WINDOWS+  ghc-options: -main-is Streamly.Test.FileSystem.Event.Windows+  if !os(windows)+    buildable: False+ test-suite FileSystem.Handle   import: test-options   type: exitcode-stdio-1.0@@ -361,6 +413,16 @@   type: exitcode-stdio-1.0   main-is: Streamly/Test/Unicode/Stream.hs   ghc-options: -main-is Streamly.Test.Unicode.Stream.main++test-suite Unicode.Char+  import: test-options+  type: exitcode-stdio-1.0+  main-is: Streamly/Test/Unicode/Char.hs+  ghc-options: -main-is Streamly.Test.Unicode.Char.main+  if flag(dev)+    buildable: True+  else+    buildable: False  test-suite version-bounds   import: test-options