diff options
479 files changed, 51484 insertions, 0 deletions
diff --git a/third_party/bazel/rules_haskell/.bazelrc b/third_party/bazel/rules_haskell/.bazelrc new file mode 100644 index 000000000000..503086f27968 --- /dev/null +++ b/third_party/bazel/rules_haskell/.bazelrc @@ -0,0 +1,27 @@ +# See https://docs.bazel.build/versions/master/user-manual.html#bazelrc. + +# Use this configuration when targeting Windows. Eventually this will +# no longer be required: +# https://bazel.build/roadmaps/platforms.html#replace---cpu-and---host_cpu-flags. +build:windows --crosstool_top=@io_tweag_rules_haskell_ghc_windows_amd64//:toolchain -s --verbose_failures --sandbox_debug + +build:ci --loading_phase_threads=1 +build:ci --jobs=2 +build:ci --verbose_failures +# Make sure we don't rely on the names of convenience symlinks because those +# can be changed by user. +build:ci --symlink_prefix=bazel-ci- +common:ci --color=no +test:ci --test_output=errors + +# Needed on Windows for //tests/binary-with-data +# see: https://github.com/tweag/rules_haskell/issues/647#issuecomment-459001362 +test:windows --experimental_enable_runfiles + +# test environment does not propagate locales by default +# some tests reads files written in UTF8, we need to propagate the correct +# environment variables, such as LOCALE_ARCHIVE +# We also need to setup an utf8 locale +test --test_env=LANG=en_US.utf8 --test_env=LOCALE_ARCHIVE + +try-import .bazelrc.local diff --git a/third_party/bazel/rules_haskell/.circleci/config.yml b/third_party/bazel/rules_haskell/.circleci/config.yml new file mode 100644 index 000000000000..1ec2b1fc0518 --- /dev/null +++ b/third_party/bazel/rules_haskell/.circleci/config.yml @@ -0,0 +1,188 @@ +version: 2 + +# NOTE: +# Disk cache: +# We don't want to keep old artifacts around so we always build from +# scratch on master builds and upload the new cache afterwards. Because +# Circle doesn't allow skipping a "restore_cache" we create a dummy +# "empty" cache that's only ever pulled on master. Alternatively we could +# ask Bazel to clean up old items (LRU style) but the documentation is +# very terse and I could not figure how to do it: +# https://docs.bazel.build/versions/master/remote-caching.html +# It also appears that there's ongoing work but the feature is not ready: +# https://github.com/bazelbuild/bazel/issues/5139 +# +# Currently the disk cache is only implemented for the Darwin builds, +# which were the slowest ones. There is no reason why a disk cache +# couldn't be used for the other jobs: I just haven't gotten around to +# doing it. + +jobs: + build-linux-ghc-bindist: + docker: + - image: debian + working_directory: ~/rules_haskell + resource_class: large + steps: + - checkout + - run: + name: Setup test environment + command: | + apt-get update + apt-get install -y wget gnupg golang make libgmp3-dev libtinfo-dev pkg-config zip g++ zlib1g-dev unzip python bash-completion locales + echo "en_US.UTF-8 UTF-8" >> /etc/locale.gen + locale-gen + wget "https://github.com/bazelbuild/bazel/releases/download/0.24.0/bazel_0.24.0-linux-x86_64.deb" + dpkg -i bazel_0.24.0-linux-x86_64.deb + echo "common:ci --build_tag_filters -requires_hackage,-requires_zlib,-requires_doctest,-requires_c2hs,-requires_threaded_rts,-dont_test_with_bindist" > .bazelrc.local + - run: + name: Build tests + command: | + bazel build --config ci //tests/... + - run: + name: Run tests + command: | + # Run the start script test. + # Doesn't use the test suite binary, because that depends on nixpkgs dependencies. + ./tests/run-start-script.sh + # TODO: enable all tests for bindists + # (this will require tests to both work with nixpkgs and hazel backends) + + # ATTN: when you change anything here, donโt forget to copy it to the build-darwin section + build-linux-nixpkgs: + docker: + - image: nixos/nix:2.1.3 + working_directory: ~/rules_haskell + resource_class: large + steps: + - checkout + - run: + name: System dependencies + command: | + set -e + apk --no-progress update + apk --no-progress add bash ca-certificates + + mkdir -p /etc/nix + # CircleCI and Nix sandboxing don't play nice. See + # https://discourse.nixos.org/t/nixos-on-ovh-kimsufi-cloning-builder-process-operation-not-permitted/1494/5 + echo "sandbox = false" > /etc/nix/nix.conf + # No builders and no local jobs ensures that everything has to come from a binary cache + # If we want to add packages that are not cached by the offical NixOS binary cache, + # we need to manually build them (e.g. `nix-build -A <dependency> --max-jobs <no-cpu-cores>`). + # This is a sanity check. + echo "builders =" >> /etc/nix/nix.conf + echo "max-jobs = 0" >> /etc/nix/nix.conf + - run: + name: Configure + command: | + echo "build:ci --host_platform=@io_tweag_rules_haskell//haskell/platforms:linux_x86_64_nixpkgs" > .bazelrc.local + - run: + name: Build tests + command: | + nix-shell --arg docTools false --pure --run \ + 'bazel build --config ci //tests/...' + - run: + name: Run tests + # bazel does not support recursive bazel call, so we + # cannot use bazel run here because the test runner uses + # bazel + command: | + nix-shell --arg docTools false --pure --run \ + 'bazel build --config ci //tests:run-tests' + # TODO(Profpatsch) re-add a nixpkgs startup script + # and enable this test again + nix-shell --arg docTools false --pure --run \ + './bazel-ci-bin/tests/run-tests --skip "/startup script/"' + nix-shell --arg docTools false --pure --run \ + 'bazel coverage //tests/... --config ci --build_tag_filters "coverage-compatible" --test_tag_filters "coverage-compatible" --test_output=all' + + build-darwin: + macos: + xcode: "9.0" + steps: + - checkout + - run: + name: Install Nix + command: | + curl https://nixos.org/nix/install | sh + + - run: + name: Install cachix + shell: /bin/bash -eilo pipefail + command: | + nix-env -iA cachix -f https://github.com/NixOS/nixpkgs/tarball/db557aab7b690f5e0e3348459f2e4dc8fd0d9298 + + - run: + name: Run cachix + shell: /bin/bash -eilo pipefail + command: | + cachix use tweag + cachix push tweag --watch-store + background: true + + - run: + name: Configure + command: | + mkdir -p ~/.cache/bazel/ + + echo "build:ci --host_platform=@io_tweag_rules_haskell//haskell/platforms:darwin_x86_64_nixpkgs" >> .bazelrc.local + echo "build:ci --disk_cache=~/.cache/bazel/" >> .bazelrc.local + echo "common:ci --test_tag_filters -dont_test_on_darwin" >> .bazelrc.local + + - restore_cache: + keys: # see note about 'Disk cache' + - v1-rules_haskell-empty-{{ .Branch }}- + - v1-rules_haskell-cache-{{ .Branch }}- + - v1-rules_haskell-cache-master- + + - run: + name: Build tests + shell: /bin/bash -eilo pipefail + command: | + nix-shell --arg docTools false --pure --run \ + 'bazel build --config ci //tests/...' + - run: + name: Run tests + shell: /bin/bash -eilo pipefail + command: | + + # Keep CI awake + while true; do echo "."; sleep 60; done & + + nix-shell --arg docTools false --pure --run \ + 'bazel build --config ci //tests:run-tests' + # XXX 2019-01-22 Disable start script checking on Darwin + # due to a clash between binutils and clang. + nix-shell --arg docTools false --pure --run \ + './bazel-ci-bin/tests/run-tests --skip "/startup script/"' + nix-shell --arg docTools false --pure --run \ + 'bazel coverage //tests/... --config ci --build_tag_filters "coverage-compatible" --test_tag_filters "coverage-compatible" --test_output=all' + + + # see note about 'Disk cache' + - save_cache: + key: v1-rules_haskell-cache-{{ .Branch }}-{{ .BuildNum }} + paths: + - ~/.cache/bazel/ + + - run: + name: Clean up cache + shell: /bin/bash -eilo pipefail + command: | + rm -rf ~/.cache/bazel/ + mkdir -p ~/.cache/bazel/ + + - save_cache: + key: v1-rules_haskell-empty-master-{{ .BuildNum }} + paths: + - ~/.cache/bazel/ + +workflows: + version: 2 + build: + jobs: + - build-linux-ghc-bindist + - build-linux-nixpkgs + - build-darwin: + context: org-global # for the cachix token diff --git a/third_party/bazel/rules_haskell/.github/ISSUE_TEMPLATE/bug_report.md b/third_party/bazel/rules_haskell/.github/ISSUE_TEMPLATE/bug_report.md new file mode 100644 index 000000000000..0dc93d452635 --- /dev/null +++ b/third_party/bazel/rules_haskell/.github/ISSUE_TEMPLATE/bug_report.md @@ -0,0 +1,23 @@ +--- +name: Bug report +about: Create a bug report to help us fix it. +labels: 'type: bug' + +--- + +**Describe the bug** +A clear and concise description of what the bug is. + +**To Reproduce** +Steps to reproduce the behavior. + +**Expected behavior** +A clear and concise description of what you expected to happen. + +**Environment** + - OS name + version: + - Bazel version: + - Version of the rules: + +**Additional context** +Add any other context about the problem here. diff --git a/third_party/bazel/rules_haskell/.github/ISSUE_TEMPLATE/feature_request.md b/third_party/bazel/rules_haskell/.github/ISSUE_TEMPLATE/feature_request.md new file mode 100644 index 000000000000..c160d84c21f7 --- /dev/null +++ b/third_party/bazel/rules_haskell/.github/ISSUE_TEMPLATE/feature_request.md @@ -0,0 +1,18 @@ +--- +name: Feature request +about: Suggest an idea for this project. +labels: 'type: feature request' + +--- + +**Is your feature request related to a problem? Please describe.** +A clear and concise description of what the problem is. Ex. I'm always frustrated when [...] + +**Describe the solution you'd like** +A clear and concise description of what you want to happen. + +**Describe alternatives you've considered** +A clear and concise description of any alternative solutions or features you've considered. + +**Additional context** +Add any other context or screenshots about the feature request here. diff --git a/third_party/bazel/rules_haskell/.github/settings.yml b/third_party/bazel/rules_haskell/.github/settings.yml new file mode 100644 index 000000000000..c56137829963 --- /dev/null +++ b/third_party/bazel/rules_haskell/.github/settings.yml @@ -0,0 +1,37 @@ +repository: + has_wiki: false + +labels: + - name: "duplicate" + color: cfd3d7 + - name: "good first issue" + color: 7057ff + - name: "invalid" + color: cfd3d7 + - name: "more data needed" + color: bfdadc + - name: "P0" + color: b60205 + description: "blocker: fix immediately!" + - name: "P1" + color: d93f0b + description: "critical: next release" + - name: "P2" + color: e99695 + description: "major: an upcoming release" + - name: "P3" + color: fbca04 + description: "minor: not priorized" + - name: "P4" + color: fef2c0 + description: "unimportant: consider wontfix or other priority" + - name: "question" + color: d876e3 + - name: "type: bug" + color: 0052cc + - name: "type: documentation" + color: 0052cc + - name: "type: feature request" + color: 0052cc + - name: "wontfix" + color: ffffff diff --git a/third_party/bazel/rules_haskell/.gitignore b/third_party/bazel/rules_haskell/.gitignore new file mode 100644 index 000000000000..1ad8096084e2 --- /dev/null +++ b/third_party/bazel/rules_haskell/.gitignore @@ -0,0 +1,2 @@ +/bazel-* +.bazelrc.local diff --git a/third_party/bazel/rules_haskell/.netlify/build.sh b/third_party/bazel/rules_haskell/.netlify/build.sh new file mode 100755 index 000000000000..9cac684f6180 --- /dev/null +++ b/third_party/bazel/rules_haskell/.netlify/build.sh @@ -0,0 +1,28 @@ +#!/bin/sh + +set -eux + +export PATH=$HOME/bin:$PATH + +# XXX We don't want to be using the Nixpkgs CC toolchain, because +# Nixpkgs is not available. But currently we can only override the +# autoconfigured CC toolchain, not have several (which we would then +# select via --extra_toolchains). So here's a gross hack that simply +# patches out the nixpkgs_cc_configure() line. +# +# See https://github.com/bazelbuild/bazel/issues/6696. +awk ' + BEGIN {del=0} + /^nixpkgs_cc_configure\(/ {del=1} + del==0 {print} + /\)/ {del=0}' WORKSPACE > WORKSPACE.tmp + # Note: awk -i inplace not available +mv WORKSPACE.tmp WORKSPACE + +# We don't want to be depending on Nixpkgs for documentation +# generation either. +sed -i 's/vendored_node = "@nixpkgs_nodejs"/vendored_node = None/' WORKSPACE + +bazel build //docs:api_html +unzip -d public bazel-bin/docs/api_html-skydoc.zip +cp start public diff --git a/third_party/bazel/rules_haskell/.netlify/install.sh b/third_party/bazel/rules_haskell/.netlify/install.sh new file mode 100755 index 000000000000..7d8e1483174b --- /dev/null +++ b/third_party/bazel/rules_haskell/.netlify/install.sh @@ -0,0 +1,28 @@ +#!/bin/sh + +set -eux + +V=0.20.0 + +curl -LO https://github.com/bazelbuild/bazel/releases/download/$V/bazel-$V-installer-linux-x86_64.sh +chmod +x bazel-$V-installer-linux-x86_64.sh +./bazel-$V-installer-linux-x86_64.sh --user + +# XXX: Hack to prevent the `haskell_nixpkgs_package_list` rule from crashing: +# This rule expects a `nix-build` executable which is used to generate a +# store-path containing an `all-haskell-packages.bzl` file which defines the +# `package` list. Since actually installing `nix-build` on the netlify image +# seems difficult, we provide a dummy shell script which does exactly that. +packages_list=$(mktemp -d) +cat <<EOF > $packages_list/all-haskell-packages.bzl +packages = [] +EOF + +mkdir -p $HOME +cat <<EOF > $HOME/bin/nix-build +#!/usr/bin/env bash + +echo $packages_list +EOF + +chmod +x $HOME/bin/nix-build diff --git a/third_party/bazel/rules_haskell/AUTHORS b/third_party/bazel/rules_haskell/AUTHORS new file mode 100644 index 000000000000..928d70d23151 --- /dev/null +++ b/third_party/bazel/rules_haskell/AUTHORS @@ -0,0 +1,9 @@ +# This is the official list of Bazel authors for copyright purposes. +# This file is distinct from the CONTRIBUTORS files. +# See the latter for an explanation. + +# Names should be added to this file as: +# Name or Organization <email address> +# The email address is not required for organizations. + +Tweag I/O Limited diff --git a/third_party/bazel/rules_haskell/BUILD.bazel b/third_party/bazel/rules_haskell/BUILD.bazel new file mode 100644 index 000000000000..66eea2014757 --- /dev/null +++ b/third_party/bazel/rules_haskell/BUILD.bazel @@ -0,0 +1,20 @@ +load("@com_github_bazelbuild_buildtools//buildifier:def.bzl", "buildifier") + +# Run this to check for errors in BUILD files. +buildifier( + name = "buildifier", + exclude_patterns = [ + "./hazel/packages.bzl", + ], + mode = "check", +) + +# Run this to fix the errors in BUILD files. +buildifier( + name = "buildifier-fix", + exclude_patterns = [ + "./hazel/packages.bzl", + ], + mode = "fix", + verbose = True, +) diff --git a/third_party/bazel/rules_haskell/CHANGELOG.md b/third_party/bazel/rules_haskell/CHANGELOG.md new file mode 100644 index 000000000000..af0fe7ddc581 --- /dev/null +++ b/third_party/bazel/rules_haskell/CHANGELOG.md @@ -0,0 +1,461 @@ +# Change Log + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/). + +## [0.9.1] - 2019-06-03 + +### Fixed + +- Bindists were broken on MacOS. + See [884](https://github.com/tweag/rules_haskell/issues/884). + +## [0.9] - 2019-05-07 + +### Highlights + +* The minimum supported Bazel version is now v0.24. + + The version is available from [`nixpkgs + unstable`](https://github.com/NixOS/nixpkgs/pull/58147) and via + [`official + releases`](https://docs.bazel.build/versions/master/install.html). + +* Initial Windows support + + A non-trivial subset of `rules_haskell` is now working on Windows. + See the [`project + tracker`](https://github.com/tweag/rules_haskell/issues?q=is%3Aopen+is%3Aissue+project%3Atweag%2Frules_haskell%2F2) + for finished and ongoing work. + +* Improved OSX support + + Due to the `mach-o` header size limit, we took extra measures to + make sure generated library paths are as short as possible, so + linking haskell binaries works even for large dependency graphs. + +* Better Bindist support + + The default [`start` script](http://haskell.build/start) sets up a + bindist-based project by default. + + `rules_nixpkgs` is no longer a required dependency of + `rules_haskell` (but can still be used as backend). + +* Full HaskellโCโHaskell Sandwich + + A `haskell_library` can be now be used nearly anywhere a + `cc_library` can. + + The old `cc_haskell_import` and `haskell_cc_import` wrapper rules + are no longer necessary and have been deprecated. + +* Greatly improved REPL support + + A new `haskell_repl` rule allows to load multiple source targets by + source, or compiled, as needed. Example usage: + + ``` + haskell_repl( + name = "my-repl", + # Collect all transitive Haskell dependencies from these targets. + deps = [ + "//package-a:target-1", + "//package-b:target-2", + ], + # Load targets by source that match these patterns. + include = [ + "//package-a/...", + "//packaga-b/...", + "//common/...", + ], + # Don't load targets by source that match these patterns. + exclude = [ + "//package-a/vendored/...", + ], + ) + ``` + +* Support for GHC plugins + + Each `haskell_*` rule now has a `plugins` attribute. It takes a + list of bazel targets, which should be `haskell_library`s that + implement the [GHC plugin + specification](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/extending_ghc.html#compiler-plugins). + +* Initial Code Coverage support + + Measure coverage of your Haskell code. See the [โChecking Code + Coverageโ](https://rules-haskell.readthedocs.io/en/latest/haskell-use-cases.html#checking-code-coverage) + section in the manual. + +### Compatibility Notice + +[`hazel`](https://github.com/FormationAI/hazel) was [merged into +`rules_haskell`](https://github.com/tweag/rules_haskell/pull/733), but +we are not yet certain about the exact interface we want to expose. +`hazel` is therefore not included in this release, and we canโt +guarantee the original, unmerged version is compatible with this +release. If you depend on `hazel`, please use a recent `master` commit +of `rules_haskell`. + +### Changed + +* `haskell_register_ghc_bindists` is no longer re-exported from + `//haskell/haskell.bzl`. + You must now load that macro from `//haskell:nixpkgs.bzl`. + +* `rules_nixpkgs` is no longer a dependency of `rules_haskell`. + +* `haskell_import` has been renamed to `haskell_toolchain_library`. + This is a substantial breaking change. But adapting to it should be + as simple as + + ``` + sed -i 's/^haskell_import/haskell_toolchain_library/' **/BUILD{,.bazel} + sed -i 's/"haskell_import"/"haskell_toolchain_library"/' **/BUILD{,.bazel} + ``` + + See [#843](https://github.com/tweag/rules_haskell/pull/843). + +* `haskell_toolchain`โs tools attribute is now a list of labels. + Earlier entries take precendence. To migrate, add `[]` around your + argument. + See [#854](https://github.com/tweag/rules_haskell/pull/854). + +* The default outputs of `haskell_library` are now the static and/or + shared library files, not the package database config and cache + files. + +### Added + +* `haskell_repl` rule that constructs a ghci wrapper that loads + multiple targets by source. + See [#736](https://github.com/tweag/rules_haskell/pull/736). +* `plugins` attribute to `haskell_*` rules to load GHC plugins. + See [#799](https://github.com/tweag/rules_haskell/pull/799). +* The `HaskellInfo` and `HaskellLibraryInfo` providers are now + exported and thus accessible by downstream rules. + See [#844](https://github.com/tweag/rules_haskell/pull/844). +* Generate version macros for preprocessors (`c2hs`, `hsc2hs`). + See [#847](https://github.com/tweag/rules_haskell/pull/847). +* `bindist_toolchain` rule gets `haddock_flags` and `repl_ghci_args` + attributes. +* `@repl` targets write json file with build information, usable by + IDE tools. + See [#695](https://github.com/tweag/rules_haskell/pull/695). + +### Deprecated + +* `haskell_cc_import`; use `cc_library` instead. + See [#831](https://github.com/tweag/rules_haskell/pull/831). +* `cc_haskell_import`; just use `haskell_library` like a `cc_library`. + See [#831](https://github.com/tweag/rules_haskell/pull/831). + +### Fixed + +* Support protobuf roots in `haskell_proto_library`. + See [#722](https://github.com/tweag/rules_haskell/pull/722). +* Made GHC bindist relocatable on *nix. + See [#853](https://github.com/tweag/rules_haskell/pull/853). +* Various other fixes + +## [0.8] - 2019-01-28 + +* The minimum supported Bazel version is now v0.21. + +### Added + +* `haskell_register_toolchains`, `haskell_register_ghc_bindists` and + `haskell_register_ghc_nixpkgs` to register multiple toolchains for + multiple platforms at once. Toolchains from binary distributions can + now coexist with toolchains from Nixpkgs, even on the same platform. + On nixpkgs you need to provide a toolchain. See + [the `README`](./README.md#Nixpkgs) for instructions. + See [#597](https://github.com/tweag/rules_haskell/pull/597) + and [#610](https://github.com/tweag/rules_haskell/pull/610). +* Instructions on how to reference a local checkout of `rules_haskell`. +* `rules_haskell` is forward-compatible with the next breaking changes + in `bazel` versions, via the `--all_incompatible_changes` flag. + See [#613](https://github.com/tweag/rules_haskell/pull/613). + +### Removed + +* The `generate_so` attribute of `haskell_binary` and `haskell_test` + has been completely superseded by `linkstatic` in the last release + and became a no-op, so it is removed. +* The `main_file` attribute of `haskell_binary` and `haskell_test` + had been deprecated because it was a no-op, so it is removed. +* The `prebuilt_dependencies` attribute of all haskell rules + had been deprecated two versions ago and is removed. + Use `haskell_import` instead (see docs for usage). +* The `extra_binaries` field is now no longer supported. + +### Changed + +* `ghc_bindist` now requires a `target` argument. Use + `haskell_register_ghc_nixpkgs` to call `ghc_bindist` once per known + target. + See [#610](https://github.com/tweag/rules_haskell/pull/610). +* `ghc_bindist` now registers itself as a toolchain. We no longer + require a separate toolchain definition and registration in addition + to `ghc_bindist`. + See [#610](https://github.com/tweag/rules_haskell/pull/610). +* `c2hs` support is now provided in a separate toolchain called + `c2hs_toolchain`, rather than an optional extra to the + `haskell_toolchain`. + See [#590](https://github.com/tweag/rules_haskell/pull/590). +* Rename bindist arch names so they are the same as in + `rules_go/nodejs`. + +### Fixed + +* Prevent duplicate installs of bazel_skylib + See [#536](https://github.com/tweag/rules_haskell/pull/536). +* Test suite now executes all binaries, various runtime errors were + uncovered. + See [#551](https://github.com/tweag/rules_haskell/pull/551). +* Repl targets that have indirect cc_library dependencies. + See [#576](https://github.com/tweag/rules_haskell/pull/576). +* `linkstatic` for haskell binaries that have an indirect dependency + on a prebuilt haskell package. + See [#569](https://github.com/tweag/rules_haskell/pull/569). +* โฆ and an indirect dependency on a C library. + See [#567](https://github.com/tweag/rules_haskell/pull/567). +* Prefer linking agains static C libraries with `linkstatic`. + See [#587](https://github.com/tweag/rules_haskell/pull/587). +* Haddock flags take precedence over GHC compiler flags. + See [#572](https://github.com/tweag/rules_haskell/pull/572). +* User-defined GHC flags now override default flags. + See [#607](https://github.com/tweag/rules_haskell/pull/607). +* Dynamic transitive C(++) libraries work. + See [#627](https://github.com/tweag/rules_haskell/pull/627). + +## [0.7] - 2018-12-24 + +### Added + +* Support for Bazel 0.20.0. This is now also the lower bound for the + supported version. +* Supported reexported modules, via the + new + [`exports` attribute](http://api.haskell.build/haskell/haskell.html#haskell_library.exports). + See [#357](https://github.com/tweag/rules_haskell/issues/357). +* Support `linkstatic` attribute, for building mostly static binaries. + This is now the default for binaries, to match the C/C++ rules + defaults. + See [#378](https://github.com/tweag/rules_haskell/issues/378). +* It is now possible to set default Haddock flags in the toolchain + definition. + See [#425](https://github.com/tweag/rules_haskell/pull/425). +* Support wrapping Haskell libraries as shared objects callable from + Python. + See [#370](https://github.com/tweag/rules_haskell/issues/370). + +### Changed + +* REPL targets have changed name. If you have a library target `foo`, + then the corresponding REPL target is now called `foo@repl`. It was + previously called `foo-repl`. The old name is still supported but is + deprecated. +* Don't set a default version number anymore in libraries and + binaries. Version numbers, and CPP version macros, are now only used + for packages imported from Hackage. Don't use them otherwise. + See + [#386](https://github.com/tweag/rules_haskell/pull/386), + [#414](https://github.com/tweag/rules_haskell/pull/414) + and [#446](https://github.com/tweag/rules_haskell/pull/446). +* On macOS, we use `ar` for linking, not Libtool. + See [#392](https://github.com/tweag/rules_haskell/pull/392). +* The `runfiles` Haskell library has been broken out into a Cabal + library and published on Hackage. + +### Fixed + +* Make REPL force building of dependencies. + See [#363](https://github.com/tweag/rules_haskell/pull/363). +* Donโt crash on inputs missing `.haddock` interface files. See + [#362](https://github.com/tweag/rules_haskell/pull/362) +* Fix handling of non-unique package names. + See [#403](https://github.com/tweag/rules_haskell/pull/403). + +## [0.6] - 2018-07-21 + +### Added + +* Protocol buffers integration using `proto-lens`. See + [#239](https://github.com/tweag/rules_haskell/pull/239). + +* `strip_include_prefix` attribute to the `haskell_cc_import` rule. See + [#241](https://github.com/tweag/rules_haskell/pull/241). + +* Support for `c2hs` files. See + [#351](https://github.com/tweag/rules_haskell/pull/351). + +* The `extra_srcs` attribute that allows to list non-Haskell source files + that should be visible during compilation and linking (usually useful with + TH). See [#292](https://github.com/tweag/rules_haskell/pull/292). + +* The `extra_binaries` attribute to the `haskell_toolchain` rule. See + [#282](https://github.com/tweag/rules_haskell/issues/282). + +* A Haskell library for looking up runfiles. See + [#302](https://github.com/tweag/rules_haskell/pull/302). + +* A separate toolchain for `doctest`โ`haskell_doctest_toolchain`. See + [#310](https://github.com/tweag/rules_haskell/pull/310). + +* The `compiler_flags` attribute to the `haskell_toolchain` rule allowing to + specify default compiler flags. See + [#315](https://github.com/tweag/rules_haskell/issues/315). + +* The ability to set locale to be used during compilation by adding the + `locale` and `locale_archive` attributes to `haskell_toolchain`. See + [#328](https://github.com/tweag/rules_haskell/pull/328). + +* Proper support for profiling. See + [#332](https://github.com/tweag/rules_haskell/pull/332). + +* The `repl_ghci_args` attribute to the `haskell_toolchain` rule. See + [#334](https://github.com/tweag/rules_haskell/pull/334). + +* The `haskell_import` rule allowing us to make specifying dependencies more + uniform and to deprecate the `prebuilt_dependencies` attribute. See + [#337](https://github.com/tweag/rules_haskell/pull/337). + +### Fixed + +* Template Haskell linking against `cc_library`. See + [#218](https://github.com/tweag/rules_haskell/pull/218). + +* Linking issues on MacOS. See + [#221](https://github.com/tweag/rules_haskell/pull/221). + +* GHC packages that correspond to targets with the same name but in + different Bazel packages no longer clash. See + [#219](https://github.com/tweag/rules_haskell/issues/219). + +* Build breakage on MacOS when XCode is not installed. See + [#223](https://github.com/tweag/rules_haskell/pull/223). + +* Bug preventing Haddock generation because of missing dynamic shared + libraries when targets have TH in them. See + [#226](https://github.com/tweag/rules_haskell/pull/226). + +* Hyperlinks between targets contained in different Bazel packages + (Haddocks). See [#231](https://github.com/tweag/rules_haskell/issues/231). + +* Generated source files do not cause issues now. See + [#211](https://github.com/tweag/rules_haskell/pull/211). + +* `data` attributes now allow files in them. See + [#236](https://github.com/tweag/rules_haskell/issues/236). + +* Bug when headers and hsc2hs-produced files were not visible to Haddock. + See [#254](https://github.com/tweag/rules_haskell/pull/254). + +* Bug preventing using genrule-produced headers via `haskell_cc_import`. See + [#268](https://github.com/tweag/rules_haskell/pull/268). + +* Bug that allowed us avoid specifying certain `prebuilt_dependencies` if + they were already specified for transitive dependencies. See + [#286](https://github.com/tweag/rules_haskell/issues/286). + +* Bug that was making modules generated from `.hsc` and `.chs` files and + generated modules in general not available in the REPLs. See + [#323](https://github.com/tweag/rules_haskell/pull/323). + +### Changed + +* Added `-Wnoncanonical-monad-instances` to default warnings in + `haskell_lint`. + +* How REPLs work. Now there is an optional output per binary/library. Its + name is the name of target with `-repl` added. Users can then build and + run such a REPL for any defined target. See + [#220](https://github.com/tweag/rules_haskell/issues/220) and + [#225](https://github.com/tweag/rules_haskell/pull/225). + +* The `haskell_doc` rule now produces self-contained documentation bundle + with unified index. See + [#249](https://github.com/tweag/rules_haskell/pull/249). + +* `haskell_lint` now only lints direct dependencies. See + [#293](https://github.com/tweag/rules_haskell/pull/293). + +* `haskell_doctest` has been re-designed. It's now a normal rule that works + only on direct dependencies and allows to specify modules which should be + tested, pass custom flags to `doctest` executable. See + [#342](https://github.com/tweag/rules_haskell/pull/342). + +* The `prebuilt_dependencies` attribute of `haskell_binary` and + `haskell_library` has been deprecated. See + [#355](https://github.com/tweag/rules_haskell/pull/355). + +## [0.5] - 2018-04-15 + +### Added + +* Support for MacOS, courtesy of Judah Jacobson. See + [#165](https://github.com/tweag/rules_haskell/issues/165). + +* Support for `data` attributes in `haskell_binary` and `haskell_library` + rules. See [#167](https://github.com/tweag/rules_haskell/issues/167). + +* Output on building of GHC bindists so it's clearer what went wrong in case + of a failure. + +* `haskell_repl` rule allowing to interact with GHCi. See + [#82](https://github.com/tweag/rules_haskell/issues/82). + +* Support for GHC 8.4.1 bindist. See + [#175](https://github.com/tweag/rules_haskell/issues/175). + +* `haskell_lint` rule. See + [#181](https://github.com/tweag/rules_haskell/issues/181). + +* `haskell_doctest` rule. See + [#194](https://github.com/tweag/rules_haskell/issues/194). + +### Changed + +* Improved hermeticity of builds. See + [#180](https://github.com/tweag/rules_haskell/pull/180). + +* `cc_haskell_import` now works with `haskell_binary` targets as well. See + [#179](https://github.com/tweag/rules_haskell/issues/179). + +## [0.4] - 2018-02-27 + +### Added + +* `hidden_modules` attribute of the `haskell_library` rule. This allows to + selectively hide modules in a library. See + [#152](https://github.com/tweag/rules_haskell/issues/152). + +### Fixed + +* Test executables now find shared libraries correctly at runtime. See + [#151](https://github.com/tweag/rules_haskell/issues/151). + +* Building of certain modules does not fail with the โfile name does not + match module nameโ message anymore. See + [#139](https://github.com/tweag/rules_haskell/issues/139). + +* Linking issues that resulted in unresolved symbols due to incorrect order + in which static libraries are passed to linker are not resolved. See + [#140](https://github.com/tweag/rules_haskell/issues/140). + +* The โgrep not foundโ error is fixed. See + [#141](https://github.com/tweag/rules_haskell/pull/141). + +* System-level shared libraries introduced by `haskell_cc_import` are now + found correctly during compilation. See + [#142](https://github.com/tweag/rules_haskell/issues/142). + +## [0.3] - 2018-02-13 + +## [0.2] - 2018-01-07 + +## [0.1] - 2018-01-02 diff --git a/third_party/bazel/rules_haskell/CONTRIBUTING.md b/third_party/bazel/rules_haskell/CONTRIBUTING.md new file mode 100644 index 000000000000..848cbb1b9663 --- /dev/null +++ b/third_party/bazel/rules_haskell/CONTRIBUTING.md @@ -0,0 +1,36 @@ +# Contributing to Bazel + +## Contributor License Agreement + +Contributions to this project must be accompanied by a Contributor License +Agreement. You (or your employer) retain the copyright to your contribution, +this simply gives us permission to use and redistribute your contributions as +part of the project. Head over to <https://cla.developers.google.com/> to see +your current agreements on file or to sign a new one. + +You generally only need to submit a CLA once, so if you've already submitted one +(even if it was for a different project), you probably don't need to do it +again. + +## Contribution process + +1. Explain your idea and discuss your plan with members of the team. + The best way to do this is to create an [issue][issue-tracker] or + comment on an existing issue. +1. Prepare a git commit with your change. Don't forget to + add [tests][tests]. Run the existing tests with `bazel test //...`. + Update [README.md](./README.md) if appropriate. +1. [Create a pull request](https://help.github.com/articles/creating-a-pull-request/). + This will start the code review process. **All submissions, + including submissions by project members, require review.** +1. You may be asked to make some changes. You'll also need to sign the + CLA at this point, if you haven't done so already. Our continuous + integration bots will test your change automatically on supported + platforms. Once everything looks good, your change will be merged. + +[issue-tracker]: https://github.com/tweag/rules_haskell/issues +[tests]: https://github.com/tweag/rules_haskell/tree/master/tests + +## Setting up your development environment + +Read how to [set up your development environment](https://bazel.build/contributing.html) diff --git a/third_party/bazel/rules_haskell/CONTRIBUTORS b/third_party/bazel/rules_haskell/CONTRIBUTORS new file mode 100644 index 000000000000..9b4cc87d92d6 --- /dev/null +++ b/third_party/bazel/rules_haskell/CONTRIBUTORS @@ -0,0 +1,15 @@ +# People who have agreed to one of the CLAs and can contribute patches. +# The AUTHORS file lists the copyright holders; this file +# lists people. For example, Google employees are listed here +# but not in AUTHORS, because Google holds the copyright. +# +# https://developers.google.com/open-source/cla/individual +# https://developers.google.com/open-source/cla/corporate +# +# Names should be added to this file as: +# Name <email address> + +Mathieu Boespflug <m@tweag.io> +Jingwen Chen <jin@crypt.sg> +Mark Karpov <mark.karpov@tweag.io> +Mateusz Kowalczyk <mateusz.kowalczyk@tweag.io> diff --git a/third_party/bazel/rules_haskell/LICENSE b/third_party/bazel/rules_haskell/LICENSE new file mode 100644 index 000000000000..261eeb9e9f8b --- /dev/null +++ b/third_party/bazel/rules_haskell/LICENSE @@ -0,0 +1,201 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/third_party/bazel/rules_haskell/README.md b/third_party/bazel/rules_haskell/README.md new file mode 100644 index 000000000000..5357946424a8 --- /dev/null +++ b/third_party/bazel/rules_haskell/README.md @@ -0,0 +1,344 @@ +<p align="left"><img src="logo/horizontal.png" alt="rules_haskell" height="100px"></p> + +# Haskell rules for [Bazel][bazel] + +[](https://circleci.com/gh/tweag/rules_haskell) +[](https://dev.azure.com/tweag/rules_haskell/_build/latest?definitionId=1?branchName=master) + +Bazel automates building and testing software. It scales to very large +multi-language projects. This project extends Bazel with build rules +for Haskell. Get started building your own project using these rules +wih the [setup script below](#setup). + +[bazel]: https://bazel.build/ +[bazel-getting-started]: https://docs.bazel.build/versions/master/getting-started.html +[bazel-cli]: https://docs.bazel.build/versions/master/command-line-reference.html +[external-repositories]: https://docs.bazel.build/versions/master/external.html +[nix]: https://nixos.org/nix + +## Rule summary + +The full reference documentation for rules is at https://haskell.build. + +## Setup + +You'll need [Bazel >= 0.24][bazel-getting-started] installed. + +### The easy way + +In a fresh directory, run: + +```console +$ curl https://haskell.build/start | sh +``` + +This will generate initial `WORKSPACE` and `BUILD` files for you. See the +[examples](./tests) and the [API reference](#Rules) below to adapt these for +you project. Then, + +```console +$ bazel build //... # Build all targets +$ bazel test //... # Run all tests +``` + +You can learn more about Bazel's command line +syntax [here][bazel-cli]. Common [commands][bazel-cli-commands] are +`build`, `test`, `run` and `coverage`. + +### Nixpkgs + +This rule set supports [Nixpkgs][nixpkgs]. If you are on NixOS, or if +you are using Nixpkgs on your project, consider passing the following +argument on the command-line to select a Nixpkgs-based toolchain for +the build: + +``` +$ bazel build --host_platform=@io_tweag_rules_haskell//haskell/platforms:linux_x86_64_nixpkgs //... +``` + +See [below](#saving-common-command-line-flags-to-a-file) to +permanently set that flag. + +[bazel-cli-commands]: https://docs.bazel.build/versions/master/command-line-reference.html#commands +[nixpkgs]: https://nixos.org/nixpkgs/ + +### Doing it manually + +Add the following to your `WORKSPACE` file, and select a `$VERSION` +(or even an arbitrary commit hash) accordingly. + +```bzl +load("@bazel_tools//tools/build_defs/repo:http.bzl", "http_archive") + +http_archive( + name = "io_tweag_rules_haskell", + strip_prefix = "rules_haskell-$VERSION", + urls = ["https://github.com/tweag/rules_haskell/archive/v$VERSION.tar.gz"], +) + +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_repositories", + "haskell_register_toolchains", +) + +haskell_repositories() + +haskell_register_toolchains() +``` + +You will then need to write one `BUILD` file for each "package" you +want to define. See below for examples. + +## Tutorial and Examples + +We provide a [tutorial for writing your first rules][tutorial]. +The corresponding source code is in [./tutorial](./tutorial). + +A collection of example rules is in [./examples](./examples). + +[tutorial]: https://rules-haskell.readthedocs.io/en/latest/ + +## Rules + +See https://api.haskell.build for the reference documentation on provided +rules. Using [./serve-docs.sh](./serve-docs.sh), you can also view +this documentation locally. + +## Language interop + +We may be supporting interop with other languages in one way or +another. Please see languages listed below about how. + +### C/C++ + +C/C++ libraries can be specified as dependencies. Exporting Haskell libraries +as C/C++ dependencies currently requires the `cc_haskell_import` rule. This is +a temporary workaround to Bazel limitations. + +### Java + +You can supply `java_*` rule targets in `deps` of +[haskell_binary](#haskell_binary) and +[haskell_library](#haskell_library). This will make jars produced by +those dependencies available during Haskell source compilation phase +(i.e. not during linking &c. but it's subject to change) and set the +CLASSPATH for that phase as well. + +## Troubleshooting + +### No such file or directory + +If you see error messages complaining about missing `as` (`ld` or indeed +some other executable): + +``` +cc: error trying to exec 'as': execvp: No such file or directory +`cc' failed in phase `Assembler'. (Exit code: 1) +``` + +It means that your `gcc` cannot find `as` by itself. This happens only on +certain operating systems which have `gcc` compiled without `--with-as` and +`--with-ld` flags. We need to make `as` visible manually in that case: + +```bzl +# Create a symlink to system executable 'as' +genrule( + name = "toolchain_as", + outs = ["as"], + cmd = "ln -s /usr/bin/as $@", +) + +# Make it visible to rules_haskell rules: +haskell_toolchain( + name = "ghc", + tools = ["@ghc//:bin"], + version = "8.4.1", + extra_binaries = [":toolchain_as"], # <---- +) +``` + +### `__STDC_VERSION__` does not advertise C99 or later + +If you see an error message like this: + +``` +/root/.cache/bazel/_bazel_root/b8b1b1d6144a88c698a010767d2217af/external/ghc/lib/ghc-8.4.1/include/Stg.h:29:3: error: + error: #error __STDC_VERSION__ does not advertise C99 or later + # error __STDC_VERSION__ does not advertise C99 or later + ^ + | +29 | # error __STDC_VERSION__ does not advertise C99 or later + | ^ +``` + +It means that your `gcc` selects incorrect flavor of C by default. We need +C99 or later, as the error message says, so try this: + +```bzl +haskell_toolchain( + name = "ghc", + tools = ["@ghc//:bin"], + version = "8.4.1", + compiler_flags = ["-optc-std=c99"], # <---- +) +``` + +### `bazel` fails because some executable cannot be found + +Make sure you run your build in a pure nix shell +(`nix-shell --pure shell.nix`). If it still doesnโt build, +it is likely a bug. + +### A Haskell dependency fails with strange error messages + +If you get cabal error messages the likes of: + +``` +CallStack (from HasCallStack): + dieNoWrap, called at libraries/Cabal/Cabal/Distribution/Utils/LogProgress.hs:61:9 in Cabal-2.0.1.0:Distribution.Utils.LogProgress +Error: + The following packages are broken because other packages they depend on are missing. These broken packages must be rebuilt before they can be used. +installed package lens-labels-0.2.0.1 is broken due to missing package profunctors-5.2.2-HzcVdviprlKb7Ap1woZu4, tagged-0.8.5-HviTdonkllN1ZD6he1Zn8I +``` + +youโve most likely hit GHCโs +[infamous non-deterministic library ID bug](https://nixos.org/nixpkgs/manual/#how-to-recover-from-ghcs-infamous-non-deterministic-library-id-bug). + +### Warning about home modules during non-sandboxed builds + +Say you have a folder that mixes source files for two different +libraries or for a library and an executable. If you build with +sandboxing turned off, it is possible that GHC will use the source +files for one library during the build of the other. The danger in +this situation is that because GHC used inputs that Bazel didn't know +about, incremental rebuilds might not be correct. This is why you get +a warning of the following form if this happens: + +``` +<no location info>: warning: [-Wmissing-home-modules] + Modules are not listed in command line but needed for compilation: Foo +``` + +Turning sandboxing on (this is Bazel's default on Linux and macOS) +protects against this problem. If sandboxing is not an option, simply +put the source files for each target in a separate directory (you can +still use a single `BUILD` file to define all targets). + +## For `rules_haskell` developers + +### Saving common command-line flags to a file + +If you find yourself constantly passing the same flags on the +command-line for certain commands (such as `--host_platform` or +`--compiler`), you can augment the [`.bazelrc`](./.bazelrc) file in +this repository with a `.bazelrc.local` file. This file is ignored by +Git. + +### Reference a local checkout of `rules_haskell` + +When you develop on `rules_haskell`, you usually do it in the context +of a different project that has `rules_haskell` as a `WORKSPACE` +dependency, like so: + +``` +http_archive( + name = "io_tweag_rules_haskell", + strip_prefix = "rules_haskell-" + version, + sha256 = โฆ, + urls = โฆ, +) +``` + +To reference a local checkout instead, use the +[`--override_repository`][override_repository] command line option: + +``` +bazel build/test/run/sync \ + --override_repository io_tweag_rules_haskell=/path/to/checkout +``` + +If you donโt want to type that every time, [temporarily add it to +`.bazelrc`][bazelrc]. + +[override_repository]: https://docs.bazel.build/versions/master/command-line-reference.html#flag--override_repository +[local_repository]: https://docs.bazel.build/versions/master/be/workspace.html#local_repository +[bazelrc]: https://docs.bazel.build/versions/master/best-practices.html#bazelrc + +### Test Suite + +To run the test suite for these rules, you'll need [Nix][nix] +installed. First, from the projectโs folder start a pure nix shell: + +``` +$ nix-shell --pure shell.nix +``` + +This will make sure that bazel has the exact same environment +on every development system (`python`, `ghc`, `go`, โฆ). + +To build and run tests locally, execute: + +``` +$ bazel test //... +``` + +Skylark code in this project is formatted according to the output of +[buildifier]. You can check that the formatting is correct using: + +``` +$ bazel run //:buildifier +``` + +If tests fail then run the following to fix the formatting: + +``` +$ git rebase --exec "bazel run //:buildifier-fix" <first commit> +``` + +where `<first commit>` is the first commit in your pull request. +This fixes formatting for each of your commits separately, to keep +the history clean. + +[buildifier]: https://github.com/bazelbuild/buildtools/tree/master/buildifier + +### <a name="nixpkgs-pin" />How to update the nixpkgs pin + +You have to find a new git commit where all our `shell.nix` +dependencies are available from the official NixOS Hydra binary cache. + +At least for `x86-linux` this is guaranteed for the `unstable` +channels. You can find the `nixpkgs` git commit of current `unstable` +here: + +https://nixos.org/channels/nixos-unstable/git-revision + +That might be too old for your use-case (because all tests have to +pass for that channel to be updated), so as a fallback there is: + +https://nixos.org/channels/nixos-unstable-small/git-revision + +You copy that hash to `url` in +[`./nixpkgs/default.nix`](./nixpkgs/default.nix). Donโt forget to +change the `sha256` or it will use the old version. Please update the +date comment to the date of the `nixpkgs` commit you are pinning to. + +### CircleCI + +Pull Requests are checked by CircleCI. + +If a check fails and you cannot reproduce it locally (e.g. it failed on Darwin +and you only run Linux), you can [ssh into CircleCI to aid debugging][ci-ssh]. + +[ci-ssh]: https://circleci.com/docs/2.0/ssh-access-jobs/ + +#### โunable to start any buildโ + +``` +error: unable to start any build; either increase '--max-jobs' or enable remote builds +``` + +We set `--builders ""` and `--max-jobs 0` on CI to be sure all +dependencies are coming from binary caches. You might need to add an +exception (TODO: where to add exception) or [switch to a different +nixpkgs pin](#nixpkgs-pin). diff --git a/third_party/bazel/rules_haskell/ROADMAP.md b/third_party/bazel/rules_haskell/ROADMAP.md new file mode 100644 index 000000000000..4e234bddb1cb --- /dev/null +++ b/third_party/bazel/rules_haskell/ROADMAP.md @@ -0,0 +1,47 @@ +# Feature roadmap + +In the following list, each feature is associated with a corresponding +milestone. The convention for the priorities are: + +* P0 feature will block the milestone; we will delay the milestone + date until the feature is shipped. +* P1 feature can delay the milestone if the feature can be shipped + with a reasonable delay. +* P2 feature will be dropped and rescheduled for later rather than + delaying the milestone. + +We will update this list when reaching each milestone. Some milestones +may also be refined if appropriate. + +## Planned feature list + +### 1.0 + +* P1. Backpack support. +* P2. Define official GHC bindists as toolchains for each Tier-1 + platform. +* P2. Define cross-compiler toolchains. +* P2. Support multiple build flavours: fastbuild, opt, dbg/profiling. + +## Previous milestones + +### Initial support + +* P0. Ensure legalese is in place from the beginning to make project + upstreamable to official `bazelbuild` org eventually. +* P0. `haskell_library` able to compile single file library. +* P0. `haskell_binary` able to compile single file binary. +* P1. Basic binary build with a library dependency. +* P2. Transitive library dependencies. +* P2. Basic documentation with rule descriptions. + +### Build and test inline-java + +* P0. Can build and run inline-java spec and jvm-streaming spec. +* P0. Can use inline-java packages as dependencies in bigger product + (sparkle). + +### Build and test sparkle + +* P0. Able to build sparkle executable. This includes building all + relevant Java. diff --git a/third_party/bazel/rules_haskell/WORKSPACE b/third_party/bazel/rules_haskell/WORKSPACE new file mode 100644 index 000000000000..1f1c48e05c3e --- /dev/null +++ b/third_party/bazel/rules_haskell/WORKSPACE @@ -0,0 +1,354 @@ +workspace(name = "io_tweag_rules_haskell") + +load("@bazel_tools//tools/build_defs/repo:http.bzl", "http_archive") +load("@io_tweag_rules_haskell//haskell:repositories.bzl", "haskell_repositories") + +# Subrepositories of rules_haskell + +# various examples +local_repository( + name = "io_tweag_rules_haskell_examples", + path = "examples", +) + +# code for the tutorial +local_repository( + name = "io_tweag_rules_haskell_tutorial", + path = "tutorial", +) + +# Some helpers for platform-dependent configuration +load("//tools:os_info.bzl", "os_info") + +os_info(name = "os_info") + +load("@os_info//:os_info.bzl", "is_linux", "is_windows") + +# bazel dependencies +haskell_repositories() + +rules_nixpkgs_version = "0.5.2" + +rules_nixpkgs_version_is_hash = False + +rules_nixpkgs_sha256 = "5a384daa57b49abf9f0b672852f1a66a3c52aecf9d4d2ac64f6de0fd307690c8" + +http_archive( + name = "io_tweag_rules_nixpkgs", + sha256 = rules_nixpkgs_sha256, + strip_prefix = "rules_nixpkgs-%s" % rules_nixpkgs_version, + urls = ["https://github.com/tweag/rules_nixpkgs/archive/%s.tar.gz" % rules_nixpkgs_version] if rules_nixpkgs_version_is_hash else ["https://github.com/tweag/rules_nixpkgs/archive/v%s.tar.gz" % rules_nixpkgs_version], +) + +load( + "@io_tweag_rules_nixpkgs//nixpkgs:nixpkgs.bzl", + "nixpkgs_cc_configure", + "nixpkgs_local_repository", + "nixpkgs_package", +) +load( + "@io_tweag_rules_haskell//haskell:nixpkgs.bzl", + "haskell_nixpkgs_package", + "haskell_nixpkgs_packageset", +) +load( + "@io_tweag_rules_haskell//tests/external-haskell-repository:workspace_dummy.bzl", + "haskell_package_repository_dummy", +) +load( + "@io_tweag_rules_haskell//:constants.bzl", + "test_ghc_version", +) + +haskell_nixpkgs_package( + name = "ghc", + attribute_path = "haskellPackages.ghc", + build_file = "//haskell:ghc.BUILD", + nix_file = "//tests:ghc.nix", + nix_file_deps = ["//nixpkgs:default.nix"], + # rules_nixpkgs assumes we want to read from `<nixpkgs>` implicitly + # if `repository` is not set, but our nix_file uses `./nixpkgs/`. + # TODO(Profpatsch) + repositories = {"nixpkgs": "//nixpkgs:NOTUSED"}, +) + +http_archive( + name = "com_google_protobuf", + sha256 = "73fdad358857e120fd0fa19e071a96e15c0f23bb25f85d3f7009abfd4f264a2a", + strip_prefix = "protobuf-3.6.1.3", + urls = ["https://github.com/google/protobuf/archive/v3.6.1.3.tar.gz"], +) + +nixpkgs_local_repository( + name = "nixpkgs", + nix_file = "//nixpkgs:default.nix", +) + +test_compiler_flags = [ + "-XStandaloneDeriving", # Flag used at compile time + "-threaded", # Flag used at link time + + # Used by `tests/repl-flags` + "-DTESTS_TOOLCHAIN_COMPILER_FLAGS", + # this is the default, so it does not harm other tests + "-XNoOverloadedStrings", +] + +test_haddock_flags = ["-U"] + +test_repl_ghci_args = [ + # The repl test will need this flag, but set by the local + # `repl_ghci_args`. + "-UTESTS_TOOLCHAIN_REPL_FLAGS", + # The repl test will need OverloadedString + "-XOverloadedStrings", +] + +load( + "@io_tweag_rules_haskell//haskell:nixpkgs.bzl", + "haskell_register_ghc_nixpkgs", +) + +haskell_register_ghc_nixpkgs( + compiler_flags = test_compiler_flags, + haddock_flags = test_haddock_flags, + locale_archive = "@glibc_locales//:locale-archive", + nix_file = "//tests:ghc.nix", + nix_file_deps = ["//nixpkgs:default.nix"], + repl_ghci_args = test_repl_ghci_args, + version = test_ghc_version, +) + +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_register_ghc_bindists", +) + +haskell_register_ghc_bindists( + compiler_flags = test_compiler_flags, + version = test_ghc_version, +) + +register_toolchains( + "//tests:c2hs-toolchain", + "//tests:doctest-toolchain", + "//tests:protobuf-toolchain", +) + +nixpkgs_cc_configure( + nix_file = "//nixpkgs:cc-toolchain.nix", + repository = "@nixpkgs", +) + +nixpkgs_package( + name = "zlib", + build_file_content = """ +package(default_visibility = ["//visibility:public"]) + +filegroup( + name = "lib", + srcs = glob(["lib/**/*.so*", "lib/**/*.dylib", "lib/**/*.a"]), +) + +cc_library( + name = "zlib", + linkstatic = 1, + srcs = [":lib"], + testonly = 1, +) +""", + repository = "@nixpkgs", +) + +nixpkgs_package( + name = "sphinx", + attribute_path = "python36Packages.sphinx", + repository = "@nixpkgs", +) + +nixpkgs_package( + name = "graphviz", + attribute_path = "graphviz", + repository = "@nixpkgs", +) + +nixpkgs_package( + name = "zip", + attribute_path = "zip", + repository = "@nixpkgs", +) + +nixpkgs_package( + name = "zlib.dev", + build_file_content = """ +package(default_visibility = ["//visibility:public"]) + +filegroup ( + name = "include", + srcs = glob(["include/*.h"]), + testonly = 1, +) + +cc_library( + name = "zlib", + deps = ["@zlib//:zlib"], + hdrs = [":include"], + testonly = 1, + strip_include_prefix = "include", +) +""", + repository = "@nixpkgs", +) + +nixpkgs_package( + name = "glibc_locales", + attribute_path = "glibcLocales", + build_file_content = """ +package(default_visibility = ["//visibility:public"]) + +filegroup( + name = "locale-archive", + srcs = ["lib/locale/locale-archive"], +) +""", + repository = "@nixpkgs", +) + +haskell_nixpkgs_packageset( + name = "hackage-packages", + base_attribute_path = "haskellPackages", + nix_file = "//tests:ghc.nix", + nix_file_deps = ["//tests/haddock:libC.nix"], + nixopts = [ + "-j", + "1", + ], + repositories = {"nixpkgs": "@nixpkgs"}, +) + +load("@hackage-packages//:packages.bzl", "import_packages") + +import_packages(name = "hackage") + +load("@bazel_tools//tools/build_defs/repo:jvm.bzl", "jvm_maven_import_external") + +jvm_maven_import_external( + name = "org_apache_spark_spark_core_2_10", + artifact = "org.apache.spark:spark-core_2.10:1.6.0", + artifact_sha256 = "28aad0602a5eea97e9cfed3a7c5f2934cd5afefdb7f7c1d871bb07985453ea6e", + licenses = ["notice"], + server_urls = ["http://central.maven.org/maven2"], +) + +# c2hs rule in its own repository +local_repository( + name = "c2hs_repo", + path = "tests/c2hs/repo", +) + +# dummy repo for the external haskell repo test (hazel) +haskell_package_repository_dummy( + name = "haskell_package_repository_dummy", +) + +# For Skydoc + +nixpkgs_package( + name = "nixpkgs_nodejs", + # XXX Indirection derivation to make all of NodeJS rooted in + # a single directory. We shouldn't need this, but it's + # a workaround for + # https://github.com/bazelbuild/bazel/issues/2927. + nix_file_content = """ + with import <nixpkgs> {}; + runCommand "nodejs-rules_haskell" { buildInputs = [ nodejs ]; } '' + mkdir -p $out/nixpkgs_nodejs + cd $out/nixpkgs_nodejs + for i in ${nodejs}/*; do ln -s $i; done + '' + """, + nixopts = [ + "--option", + "sandbox", + "false", + ], + repository = "@nixpkgs", +) + +http_archive( + name = "build_bazel_rules_nodejs", + sha256 = "f79f605a920145216e64991d6eff4e23babc48810a9efd63a31744bb6637b01e", + strip_prefix = "rules_nodejs-b4dad57d2ecc63d74db1f5523593639a635e447d", + # Tip of https://github.com/bazelbuild/rules_nodejs/pull/471. + urls = ["https://github.com/mboes/rules_nodejs/archive/b4dad57d2ecc63d74db1f5523593639a635e447d.tar.gz"], +) + +http_archive( + name = "io_bazel_rules_sass", + sha256 = "1e135452dc627f52eab39a50f4d5b8d13e8ed66cba2e6da56ac4cbdbd776536c", + strip_prefix = "rules_sass-1.15.2", + urls = ["https://github.com/bazelbuild/rules_sass/archive/1.15.2.tar.gz"], +) + +load("@io_bazel_rules_sass//:package.bzl", "rules_sass_dependencies") + +rules_sass_dependencies() + +load("@io_bazel_rules_sass//:defs.bzl", "sass_repositories") + +sass_repositories() + +load("@build_bazel_rules_nodejs//:defs.bzl", "node_repositories") + +node_repositories( + vendored_node = "@nixpkgs_nodejs", +) + +http_archive( + name = "io_bazel_skydoc", + sha256 = "19eb6c162075707df5703c274d3348127625873dbfa5ff83b1ef4b8f5dbaa449", + strip_prefix = "skydoc-0.2.0", + urls = ["https://github.com/bazelbuild/skydoc/archive/0.2.0.tar.gz"], +) + +load("@io_bazel_skydoc//:setup.bzl", "skydoc_repositories") + +skydoc_repositories() + +# For buildifier + +http_archive( + name = "io_bazel_rules_go", + sha256 = "8be57ff66da79d9e4bd434c860dce589195b9101b2c187d144014bbca23b5166", + strip_prefix = "rules_go-0.16.3", + urls = ["https://github.com/bazelbuild/rules_go/archive/0.16.3.tar.gz"], +) + +http_archive( + name = "com_github_bazelbuild_buildtools", + sha256 = "7525deb4d74e3aa4cb2b960da7d1c400257a324be4e497f75d265f2f508c518f", + strip_prefix = "buildtools-0.22.0", + urls = ["https://github.com/bazelbuild/buildtools/archive/0.22.0.tar.gz"], +) + +# A repository that generates the Go SDK imports, see ./tools/go_sdk/README +local_repository( + name = "go_sdk_repo", + path = "tools/go_sdk", +) + +load( + "@io_bazel_rules_go//go:def.bzl", + "go_register_toolchains", + "go_rules_dependencies", +) + +go_rules_dependencies() + +# If Windows, ask Bazel to download a Go SDK. Otherwise use the nix-shell +# provided GO SDK. +go_register_toolchains() if is_windows else go_register_toolchains(go_version = "host") + +load("@com_github_bazelbuild_buildtools//buildifier:deps.bzl", "buildifier_dependencies") + +buildifier_dependencies() diff --git a/third_party/bazel/rules_haskell/azure-pipelines.yml b/third_party/bazel/rules_haskell/azure-pipelines.yml new file mode 100644 index 000000000000..1ae3f7559003 --- /dev/null +++ b/third_party/bazel/rules_haskell/azure-pipelines.yml @@ -0,0 +1,71 @@ +jobs: +- job: Windows + pool: + vmImage: 'vs2017-win2016' + steps: + - bash: | + set -e + curl -LO https://github.com/bazelbuild/bazel/releases/download/0.23.2/bazel-0.23.2-windows-x86_64.exe + mv bazel-*.exe bazel.exe + mkdir /c/bazel + mv bazel.exe /c/bazel + /c/bazel/bazel.exe info release + + displayName: 'Install Bazel' + + - powershell: | + Write-Host "Enable long path behavior" + # See https://docs.microsoft.com/en-us/windows/desktop/fileio/naming-a-file#maximum-path-length-limitation + Set-ItemProperty -Path 'HKLM:\SYSTEM\CurrentControlSet\Control\FileSystem' -Name 'LongPathsEnabled' -Value 1 + displayName: "Enable da long paths" + + - bash: | + set -e + export MSYS2_ARG_CONV_EXCL="*" + # Tests that build but don't run + /c/bazel/bazel.exe build --config windows "//tests/c-compiles-still/..." + /c/bazel/bazel.exe build --config windows "//tests/binary-with-data/..." + /c/bazel/bazel.exe build --config windows "//tests/binary-indirect-cbits" + + # Tests that only require building + # (when using 'test' CI fails with: + # ERROR: No test targets were found, yet testing was requested + # ) + # See https://github.com/bazelbuild/bazel/issues/7291 + /c/bazel/bazel.exe build --config windows "//tests/data/..." + /c/bazel/bazel.exe build --config windows "//tests/failures/..." + /c/bazel/bazel.exe build --config windows "//tests/hidden-modules/..." + /c/bazel/bazel.exe build --config windows "//tests/package-id-clash/..." + + # Tests that succeed + /c/bazel/bazel.exe test --config windows "//tests:test-binary-simple" + /c/bazel/bazel.exe test --config windows "//tests:test-binary-custom-main" + /c/bazel/bazel.exe test --config windows "//tests/binary-custom-main/..." + /c/bazel/bazel.exe test --config windows "//tests/binary-exe-path/..." + /c/bazel/bazel.exe test --config windows "//tests/binary-with-data/..." + /c/bazel/bazel.exe test --config windows "//tests/binary-with-lib/..." + /c/bazel/bazel.exe test --config windows "//tests/binary-with-main/..." + /c/bazel/bazel.exe test --config windows "//tests/binary-simple/..." + /c/bazel/bazel.exe test --config windows "//tests/binary-with-compiler-flags/..." + /c/bazel/bazel.exe test --config windows "//tests/binary-with-import/..." + /c/bazel/bazel.exe test --config windows "//tests/binary-with-link-flags/..." + /c/bazel/bazel.exe test --config windows "//tests/cpp_macro_conflict/..." + /c/bazel/bazel.exe test --config windows "//tests/extra-source-files/..." + /c/bazel/bazel.exe test --config windows "//tests/java_classpath/..." + /c/bazel/bazel.exe test --config windows "//tests/generated-modules/..." + /c/bazel/bazel.exe test --config windows "//tests/haskell_lint/..." + /c/bazel/bazel.exe test --config windows "//tests/haskell_test/..." + /c/bazel/bazel.exe test --config windows "//tests/hs-boot/..." + /c/bazel/bazel.exe test --config windows "//tests/indirect-link/..." + /c/bazel/bazel.exe test --config windows "//tests/library-deps/..." + /c/bazel/bazel.exe test --config windows "//tests/library-exports/..." + /c/bazel/bazel.exe test --config windows "//tests/library-linkstatic-flag/..." + /c/bazel/bazel.exe test --config windows "//tests/lhs/..." + /c/bazel/bazel.exe test --config windows "//tests/package-id-clash-binary/..." + /c/bazel/bazel.exe test --config windows "//tests/package-name/..." + /c/bazel/bazel.exe test --config windows "//tests/textual-hdrs/..." + /c/bazel/bazel.exe test --config windows "//tests/two-libs/..." + /c/bazel/bazel.exe test --config windows "//tests/encoding/..." + /c/bazel/bazel.exe test --config windows "//tests/c-compiles/..." + + displayName: 'Run Bazel' diff --git a/third_party/bazel/rules_haskell/constants.bzl b/third_party/bazel/rules_haskell/constants.bzl new file mode 100644 index 000000000000..930fc8e384bf --- /dev/null +++ b/third_party/bazel/rules_haskell/constants.bzl @@ -0,0 +1 @@ +test_ghc_version = "8.6.4" diff --git a/third_party/bazel/rules_haskell/debug/linking_utils/BUILD.bazel b/third_party/bazel/rules_haskell/debug/linking_utils/BUILD.bazel new file mode 100644 index 000000000000..a32be2cfb6f9 --- /dev/null +++ b/third_party/bazel/rules_haskell/debug/linking_utils/BUILD.bazel @@ -0,0 +1,50 @@ +load( + ":ldd_test.bzl", + "ldd_test", +) + +py_library( + name = "linking_utils", + srcs = ["ldd.py"], + visibility = ["//visibility:public"], +) + +# test the ldd debug library on the output of `//tests/binary-indirect-cbits` +ldd_test( + name = "test-ldd", + current_workspace = None, + elf_binary = "//tests/binary-indirect-cbits", + script = r''' +import sys + +def contains_error(error): + """check whether any of the dependencies contains `error`, + where error is something from `LDD_ERRORS`. + Returns {} if there's no error. + """ + def f(d): + return { k: v for k, v in d['needed'].items() + if (v == error + or (v not in LDD_ERRORS + and dict_remove_empty(v['item']) != {})) } + return f + +# output should have some runpaths +assert \ + ldd(identity, sys.argv[1])['runpath_dirs']\ + > 0 + +# some of the dependencies are implicit and not in NEEDED flags +assert ldd(contains_error(LDD_UNKNOWN), sys.argv[1]) + +import pprint +# none of the dependencies must be missing +res = ldd(contains_error(LDD_MISSING), sys.argv[1]) +if res != {}: + print("These dependencies are missing:") + pprint.pprint(res) + exit(1) +''', + # it only works on linux + tags = ["dont_test_on_darwin"], +) diff --git a/third_party/bazel/rules_haskell/debug/linking_utils/README.md b/third_party/bazel/rules_haskell/debug/linking_utils/README.md new file mode 100644 index 000000000000..57384a27fe54 --- /dev/null +++ b/third_party/bazel/rules_haskell/debug/linking_utils/README.md @@ -0,0 +1,265 @@ +# Debugging linking errors + +The usual utilities, like `nm`, `objdump`, and of course `ldd` (see +[here](https://linux-audit.com/elf-binaries-on-linux-understanding-and-analysis/#tools-for-binary-analysis) +for a good overview of existing tools) go a long way. Yet, when +debugging non-trivial runtime linker failures one would oftentimes +like to filter outputs programmatically, with more advanced query +logic than just simple `grep` and `sed` expressions. + +This library provides a small set of utility subroutines. These can +help debug complicated linker errors. + +The main function is `ldd(f, elf_path)`. It is in the same spirit +as `ldd(1)`, but instead of a flat list of resolved libraries, it +returns a tree of structured information. + +When we use the term `ldd` in the following document, it refers +to the `ldd` function exported from [./ldd.py](./ldd.py). + +To query that tree, you pass it a function `f`, which is applied to +each dependency recursively (transforming the tree from the bottom +up). + +The following functions are exported alongside the `ldd` function. +They can be passed to `ldd` and used as building blocks for insightful +queries: + +- `identity`: donโt transform, output everything +- `remove_matching_needed`: remove needed entries that match a regex +- `remove_matching_runpaths`: remove runpaths that match a regex +- `non_existing_runpaths`: return a list of runpaths that donโt exist + in the filesystem +- `unused_runpaths`: return a list of runpaths that are listed in the + elf binary header, but no dependency was actually found in them +- `collect_unused_runpaths`: give an overview of all unused runpaths + +Helpers: +- `dict_remove_empty`: remove fields with empty lists/dicts from an output +- `items`: `dict.iteritems()` for both python 2 and 3 + +See the introductory tutorial below on how to use these functions. + +## Example usage + +### Setup + +If you have a bazel target which outputs a binary which you want to +debug, the easiest way is to use `ldd_test`: + +```python +load( + "//:debug/linking_utils/ldd_test.bzl", + "ldd_test", +) + +ldd_test( + name = "test-ldd", + elf_binary = "//tests/binary-indirect-cbits", + current_workspace = None, + script = r''' +YOUR SCRIPT HERE +''' +) +``` + +All exported functions from `ldd.py` are already in scope. +See the [`BUILD`](./BUILD) file in this directory for an example. + + +### Writing queries + +`ldd` takes a function that is applied to each layer of elf +dependencies. This function is passed a set of structured data. +This data is gathered by querying the elf binary with `objdump` +and parsing the header fields of the dynamic section: + +``` +DependencyInfo : +{ needed : dict(string, union( + LDD_MISSING, LDD_UNKNOWN, + { + # the needed dependency + item : a, + # where the dependency was found in + found_in : RunpathDir + })) +# all runpath directories that were searched +, runpath_dirs : [ RunpathDir ] } +``` + +The amount of data can get quite extensive for larger projects, so you +need a way to filter it down to get to the bottom of our problem. + +If a transitive dependency cannot be found by the runtime linker, the +binary cannot be started. `ldd` shows such a problem by setting +the corresponding value in the `needed` dict to `LDD_MISSING`. +To remove everything from the output but the missing dependency and +the path to that dependency, you can write a filter like this: + +```python +# `d` is the DependencyInfo dict from above +def filter_down_to_missing(d): + res = {} + + # items is a .iteritems() that works for py 2 and 3 + for name, dep in items(d['needed']): + if dep == LDD_MISSING: + res[name] = LDD_MISSING + elif dep in LDD_ERRORS: + pass + else: + # dep['item'] contains the already converted info + # from the previous layer + res[name] = dep['item'] + + # dict_remove_empty removes all empty fields from the dict, + # otherwise your result contains a lot of {} in the values. + return dict_remove_empty(res) + +# To get human-readable output, we re-use pythonโs pretty printing +# library. Itโs only simple python values after all! +import pprint +pprint.pprint( + # actually parse the elf binary and apply only_missing on each layer + ldd( + filter_down_to_missing, + # the path to the elf binary you want to expect. + elf_binary_path + ) +) +``` + +Note that in the filter you only need to filter the data for the +current executable, and add the info from previous layers (which are +available in `d['item']`). + +The result might look something like: + +```python +{'libfoo.so.5': {'libbar.so.1': {'libbaz.so.6': 'MISSING'}}} +``` + +or + +```python +{} +``` + +if nothing is missing. + +Now, that is a similar output to what a tool like `lddtree(1)` could +give you. But we donโt need to stop there because itโs trivial to +augment your output with more information: + + +```python +def missing_with_runpath(d): + # our previous function can be re-used + missing = filter_down_to_missing(d) + + # only display runpaths if there are missing deps + runpaths = [] if missing is {} else d['runpath_dirs'] + + # dict_remove_empty keeps the output clean + return dict_remove_empty({ + 'rpth': runpaths, + 'miss': missing + }) + +# same invocation, different function +pprint.pprint( + ldd( + missing_with_runpath, + elf_binary_path + ) +) +``` + +which displays something like this for my example binary: + +```python +{ 'miss': { 'libfoo.so.5': { 'miss': { 'libbar.so.1': { 'miss': { 'libbaz.so.6': 'MISSING'}, + 'rpth': [ { 'absolute_path': '/home/philip/.cache/bazel/_bazel_philip/fd9fea5ad581ea59473dc1f9d6bce826/execroot/myproject/bazel-out/k8-fastbuild/bin/something/and/bazel-out/k8-fastbuild/bin/other/integrate', + 'path': '$ORIGIN/../../../../../../bazel-out/k8-fastbuild/bin/other/integrate'}]}}, + 'rpth': [ { 'absolute_path': '/nix/store/xdsjx0gba4id3yyqxv66bxnm2sqixkjj-glibc-2.27/lib', + 'path': '/nix/store/xdsjx0gba4id3yyqxv66bxnm2sqixkjj-glibc-2.27/lib'}, + { 'absolute_path': '/nix/store/x6inizi5ahlyhqxxwv1rvn05a25icarq-gcc-7.3.0-lib/lib', + 'path': '/nix/store/x6inizi5ahlyhqxxwv1rvn05a25icarq-gcc-7.3.0-lib/lib'}]}}, + 'rpth': [ โฆ lots more nix rpaths โฆ ]} +``` + +Thatโs still a bit cluttered for my taste, so letโs filter out +the `/nix/store` paths (which are mostly noise): + +```python +import re +nix_matcher = re.compile("/nix/store.*") + +def missing_with_runpath(d): + missing = filter_down_to_missing(d) + + # this is one of the example functions provided by ldd.py + remove_matching_runpaths(d, nix_matcher) + # ^^^ + + runpaths = [] if missing is {} else d['runpath_dirs'] + + # dict_remove_empty keeps the output clean + return dict_remove_empty({ + 'rpth': runpaths, + 'miss': missing + }) +``` + +and we are down to: + +```python +{ 'miss': { 'libfoo.so.5': { 'miss': { 'libbar.so.1': { 'miss': { 'libbaz.so.6': 'MISSING'}, + 'rpth': [ { 'absolute_path': '/home/philip/.cache/bazel/_bazel_philip/fd9fea5ad581ea59473dc1f9d6bce826/execroot/myproject/bazel-out/k8-fastbuild/bin/something/and/bazel-out/k8-fastbuild/bin/other/integrate', + 'path': '$ORIGIN/../../../../../../bazel-out/k8-fastbuild/bin/other/integrate'}]}}} +``` + +โฆ which shows exactly the path that is missing the dependency we +expect. But what has gone wrong? Does this path even exist? We can +find out! + +```python +import re +nix_matcher = re.compile("/nix/store.*") + +def missing_with_runpath(d): + missing = filter_down_to_missing(d) + remove_matching_runpaths(d, nix_matcher) + runpaths = [] if missing is {} else d['runpath_dirs'] + + # returns a list of runpaths that donโt exist in the filesystem + doesnt_exist = non_existing_runpaths(d) + # ^^^ + + return dict_remove_empty({ + 'rpth': runpaths, + 'miss': missing, + 'doesnt_exist': doesnt_exist, + }) +``` + +I amended the output by a list of runpaths which point to non-existing +directories: + +```python +{ 'miss': { 'libfoo.so.5': { 'miss': { 'libbar.so.1': { 'miss': { 'libbaz.so.6': 'MISSING'}, + 'rpth': [ { 'absolute_path': '/home/philip/.cache/bazel/_bazel_philip/fd9fea5ad581ea59473dc1f9d6bce826/execroot/myproject/bazel-out/k8-fastbuild/bin/something/and/bazel-out/k8-fastbuild/bin/other/integrate', + 'path': '$ORIGIN/../../../../../../bazel-out/k8-fastbuild/bin/other/integrate'}] + 'doesnt_exist': [ { 'absolute_path': '/home/philip/.cache/bazel/_bazel_philip/fd9fea5ad581ea59473dc1f9d6bce826/execroot/myproject/bazel-out/k8-fastbuild/bin/something/and/bazel-out/k8-fastbuild/bin/other/integrate', + 'path': '$ORIGIN/../../../../../../bazel-out/k8-fastbuild/bin/other/integrate'}]}}} +``` + +Suddenly itโs perfectly clear where the problem lies, +`$ORIGIN/../../../../../../bazel-out/k8-fastbuild/bin/other/integrate` +points to a path that does not exist. + +Any data query youโd like to do is possible, as long as it uses +the data provided by the `ldd` function. See the lower part of +`ldd.py` for more examples. + diff --git a/third_party/bazel/rules_haskell/debug/linking_utils/ldd.py b/third_party/bazel/rules_haskell/debug/linking_utils/ldd.py new file mode 100644 index 000000000000..897cfdc713d3 --- /dev/null +++ b/third_party/bazel/rules_haskell/debug/linking_utils/ldd.py @@ -0,0 +1,288 @@ +import subprocess +import os +import sys +import re + + +### helper functions + +def list_to_dict(f, l): + """dict with elements of list as keys & as values transformed by f""" + d = {} + for el in l: + d[el] = f(el) + return d + +def dict_remove_empty(d): + """remove keys that have [] or {} or as values""" + new = {} + for k, v in d.items(): + if not (v == [] or v == {}): + new[k] = v + return new + +def identity(x): + """identity function""" + return x + +def const(x): + """(curried) constant function""" + def f(y): + return x + return f + +def memoized(cache, f, arg): + """Memoizes a call to `f` with `arg` in the dict `cache`. + Modifies the cache dict in place.""" + res = cache.get(arg) + if arg in cache: + return cache[arg] + else: + res = f(arg) + cache[arg] = res + return res + +### IO functions that find elf dependencies + +_field_matcher = re.compile(b" ([A-Z0-9_]+) +(.*)$") + +def read_dynamic_fields(elf_path): + """Read the dynamic header fields from an elf binary + + Args: + elf_path: path to the elf binary (either absolute or relative to pwd) + + Returns: + a list [(field_key, field_value)] where field_keys could appear multiple + times (for example there's usually more than one NEEDED field). + """ + res = subprocess.check_output([ + # force locale to C for stable output + "env", "LC_ALL=C", + "objdump", + # specifying the section brings execution time down from 150ms to 10ms + "--section=.dynamic", + "--all-headers", + elf_path + ]) + to_end = res.split(b"Dynamic Section:\n")[1] + # to first empty line + dyn_section = to_end[: 1 + to_end.find(b"\n\n")] + def read_dynamic_field(s): + """return (field_key, field_value)""" + return _field_matcher.match(s).groups() + return list(map(read_dynamic_field, dyn_section.splitlines(True))) + +def __query_dynamic_fields(df, key): + """takes a list of dynamic field tuples (key and value), + where keys can appear multiple times, and returns a list of all + values with the given key (in stable order).""" + return [v for k, v in df if k == key] + +def parse_runpath_dirs(elf_path, elf_dynamic_fields): + """Parse a RUNPATH entry from an elf header bytestring. + + Returns: + { path: unmodified string from DT_RUNPATH + , absolute_path: fully normalized, absolute path to dir } + """ + fields = __query_dynamic_fields(elf_dynamic_fields, b"RUNPATH") + if fields == []: + return [] + assert len(fields) == 1 + val = fields[0] + origin = os.path.dirname(elf_path) + return [{ 'path': path, + 'absolute_path': os.path.abspath(path.replace("$ORIGIN", origin)) } + for path in val.decode().strip(":").split(":") + if path != ""] + +def parse_needed(elf_dynamic_fields): + """Returns the list of DT_NEEDED entries for elf""" + return [n.decode() for n in __query_dynamic_fields(elf_dynamic_fields, b"NEEDED")] + + +### Main utility + +# cannot find dependency +LDD_MISSING = "MISSING" +# don't know how to search for dependency +LDD_UNKNOWN = "DUNNO" +# list of all errors for easy branching +LDD_ERRORS = [ LDD_MISSING, LDD_UNKNOWN ] + +def _ldd(elf_cache, f, elf_path): + """Same as `ldd` (below), except for an additional `elf_cache` argument, + which is a dict needed for memoizing elf files that were already read. + This is done because the elf reading operation is quite expensive + and many files are referenced multiple times (e.g. glib.so).""" + + def search(rdirs, elf_libname): + """search for elf_libname in runfile dirs + and return either the name or missing""" + res = LDD_MISSING + for rdir in rdirs: + potential_path = os.path.join(rdir['absolute_path'], elf_libname) + if os.path.exists(potential_path): + res = { + 'item': potential_path, + 'found_in': rdir, + } + break + return res + + def recurse(search_res): + """Unfold the subtree of ELF dependencies for a `search` result""" + if search_res == LDD_MISSING: + return LDD_MISSING + else: + # we keep all other fields in search_res the same, + # just item is the one that does the recursion. + # This is the part that would normally be done by fmap. + search_res['item'] = _ldd(elf_cache, f, search_res['item']) + return search_res + + # (GNU) ld.so resolves any symlinks before searching for dependencies + elf_realpath = os.path.realpath(elf_path) + + # memoized uses the cache to not repeat the I/O action + # for the same elf files (same path) + dyn_fields = memoized( + elf_cache, read_dynamic_fields, elf_realpath + ) + rdirs = parse_runpath_dirs(elf_realpath, dyn_fields) + all_needed = parse_needed(dyn_fields) + + # if there's no runpath dirs we don't know where to search + if rdirs == []: + needed = list_to_dict(const(LDD_UNKNOWN), all_needed) + else: + needed = list_to_dict( + lambda name: recurse(search(rdirs, name)), + all_needed + ) + + result = { + 'runpath_dirs': rdirs, + 'needed': needed + } + # Here, f is applied to the result of the previous level of recursion + return f(result) + + +def ldd(f, elf_path): + """follows DT_NEEDED ELF headers for elf by searching the through DT_RUNPATH. + + DependencyInfo : + { needed : dict(string, union( + LDD_MISSING, LDD_UNKNOWN, + { + # the needed dependency + item : a, + # where the dependency was found in + found_in : RunpathDir + })) + # all runpath directories that were searched + , runpath_dirs : [ RunpathDir ] } + + Args: + f: DependencyInfo -> a + modifies the results of each level + elf_path: path to ELF file, either absolute or relative to current working dir + + Returns: a + """ + elf_cache = {} + return _ldd(elf_cache, f, elf_path) + + +### Functions to pass to ldd + +# Only use the current layer + +def remove_matching_needed(d, re_matcher_absolute_path=None, re_matcher_path=None): + """Destructively removes needed values from d['needed'] + if they match the given regex matcher. + Doesn't remove LDD_ERRORS.""" + def pred(v): + """return true if match""" + if v in LDD_ERRORS: + return False + found_in = v['found_in'] + abs_match = re_matcher_absolute_path.match(found_in['absolute_path']) \ + if re_matcher_absolute_path else False + match = re_matcher_path.match(found_in['path']) \ + if re_matcher_path else False + if abs_match or match: + return True + d['needed'] = { + k: v for k, v in d['needed'].items() + if not pred(v) + } + +def remove_matching_runpaths(d, re_matcher): + """Destructively removes runpaths from d['runpath_dirs'] + if they match the given regex matcher.""" + d['runpath_dirs'] = [ + runp for runp in d['runpath_dirs'] + if not re_matcher.match(runp['absolute_path']) + ] + return d + +def non_existing_runpaths(d): + """Return a list of runpaths_dirs that do not exist in the file system.""" + return [ + runp for runp in d['runpath_dirs'] + if not os.path.exists(runp['absolute_path']) + ] + +def unused_runpaths(d): + """Return a list of runpath_dirs that were not used to find NEEDED dependencies.""" + used = set() + for k, v in d['needed'].items(): + if not v in LDD_ERRORS: + used.add(v['found_in']['absolute_path']) + return [ + u for u in d['runpath_dirs'] + if u['absolute_path'] not in used + ] + +# Also use the results of sub-layers + +def collect_unused_runpaths(d): + """This is like `unused_runpaths`, but it creates a deduplicated list of all unused runpaths + for its dependencies instead of just returning them for the current layer. + + Returns: + a dict of two fields; + `mine` contains the unused dependencies of the current binary under scrutiny + `others` contains a flat dict of all .sos with unused runpath entries and a list of them for each .so + """ + used = set() + given = set(r['absolute_path'] for r in d['runpath_dirs']) + prev = {} + # TODO: use `unused_runpaths` here + for k, v in d['needed'].items(): + if not v in LDD_ERRORS: + used.add(v['found_in']['absolute_path']) + prev[k] = v['item'] + unused = [ + u for u in given.difference(used) + # leave out nix storepaths + if not u.startswith("/nix/store") + ] + + # Each layer doesn't know about their own name + # So we return a list of unused for this layer ('mine') + # and a dict of all previeous layers combined (name to list) + def combine_unused(deps): + res = {} + for name, dep in deps.items(): + res.update(dep['others']) + res[name] = dep['mine'] + return res + + return { + 'mine': unused, + 'others': combine_unused(prev), + } diff --git a/third_party/bazel/rules_haskell/debug/linking_utils/ldd_test.bzl b/third_party/bazel/rules_haskell/debug/linking_utils/ldd_test.bzl new file mode 100644 index 000000000000..5872828df282 --- /dev/null +++ b/third_party/bazel/rules_haskell/debug/linking_utils/ldd_test.bzl @@ -0,0 +1,26 @@ +load( + "//:tests/inline_tests.bzl", + "py_inline_test", +) + +# +def ldd_test(name, elf_binary, script, current_workspace = None, tags = []): + """Test with imported linking_utils.ldd library. + The path to the `elf_binary` is passed in sys.argv[1]. + """ + py_inline_test( + name, + deps = ["@io_tweag_rules_haskell//debug/linking_utils"], + data = [elf_binary], + args = ["{}/$(rootpath {})".format(current_workspace, elf_binary)] if current_workspace else ["$(rootpath {})".format(elf_binary)], + script = """ +from io_tweag_rules_haskell.debug.linking_utils.ldd import \\ + dict_remove_empty, identity, const, \\ + LDD_MISSING, LDD_UNKNOWN, LDD_ERRORS, \\ + ldd, \\ + remove_matching_needed, remove_matching_runpaths, \\ + non_existing_runpaths, unused_runpaths, \\ + collect_unused_runpaths +""" + script, + tags = tags, + ) diff --git a/third_party/bazel/rules_haskell/docs/.gitignore b/third_party/bazel/rules_haskell/docs/.gitignore new file mode 100644 index 000000000000..e35d8850c968 --- /dev/null +++ b/third_party/bazel/rules_haskell/docs/.gitignore @@ -0,0 +1 @@ +_build diff --git a/third_party/bazel/rules_haskell/docs/BUILD.bazel b/third_party/bazel/rules_haskell/docs/BUILD.bazel new file mode 100644 index 000000000000..e21093c8ec6c --- /dev/null +++ b/third_party/bazel/rules_haskell/docs/BUILD.bazel @@ -0,0 +1,46 @@ +load("@io_bazel_skydoc//skylark:skylark.bzl", "skylark_doc") + +genrule( + name = "guide_html", + srcs = ["conf.py"] + glob(["*.rst"]), + outs = ["guide_html.zip"], + cmd = """ + set -euo pipefail + # Nixpkgs_rules are pointing to every bins individually. Here + # we are extracting the /bin dir path to append it to the $$PATH. + CWD=`pwd` + sphinxBinDir=$${CWD}/$$(echo $(locations @sphinx//:bin) | cut -d ' ' -f 1 | xargs dirname) + dotBinDir=$${CWD}/$$(echo $(locations @graphviz//:bin) | cut -d ' ' -f 1 | xargs dirname) + zipBinDir=$${CWD}/$$(echo $(locations @zip//:bin) | cut -d ' ' -f 1 | xargs dirname) + PATH=$${PATH}:$${sphinxBinDir}:$${dotBinDir}:$${zipBinDir} + sourcedir=$$(dirname $(location conf.py)) + builddir=$$(mktemp -d rules_haskell_docs.XXXX) + sphinx-build -M html $$sourcedir $$builddir -W -N -q + (cd $$builddir/html && zip -q -r $$CWD/$@ .) + rm -rf $$builddir + """, + tools = [ + "@graphviz//:bin", + "@sphinx//:bin", + "@zip//:bin", + ], +) + +skylark_doc( + name = "api_html", + srcs = [ + + # The order of these files defines the order in which the corresponding + # sections are presented in the docs. + "//haskell:haskell.bzl", + "//haskell:haddock.bzl", + "//haskell:lint.bzl", + "//haskell:toolchain.bzl", + "//haskell:protobuf.bzl", + "//haskell:cc.bzl", + "//haskell:repositories.bzl", + "//haskell:ghc_bindist.bzl", + "//haskell:nixpkgs.bzl", + ], + format = "html", +) diff --git a/third_party/bazel/rules_haskell/docs/conf.py b/third_party/bazel/rules_haskell/docs/conf.py new file mode 100644 index 000000000000..acfe5dc7af88 --- /dev/null +++ b/third_party/bazel/rules_haskell/docs/conf.py @@ -0,0 +1,41 @@ +project = 'rules_haskell' + +copyright = '2018, The rules_haskell authors' + +source_suffix = '.rst' + +extensions = [ + 'sphinx.ext.graphviz', + 'sphinx.ext.todo', +] + +master_doc = 'index' + +language = None + +exclude_patterns = ['_build', 'Thumbs.db', '.DS_Store'] + +pygments_style = 'sphinx' + +html_theme = 'alabaster' + +html_theme_options = { + 'show_powered_by': False, + 'github_user': 'tweag', + 'github_repo': 'rules_haskell', + 'github_banner': True, + 'github_type': "star", + 'show_related': False, + 'note_bg': '#FFF59C', +} + +html_show_sphinx = False + +todo_include_todos = True + +# Grouping the document tree into LaTeX files. List of tuples +# (source start file, target name, title, author, documentclass). +latex_documents = [ + (master_doc, 'rules_haskell.tex', 'rules\\_haskell Documentation', + 'Tweag I/O', 'manual'), +] diff --git a/third_party/bazel/rules_haskell/docs/haskell-use-cases.rst b/third_party/bazel/rules_haskell/docs/haskell-use-cases.rst new file mode 100644 index 000000000000..a8c4340cf70f --- /dev/null +++ b/third_party/bazel/rules_haskell/docs/haskell-use-cases.rst @@ -0,0 +1,283 @@ +.. _use-cases: + +Common Haskell Build Use Cases +============================== + +Picking a compiler +------------------ + +Unlike Bazel's native C++ rules, rules_haskell does not auto-detect +a Haskell compiler toolchain from the environment. This is by design. +We require that you declare a compiler to use in your ``WORKSPACE`` +file. + +There are two common sources for a compiler. One is to use the +official binary distributions from `haskell.org`_. This is done using +the `ghc_bindist`_ rule. + +The compiler can also be pulled from Nixpkgs_, a set of package +definitions for the `Nix package manager`_. Pulling the compiler from +Nixpkgs makes the build more hermetic, because the transitive closure +of the compiler and all its dependencies is precisely defined in the +``WORKSPACE`` file. Use `rules_nixpkgs`_ to do so (where ``X.Y.Z`` +stands for any recent release):: + + load("@bazel_tools//tools/build_defs/repo:http.bzl", "http_archive") + + http_archive( + name = "io_tweag_rules_nixpkgs", + strip_prefix = "rules_nixpkgs-X.Y.Z", + urls = ["https://github.com/tweag/rules_nixpkgs/archive/vX.Y.Z.tar.gz"], + ) + + load( + "@io_tweag_rules_nixpkgs//nixpkgs:nixpkgs.bzl", + "nixpkgs_git_repository", + "nixpkgs_package" + ) + + nixpkgs_git_repository( + name = "nixpkgs", + revision = "18.09", # Any tag or commit hash + ) + + nixpkgs_package( + name = "ghc", + repositories = { "nixpkgs": "@nixpkgs//:default.nix" } + attribute_path = "haskell.compiler.ghc843", # Any compiler version + build_file = "@io_tweag_rules_haskell//haskell:ghc.BUILD", + ) + + register_toolchains("//:ghc") + +This workspace description specifies which Nixpkgs version to use, +then exposes a Nixpkgs package containing the GHC compiler. The +description assumes that there exists a ``BUILD`` file at the root of +the repository that includes the following:: + + haskell_toolchain( + name = "ghc", + # Versions here and in WORKSPACE must match. + version = "8.4.3", + # Use binaries from @ghc//:bin to define //:ghc toolchain. + tools = ["@ghc//:bin"], + ) + +.. _Bazel+Nix blog post: https://www.tweag.io/posts/2018-03-15-bazel-nix.html +.. _Nix package manager: https://nixos.org/nix +.. _Nixpkgs: https://nixos.org/nixpkgs/manual/ +.. _ghc_bindist: http://api.haskell.build/haskell/ghc_bindist.html#ghc_bindist +.. _haskell.org: https://haskell.org +.. _haskell_binary: http://api.haskell.build/haskell/haskell.html#haskell_binary +.. _haskell_library: http://api.haskell.build/haskell/haskell.html#haskell_library +.. _rules_nixpkgs: https://github.com/tweag/rules_nixpkgs + +Loading targets in a REPL +------------------------- + +Rebuilds are currently not incremental *within* a binary or library +target (rebuilds are incremental across targets of course). Any change +in any source file will trigger a rebuild of all source files listed +in a target. In Bazel, it is conventional to decompose libraries into +small units. In this way, libraries require less work to rebuild. +Still, for interactive development full incrementality and fast +recompilation times are crucial for a good developer experience. We +recommend making all development REPL-driven for fast feedback when +source files change. + +Every `haskell_binary`_ and every `haskell_library`_ target has an +optional executable output that can be run to drop you into an +interactive session. If the target's name is ``foo``, then the REPL +output is called ``foo@repl``. + +Consider the following binary target:: + + haskell_binary( + name = "hello", + srcs = ["Main.hs", "Other.hs"], + deps = ["//lib:some_lib"], + ) + +The target above also implicitly defines ``hello@repl``. You can call +the REPL like this (requires Bazel 0.15 or later):: + + $ bazel run //:hello@repl + +This works for any ``haskell_binary`` or ``haskell_library`` target. +Modules of all libraries will be loaded in interpreted mode and can be +reloaded using the ``:r`` GHCi command when source files change. + +Building code with Hackage dependencies (using Nix) +--------------------------------------------------- + +Each Haskell library or binary needs a simple build description to +tell Bazel what source files to use and what the dependencies are, if +any. Packages on Hackage don't usually ship with `BUILD.bazel` files. +So if your code depends on them, you either need to write a build +description for each package, generate one (see next section), or +decide not to use Bazel to build packages published on Hackage. This +section documents one way to do the latter. + +Nix is a package manager. The set of package definitions is called +Nixpkgs. This repository contains definitions for most actively +maintained Cabal packages published on Hackage. Where these packages +depend on system libraries like zlib, ncurses or libpng, Nixpkgs also +contains package descriptions for those, and declares those as +dependencies of the Cabal packages. Since these definitions already +exist, we can reuse them instead of rewriting these definitions as +build definitions in Bazel. See the `Bazel+Nix blog post`_ for a more +detailed rationale. + +To use Nixpkgs in Bazel, we need `rules_nixpkgs`_. See `Picking +a compiler`_ for how to import Nixpkgs rules into your workspace and +how to use a compiler from Nixpkgs. To use Cabal packages from +Nixpkgs, replace the compiler definition with the following:: + + nixpkgs_package( + name = "ghc", + repositories = { "nixpkgs": "@nixpkgs//:default.nix" }, + nix_file = "//:ghc.nix", + build_file = "@io_tweag_rules_haskell//haskell:ghc.BUILD", + ) + +This definition assumes a ``ghc.nix`` file at the root of the +repository. In this file, you can use the Nix expression language to +construct a compiler with all the packages you depend on in scope:: + + with (import <nixpkgs> {}); + + haskellPackages.ghcWithPackages (p: with p; [ + containers + lens + text + ]) + +Each package mentioned in ``ghc.nix`` can then be imported using +`haskell_toolchain_library`_ in ``BUILD`` files. + +.. _haskell_toolchain_library: http://api.haskell.build/haskell/haskell.html#haskell_toolchain_library + +Building code with Hackage dependencies (using Hazel) +----------------------------------------------------- + +.. todo:: + + Explain how to use Hazel instead of Nix + +Generating API documentation +---------------------------- + +The `haskell_doc`_ rule can be used to build API documentation for +a given library (using Haddock). Building a target called +``//my/pkg:mylib_docs`` would make the documentation available at +``bazel-bin/my/pkg/mylib_docs/index/index.html``. + +Alternatively, you can use the +``@io_tweag_rules_haskell//haskell:haskell.bzl%haskell_doc_aspect`` +aspect to ask Bazel from the command-line to build documentation for +any given target (or indeed all targets), like in the following: + +.. code-block:: console + + $ bazel build //my/pkg:mylib \ + --aspects @io_tweag_rules_haskell//haskell:haskell.bzl%haskell_doc_aspect + +.. _haskell_doc: http://api.haskell.build/haskell/haddock.html#haskell_doc + +Linting your code +----------------- + +The `haskell_lint`_ rule does not build code but runs the GHC +typechecker on all listed dependencies. Warnings are treated as +errors. + +Alternatively, you can directly check a target using + +.. code-block:: console + + $ bazel build //my/haskell:target \ + --aspects @io_tweag_rules_haskell//haskell:haskell.bzl%haskell_lint_aspect + +.. _haskell_lint: http://api.haskell.build/haskell/lint.html#haskell_lint + +Checking code coverage +---------------------- + +"Code coverage" is the name given to metrics that describe how much source +code is covered by a given test suite. A specific code coverage metric +implemented here is expression coverage, or the number of expressions in +the source code that are explored when the tests are run. + +Haskell's ``ghc`` compiler has built-in support for code coverage analysis, +through the hpc_ tool. The Haskell rules allow the use of this tool to analyse +``haskell_library`` coverage by ``haskell_test`` rules. To do so, you have a +few options. You can add +``expected_covered_expressions_percentage=<some integer between 0 and 100>`` to +the attributes of a ``haskell_test``, and if the expression coverage percentage +is lower than this amount, the test will fail. Alternatively, you can add +``expected_uncovered_expression_count=<some integer greater or equal to 0>`` to +the attributes of a ``haskell_test``, and instead the test will fail if the +number of uncovered expressions is greater than this amount. Finally, you could +do both at once, and have both of these checks analyzed by the coverage runner. +To see the coverage details of the test suite regardless of if the test passes +or fails, add ``--test_output=all`` as a flag when invoking the test, and there +will be a report in the test output. You will only see the report if you +required a certain level of expression coverage in the rule attributes. + +For example, your BUILD file might look like this: :: + + haskell_library( + name = "lib", + srcs = ["Lib.hs"], + deps = [ + "//tests/hackage:base", + ], + ) + + haskell_test( + name = "test", + srcs = ["Main.hs"], + deps = [ + ":lib", + "//tests/hackage:base", + ], + expected_covered_expressions_percentage = 80, + expected_uncovered_expression_count = 10, + ) + +And if you ran ``bazel coverage //somepackage:test --test_output=all``, you +might see a result like this: :: + + INFO: From Testing //somepackage:test: + ==================== Test output for //somepackage:test: + Overall report + 100% expressions used (9/9) + 100% boolean coverage (0/0) + 100% guards (0/0) + 100% 'if' conditions (0/0) + 100% qualifiers (0/0) + 100% alternatives used (0/0) + 100% local declarations used (0/0) + 100% top-level declarations used (3/3) + ============================================================================= + +Here, the test passes because it actually has 100% expression coverage and 0 +uncovered expressions, which is even better than we expected on both counts. + +There is an optional ``haskell_test`` attribute called +``strict_coverage_analysis``, which is a boolean that changes the coverage +analysis such that even having better coverage than expected fails the test. +This can be used to enforce that developers must upgrade the expected test +coverage when they improve it. On the other hand, it requires changing the +expected coverage for almost any change. + +There a couple of notes regarding the coverage analysis functionality: + +- Coverage analysis currently is scoped to all source files and all + locally-built Haskell dependencies (both direct and transitive) for a given + test rule. +- Coverage-enabled build and execution for ``haskell_test`` targets may take + longer than regular. However, this has not effected regular ``run`` / + ``build`` / ``test`` performance. + +.. _hpc: <http://hackage.haskell.org/package/hpc> diff --git a/third_party/bazel/rules_haskell/docs/haskell.rst b/third_party/bazel/rules_haskell/docs/haskell.rst new file mode 100644 index 000000000000..353561111a21 --- /dev/null +++ b/third_party/bazel/rules_haskell/docs/haskell.rst @@ -0,0 +1,364 @@ +.. _guide: + +Introduction to Bazel: Building a Haskell project +================================================= + +In this tutorial, you'll learn the basics of building Haskell +applications with Bazel. You will set up your workspace and build +a simple Haskell project that illustrates key Bazel concepts, such as +targets and ``BUILD.bazel`` files. After completing this tutorial, take +a look at :ref:`Common Haskell build use cases <use-cases>` for +information on more advanced concepts such as writing and running +Haskell tests. + +What you'll learn +----------------- + +In this tutorial you'll learn how to: + +* build a target, +* visualize the project's dependencies, +* split the project into multiple targets and packages, +* control target visibility across packages, +* reference targets through labels. + +Before you begin +---------------- + +To prepare for the tutorial, first `install Bazel`_ if you don't have +it installed already. Then, retrieve the ``rules_haskell`` GitHub +repository:: + + git clone https://github.com/tweag/rules_haskell/ + +The sample project for this tutorial is in the ``tutorial`` +directory and is structured as follows:: + + rules_haskell + โโโ tutorial + โโโ WORKSPACE + โโโ main + โ โโโ BUILD.bazel + โ โโโ Main.hs + โโโ lib + โโโ BUILD.bazel + โโโ Bool.hs + +The first thing to do is to:: + + $ cd tutorial + +Build with Bazel +---------------- + +Set up the workspace +^^^^^^^^^^^^^^^^^^^^ + +Before you can build a project, you need to set up its workspace. +A workspace is a directory that holds your project's source files and +Bazel's build outputs. It also contains files that Bazel recognizes as +special: + +* the ``WORKSPACE`` file, which identifies the directory and its + contents as a Bazel workspace and lives at the root of the project's + directory structure, + +* one or more ``BUILD.bazel`` files, which tell Bazel how to build different + parts of the project. (A directory within the workspace that + contains a ``BUILD.bazel`` file is a *package*. You will learn about + packages later in this tutorial.) + +To designate a directory as a Bazel workspace, create an empty file +named ``WORKSPACE`` in that directory. + +When Bazel builds the project, all inputs and dependencies must be in +the same workspace. Files residing in different workspaces are +independent of one another unless linked, which is beyond the scope of +this tutorial. + +Understand the BUILD file +^^^^^^^^^^^^^^^^^^^^^^^^^ + +It is recommended to use a ``.bazel`` extension for each ``BUILD`` file to +avoid clashing with files or folders already using that name. + +A ``BUILD.bazel`` file contains several different types of instructions for +Bazel. The most important type is the *build rule*, which tells Bazel +how to build the desired outputs, such as executable binaries or +libraries. Each instance of a build rule in the ``BUILD.bazel`` file is +called a *target* and points to a specific set of source files and +dependencies. A target can also point to other targets. + +Take a look at the ``BUILD.bazel`` file in the ``tutorial/lib`` directory:: + + haskell_library( + name = "booleans", + srcs = ["Bool.hs"], + ) + +In our example, the ``booleans`` target instantiates the +`haskell_library`_ rule. The rule tells Bazel to build a reusable +(statically or dynamically linked) library from the ``Bool.hs`` source +file with no dependencies. + +The attributes in the target explicitly state its dependencies and +options. While the ``name`` attribute is mandatory, many are optional. +For example, in the ``booleans`` target, ``name`` is self-explanatory, +and ``srcs`` specifies the source file(s) from which Bazel builds the +target. + +Build the project +^^^^^^^^^^^^^^^^^ + +Let's build your sample project. Run the following command:: + + $ bazel build //lib:booleans + +Notice the target label - the ``//lib:`` part is the location of our +``BUILD.bazel`` file relative to the root of the workspace, and ``booleans`` +is what we named that target in the ``BUILD.bazel`` file. (You will learn +about target labels in more detail at the end of this tutorial.) + +Bazel produces output similar to the following:: + + INFO: Found 1 target... + Target //lib:booleans up-to-date: + bazel-bin/lib/libZSbooleans/libZSbooleans.conf + bazel-bin/lib/libZSbooleans/package.cache + INFO: Elapsed time: 2.288s, Critical Path: 0.68s + +Congratulations, you just built your first Bazel target! Bazel places +build outputs in the ``bazel-bin`` directory at the root of the +workspace. Browse through its contents to get an idea for Bazel's +output structure. + +Review the dependency graph +^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +A successful build has all of its dependencies explicitly stated in +the ``BUILD.bazel`` file. Bazel uses those statements to create the +project's dependency graph, which enables accurate incremental builds. + +Let's visualize our sample project's dependencies. First, generate +a text representation of the dependency graph (run the command at the +workspace root):: + + bazel query --nohost_deps --noimplicit_deps \ + 'deps(//lib:booleans)' --output graph + +The above command tells Bazel to look for all dependencies for the +target ``//lib:booleans`` (excluding host and implicit dependencies) +and format the output as a graph. + +Then, paste the text into GraphViz_. + +On Ubuntu, you can view the graph locally by installing GraphViz and the xdot +Dot Viewer:: + + sudo apt update && sudo apt install graphviz xdot + +Then you can generate and view the graph by piping the text output above +straight to xdot:: + + xdot <(bazel query --nohost_deps --noimplicit_deps \ + 'deps(//lib:booleans)' --output graph) + +As you can see, the first stage of the sample project has a single +target that builds a single source file with no additional +dependencies: + +.. digraph:: booleans + + node [shape=box]; + "//lib:booleans" + "//lib:booleans" -> "//lib:Bool.hs" + "//lib:Bool.hs" + +Now that you have set up your workspace, built your project, and +examined its dependencies, let's add some complexity. + +Refine your Bazel build +----------------------- + +While a single target is sufficient for small projects, you may want +to split larger projects into multiple targets and packages to allow +for fast incremental builds (that is, only rebuild what's changed) and +to speed up your builds by building multiple parts of a project at +once. + +Specify multiple build targets +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +Let's split our sample project build into two targets. Take a look at +the ``BUILD.bazel`` files in the ``tutorial/lib`` and ``tutorial/main`` +directories. The contents of both files could have been kept in +a single ``BUILD.bazel`` as follows:: + + haskell_library( + name = "booleans", + srcs = ["Bool.hs"], + ) + + haskell_toolchain_library(name = "base") + + haskell_binary( + name = "demorgan", + srcs = ["Main.hs"], + compiler_flags = ["-threaded"], + deps = [":base", ":booleans"], + ) + +With this single ``BUILD.bazel`` file, Bazel first builds the ``booleans`` +library (using the `haskell_library`_ rule), then the ``demorgan`` +binary (which as an example uses the ``booleans`` library to check one +of the De Morgan laws). The ``deps`` attribute in the ``demorgan`` +target tells Bazel that the ``:booleans`` library is required to build +the ``demorgan`` binary. The binary also requires the ``base`` +built-in library that ships with GHC, to perform I/O among other +things. Libraries like ``base``, ``bytestring`` and others that ship +with GHC are special in that they are prebuilt outside of Bazel. To +import them as regular targets, we use the `haskell_toolchain_library`_ rule. + +Let's build this new version of our project:: + + $ bazel build //main:demorgan + +Bazel produces output similar to the following:: + + INFO: Found 1 target... + Target //main:demorgan up-to-date: + bazel-bin/main/demorgan + INFO: Elapsed time: 2.728s, Critical Path: 1.23s + +Now test your freshly built binary:: + + $ bazel-bin/main/demorgan + +Or alternatively:: + + $ bazel run //main:demorgan + +If you now modify ``Bool.hs`` and rebuild the project, Bazel will +usually only recompile that file. + +Looking at the dependency graph: + +.. digraph:: demorgan + + node [shape=box]; + "//main:demorgan" + "//main:demorgan" -> "//main:base\n//main:Main.hs" + "//main:demorgan" -> "//lib:booleans" + "//lib:booleans" + "//lib:booleans" -> "//lib:Bool.hs" + "//lib:Bool.hs" + "//main:base\n//main:Main.hs" + +You have now built the project with two targets. The ``demorgan`` +target builds one source file and depends on one other target +(``//lib:booleans``), which builds one additional source file. + +Use multiple packages +^^^^^^^^^^^^^^^^^^^^^ + +Letโs now split the project into multiple packages. + +Notice that we actually have two sub-directories, and each contains +a ``BUILD.bazel`` file. Therefore, to Bazel, the workspace contains two +packages, ``lib`` and ``main``. + +Take a look at the ``lib/BUILD.bazel`` file:: + + haskell_library( + name = "booleans", + srcs = ["Bool.hs"], + visibility = ["//main:__pkg__"], + ) + +And at the ``main/BUILD.bazel`` file:: + + haskell_toolchain_library(name = "base") + + haskell_binary( + name = "demorgan", + srcs = ["Main.hs"], + compiler_flags = ["-threaded"], + deps = [":base", "//lib:booleans"], + ) + +As you can see, the ``demorgan`` target in the ``main`` package +depends on the ``booleans`` target in the ``lib`` package (hence the +target label ``//lib:booleans``) - Bazel knows this through the +``deps`` attribute. + +Notice that for the build to succeed, we make the ``//lib:booleans`` +target in ``lib/BUILD.bazel`` explicitly visible to targets in +``main/BUILD.bazel`` using the ``visibility`` attribute. This is because by +default targets are only visible to other targets in the same +``BUILD.bazel`` file. (Bazel uses target visibility to prevent issues such +as libraries containing implementation details leaking into public +APIs.) + +You have built the project as two packages with three targets and +understand the dependencies between them. + +Use labels to reference targets +------------------------------- + +In ``BUILD.bazel`` files and at the command line, Bazel uses *labels* to +reference targets - for example, ``//main:demorgan`` or +``//lib:booleans``. Their syntax is:: + + //path/to/package:target-name + +If the target is a rule target, then ``path/to/package`` is the path +to the directory containing the ``BUILD.bazel`` file, and ``target-name`` is +what you named the target in the ``BUILD.bazel`` file (the ``name`` +attribute). If the target is a file target, then ``path/to/package`` +is the path to the root of the package, and ``target-name`` is the +name of the target file, including its full path. + +When referencing targets within the same package, you can skip the +package path and just use ``//:target-name``. When referencing targets +within the same ``BUILD.bazel`` file, you can even skip the ``//`` workspace +root identifier and just use ``:target-name``. + +Further reading +--------------- + +Congratulations! You now know the basics of building a Haskell project +with Bazel. Next, read up on the most common :ref:`Common Haskell +build use cases <use-cases>`. Then, check out the following: + +* `External Dependencies`_ to learn more about working with local and + remote repositories. + +* The `Build Encyclopedia`_ to learn more about Bazel. + +* The `C++ build tutorial`_ to get started with building C++ + applications with Bazel. + +* The `Java build tutorial`_ to get started with building Java + applications with Bazel. + +* The `Android application tutorial`_ to get started with building + mobile applications for Android with Bazel. + +* The `iOS application tutorial`_ to get started with building mobile + applications for iOS with Bazel. + +Happy building! + +.. note:: This tutorial is adapted from the Bazel `C++ build tutorial`_. + +.. _install Bazel: https://docs.bazel.build/versions/master/install.html +.. _haskell_binary: http://api.haskell.build/haskell/haskell.html#haskell_binary +.. _haskell_toolchain_library: http://api.haskell.build/haskell/haskell.html#haskell_toolchain_library +.. _haskell_library: http://api.haskell.build/haskell/haskell.html#haskell_library +.. _graphviz: https://www.graphviz.org/ +.. _external dependencies: https://docs.bazel.build/versions/master/external.html +.. _build encyclopedia: https://docs.bazel.build/versions/master/be/overview.html +.. _C++ build tutorial: https://docs.bazel.build/versions/master/tutorial/cpp.html +.. _Java build tutorial: https://docs.bazel.build/versions/master/tutorial/java.html +.. _Android application tutorial: https://docs.bazel.build/versions/master/tutorial/android-app.html +.. _iOS application tutorial: https://docs.bazel.build/versions/master/tutorial/ios-app.html diff --git a/third_party/bazel/rules_haskell/docs/index.rst b/third_party/bazel/rules_haskell/docs/index.rst new file mode 100644 index 000000000000..f9292871ef55 --- /dev/null +++ b/third_party/bazel/rules_haskell/docs/index.rst @@ -0,0 +1,23 @@ +.. meta:: + :description: User guide for building Haskell code with Bazel. + +Build Haskell Using Bazel +========================= + +Bazel_ is a tool for automating the *building* and the *testing* of +software. Follow :ref:`this guide <guide>` to get started building +small Haskell projects using Bazel. For a deeper dive and solutions to +more advanced use cases, see :ref:`Common Haskell Build Use Cases +<use-cases>`. Refer to the `Bazel documentation`_ for more about +Bazel. + +.. toctree:: + :maxdepth: 2 + :caption: Contents: + + why-bazel + haskell + haskell-use-cases + +.. _Bazel: https://bazel.build +.. _Bazel documentation: https://docs.bazel.build/versions/master/getting-started.html diff --git a/third_party/bazel/rules_haskell/docs/why-bazel.rst b/third_party/bazel/rules_haskell/docs/why-bazel.rst new file mode 100644 index 000000000000..2ad4bc598be3 --- /dev/null +++ b/third_party/bazel/rules_haskell/docs/why-bazel.rst @@ -0,0 +1,102 @@ +.. _why-bazel: + +Is Bazel right for me? +====================== + +Nearly as many build tools exist as there are programming languages +out there. C++ has Autotools_/Make_, CMake_ and many others. Java has +Ant_, Maven_, Gradle_ and several more. Haskell has Cabal_, Stack_, +Shake_ and several more. Each of these originated in a given language +community but are in some cases generic enough to support building any +language. Are any of them the right choice for your use case? Should +you be combining several systems? That's what this document should +help you answer. + +Rule of thumb +------------- + +If a combination of the following apply, then you're better off using +Cabal_ or Stack_: + +* your project is an independently publishable single library, or + small set of libraries; +* your project is open source code and has at most small static + assets (hence publishable on Hackage); +* your project is nearly entirely Haskell code with perhaps a little + bit of C; +* your project has many dependencies on other packages found on + Hackage but few if any system dependencies (like zlib, libpng etc); + +Bazel works well for the following use cases: + +* projects that cannot be hosted on Hackage (games with large static + assets, proprietary code etc); +* projects with a very large amount of code hosted in a single + repository; +* projects in which you or your team are writing code in two or more + languages (e.g. Haskell/PureScript, or Haskell/Java, or + Haskell/C++/FORTRAN); + +Rationale +--------- + +For all the benefits it can bring, Bazel also has an upfront cost. +Don't pay that cost if the benefits don't justify it. + +If you don't have much code to build, any build tool will do. Build +issues like lack of complete reproducibility are comparatively easier +to debug, and working around build system bugs by wiping the entire +build cache first is entirely viable in this particular case. So might +as well use low-powered Haskell-native build tools that ship with GHC. +You won't *need* sandboxed build actions to guarantee build system +correctness, completely hermetic builds for good reproducibility, +build caching, test result caching or distributed builds for faster +build and test times. Those features start to matter for larger +projects, and become essential for very large monorepos_. + +Why exactly do these features matter? + +* **Hermetic builds** are builds that do not take any part of the + host's system configuration (set of installed system libraries and + their versions, content of ``/etc``, OS version, etc) as an input. + If all build actions are deterministic, hermeticity guarantees that + builds are reproducible anywhere, anytime. More developers on + a project means more subtly different system configurations to cope + with. The more system configurations, the more likely that the build + will fail in one of these configurations but not in others... Unless + the build is completely hermetic. +* **Sandboxing build actions** guarantees that all inputs to all build + actions are properly declared. This helps prevent build system + correctness bugs, which are surprisingly and exceedingly common in + most non-sandboxing build systems, especially as the build system + becomes more complex. When a build system *might* be incorrect, + users regularly have to wipe the entire build cache to work around + issues. As the codebase becomes very large, rebuilding from scratch + can cost a lot of CPU time. +* **Distributed build caches** make building the code from a fresh + checkout trivially fast. Continuous integration populates the build + cache at every branch push, so that building all artifacts from + fresh checkouts seldom needs to actually build anything at all + locally. In the common case, builds become network-bound instead of + CPU-bound. +* **Distributed build action execution** mean that average build times + can stay constant even as the codebase grows, because you can + seamlessly distribute the build on more machines. +* **Test result caching** is the key to keeping continuous + integration times very low. Only those tests that depend on code + that was modified need be rerun. + +On their own hermetic and sandboxed builds can already save quite +a few headaches. But crucially, without them one can't even hope to +have any of the other features that follow them above. + +.. _Autotools: https://en.wikipedia.org/wiki/GNU_Build_System +.. _Make: https://en.wikipedia.org/wiki/Make_(software) +.. _CMake: https://cmake.org/ +.. _Ant: https://ant.apache.org/ +.. _Maven: https://maven.apache.org/index.html +.. _Gradle: https://gradle.org/ +.. _Cabal: https://www.haskell.org/cabal/ +.. _Stack: http://haskellstack.org/ +.. _Shake: https://shakebuild.com/ +.. _monorepos: https://en.wikipedia.org/wiki/Monorepo diff --git a/third_party/bazel/rules_haskell/examples/.bazelrc b/third_party/bazel/rules_haskell/examples/.bazelrc new file mode 120000 index 000000000000..adb61980d232 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/.bazelrc @@ -0,0 +1 @@ +../.bazelrc \ No newline at end of file diff --git a/third_party/bazel/rules_haskell/examples/.gitignore b/third_party/bazel/rules_haskell/examples/.gitignore new file mode 100644 index 000000000000..a6ef824c1f83 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/.gitignore @@ -0,0 +1 @@ +/bazel-* diff --git a/third_party/bazel/rules_haskell/examples/BUILD.bazel b/third_party/bazel/rules_haskell/examples/BUILD.bazel new file mode 100644 index 000000000000..ff7445a2f7c3 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/BUILD.bazel @@ -0,0 +1,10 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_toolchain", +) + +haskell_toolchain( + name = "ghc", + tools = ["@ghc//:bin"], + version = "8.6.4", +) diff --git a/third_party/bazel/rules_haskell/examples/README.md b/third_party/bazel/rules_haskell/examples/README.md new file mode 100644 index 000000000000..7b477f547619 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/README.md @@ -0,0 +1,45 @@ +# rule_haskell examples + +Examples of using [rules_haskell][rules_haskell], the Bazel rule set +for building Haskell code. + +* [**vector:**](./vector/) shows how to build the `vector` package as + found on Hackage, using a Nix provided compiler toolchain. +* [**rts:**](./rts/) demonstrates foreign exports and shows how to + link against GHC's RTS library, i.e. `libHSrts.so`. + +## **Important** + +Run all commands from the root of `rules_haskell`. +If you `cd examples/`, bazel *will* [break on +you](https://github.com/tweag/rules_haskell/issues/740). +This is a current problem with bazel workspaces. + +## Root Workspace + +Build everything in the root workspace with; + +``` +$ bazel build @io_tweag_rules_haskell_examples//... +``` + +Show every target of the vector example; + +``` +$ bazel query @io_tweag_rules_haskell_examples//vector/... +@io_tweag_rules_haskell_examples//vector:vector +@io_tweag_rules_haskell_examples//vector:semigroups +@io_tweag_rules_haskell_examples//vector:primitive +@io_tweag_rules_haskell_examples//vector:ghc-prim +@io_tweag_rules_haskell_examples//vector:deepseq +@io_tweag_rules_haskell_examples//vector:base +``` + +Build the two main Haskell targets; + +``` +$ bazel build @io_tweag_rules_haskell_examples//vector +$ bazel build @io_tweag_rules_haskell_examples//rts:add-one-hs +``` + +[rules_haskell]: https://github.com/tweag/rules_haskell diff --git a/third_party/bazel/rules_haskell/examples/WORKSPACE b/third_party/bazel/rules_haskell/examples/WORKSPACE new file mode 100644 index 000000000000..1e99f221190a --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/WORKSPACE @@ -0,0 +1,58 @@ +workspace(name = "io_tweag_rules_haskell_examples") + +local_repository( + name = "io_tweag_rules_haskell", + path = "..", +) + +load("@bazel_tools//tools/build_defs/repo:http.bzl", "http_archive") +load("@io_tweag_rules_haskell//haskell:repositories.bzl", "haskell_repositories") + +haskell_repositories() + +rules_nixpkgs_version = "0.5.2" + +http_archive( + name = "io_tweag_rules_nixpkgs", + sha256 = "5a384daa57b49abf9f0b672852f1a66a3c52aecf9d4d2ac64f6de0fd307690c8", + strip_prefix = "rules_nixpkgs-%s" % rules_nixpkgs_version, + urls = ["https://github.com/tweag/rules_nixpkgs/archive/v%s.tar.gz" % rules_nixpkgs_version], +) + +load( + "@io_tweag_rules_nixpkgs//nixpkgs:nixpkgs.bzl", + "nixpkgs_cc_configure", + "nixpkgs_package", +) + +# For the rts example. +nixpkgs_package( + name = "ghc", + attribute_path = "haskellPackages.ghc", + build_file = "@io_tweag_rules_haskell//haskell:ghc.BUILD", + repository = "@io_tweag_rules_haskell//nixpkgs:default.nix", +) + +nixpkgs_cc_configure( + nix_file = "@io_tweag_rules_haskell//nixpkgs:cc-toolchain.nix", + repository = "@io_tweag_rules_haskell//nixpkgs:default.nix", +) + +load( + "@io_tweag_rules_haskell//haskell:nixpkgs.bzl", + "haskell_register_ghc_nixpkgs", +) + +haskell_register_ghc_nixpkgs( + repositories = { + "nixpkgs": "@io_tweag_rules_haskell//nixpkgs:default.nix", + }, + version = "8.6.4", +) + +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_register_ghc_bindists", +) + +haskell_register_ghc_bindists(version = "8.6.4") diff --git a/third_party/bazel/rules_haskell/examples/primitive/BUILD.bazel b/third_party/bazel/rules_haskell/examples/primitive/BUILD.bazel new file mode 100644 index 000000000000..798e55f29be7 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/BUILD.bazel @@ -0,0 +1,33 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_cc_import", + "haskell_library", + "haskell_toolchain_library", +) + +haskell_toolchain_library(name = "base") + +haskell_toolchain_library(name = "ghc-prim") + +cc_library( + name = "memops", + srcs = ["cbits/primitive-memops.c"], + hdrs = ["cbits/primitive-memops.h"], + deps = ["@ghc//:threaded-rts"], +) + +haskell_library( + name = "primitive", + srcs = glob([ + "Data/**/*.hs", + "Control/**/*.hs", + ]), + version = "0", + visibility = ["//visibility:public"], + deps = [ + ":base", + ":ghc-prim", + ":memops", + "//transformers", + ], +) diff --git a/third_party/bazel/rules_haskell/examples/primitive/Control/Monad/Primitive.hs b/third_party/bazel/rules_haskell/examples/primitive/Control/Monad/Primitive.hs new file mode 100644 index 000000000000..f182c18b086b --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Control/Monad/Primitive.hs @@ -0,0 +1,298 @@ +{-# LANGUAGE CPP, MagicHash, UnboxedTuples, TypeFamilies #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} + +-- | +-- Module : Control.Monad.Primitive +-- Copyright : (c) Roman Leshchinskiy 2009 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> +-- Portability : non-portable +-- +-- Primitive state-transformer monads +-- + +module Control.Monad.Primitive ( + PrimMonad(..), RealWorld, primitive_, + PrimBase(..), + liftPrim, primToPrim, primToIO, primToST, ioToPrim, stToPrim, + unsafePrimToPrim, unsafePrimToIO, unsafePrimToST, unsafeIOToPrim, + unsafeSTToPrim, unsafeInlinePrim, unsafeInlineIO, unsafeInlineST, + touch, evalPrim +) where + +import GHC.Prim ( State#, RealWorld, touch# ) +import GHC.Base ( unsafeCoerce#, realWorld# ) +#if MIN_VERSION_base(4,4,0) +import GHC.Base ( seq# ) +#else +import Control.Exception (evaluate) +#endif +#if MIN_VERSION_base(4,2,0) +import GHC.IO ( IO(..) ) +#else +import GHC.IOBase ( IO(..) ) +#endif +import GHC.ST ( ST(..) ) + +import Control.Monad.Trans.Class (lift) +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid (Monoid) +#endif + +import Control.Monad.Trans.Cont ( ContT ) +import Control.Monad.Trans.Identity ( IdentityT (IdentityT) ) +import Control.Monad.Trans.List ( ListT ) +import Control.Monad.Trans.Maybe ( MaybeT ) +import Control.Monad.Trans.Error ( ErrorT, Error) +import Control.Monad.Trans.Reader ( ReaderT ) +import Control.Monad.Trans.State ( StateT ) +import Control.Monad.Trans.Writer ( WriterT ) +import Control.Monad.Trans.RWS ( RWST ) + +#if MIN_VERSION_transformers(0,4,0) +import Control.Monad.Trans.Except ( ExceptT ) +#endif + +#if MIN_VERSION_transformers(0,5,3) +import Control.Monad.Trans.Accum ( AccumT ) +import Control.Monad.Trans.Select ( SelectT ) +#endif + +import qualified Control.Monad.Trans.RWS.Strict as Strict ( RWST ) +import qualified Control.Monad.Trans.State.Strict as Strict ( StateT ) +import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT ) + +-- | Class of monads which can perform primitive state-transformer actions +class Monad m => PrimMonad m where + -- | State token type + type PrimState m + + -- | Execute a primitive operation + primitive :: (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a + +-- | Class of primitive monads for state-transformer actions. +-- +-- Unlike 'PrimMonad', this typeclass requires that the @Monad@ be fully +-- expressed as a state transformer, therefore disallowing other monad +-- transformers on top of the base @IO@ or @ST@. +-- +-- @since 0.6.0.0 +class PrimMonad m => PrimBase m where + -- | Expose the internal structure of the monad + internal :: m a -> State# (PrimState m) -> (# State# (PrimState m), a #) + +-- | Execute a primitive operation with no result +primitive_ :: PrimMonad m + => (State# (PrimState m) -> State# (PrimState m)) -> m () +{-# INLINE primitive_ #-} +primitive_ f = primitive (\s# -> + case f s# of + s'# -> (# s'#, () #)) + +instance PrimMonad IO where + type PrimState IO = RealWorld + primitive = IO + {-# INLINE primitive #-} +instance PrimBase IO where + internal (IO p) = p + {-# INLINE internal #-} + +-- | @since 0.6.3.0 +instance PrimMonad m => PrimMonad (ContT r m) where + type PrimState (ContT r m) = PrimState m + primitive = lift . primitive + {-# INLINE primitive #-} + +instance PrimMonad m => PrimMonad (IdentityT m) where + type PrimState (IdentityT m) = PrimState m + primitive = lift . primitive + {-# INLINE primitive #-} + +-- | @since 0.6.2.0 +instance PrimBase m => PrimBase (IdentityT m) where + internal (IdentityT m) = internal m + {-# INLINE internal #-} + +instance PrimMonad m => PrimMonad (ListT m) where + type PrimState (ListT m) = PrimState m + primitive = lift . primitive + {-# INLINE primitive #-} + +instance PrimMonad m => PrimMonad (MaybeT m) where + type PrimState (MaybeT m) = PrimState m + primitive = lift . primitive + {-# INLINE primitive #-} + +instance (Error e, PrimMonad m) => PrimMonad (ErrorT e m) where + type PrimState (ErrorT e m) = PrimState m + primitive = lift . primitive + {-# INLINE primitive #-} + +instance PrimMonad m => PrimMonad (ReaderT r m) where + type PrimState (ReaderT r m) = PrimState m + primitive = lift . primitive + {-# INLINE primitive #-} + +instance PrimMonad m => PrimMonad (StateT s m) where + type PrimState (StateT s m) = PrimState m + primitive = lift . primitive + {-# INLINE primitive #-} + +instance (Monoid w, PrimMonad m) => PrimMonad (WriterT w m) where + type PrimState (WriterT w m) = PrimState m + primitive = lift . primitive + {-# INLINE primitive #-} + +instance (Monoid w, PrimMonad m) => PrimMonad (RWST r w s m) where + type PrimState (RWST r w s m) = PrimState m + primitive = lift . primitive + {-# INLINE primitive #-} + +#if MIN_VERSION_transformers(0,4,0) +instance PrimMonad m => PrimMonad (ExceptT e m) where + type PrimState (ExceptT e m) = PrimState m + primitive = lift . primitive + {-# INLINE primitive #-} +#endif + +#if MIN_VERSION_transformers(0,5,3) +-- | @since 0.6.3.0 +instance ( Monoid w + , PrimMonad m +# if !(MIN_VERSION_base(4,8,0)) + , Functor m +# endif + ) => PrimMonad (AccumT w m) where + type PrimState (AccumT w m) = PrimState m + primitive = lift . primitive + {-# INLINE primitive #-} +instance PrimMonad m => PrimMonad (SelectT r m) where + type PrimState (SelectT r m) = PrimState m + primitive = lift . primitive + {-# INLINE primitive #-} +#endif + +instance PrimMonad m => PrimMonad (Strict.StateT s m) where + type PrimState (Strict.StateT s m) = PrimState m + primitive = lift . primitive + {-# INLINE primitive #-} + +instance (Monoid w, PrimMonad m) => PrimMonad (Strict.WriterT w m) where + type PrimState (Strict.WriterT w m) = PrimState m + primitive = lift . primitive + {-# INLINE primitive #-} + +instance (Monoid w, PrimMonad m) => PrimMonad (Strict.RWST r w s m) where + type PrimState (Strict.RWST r w s m) = PrimState m + primitive = lift . primitive + {-# INLINE primitive #-} + +instance PrimMonad (ST s) where + type PrimState (ST s) = s + primitive = ST + {-# INLINE primitive #-} +instance PrimBase (ST s) where + internal (ST p) = p + {-# INLINE internal #-} + +-- | Lifts a 'PrimBase' into another 'PrimMonad' with the same underlying state +-- token type. +liftPrim + :: (PrimBase m1, PrimMonad m2, PrimState m1 ~ PrimState m2) => m1 a -> m2 a +{-# INLINE liftPrim #-} +liftPrim = primToPrim + +-- | Convert a 'PrimBase' to another monad with the same state token. +primToPrim :: (PrimBase m1, PrimMonad m2, PrimState m1 ~ PrimState m2) + => m1 a -> m2 a +{-# INLINE primToPrim #-} +primToPrim m = primitive (internal m) + +-- | Convert a 'PrimBase' with a 'RealWorld' state token to 'IO' +primToIO :: (PrimBase m, PrimState m ~ RealWorld) => m a -> IO a +{-# INLINE primToIO #-} +primToIO = primToPrim + +-- | Convert a 'PrimBase' to 'ST' +primToST :: PrimBase m => m a -> ST (PrimState m) a +{-# INLINE primToST #-} +primToST = primToPrim + +-- | Convert an 'IO' action to a 'PrimMonad'. +-- +-- @since 0.6.2.0 +ioToPrim :: (PrimMonad m, PrimState m ~ RealWorld) => IO a -> m a +{-# INLINE ioToPrim #-} +ioToPrim = primToPrim + +-- | Convert an 'ST' action to a 'PrimMonad'. +-- +-- @since 0.6.2.0 +stToPrim :: PrimMonad m => ST (PrimState m) a -> m a +{-# INLINE stToPrim #-} +stToPrim = primToPrim + +-- | Convert a 'PrimBase' to another monad with a possibly different state +-- token. This operation is highly unsafe! +unsafePrimToPrim :: (PrimBase m1, PrimMonad m2) => m1 a -> m2 a +{-# INLINE unsafePrimToPrim #-} +unsafePrimToPrim m = primitive (unsafeCoerce# (internal m)) + +-- | Convert any 'PrimBase' to 'ST' with an arbitrary state token. This +-- operation is highly unsafe! +unsafePrimToST :: PrimBase m => m a -> ST s a +{-# INLINE unsafePrimToST #-} +unsafePrimToST = unsafePrimToPrim + +-- | Convert any 'PrimBase' to 'IO'. This operation is highly unsafe! +unsafePrimToIO :: PrimBase m => m a -> IO a +{-# INLINE unsafePrimToIO #-} +unsafePrimToIO = unsafePrimToPrim + +-- | Convert an 'ST' action with an arbitraty state token to any 'PrimMonad'. +-- This operation is highly unsafe! +-- +-- @since 0.6.2.0 +unsafeSTToPrim :: PrimMonad m => ST s a -> m a +{-# INLINE unsafeSTToPrim #-} +unsafeSTToPrim = unsafePrimToPrim + +-- | Convert an 'IO' action to any 'PrimMonad'. This operation is highly +-- unsafe! +-- +-- @since 0.6.2.0 +unsafeIOToPrim :: PrimMonad m => IO a -> m a +{-# INLINE unsafeIOToPrim #-} +unsafeIOToPrim = unsafePrimToPrim + +unsafeInlinePrim :: PrimBase m => m a -> a +{-# INLINE unsafeInlinePrim #-} +unsafeInlinePrim m = unsafeInlineIO (unsafePrimToIO m) + +unsafeInlineIO :: IO a -> a +{-# INLINE unsafeInlineIO #-} +unsafeInlineIO m = case internal m realWorld# of (# _, r #) -> r + +unsafeInlineST :: ST s a -> a +{-# INLINE unsafeInlineST #-} +unsafeInlineST = unsafeInlinePrim + +touch :: PrimMonad m => a -> m () +{-# INLINE touch #-} +touch x = unsafePrimToPrim + $ (primitive (\s -> case touch# x s of { s' -> (# s', () #) }) :: IO ()) + +-- | Create an action to force a value; generalizes 'Control.Exception.evaluate' +-- +-- @since 0.6.2.0 +evalPrim :: forall a m . PrimMonad m => a -> m a +#if MIN_VERSION_base(4,4,0) +evalPrim a = primitive (\s -> seq# a s) +#else +-- This may or may not work so well, but there's probably nothing better to do. +{-# NOINLINE evalPrim #-} +evalPrim a = unsafePrimToPrim (evaluate a :: IO a) +#endif diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive.hs new file mode 100644 index 000000000000..db545ed81514 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE MagicHash #-} +{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} +-- | +-- Module : Data.Primitive +-- Copyright : (c) Roman Leshchinskiy 2009-2012 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> +-- Portability : non-portable +-- +-- Reexports all primitive operations +-- +module Data.Primitive ( + -- * Re-exports + module Data.Primitive.Types + ,module Data.Primitive.Array + ,module Data.Primitive.ByteArray + ,module Data.Primitive.Addr + ,module Data.Primitive.SmallArray + ,module Data.Primitive.UnliftedArray + ,module Data.Primitive.PrimArray + ,module Data.Primitive.MutVar + -- * Naming Conventions + -- $namingConventions +) where + +import Data.Primitive.Types +import Data.Primitive.Array +import Data.Primitive.ByteArray +import Data.Primitive.Addr +import Data.Primitive.SmallArray +import Data.Primitive.UnliftedArray +import Data.Primitive.PrimArray +import Data.Primitive.MutVar + +{- $namingConventions +For historical reasons, this library embraces the practice of suffixing +the name of a function with the type it operates on. For example, three +of the variants of the array indexing function are: + +> indexArray :: Array a -> Int -> a +> indexSmallArray :: SmallArray a -> Int -> a +> indexPrimArray :: Prim a => PrimArray a -> Int -> a + +In a few places, where the language sounds more natural, the array type +is instead used as a prefix. For example, @Data.Primitive.SmallArray@ +exports @smallArrayFromList@, which would sound unnatural if it used +@SmallArray@ as a suffix instead. + +This library provides several functions traversing, building, and filtering +arrays. These functions are suffixed with an additional character to +indicate their the nature of their effectfulness: + +* No suffix: A non-effectful pass over the array. +* @-A@ suffix: An effectful pass over the array, where the effect is 'Applicative'. +* @-P@ suffix: An effectful pass over the array, where the effect is 'PrimMonad'. + +Additionally, an apostrophe can be used to indicate strictness in the elements. +The variants with an apostrophe are used in @Data.Primitive.Array@ but not +in @Data.Primitive.PrimArray@ since the array type it provides is always strict in the element. +For example, there are three variants of the function that filters elements +from a primitive array. + +> filterPrimArray :: (Prim a ) => (a -> Bool) -> PrimArray a -> PrimArray a +> filterPrimArrayA :: (Prim a, Applicative f) => (a -> f Bool) -> PrimArray a -> f (PrimArray a) +> filterPrimArrayP :: (Prim a, PrimMonad m) => (a -> m Bool) -> PrimArray a -> m (PrimArray a) + +As long as the effectful context is a monad that is sufficiently affine +the behaviors of the 'Applicative' and 'PrimMonad' variants produce the same results +and differ only in their strictness. Monads that are sufficiently affine +include: + +* 'IO' and 'ST' +* Any combination of 'MaybeT', 'ExceptT', 'StateT' and 'Writer' on top + of another sufficiently affine monad. + +There is one situation where the names deviate from effectful suffix convention +described above. Throughout the haskell ecosystem, the 'Applicative' variant of +'map' is known as 'traverse', not @mapA@. Consequently, we adopt the following +naming convention for mapping: + +> mapPrimArray :: (Prim a, Prim b) => (a -> b) -> PrimArray a -> PrimArray b +> traversePrimArray :: (Applicative f, Prim a, Prim b) => (a -> f b) -> PrimArray a -> f (PrimArray b) +> traversePrimArrayP :: (PrimMonad m, Prim a, Prim b) => (a -> m b) -> PrimArray a -> m (PrimArray b) +-} diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Addr.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Addr.hs new file mode 100644 index 000000000000..2ff25005c6aa --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Addr.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE MagicHash, UnboxedTuples, CPP #-} + +-- | +-- Module : Data.Primitive.Addr +-- Copyright : (c) Roman Leshchinskiy 2009-2012 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> +-- Portability : non-portable +-- +-- Primitive operations on machine addresses +-- + +module Data.Primitive.Addr ( + -- * Types + Addr(..), + + -- * Address arithmetic + nullAddr, plusAddr, minusAddr, remAddr, + + -- * Element access + indexOffAddr, readOffAddr, writeOffAddr, + + -- * Block operations + copyAddr, +#if __GLASGOW_HASKELL__ >= 708 + copyAddrToByteArray, +#endif + moveAddr, setAddr, + + -- * Conversion + addrToInt +) where + +import Control.Monad.Primitive +import Data.Primitive.Types +#if __GLASGOW_HASKELL__ >= 708 +import Data.Primitive.ByteArray +#endif + +import GHC.Base ( Int(..) ) +import GHC.Prim + +import GHC.Ptr +import Foreign.Marshal.Utils + + +-- | The null address +nullAddr :: Addr +nullAddr = Addr nullAddr# + +infixl 6 `plusAddr`, `minusAddr` +infixl 7 `remAddr` + +-- | Offset an address by the given number of bytes +plusAddr :: Addr -> Int -> Addr +plusAddr (Addr a#) (I# i#) = Addr (plusAddr# a# i#) + +-- | Distance in bytes between two addresses. The result is only valid if the +-- difference fits in an 'Int'. +minusAddr :: Addr -> Addr -> Int +minusAddr (Addr a#) (Addr b#) = I# (minusAddr# a# b#) + +-- | The remainder of the address and the integer. +remAddr :: Addr -> Int -> Int +remAddr (Addr a#) (I# i#) = I# (remAddr# a# i#) + +-- | Read a value from a memory position given by an address and an offset. +-- The memory block the address refers to must be immutable. The offset is in +-- elements of type @a@ rather than in bytes. +indexOffAddr :: Prim a => Addr -> Int -> a +{-# INLINE indexOffAddr #-} +indexOffAddr (Addr addr#) (I# i#) = indexOffAddr# addr# i# + +-- | Read a value from a memory position given by an address and an offset. +-- The offset is in elements of type @a@ rather than in bytes. +readOffAddr :: (Prim a, PrimMonad m) => Addr -> Int -> m a +{-# INLINE readOffAddr #-} +readOffAddr (Addr addr#) (I# i#) = primitive (readOffAddr# addr# i#) + +-- | Write a value to a memory position given by an address and an offset. +-- The offset is in elements of type @a@ rather than in bytes. +writeOffAddr :: (Prim a, PrimMonad m) => Addr -> Int -> a -> m () +{-# INLINE writeOffAddr #-} +writeOffAddr (Addr addr#) (I# i#) x = primitive_ (writeOffAddr# addr# i# x) + +-- | Copy the given number of bytes from the second 'Addr' to the first. The +-- areas may not overlap. +copyAddr :: PrimMonad m => Addr -- ^ destination address + -> Addr -- ^ source address + -> Int -- ^ number of bytes + -> m () +{-# INLINE copyAddr #-} +copyAddr (Addr dst#) (Addr src#) n + = unsafePrimToPrim $ copyBytes (Ptr dst#) (Ptr src#) n + +#if __GLASGOW_HASKELL__ >= 708 +-- | Copy the given number of bytes from the 'Addr' to the 'MutableByteArray'. +-- The areas may not overlap. This function is only available when compiling +-- with GHC 7.8 or newer. +-- +-- @since 0.6.4.0 +copyAddrToByteArray :: PrimMonad m + => MutableByteArray (PrimState m) -- ^ destination + -> Int -- ^ offset into the destination array + -> Addr -- ^ source + -> Int -- ^ number of bytes to copy + -> m () +{-# INLINE copyAddrToByteArray #-} +copyAddrToByteArray (MutableByteArray marr) (I# off) (Addr addr) (I# len) = + primitive_ $ copyAddrToByteArray# addr marr off len +#endif + +-- | Copy the given number of bytes from the second 'Addr' to the first. The +-- areas may overlap. +moveAddr :: PrimMonad m => Addr -- ^ destination address + -> Addr -- ^ source address + -> Int -- ^ number of bytes + -> m () +{-# INLINE moveAddr #-} +moveAddr (Addr dst#) (Addr src#) n + = unsafePrimToPrim $ moveBytes (Ptr dst#) (Ptr src#) n + +-- | Fill a memory block of with the given value. The length is in +-- elements of type @a@ rather than in bytes. +setAddr :: (Prim a, PrimMonad m) => Addr -> Int -> a -> m () +{-# INLINE setAddr #-} +setAddr (Addr addr#) (I# n#) x = primitive_ (setOffAddr# addr# 0# n# x) + +-- | Convert an 'Addr' to an 'Int'. +addrToInt :: Addr -> Int +{-# INLINE addrToInt #-} +addrToInt (Addr addr#) = I# (addr2Int# addr#) diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Array.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Array.hs new file mode 100644 index 000000000000..13352f6cb444 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Array.hs @@ -0,0 +1,822 @@ +{-# LANGUAGE CPP, MagicHash, UnboxedTuples, DeriveDataTypeable, BangPatterns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Data.Primitive.Array +-- Copyright : (c) Roman Leshchinskiy 2009-2012 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> +-- Portability : non-portable +-- +-- Primitive arrays of boxed values. +-- + +module Data.Primitive.Array ( + Array(..), MutableArray(..), + + newArray, readArray, writeArray, indexArray, indexArrayM, indexArray##, + freezeArray, thawArray, runArray, + unsafeFreezeArray, unsafeThawArray, sameMutableArray, + copyArray, copyMutableArray, + cloneArray, cloneMutableArray, + sizeofArray, sizeofMutableArray, + fromListN, fromList, + mapArray', + traverseArrayP +) where + +import Control.Monad.Primitive + +import GHC.Base ( Int(..) ) +import GHC.Prim +import qualified GHC.Exts as Exts +#if (MIN_VERSION_base(4,7,0)) +import GHC.Exts (fromListN, fromList) +#endif + +import Data.Typeable ( Typeable ) +import Data.Data + (Data(..), DataType, mkDataType, Constr, mkConstr, Fixity(..), constrIndex) +import Data.Primitive.Internal.Compat ( isTrue#, mkNoRepType ) + +import Control.Monad.ST(ST,runST) + +import Control.Applicative +import Control.Monad (MonadPlus(..), when) +import Control.Monad.Fix +#if MIN_VERSION_base(4,4,0) +import Control.Monad.Zip +#endif +import Data.Foldable (Foldable(..), toList) +#if !(MIN_VERSION_base(4,8,0)) +import Data.Traversable (Traversable(..)) +import Data.Monoid +#endif +#if MIN_VERSION_base(4,9,0) +import qualified GHC.ST as GHCST +import qualified Data.Foldable as F +import Data.Semigroup +#endif +#if MIN_VERSION_base(4,8,0) +import Data.Functor.Identity +#endif +#if MIN_VERSION_base(4,10,0) +import GHC.Exts (runRW#) +#elif MIN_VERSION_base(4,9,0) +import GHC.Base (runRW#) +#endif + +import Text.ParserCombinators.ReadP + +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) +import Data.Functor.Classes (Eq1(..),Ord1(..),Show1(..),Read1(..)) +#endif + +-- | Boxed arrays +data Array a = Array + { array# :: Array# a } + deriving ( Typeable ) + +-- | Mutable boxed arrays associated with a primitive state token. +data MutableArray s a = MutableArray + { marray# :: MutableArray# s a } + deriving ( Typeable ) + +sizeofArray :: Array a -> Int +sizeofArray a = I# (sizeofArray# (array# a)) +{-# INLINE sizeofArray #-} + +sizeofMutableArray :: MutableArray s a -> Int +sizeofMutableArray a = I# (sizeofMutableArray# (marray# a)) +{-# INLINE sizeofMutableArray #-} + +-- | Create a new mutable array of the specified size and initialise all +-- elements with the given value. +newArray :: PrimMonad m => Int -> a -> m (MutableArray (PrimState m) a) +{-# INLINE newArray #-} +newArray (I# n#) x = primitive + (\s# -> case newArray# n# x s# of + (# s'#, arr# #) -> + let ma = MutableArray arr# + in (# s'# , ma #)) + +-- | Read a value from the array at the given index. +readArray :: PrimMonad m => MutableArray (PrimState m) a -> Int -> m a +{-# INLINE readArray #-} +readArray arr (I# i#) = primitive (readArray# (marray# arr) i#) + +-- | Write a value to the array at the given index. +writeArray :: PrimMonad m => MutableArray (PrimState m) a -> Int -> a -> m () +{-# INLINE writeArray #-} +writeArray arr (I# i#) x = primitive_ (writeArray# (marray# arr) i# x) + +-- | Read a value from the immutable array at the given index. +indexArray :: Array a -> Int -> a +{-# INLINE indexArray #-} +indexArray arr (I# i#) = case indexArray# (array# arr) i# of (# x #) -> x + +-- | Read a value from the immutable array at the given index, returning +-- the result in an unboxed unary tuple. This is currently used to implement +-- folds. +indexArray## :: Array a -> Int -> (# a #) +indexArray## arr (I# i) = indexArray# (array# arr) i +{-# INLINE indexArray## #-} + +-- | Monadically read a value from the immutable array at the given index. +-- This allows us to be strict in the array while remaining lazy in the read +-- element which is very useful for collective operations. Suppose we want to +-- copy an array. We could do something like this: +-- +-- > copy marr arr ... = do ... +-- > writeArray marr i (indexArray arr i) ... +-- > ... +-- +-- But since primitive arrays are lazy, the calls to 'indexArray' will not be +-- evaluated. Rather, @marr@ will be filled with thunks each of which would +-- retain a reference to @arr@. This is definitely not what we want! +-- +-- With 'indexArrayM', we can instead write +-- +-- > copy marr arr ... = do ... +-- > x <- indexArrayM arr i +-- > writeArray marr i x +-- > ... +-- +-- Now, indexing is executed immediately although the returned element is +-- still not evaluated. +-- +indexArrayM :: Monad m => Array a -> Int -> m a +{-# INLINE indexArrayM #-} +indexArrayM arr (I# i#) + = case indexArray# (array# arr) i# of (# x #) -> return x + +-- | Create an immutable copy of a slice of an array. +-- +-- This operation makes a copy of the specified section, so it is safe to +-- continue using the mutable array afterward. +freezeArray + :: PrimMonad m + => MutableArray (PrimState m) a -- ^ source + -> Int -- ^ offset + -> Int -- ^ length + -> m (Array a) +{-# INLINE freezeArray #-} +freezeArray (MutableArray ma#) (I# off#) (I# len#) = + primitive $ \s -> case freezeArray# ma# off# len# s of + (# s', a# #) -> (# s', Array a# #) + +-- | Convert a mutable array to an immutable one without copying. The +-- array should not be modified after the conversion. +unsafeFreezeArray :: PrimMonad m => MutableArray (PrimState m) a -> m (Array a) +{-# INLINE unsafeFreezeArray #-} +unsafeFreezeArray arr + = primitive (\s# -> case unsafeFreezeArray# (marray# arr) s# of + (# s'#, arr'# #) -> + let a = Array arr'# + in (# s'#, a #)) + +-- | Create a mutable array from a slice of an immutable array. +-- +-- This operation makes a copy of the specified slice, so it is safe to use the +-- immutable array afterward. +thawArray + :: PrimMonad m + => Array a -- ^ source + -> Int -- ^ offset + -> Int -- ^ length + -> m (MutableArray (PrimState m) a) +{-# INLINE thawArray #-} +thawArray (Array a#) (I# off#) (I# len#) = + primitive $ \s -> case thawArray# a# off# len# s of + (# s', ma# #) -> (# s', MutableArray ma# #) + +-- | Convert an immutable array to an mutable one without copying. The +-- immutable array should not be used after the conversion. +unsafeThawArray :: PrimMonad m => Array a -> m (MutableArray (PrimState m) a) +{-# INLINE unsafeThawArray #-} +unsafeThawArray a + = primitive (\s# -> case unsafeThawArray# (array# a) s# of + (# s'#, arr'# #) -> + let ma = MutableArray arr'# + in (# s'#, ma #)) + +-- | Check whether the two arrays refer to the same memory block. +sameMutableArray :: MutableArray s a -> MutableArray s a -> Bool +{-# INLINE sameMutableArray #-} +sameMutableArray arr brr + = isTrue# (sameMutableArray# (marray# arr) (marray# brr)) + +-- | Copy a slice of an immutable array to a mutable array. +copyArray :: PrimMonad m + => MutableArray (PrimState m) a -- ^ destination array + -> Int -- ^ offset into destination array + -> Array a -- ^ source array + -> Int -- ^ offset into source array + -> Int -- ^ number of elements to copy + -> m () +{-# INLINE copyArray #-} +#if __GLASGOW_HASKELL__ > 706 +-- NOTE: copyArray# and copyMutableArray# are slightly broken in GHC 7.6.* and earlier +copyArray (MutableArray dst#) (I# doff#) (Array src#) (I# soff#) (I# len#) + = primitive_ (copyArray# src# soff# dst# doff# len#) +#else +copyArray !dst !doff !src !soff !len = go 0 + where + go i | i < len = do + x <- indexArrayM src (soff+i) + writeArray dst (doff+i) x + go (i+1) + | otherwise = return () +#endif + +-- | Copy a slice of a mutable array to another array. The two arrays may +-- not be the same. +copyMutableArray :: PrimMonad m + => MutableArray (PrimState m) a -- ^ destination array + -> Int -- ^ offset into destination array + -> MutableArray (PrimState m) a -- ^ source array + -> Int -- ^ offset into source array + -> Int -- ^ number of elements to copy + -> m () +{-# INLINE copyMutableArray #-} +#if __GLASGOW_HASKELL__ >= 706 +-- NOTE: copyArray# and copyMutableArray# are slightly broken in GHC 7.6.* and earlier +copyMutableArray (MutableArray dst#) (I# doff#) + (MutableArray src#) (I# soff#) (I# len#) + = primitive_ (copyMutableArray# src# soff# dst# doff# len#) +#else +copyMutableArray !dst !doff !src !soff !len = go 0 + where + go i | i < len = do + x <- readArray src (soff+i) + writeArray dst (doff+i) x + go (i+1) + | otherwise = return () +#endif + +-- | Return a newly allocated Array with the specified subrange of the +-- provided Array. The provided Array should contain the full subrange +-- specified by the two Ints, but this is not checked. +cloneArray :: Array a -- ^ source array + -> Int -- ^ offset into destination array + -> Int -- ^ number of elements to copy + -> Array a +{-# INLINE cloneArray #-} +cloneArray (Array arr#) (I# off#) (I# len#) + = case cloneArray# arr# off# len# of arr'# -> Array arr'# + +-- | Return a newly allocated MutableArray. with the specified subrange of +-- the provided MutableArray. The provided MutableArray should contain the +-- full subrange specified by the two Ints, but this is not checked. +cloneMutableArray :: PrimMonad m + => MutableArray (PrimState m) a -- ^ source array + -> Int -- ^ offset into destination array + -> Int -- ^ number of elements to copy + -> m (MutableArray (PrimState m) a) +{-# INLINE cloneMutableArray #-} +cloneMutableArray (MutableArray arr#) (I# off#) (I# len#) = primitive + (\s# -> case cloneMutableArray# arr# off# len# s# of + (# s'#, arr'# #) -> (# s'#, MutableArray arr'# #)) + +emptyArray :: Array a +emptyArray = + runST $ newArray 0 (die "emptyArray" "impossible") >>= unsafeFreezeArray +{-# NOINLINE emptyArray #-} + +#if !MIN_VERSION_base(4,9,0) +createArray + :: Int + -> a + -> (forall s. MutableArray s a -> ST s ()) + -> Array a +createArray 0 _ _ = emptyArray +createArray n x f = runArray $ do + mary <- newArray n x + f mary + pure mary + +runArray + :: (forall s. ST s (MutableArray s a)) + -> Array a +runArray m = runST $ m >>= unsafeFreezeArray + +#else /* Below, runRW# is available. */ + +-- This low-level business is designed to work with GHC's worker-wrapper +-- transformation. A lot of the time, we don't actually need an Array +-- constructor. By putting it on the outside, and being careful about +-- how we special-case the empty array, we can make GHC smarter about this. +-- The only downside is that separately created 0-length arrays won't share +-- their Array constructors, although they'll share their underlying +-- Array#s. +createArray + :: Int + -> a + -> (forall s. MutableArray s a -> ST s ()) + -> Array a +createArray 0 _ _ = Array (emptyArray# (# #)) +createArray n x f = runArray $ do + mary <- newArray n x + f mary + pure mary + +runArray + :: (forall s. ST s (MutableArray s a)) + -> Array a +runArray m = Array (runArray# m) + +runArray# + :: (forall s. ST s (MutableArray s a)) + -> Array# a +runArray# m = case runRW# $ \s -> + case unST m s of { (# s', MutableArray mary# #) -> + unsafeFreezeArray# mary# s'} of (# _, ary# #) -> ary# + +unST :: ST s a -> State# s -> (# State# s, a #) +unST (GHCST.ST f) = f + +emptyArray# :: (# #) -> Array# a +emptyArray# _ = case emptyArray of Array ar -> ar +{-# NOINLINE emptyArray# #-} +#endif + + +die :: String -> String -> a +die fun problem = error $ "Data.Primitive.Array." ++ fun ++ ": " ++ problem + +arrayLiftEq :: (a -> b -> Bool) -> Array a -> Array b -> Bool +arrayLiftEq p a1 a2 = sizeofArray a1 == sizeofArray a2 && loop (sizeofArray a1 - 1) + where loop i | i < 0 = True + | (# x1 #) <- indexArray## a1 i + , (# x2 #) <- indexArray## a2 i + , otherwise = p x1 x2 && loop (i-1) + +instance Eq a => Eq (Array a) where + a1 == a2 = arrayLiftEq (==) a1 a2 + +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) +-- | @since 0.6.4.0 +instance Eq1 Array where +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) + liftEq = arrayLiftEq +#else + eq1 = arrayLiftEq (==) +#endif +#endif + +instance Eq (MutableArray s a) where + ma1 == ma2 = isTrue# (sameMutableArray# (marray# ma1) (marray# ma2)) + +arrayLiftCompare :: (a -> b -> Ordering) -> Array a -> Array b -> Ordering +arrayLiftCompare elemCompare a1 a2 = loop 0 + where + mn = sizeofArray a1 `min` sizeofArray a2 + loop i + | i < mn + , (# x1 #) <- indexArray## a1 i + , (# x2 #) <- indexArray## a2 i + = elemCompare x1 x2 `mappend` loop (i+1) + | otherwise = compare (sizeofArray a1) (sizeofArray a2) + +-- | Lexicographic ordering. Subject to change between major versions. +instance Ord a => Ord (Array a) where + compare a1 a2 = arrayLiftCompare compare a1 a2 + +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) +-- | @since 0.6.4.0 +instance Ord1 Array where +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) + liftCompare = arrayLiftCompare +#else + compare1 = arrayLiftCompare compare +#endif +#endif + +instance Foldable Array where + -- Note: we perform the array lookups eagerly so we won't + -- create thunks to perform lookups even if GHC can't see + -- that the folding function is strict. + foldr f = \z !ary -> + let + !sz = sizeofArray ary + go i + | i == sz = z + | (# x #) <- indexArray## ary i + = f x (go (i+1)) + in go 0 + {-# INLINE foldr #-} + foldl f = \z !ary -> + let + go i + | i < 0 = z + | (# x #) <- indexArray## ary i + = f (go (i-1)) x + in go (sizeofArray ary - 1) + {-# INLINE foldl #-} + foldr1 f = \ !ary -> + let + !sz = sizeofArray ary - 1 + go i = + case indexArray## ary i of + (# x #) | i == sz -> x + | otherwise -> f x (go (i+1)) + in if sz < 0 + then die "foldr1" "empty array" + else go 0 + {-# INLINE foldr1 #-} + foldl1 f = \ !ary -> + let + !sz = sizeofArray ary - 1 + go i = + case indexArray## ary i of + (# x #) | i == 0 -> x + | otherwise -> f (go (i - 1)) x + in if sz < 0 + then die "foldl1" "empty array" + else go sz + {-# INLINE foldl1 #-} +#if MIN_VERSION_base(4,6,0) + foldr' f = \z !ary -> + let + go i !acc + | i == -1 = acc + | (# x #) <- indexArray## ary i + = go (i-1) (f x acc) + in go (sizeofArray ary - 1) z + {-# INLINE foldr' #-} + foldl' f = \z !ary -> + let + !sz = sizeofArray ary + go i !acc + | i == sz = acc + | (# x #) <- indexArray## ary i + = go (i+1) (f acc x) + in go 0 z + {-# INLINE foldl' #-} +#endif +#if MIN_VERSION_base(4,8,0) + null a = sizeofArray a == 0 + {-# INLINE null #-} + length = sizeofArray + {-# INLINE length #-} + maximum ary | sz == 0 = die "maximum" "empty array" + | (# frst #) <- indexArray## ary 0 + = go 1 frst + where + sz = sizeofArray ary + go i !e + | i == sz = e + | (# x #) <- indexArray## ary i + = go (i+1) (max e x) + {-# INLINE maximum #-} + minimum ary | sz == 0 = die "minimum" "empty array" + | (# frst #) <- indexArray## ary 0 + = go 1 frst + where sz = sizeofArray ary + go i !e + | i == sz = e + | (# x #) <- indexArray## ary i + = go (i+1) (min e x) + {-# INLINE minimum #-} + sum = foldl' (+) 0 + {-# INLINE sum #-} + product = foldl' (*) 1 + {-# INLINE product #-} +#endif + +newtype STA a = STA {_runSTA :: forall s. MutableArray# s a -> ST s (Array a)} + +runSTA :: Int -> STA a -> Array a +runSTA !sz = \ (STA m) -> runST $ newArray_ sz >>= \ ar -> m (marray# ar) +{-# INLINE runSTA #-} + +newArray_ :: Int -> ST s (MutableArray s a) +newArray_ !n = newArray n badTraverseValue + +badTraverseValue :: a +badTraverseValue = die "traverse" "bad indexing" +{-# NOINLINE badTraverseValue #-} + +instance Traversable Array where + traverse f = traverseArray f + {-# INLINE traverse #-} + +traverseArray + :: Applicative f + => (a -> f b) + -> Array a + -> f (Array b) +traverseArray f = \ !ary -> + let + !len = sizeofArray ary + go !i + | i == len = pure $ STA $ \mary -> unsafeFreezeArray (MutableArray mary) + | (# x #) <- indexArray## ary i + = liftA2 (\b (STA m) -> STA $ \mary -> + writeArray (MutableArray mary) i b >> m mary) + (f x) (go (i + 1)) + in if len == 0 + then pure emptyArray + else runSTA len <$> go 0 +{-# INLINE [1] traverseArray #-} + +{-# RULES +"traverse/ST" forall (f :: a -> ST s b). traverseArray f = + traverseArrayP f +"traverse/IO" forall (f :: a -> IO b). traverseArray f = + traverseArrayP f + #-} +#if MIN_VERSION_base(4,8,0) +{-# RULES +"traverse/Id" forall (f :: a -> Identity b). traverseArray f = + (coerce :: (Array a -> Array (Identity b)) + -> Array a -> Identity (Array b)) (fmap f) + #-} +#endif + +-- | This is the fastest, most straightforward way to traverse +-- an array, but it only works correctly with a sufficiently +-- "affine" 'PrimMonad' instance. In particular, it must only produce +-- *one* result array. 'Control.Monad.Trans.List.ListT'-transformed +-- monads, for example, will not work right at all. +traverseArrayP + :: PrimMonad m + => (a -> m b) + -> Array a + -> m (Array b) +traverseArrayP f = \ !ary -> + let + !sz = sizeofArray ary + go !i !mary + | i == sz + = unsafeFreezeArray mary + | otherwise + = do + a <- indexArrayM ary i + b <- f a + writeArray mary i b + go (i + 1) mary + in do + mary <- newArray sz badTraverseValue + go 0 mary +{-# INLINE traverseArrayP #-} + +-- | Strict map over the elements of the array. +mapArray' :: (a -> b) -> Array a -> Array b +mapArray' f a = + createArray (sizeofArray a) (die "mapArray'" "impossible") $ \mb -> + let go i | i == sizeofArray a + = return () + | otherwise + = do x <- indexArrayM a i + -- We use indexArrayM here so that we will perform the + -- indexing eagerly even if f is lazy. + let !y = f x + writeArray mb i y >> go (i+1) + in go 0 +{-# INLINE mapArray' #-} + +arrayFromListN :: Int -> [a] -> Array a +arrayFromListN n l = + createArray n (die "fromListN" "uninitialized element") $ \sma -> + let go !ix [] = if ix == n + then return () + else die "fromListN" "list length less than specified size" + go !ix (x : xs) = if ix < n + then do + writeArray sma ix x + go (ix+1) xs + else die "fromListN" "list length greater than specified size" + in go 0 l + +arrayFromList :: [a] -> Array a +arrayFromList l = arrayFromListN (length l) l + +#if MIN_VERSION_base(4,7,0) +instance Exts.IsList (Array a) where + type Item (Array a) = a + fromListN = arrayFromListN + fromList = arrayFromList + toList = toList +#else +fromListN :: Int -> [a] -> Array a +fromListN = arrayFromListN + +fromList :: [a] -> Array a +fromList = arrayFromList +#endif + +instance Functor Array where + fmap f a = + createArray (sizeofArray a) (die "fmap" "impossible") $ \mb -> + let go i | i == sizeofArray a + = return () + | otherwise + = do x <- indexArrayM a i + writeArray mb i (f x) >> go (i+1) + in go 0 +#if MIN_VERSION_base(4,8,0) + e <$ a = createArray (sizeofArray a) e (\ !_ -> pure ()) +#endif + +instance Applicative Array where + pure x = runArray $ newArray 1 x + ab <*> a = createArray (szab*sza) (die "<*>" "impossible") $ \mb -> + let go1 i = when (i < szab) $ + do + f <- indexArrayM ab i + go2 (i*sza) f 0 + go1 (i+1) + go2 off f j = when (j < sza) $ + do + x <- indexArrayM a j + writeArray mb (off + j) (f x) + go2 off f (j + 1) + in go1 0 + where szab = sizeofArray ab ; sza = sizeofArray a + a *> b = createArray (sza*szb) (die "*>" "impossible") $ \mb -> + let go i | i < sza = copyArray mb (i * szb) b 0 szb + | otherwise = return () + in go 0 + where sza = sizeofArray a ; szb = sizeofArray b + a <* b = createArray (sza*szb) (die "<*" "impossible") $ \ma -> + let fill off i e | i < szb = writeArray ma (off+i) e >> fill off (i+1) e + | otherwise = return () + go i | i < sza + = do x <- indexArrayM a i + fill (i*szb) 0 x >> go (i+1) + | otherwise = return () + in go 0 + where sza = sizeofArray a ; szb = sizeofArray b + +instance Alternative Array where + empty = emptyArray + a1 <|> a2 = createArray (sza1 + sza2) (die "<|>" "impossible") $ \ma -> + copyArray ma 0 a1 0 sza1 >> copyArray ma sza1 a2 0 sza2 + where sza1 = sizeofArray a1 ; sza2 = sizeofArray a2 + some a | sizeofArray a == 0 = emptyArray + | otherwise = die "some" "infinite arrays are not well defined" + many a | sizeofArray a == 0 = pure [] + | otherwise = die "many" "infinite arrays are not well defined" + +data ArrayStack a + = PushArray !(Array a) !(ArrayStack a) + | EmptyStack +-- See the note in SmallArray about how we might improve this. + +instance Monad Array where + return = pure + (>>) = (*>) + + ary >>= f = collect 0 EmptyStack (la-1) + where + la = sizeofArray ary + collect sz stk i + | i < 0 = createArray sz (die ">>=" "impossible") $ fill 0 stk + | (# x #) <- indexArray## ary i + , let sb = f x + lsb = sizeofArray sb + -- If we don't perform this check, we could end up allocating + -- a stack full of empty arrays if someone is filtering most + -- things out. So we refrain from pushing empty arrays. + = if lsb == 0 + then collect sz stk (i - 1) + else collect (sz + lsb) (PushArray sb stk) (i-1) + + fill _ EmptyStack _ = return () + fill off (PushArray sb sbs) smb + | let lsb = sizeofArray sb + = copyArray smb off sb 0 (lsb) + *> fill (off + lsb) sbs smb + + fail _ = empty + +instance MonadPlus Array where + mzero = empty + mplus = (<|>) + +zipW :: String -> (a -> b -> c) -> Array a -> Array b -> Array c +zipW s f aa ab = createArray mn (die s "impossible") $ \mc -> + let go i | i < mn + = do + x <- indexArrayM aa i + y <- indexArrayM ab i + writeArray mc i (f x y) + go (i+1) + | otherwise = return () + in go 0 + where mn = sizeofArray aa `min` sizeofArray ab +{-# INLINE zipW #-} + +#if MIN_VERSION_base(4,4,0) +instance MonadZip Array where + mzip aa ab = zipW "mzip" (,) aa ab + mzipWith f aa ab = zipW "mzipWith" f aa ab + munzip aab = runST $ do + let sz = sizeofArray aab + ma <- newArray sz (die "munzip" "impossible") + mb <- newArray sz (die "munzip" "impossible") + let go i | i < sz = do + (a, b) <- indexArrayM aab i + writeArray ma i a + writeArray mb i b + go (i+1) + go _ = return () + go 0 + (,) <$> unsafeFreezeArray ma <*> unsafeFreezeArray mb +#endif + +instance MonadFix Array where + mfix f = createArray (sizeofArray (f err)) + (die "mfix" "impossible") $ flip fix 0 $ + \r !i !mary -> when (i < sz) $ do + writeArray mary i (fix (\xi -> f xi `indexArray` i)) + r (i + 1) mary + where + sz = sizeofArray (f err) + err = error "mfix for Data.Primitive.Array applied to strict function." + +#if MIN_VERSION_base(4,9,0) +-- | @since 0.6.3.0 +instance Semigroup (Array a) where + (<>) = (<|>) + sconcat = mconcat . F.toList +#endif + +instance Monoid (Array a) where + mempty = empty +#if !(MIN_VERSION_base(4,11,0)) + mappend = (<|>) +#endif + mconcat l = createArray sz (die "mconcat" "impossible") $ \ma -> + let go !_ [ ] = return () + go off (a:as) = + copyArray ma off a 0 (sizeofArray a) >> go (off + sizeofArray a) as + in go 0 l + where sz = sum . fmap sizeofArray $ l + +arrayLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Array a -> ShowS +arrayLiftShowsPrec elemShowsPrec elemListShowsPrec p a = showParen (p > 10) $ + showString "fromListN " . shows (sizeofArray a) . showString " " + . listLiftShowsPrec elemShowsPrec elemListShowsPrec 11 (toList a) + +-- this need to be included for older ghcs +listLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> [a] -> ShowS +listLiftShowsPrec _ sl _ = sl + +instance Show a => Show (Array a) where + showsPrec p a = arrayLiftShowsPrec showsPrec showList p a + +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) +-- | @since 0.6.4.0 +instance Show1 Array where +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) + liftShowsPrec = arrayLiftShowsPrec +#else + showsPrec1 = arrayLiftShowsPrec showsPrec showList +#endif +#endif + +arrayLiftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (Array a) +arrayLiftReadsPrec _ listReadsPrec p = readParen (p > 10) . readP_to_S $ do + () <$ string "fromListN" + skipSpaces + n <- readS_to_P reads + skipSpaces + l <- readS_to_P listReadsPrec + return $ arrayFromListN n l + +instance Read a => Read (Array a) where + readsPrec = arrayLiftReadsPrec readsPrec readList + +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) +-- | @since 0.6.4.0 +instance Read1 Array where +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) + liftReadsPrec = arrayLiftReadsPrec +#else + readsPrec1 = arrayLiftReadsPrec readsPrec readList +#endif +#endif + + +arrayDataType :: DataType +arrayDataType = mkDataType "Data.Primitive.Array.Array" [fromListConstr] + +fromListConstr :: Constr +fromListConstr = mkConstr arrayDataType "fromList" [] Prefix + +instance Data a => Data (Array a) where + toConstr _ = fromListConstr + dataTypeOf _ = arrayDataType + gunfold k z c = case constrIndex c of + 1 -> k (z fromList) + _ -> error "gunfold" + gfoldl f z m = z fromList `f` toList m + +instance (Typeable s, Typeable a) => Data (MutableArray s a) where + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Data.Primitive.Array.MutableArray" diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/ByteArray.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/ByteArray.hs new file mode 100644 index 000000000000..527205330b8b --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/ByteArray.hs @@ -0,0 +1,549 @@ +{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples, UnliftedFFITypes, DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Data.Primitive.ByteArray +-- Copyright : (c) Roman Leshchinskiy 2009-2012 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> +-- Portability : non-portable +-- +-- Primitive operations on ByteArrays +-- + +module Data.Primitive.ByteArray ( + -- * Types + ByteArray(..), MutableByteArray(..), ByteArray#, MutableByteArray#, + + -- * Allocation + newByteArray, newPinnedByteArray, newAlignedPinnedByteArray, + resizeMutableByteArray, + + -- * Element access + readByteArray, writeByteArray, indexByteArray, + + -- * Constructing + byteArrayFromList, byteArrayFromListN, + + -- * Folding + foldrByteArray, + + -- * Freezing and thawing + unsafeFreezeByteArray, unsafeThawByteArray, + + -- * Block operations + copyByteArray, copyMutableByteArray, +#if __GLASGOW_HASKELL__ >= 708 + copyByteArrayToAddr, copyMutableByteArrayToAddr, +#endif + moveByteArray, + setByteArray, fillByteArray, + + -- * Information + sizeofByteArray, + sizeofMutableByteArray, getSizeofMutableByteArray, sameMutableByteArray, +#if __GLASGOW_HASKELL__ >= 802 + isByteArrayPinned, isMutableByteArrayPinned, +#endif + byteArrayContents, mutableByteArrayContents + +) where + +import Control.Monad.Primitive +import Control.Monad.ST +import Data.Primitive.Types + +import Foreign.C.Types +import Data.Word ( Word8 ) +import GHC.Base ( Int(..) ) +#if __GLASGOW_HASKELL__ >= 708 +import qualified GHC.Exts as Exts ( IsList(..) ) +#endif +import GHC.Prim +#if __GLASGOW_HASKELL__ >= 706 + hiding (setByteArray#) +#endif + +import Data.Typeable ( Typeable ) +import Data.Data ( Data(..) ) +import Data.Primitive.Internal.Compat ( isTrue#, mkNoRepType ) +import Numeric + +#if MIN_VERSION_base(4,9,0) +import qualified Data.Semigroup as SG +import qualified Data.Foldable as F +#endif + +#if !(MIN_VERSION_base(4,8,0)) +import Data.Monoid (Monoid(..)) +#endif + +#if __GLASGOW_HASKELL__ >= 802 +import GHC.Exts as Exts (isByteArrayPinned#,isMutableByteArrayPinned#) +#endif + +#if __GLASGOW_HASKELL__ >= 804 +import GHC.Exts (compareByteArrays#) +#else +import System.IO.Unsafe (unsafeDupablePerformIO) +#endif + +-- | Byte arrays +data ByteArray = ByteArray ByteArray# deriving ( Typeable ) + +-- | Mutable byte arrays associated with a primitive state token +data MutableByteArray s = MutableByteArray (MutableByteArray# s) + deriving( Typeable ) + +-- | Create a new mutable byte array of the specified size in bytes. +newByteArray :: PrimMonad m => Int -> m (MutableByteArray (PrimState m)) +{-# INLINE newByteArray #-} +newByteArray (I# n#) + = primitive (\s# -> case newByteArray# n# s# of + (# s'#, arr# #) -> (# s'#, MutableByteArray arr# #)) + +-- | Create a /pinned/ byte array of the specified size in bytes. The garbage +-- collector is guaranteed not to move it. +newPinnedByteArray :: PrimMonad m => Int -> m (MutableByteArray (PrimState m)) +{-# INLINE newPinnedByteArray #-} +newPinnedByteArray (I# n#) + = primitive (\s# -> case newPinnedByteArray# n# s# of + (# s'#, arr# #) -> (# s'#, MutableByteArray arr# #)) + +-- | Create a /pinned/ byte array of the specified size in bytes and with the +-- given alignment. The garbage collector is guaranteed not to move it. +newAlignedPinnedByteArray + :: PrimMonad m + => Int -- ^ size + -> Int -- ^ alignment + -> m (MutableByteArray (PrimState m)) +{-# INLINE newAlignedPinnedByteArray #-} +newAlignedPinnedByteArray (I# n#) (I# k#) + = primitive (\s# -> case newAlignedPinnedByteArray# n# k# s# of + (# s'#, arr# #) -> (# s'#, MutableByteArray arr# #)) + +-- | Yield a pointer to the array's data. This operation is only safe on +-- /pinned/ byte arrays allocated by 'newPinnedByteArray' or +-- 'newAlignedPinnedByteArray'. +byteArrayContents :: ByteArray -> Addr +{-# INLINE byteArrayContents #-} +byteArrayContents (ByteArray arr#) = Addr (byteArrayContents# arr#) + +-- | Yield a pointer to the array's data. This operation is only safe on +-- /pinned/ byte arrays allocated by 'newPinnedByteArray' or +-- 'newAlignedPinnedByteArray'. +mutableByteArrayContents :: MutableByteArray s -> Addr +{-# INLINE mutableByteArrayContents #-} +mutableByteArrayContents (MutableByteArray arr#) + = Addr (byteArrayContents# (unsafeCoerce# arr#)) + +-- | Check if the two arrays refer to the same memory block. +sameMutableByteArray :: MutableByteArray s -> MutableByteArray s -> Bool +{-# INLINE sameMutableByteArray #-} +sameMutableByteArray (MutableByteArray arr#) (MutableByteArray brr#) + = isTrue# (sameMutableByteArray# arr# brr#) + +-- | Resize a mutable byte array. The new size is given in bytes. +-- +-- This will either resize the array in-place or, if not possible, allocate the +-- contents into a new, unpinned array and copy the original array's contents. +-- +-- To avoid undefined behaviour, the original 'MutableByteArray' shall not be +-- accessed anymore after a 'resizeMutableByteArray' has been performed. +-- Moreover, no reference to the old one should be kept in order to allow +-- garbage collection of the original 'MutableByteArray' in case a new +-- 'MutableByteArray' had to be allocated. +-- +-- @since 0.6.4.0 +resizeMutableByteArray + :: PrimMonad m => MutableByteArray (PrimState m) -> Int + -> m (MutableByteArray (PrimState m)) +{-# INLINE resizeMutableByteArray #-} +#if __GLASGOW_HASKELL__ >= 710 +resizeMutableByteArray (MutableByteArray arr#) (I# n#) + = primitive (\s# -> case resizeMutableByteArray# arr# n# s# of + (# s'#, arr'# #) -> (# s'#, MutableByteArray arr'# #)) +#else +resizeMutableByteArray arr n + = do arr' <- newByteArray n + copyMutableByteArray arr' 0 arr 0 (min (sizeofMutableByteArray arr) n) + return arr' +#endif + +-- | Get the size of a byte array in bytes. Unlike 'sizeofMutableByteArray', +-- this function ensures sequencing in the presence of resizing. +getSizeofMutableByteArray + :: PrimMonad m => MutableByteArray (PrimState m) -> m Int +{-# INLINE getSizeofMutableByteArray #-} +#if __GLASGOW_HASKELL__ >= 801 +getSizeofMutableByteArray (MutableByteArray arr#) + = primitive (\s# -> case getSizeofMutableByteArray# arr# s# of + (# s'#, n# #) -> (# s'#, I# n# #)) +#else +getSizeofMutableByteArray arr + = return (sizeofMutableByteArray arr) +#endif + +-- | Convert a mutable byte array to an immutable one without copying. The +-- array should not be modified after the conversion. +unsafeFreezeByteArray + :: PrimMonad m => MutableByteArray (PrimState m) -> m ByteArray +{-# INLINE unsafeFreezeByteArray #-} +unsafeFreezeByteArray (MutableByteArray arr#) + = primitive (\s# -> case unsafeFreezeByteArray# arr# s# of + (# s'#, arr'# #) -> (# s'#, ByteArray arr'# #)) + +-- | Convert an immutable byte array to a mutable one without copying. The +-- original array should not be used after the conversion. +unsafeThawByteArray + :: PrimMonad m => ByteArray -> m (MutableByteArray (PrimState m)) +{-# INLINE unsafeThawByteArray #-} +unsafeThawByteArray (ByteArray arr#) + = primitive (\s# -> (# s#, MutableByteArray (unsafeCoerce# arr#) #)) + +-- | Size of the byte array in bytes. +sizeofByteArray :: ByteArray -> Int +{-# INLINE sizeofByteArray #-} +sizeofByteArray (ByteArray arr#) = I# (sizeofByteArray# arr#) + +-- | Size of the mutable byte array in bytes. This function\'s behavior +-- is undefined if 'resizeMutableByteArray' is ever called on the mutable +-- byte array given as the argument. Consequently, use of this function +-- is discouraged. Prefer 'getSizeofMutableByteArray', which ensures correct +-- sequencing in the presence of resizing. +sizeofMutableByteArray :: MutableByteArray s -> Int +{-# INLINE sizeofMutableByteArray #-} +sizeofMutableByteArray (MutableByteArray arr#) = I# (sizeofMutableByteArray# arr#) + +#if __GLASGOW_HASKELL__ >= 802 +-- | Check whether or not the byte array is pinned. Pinned byte arrays cannot +-- be moved by the garbage collector. It is safe to use 'byteArrayContents' +-- on such byte arrays. This function is only available when compiling with +-- GHC 8.2 or newer. +-- +-- @since 0.6.4.0 +isByteArrayPinned :: ByteArray -> Bool +{-# INLINE isByteArrayPinned #-} +isByteArrayPinned (ByteArray arr#) = isTrue# (Exts.isByteArrayPinned# arr#) + +-- | Check whether or not the mutable byte array is pinned. This function is +-- only available when compiling with GHC 8.2 or newer. +-- +-- @since 0.6.4.0 +isMutableByteArrayPinned :: MutableByteArray s -> Bool +{-# INLINE isMutableByteArrayPinned #-} +isMutableByteArrayPinned (MutableByteArray marr#) = isTrue# (Exts.isMutableByteArrayPinned# marr#) +#endif + +-- | Read a primitive value from the byte array. The offset is given in +-- elements of type @a@ rather than in bytes. +indexByteArray :: Prim a => ByteArray -> Int -> a +{-# INLINE indexByteArray #-} +indexByteArray (ByteArray arr#) (I# i#) = indexByteArray# arr# i# + +-- | Read a primitive value from the byte array. The offset is given in +-- elements of type @a@ rather than in bytes. +readByteArray + :: (Prim a, PrimMonad m) => MutableByteArray (PrimState m) -> Int -> m a +{-# INLINE readByteArray #-} +readByteArray (MutableByteArray arr#) (I# i#) + = primitive (readByteArray# arr# i#) + +-- | Write a primitive value to the byte array. The offset is given in +-- elements of type @a@ rather than in bytes. +writeByteArray + :: (Prim a, PrimMonad m) => MutableByteArray (PrimState m) -> Int -> a -> m () +{-# INLINE writeByteArray #-} +writeByteArray (MutableByteArray arr#) (I# i#) x + = primitive_ (writeByteArray# arr# i# x) + +-- | Right-fold over the elements of a 'ByteArray'. +foldrByteArray :: forall a b. (Prim a) => (a -> b -> b) -> b -> ByteArray -> b +foldrByteArray f z arr = go 0 + where + go i + | sizeofByteArray arr > i * sz = f (indexByteArray arr i) (go (i+1)) + | otherwise = z + sz = sizeOf (undefined :: a) + +byteArrayFromList :: Prim a => [a] -> ByteArray +byteArrayFromList xs = byteArrayFromListN (length xs) xs + +byteArrayFromListN :: Prim a => Int -> [a] -> ByteArray +byteArrayFromListN n ys = runST $ do + marr <- newByteArray (n * sizeOf (head ys)) + let go !ix [] = if ix == n + then return () + else die "byteArrayFromListN" "list length less than specified size" + go !ix (x : xs) = if ix < n + then do + writeByteArray marr ix x + go (ix + 1) xs + else die "byteArrayFromListN" "list length greater than specified size" + go 0 ys + unsafeFreezeByteArray marr + +unI# :: Int -> Int# +unI# (I# n#) = n# + +-- | Copy a slice of an immutable byte array to a mutable byte array. +copyByteArray + :: PrimMonad m => MutableByteArray (PrimState m) + -- ^ destination array + -> Int -- ^ offset into destination array + -> ByteArray -- ^ source array + -> Int -- ^ offset into source array + -> Int -- ^ number of bytes to copy + -> m () +{-# INLINE copyByteArray #-} +copyByteArray (MutableByteArray dst#) doff (ByteArray src#) soff sz + = primitive_ (copyByteArray# src# (unI# soff) dst# (unI# doff) (unI# sz)) + +-- | Copy a slice of a mutable byte array into another array. The two slices +-- may not overlap. +copyMutableByteArray + :: PrimMonad m => MutableByteArray (PrimState m) + -- ^ destination array + -> Int -- ^ offset into destination array + -> MutableByteArray (PrimState m) + -- ^ source array + -> Int -- ^ offset into source array + -> Int -- ^ number of bytes to copy + -> m () +{-# INLINE copyMutableByteArray #-} +copyMutableByteArray (MutableByteArray dst#) doff + (MutableByteArray src#) soff sz + = primitive_ (copyMutableByteArray# src# (unI# soff) dst# (unI# doff) (unI# sz)) + +#if __GLASGOW_HASKELL__ >= 708 +-- | Copy a slice of a byte array to an unmanaged address. These must not +-- overlap. This function is only available when compiling with GHC 7.8 +-- or newer. +-- +-- @since 0.6.4.0 +copyByteArrayToAddr + :: PrimMonad m + => Addr -- ^ destination + -> ByteArray -- ^ source array + -> Int -- ^ offset into source array + -> Int -- ^ number of bytes to copy + -> m () +{-# INLINE copyByteArrayToAddr #-} +copyByteArrayToAddr (Addr dst#) (ByteArray src#) soff sz + = primitive_ (copyByteArrayToAddr# src# (unI# soff) dst# (unI# sz)) + +-- | Copy a slice of a mutable byte array to an unmanaged address. These must +-- not overlap. This function is only available when compiling with GHC 7.8 +-- or newer. +-- +-- @since 0.6.4.0 +copyMutableByteArrayToAddr + :: PrimMonad m + => Addr -- ^ destination + -> MutableByteArray (PrimState m) -- ^ source array + -> Int -- ^ offset into source array + -> Int -- ^ number of bytes to copy + -> m () +{-# INLINE copyMutableByteArrayToAddr #-} +copyMutableByteArrayToAddr (Addr dst#) (MutableByteArray src#) soff sz + = primitive_ (copyMutableByteArrayToAddr# src# (unI# soff) dst# (unI# sz)) +#endif + +-- | Copy a slice of a mutable byte array into another, potentially +-- overlapping array. +moveByteArray + :: PrimMonad m => MutableByteArray (PrimState m) + -- ^ destination array + -> Int -- ^ offset into destination array + -> MutableByteArray (PrimState m) + -- ^ source array + -> Int -- ^ offset into source array + -> Int -- ^ number of bytes to copy + -> m () +{-# INLINE moveByteArray #-} +moveByteArray (MutableByteArray dst#) doff + (MutableByteArray src#) soff sz + = unsafePrimToPrim + $ memmove_mba dst# (fromIntegral doff) src# (fromIntegral soff) + (fromIntegral sz) + +-- | Fill a slice of a mutable byte array with a value. The offset and length +-- are given in elements of type @a@ rather than in bytes. +setByteArray + :: (Prim a, PrimMonad m) => MutableByteArray (PrimState m) -- ^ array to fill + -> Int -- ^ offset into array + -> Int -- ^ number of values to fill + -> a -- ^ value to fill with + -> m () +{-# INLINE setByteArray #-} +setByteArray (MutableByteArray dst#) (I# doff#) (I# sz#) x + = primitive_ (setByteArray# dst# doff# sz# x) + +-- | Fill a slice of a mutable byte array with a byte. +fillByteArray + :: PrimMonad m => MutableByteArray (PrimState m) + -- ^ array to fill + -> Int -- ^ offset into array + -> Int -- ^ number of bytes to fill + -> Word8 -- ^ byte to fill with + -> m () +{-# INLINE fillByteArray #-} +fillByteArray = setByteArray + +foreign import ccall unsafe "primitive-memops.h hsprimitive_memmove" + memmove_mba :: MutableByteArray# s -> CInt + -> MutableByteArray# s -> CInt + -> CSize -> IO () + +instance Data ByteArray where + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Data.Primitive.ByteArray.ByteArray" + +instance Typeable s => Data (MutableByteArray s) where + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Data.Primitive.ByteArray.MutableByteArray" + +-- | @since 0.6.3.0 +instance Show ByteArray where + showsPrec _ ba = + showString "[" . go 0 + where + go i + | i < sizeofByteArray ba = comma . showString "0x" . showHex (indexByteArray ba i :: Word8) . go (i+1) + | otherwise = showChar ']' + where + comma | i == 0 = id + | otherwise = showString ", " + + +compareByteArrays :: ByteArray -> ByteArray -> Int -> Ordering +{-# INLINE compareByteArrays #-} +#if __GLASGOW_HASKELL__ >= 804 +compareByteArrays (ByteArray ba1#) (ByteArray ba2#) (I# n#) = + compare (I# (compareByteArrays# ba1# 0# ba2# 0# n#)) 0 +#else +-- Emulate GHC 8.4's 'GHC.Prim.compareByteArrays#' +compareByteArrays (ByteArray ba1#) (ByteArray ba2#) (I# n#) + = compare (fromCInt (unsafeDupablePerformIO (memcmp_ba ba1# ba2# n))) 0 + where + n = fromIntegral (I# n#) :: CSize + fromCInt = fromIntegral :: CInt -> Int + +foreign import ccall unsafe "primitive-memops.h hsprimitive_memcmp" + memcmp_ba :: ByteArray# -> ByteArray# -> CSize -> IO CInt +#endif + + +sameByteArray :: ByteArray# -> ByteArray# -> Bool +sameByteArray ba1 ba2 = + case reallyUnsafePtrEquality# (unsafeCoerce# ba1 :: ()) (unsafeCoerce# ba2 :: ()) of +#if __GLASGOW_HASKELL__ >= 708 + r -> isTrue# r +#else + 1# -> True + 0# -> False +#endif + +-- | @since 0.6.3.0 +instance Eq ByteArray where + ba1@(ByteArray ba1#) == ba2@(ByteArray ba2#) + | sameByteArray ba1# ba2# = True + | n1 /= n2 = False + | otherwise = compareByteArrays ba1 ba2 n1 == EQ + where + n1 = sizeofByteArray ba1 + n2 = sizeofByteArray ba2 + +-- | Non-lexicographic ordering. This compares the lengths of +-- the byte arrays first and uses a lexicographic ordering if +-- the lengths are equal. Subject to change between major versions. +-- +-- @since 0.6.3.0 +instance Ord ByteArray where + ba1@(ByteArray ba1#) `compare` ba2@(ByteArray ba2#) + | sameByteArray ba1# ba2# = EQ + | n1 /= n2 = n1 `compare` n2 + | otherwise = compareByteArrays ba1 ba2 n1 + where + n1 = sizeofByteArray ba1 + n2 = sizeofByteArray ba2 +-- Note: On GHC 8.4, the primop compareByteArrays# performs a check for pointer +-- equality as a shortcut, so the check here is actually redundant. However, it +-- is included here because it is likely better to check for pointer equality +-- before checking for length equality. Getting the length requires deferencing +-- the pointers, which could cause accesses to memory that is not in the cache. +-- By contrast, a pointer equality check is always extremely cheap. + +appendByteArray :: ByteArray -> ByteArray -> ByteArray +appendByteArray a b = runST $ do + marr <- newByteArray (sizeofByteArray a + sizeofByteArray b) + copyByteArray marr 0 a 0 (sizeofByteArray a) + copyByteArray marr (sizeofByteArray a) b 0 (sizeofByteArray b) + unsafeFreezeByteArray marr + +concatByteArray :: [ByteArray] -> ByteArray +concatByteArray arrs = runST $ do + let len = calcLength arrs 0 + marr <- newByteArray len + pasteByteArrays marr 0 arrs + unsafeFreezeByteArray marr + +pasteByteArrays :: MutableByteArray s -> Int -> [ByteArray] -> ST s () +pasteByteArrays !_ !_ [] = return () +pasteByteArrays !marr !ix (x : xs) = do + copyByteArray marr ix x 0 (sizeofByteArray x) + pasteByteArrays marr (ix + sizeofByteArray x) xs + +calcLength :: [ByteArray] -> Int -> Int +calcLength [] !n = n +calcLength (x : xs) !n = calcLength xs (sizeofByteArray x + n) + +emptyByteArray :: ByteArray +emptyByteArray = runST (newByteArray 0 >>= unsafeFreezeByteArray) + +replicateByteArray :: Int -> ByteArray -> ByteArray +replicateByteArray n arr = runST $ do + marr <- newByteArray (n * sizeofByteArray arr) + let go i = if i < n + then do + copyByteArray marr (i * sizeofByteArray arr) arr 0 (sizeofByteArray arr) + go (i + 1) + else return () + go 0 + unsafeFreezeByteArray marr + +#if MIN_VERSION_base(4,9,0) +instance SG.Semigroup ByteArray where + (<>) = appendByteArray + sconcat = mconcat . F.toList + stimes i arr + | itgr < 1 = emptyByteArray + | itgr <= (fromIntegral (maxBound :: Int)) = replicateByteArray (fromIntegral itgr) arr + | otherwise = error "Data.Primitive.ByteArray#stimes: cannot allocate the requested amount of memory" + where itgr = toInteger i :: Integer +#endif + +instance Monoid ByteArray where + mempty = emptyByteArray +#if !(MIN_VERSION_base(4,11,0)) + mappend = appendByteArray +#endif + mconcat = concatByteArray + +#if __GLASGOW_HASKELL__ >= 708 +-- | @since 0.6.3.0 +instance Exts.IsList ByteArray where + type Item ByteArray = Word8 + + toList = foldrByteArray (:) [] + fromList xs = byteArrayFromListN (length xs) xs + fromListN = byteArrayFromListN +#endif + +die :: String -> String -> a +die fun problem = error $ "Data.Primitive.ByteArray." ++ fun ++ ": " ++ problem + diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Internal/Compat.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Internal/Compat.hs new file mode 100644 index 000000000000..f6b8016ad92a --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Internal/Compat.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE CPP, MagicHash #-} + +-- | +-- Module : Data.Primitive.Internal.Compat +-- Copyright : (c) Roman Leshchinskiy 2011-2012 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> +-- Portability : non-portable +-- +-- Compatibility functions +-- + +module Data.Primitive.Internal.Compat ( + isTrue# + , mkNoRepType + ) where + +#if MIN_VERSION_base(4,2,0) +import Data.Data (mkNoRepType) +#else +import Data.Data (mkNorepType) +#endif + +#if MIN_VERSION_base(4,7,0) +import GHC.Exts (isTrue#) +#endif + + + +#if !MIN_VERSION_base(4,2,0) +mkNoRepType = mkNorepType +#endif + +#if !MIN_VERSION_base(4,7,0) +isTrue# :: Bool -> Bool +isTrue# b = b +#endif diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Internal/Operations.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Internal/Operations.hs new file mode 100644 index 000000000000..091e11f5d6a9 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Internal/Operations.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE MagicHash, UnliftedFFITypes #-} + +-- | +-- Module : Data.Primitive.Internal.Operations +-- Copyright : (c) Roman Leshchinskiy 2011-2012 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> +-- Portability : non-portable +-- +-- Internal operations +-- + + +module Data.Primitive.Internal.Operations ( + setWord8Array#, setWord16Array#, setWord32Array#, + setWord64Array#, setWordArray#, + setInt8Array#, setInt16Array#, setInt32Array#, + setInt64Array#, setIntArray#, + setAddrArray#, setFloatArray#, setDoubleArray#, setWideCharArray#, + + setWord8OffAddr#, setWord16OffAddr#, setWord32OffAddr#, + setWord64OffAddr#, setWordOffAddr#, + setInt8OffAddr#, setInt16OffAddr#, setInt32OffAddr#, + setInt64OffAddr#, setIntOffAddr#, + setAddrOffAddr#, setFloatOffAddr#, setDoubleOffAddr#, setWideCharOffAddr# +) where + +import Data.Primitive.MachDeps (Word64_#, Int64_#) +import Foreign.C.Types +import GHC.Prim + +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8" + setWord8Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word16" + setWord16Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word32" + setWord32Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word64" + setWord64Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word64_# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word" + setWordArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8" + setInt8Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word16" + setInt16Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word32" + setInt32Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word64" + setInt64Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int64_# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word" + setIntArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Ptr" + setAddrArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Addr# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Float" + setFloatArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Float# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Double" + setDoubleArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Double# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Char" + setWideCharArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Char# -> IO () + +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8" + setWord8OffAddr# :: Addr# -> CPtrdiff -> CSize -> Word# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word16" + setWord16OffAddr# :: Addr# -> CPtrdiff -> CSize -> Word# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word32" + setWord32OffAddr# :: Addr# -> CPtrdiff -> CSize -> Word# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word64" + setWord64OffAddr# :: Addr# -> CPtrdiff -> CSize -> Word64_# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word" + setWordOffAddr# :: Addr# -> CPtrdiff -> CSize -> Word# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8" + setInt8OffAddr# :: Addr# -> CPtrdiff -> CSize -> Int# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word16" + setInt16OffAddr# :: Addr# -> CPtrdiff -> CSize -> Int# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word32" + setInt32OffAddr# :: Addr# -> CPtrdiff -> CSize -> Int# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word64" + setInt64OffAddr# :: Addr# -> CPtrdiff -> CSize -> Int64_# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word" + setIntOffAddr# :: Addr# -> CPtrdiff -> CSize -> Int# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Ptr" + setAddrOffAddr# :: Addr# -> CPtrdiff -> CSize -> Addr# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Float" + setFloatOffAddr# :: Addr# -> CPtrdiff -> CSize -> Float# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Double" + setDoubleOffAddr# :: Addr# -> CPtrdiff -> CSize -> Double# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Char" + setWideCharOffAddr# :: Addr# -> CPtrdiff -> CSize -> Char# -> IO () + diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MVar.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MVar.hs new file mode 100644 index 000000000000..3c7bfd1fa054 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MVar.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +-- | +-- Module : Data.Primitive.MVar +-- License : BSD2 +-- Portability : non-portable +-- +-- Primitive operations on @MVar@. This module provides a similar interface +-- to "Control.Concurrent.MVar". However, the functions are generalized to +-- work in any 'PrimMonad' instead of only working in 'IO'. Note that all +-- of the functions here are completely deterministic. Users of 'MVar' are +-- responsible for designing abstractions that guarantee determinism in +-- the presence of multi-threading. +-- +-- @since 0.6.4.0 +module Data.Primitive.MVar + ( MVar(..) + , newMVar + , isEmptyMVar + , newEmptyMVar + , putMVar + , readMVar + , takeMVar + , tryPutMVar + , tryReadMVar + , tryTakeMVar + ) where + +import Control.Monad.Primitive +import Data.Primitive.Internal.Compat (isTrue#) +import GHC.Exts (MVar#,newMVar#,takeMVar#,sameMVar#,putMVar#,tryTakeMVar#, + isEmptyMVar#,tryPutMVar#,(/=#)) + +#if __GLASGOW_HASKELL__ >= 708 +import GHC.Exts (readMVar#,tryReadMVar#) +#endif + +data MVar s a = MVar (MVar# s a) + +instance Eq (MVar s a) where + MVar mvar1# == MVar mvar2# = isTrue# (sameMVar# mvar1# mvar2#) + +-- | Create a new 'MVar' that is initially empty. +newEmptyMVar :: PrimMonad m => m (MVar (PrimState m) a) +newEmptyMVar = primitive $ \ s# -> + case newMVar# s# of + (# s2#, svar# #) -> (# s2#, MVar svar# #) + + +-- | Create a new 'MVar' that holds the supplied argument. +newMVar :: PrimMonad m => a -> m (MVar (PrimState m) a) +newMVar value = + newEmptyMVar >>= \ mvar -> + putMVar mvar value >> + return mvar + +-- | Return the contents of the 'MVar'. If the 'MVar' is currently +-- empty, 'takeMVar' will wait until it is full. After a 'takeMVar', +-- the 'MVar' is left empty. +takeMVar :: PrimMonad m => MVar (PrimState m) a -> m a +takeMVar (MVar mvar#) = primitive $ \ s# -> takeMVar# mvar# s# + +-- | Atomically read the contents of an 'MVar'. If the 'MVar' is +-- currently empty, 'readMVar' will wait until it is full. +-- 'readMVar' is guaranteed to receive the next 'putMVar'. +-- +-- /Multiple Wakeup:/ 'readMVar' is multiple-wakeup, so when multiple readers +-- are blocked on an 'MVar', all of them are woken up at the same time. +-- +-- /Compatibility note:/ On GHCs prior to 7.8, 'readMVar' is a combination +-- of 'takeMVar' and 'putMVar'. Consequently, its behavior differs in the +-- following ways: +-- +-- * It is single-wakeup instead of multiple-wakeup. +-- * It might not receive the value from the next call to 'putMVar' if +-- there is already a pending thread blocked on 'takeMVar'. +-- * If another thread puts a value in the 'MVar' in between the +-- calls to 'takeMVar' and 'putMVar', that value may be overridden. +readMVar :: PrimMonad m => MVar (PrimState m) a -> m a +#if __GLASGOW_HASKELL__ >= 708 +readMVar (MVar mvar#) = primitive $ \ s# -> readMVar# mvar# s# +#else +readMVar mv = do + a <- takeMVar mv + putMVar mv a + return a +#endif + +-- |Put a value into an 'MVar'. If the 'MVar' is currently full, +-- 'putMVar' will wait until it becomes empty. +putMVar :: PrimMonad m => MVar (PrimState m) a -> a -> m () +putMVar (MVar mvar#) x = primitive_ (putMVar# mvar# x) + +-- |A non-blocking version of 'takeMVar'. The 'tryTakeMVar' function +-- returns immediately, with 'Nothing' if the 'MVar' was empty, or +-- @'Just' a@ if the 'MVar' was full with contents @a@. After 'tryTakeMVar', +-- the 'MVar' is left empty. +tryTakeMVar :: PrimMonad m => MVar (PrimState m) a -> m (Maybe a) +tryTakeMVar (MVar m) = primitive $ \ s -> + case tryTakeMVar# m s of + (# s', 0#, _ #) -> (# s', Nothing #) -- MVar is empty + (# s', _, a #) -> (# s', Just a #) -- MVar is full + + +-- |A non-blocking version of 'putMVar'. The 'tryPutMVar' function +-- attempts to put the value @a@ into the 'MVar', returning 'True' if +-- it was successful, or 'False' otherwise. +tryPutMVar :: PrimMonad m => MVar (PrimState m) a -> a -> m Bool +tryPutMVar (MVar mvar#) x = primitive $ \ s# -> + case tryPutMVar# mvar# x s# of + (# s, 0# #) -> (# s, False #) + (# s, _ #) -> (# s, True #) + +-- | A non-blocking version of 'readMVar'. The 'tryReadMVar' function +-- returns immediately, with 'Nothing' if the 'MVar' was empty, or +-- @'Just' a@ if the 'MVar' was full with contents @a@. +-- +-- /Compatibility note:/ On GHCs prior to 7.8, 'tryReadMVar' is a combination +-- of 'tryTakeMVar' and 'putMVar'. Consequently, its behavior differs in the +-- following ways: +-- +-- * It is single-wakeup instead of multiple-wakeup. +-- * In the presence of other threads calling 'putMVar', 'tryReadMVar' +-- may block. +-- * If another thread puts a value in the 'MVar' in between the +-- calls to 'tryTakeMVar' and 'putMVar', that value may be overridden. +tryReadMVar :: PrimMonad m => MVar (PrimState m) a -> m (Maybe a) +#if __GLASGOW_HASKELL__ >= 708 +tryReadMVar (MVar m) = primitive $ \ s -> + case tryReadMVar# m s of + (# s', 0#, _ #) -> (# s', Nothing #) -- MVar is empty + (# s', _, a #) -> (# s', Just a #) -- MVar is full +#else +tryReadMVar mv = do + ma <- tryTakeMVar mv + case ma of + Just a -> do + putMVar mv a + return (Just a) + Nothing -> return Nothing +#endif + +-- | Check whether a given 'MVar' is empty. +-- +-- Notice that the boolean value returned is just a snapshot of +-- the state of the MVar. By the time you get to react on its result, +-- the MVar may have been filled (or emptied) - so be extremely +-- careful when using this operation. Use 'tryTakeMVar' instead if possible. +isEmptyMVar :: PrimMonad m => MVar (PrimState m) a -> m Bool +isEmptyMVar (MVar mv#) = primitive $ \ s# -> + case isEmptyMVar# mv# s# of + (# s2#, flg #) -> (# s2#, isTrue# (flg /=# 0#) #) diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MachDeps.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MachDeps.hs new file mode 100644 index 000000000000..d36c25236413 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MachDeps.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE CPP, MagicHash #-} +-- | +-- Module : Data.Primitive.MachDeps +-- Copyright : (c) Roman Leshchinskiy 2009-2012 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> +-- Portability : non-portable +-- +-- Machine-dependent constants +-- + +module Data.Primitive.MachDeps where + +#include "MachDeps.h" + +import GHC.Prim + +sIZEOF_CHAR, + aLIGNMENT_CHAR, + + sIZEOF_INT, + aLIGNMENT_INT, + + sIZEOF_WORD, + aLIGNMENT_WORD, + + sIZEOF_DOUBLE, + aLIGNMENT_DOUBLE, + + sIZEOF_FLOAT, + aLIGNMENT_FLOAT, + + sIZEOF_PTR, + aLIGNMENT_PTR, + + sIZEOF_FUNPTR, + aLIGNMENT_FUNPTR, + + sIZEOF_STABLEPTR, + aLIGNMENT_STABLEPTR, + + sIZEOF_INT8, + aLIGNMENT_INT8, + + sIZEOF_WORD8, + aLIGNMENT_WORD8, + + sIZEOF_INT16, + aLIGNMENT_INT16, + + sIZEOF_WORD16, + aLIGNMENT_WORD16, + + sIZEOF_INT32, + aLIGNMENT_INT32, + + sIZEOF_WORD32, + aLIGNMENT_WORD32, + + sIZEOF_INT64, + aLIGNMENT_INT64, + + sIZEOF_WORD64, + aLIGNMENT_WORD64 :: Int + + +sIZEOF_CHAR = SIZEOF_HSCHAR +aLIGNMENT_CHAR = ALIGNMENT_HSCHAR + +sIZEOF_INT = SIZEOF_HSINT +aLIGNMENT_INT = ALIGNMENT_HSINT + +sIZEOF_WORD = SIZEOF_HSWORD +aLIGNMENT_WORD = ALIGNMENT_HSWORD + +sIZEOF_DOUBLE = SIZEOF_HSDOUBLE +aLIGNMENT_DOUBLE = ALIGNMENT_HSDOUBLE + +sIZEOF_FLOAT = SIZEOF_HSFLOAT +aLIGNMENT_FLOAT = ALIGNMENT_HSFLOAT + +sIZEOF_PTR = SIZEOF_HSPTR +aLIGNMENT_PTR = ALIGNMENT_HSPTR + +sIZEOF_FUNPTR = SIZEOF_HSFUNPTR +aLIGNMENT_FUNPTR = ALIGNMENT_HSFUNPTR + +sIZEOF_STABLEPTR = SIZEOF_HSSTABLEPTR +aLIGNMENT_STABLEPTR = ALIGNMENT_HSSTABLEPTR + +sIZEOF_INT8 = SIZEOF_INT8 +aLIGNMENT_INT8 = ALIGNMENT_INT8 + +sIZEOF_WORD8 = SIZEOF_WORD8 +aLIGNMENT_WORD8 = ALIGNMENT_WORD8 + +sIZEOF_INT16 = SIZEOF_INT16 +aLIGNMENT_INT16 = ALIGNMENT_INT16 + +sIZEOF_WORD16 = SIZEOF_WORD16 +aLIGNMENT_WORD16 = ALIGNMENT_WORD16 + +sIZEOF_INT32 = SIZEOF_INT32 +aLIGNMENT_INT32 = ALIGNMENT_INT32 + +sIZEOF_WORD32 = SIZEOF_WORD32 +aLIGNMENT_WORD32 = ALIGNMENT_WORD32 + +sIZEOF_INT64 = SIZEOF_INT64 +aLIGNMENT_INT64 = ALIGNMENT_INT64 + +sIZEOF_WORD64 = SIZEOF_WORD64 +aLIGNMENT_WORD64 = ALIGNMENT_WORD64 + +#if WORD_SIZE_IN_BITS == 32 +type Word64_# = Word64# +type Int64_# = Int64# +#else +type Word64_# = Word# +type Int64_# = Int# +#endif + diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MutVar.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MutVar.hs new file mode 100644 index 000000000000..f707bfb6308c --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MutVar.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE MagicHash, UnboxedTuples, DeriveDataTypeable #-} + +-- | +-- Module : Data.Primitive.MutVar +-- Copyright : (c) Justin Bonnar 2011, Roman Leshchinskiy 2011-2012 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> +-- Portability : non-portable +-- +-- Primitive boxed mutable variables +-- + +module Data.Primitive.MutVar ( + MutVar(..), + + newMutVar, + readMutVar, + writeMutVar, + + atomicModifyMutVar, + atomicModifyMutVar', + modifyMutVar, + modifyMutVar' +) where + +import Control.Monad.Primitive ( PrimMonad(..), primitive_ ) +import GHC.Prim ( MutVar#, sameMutVar#, newMutVar#, + readMutVar#, writeMutVar#, atomicModifyMutVar# ) +import Data.Primitive.Internal.Compat ( isTrue# ) +import Data.Typeable ( Typeable ) + +-- | A 'MutVar' behaves like a single-element mutable array associated +-- with a primitive state token. +data MutVar s a = MutVar (MutVar# s a) + deriving ( Typeable ) + +instance Eq (MutVar s a) where + MutVar mva# == MutVar mvb# = isTrue# (sameMutVar# mva# mvb#) + +-- | Create a new 'MutVar' with the specified initial value +newMutVar :: PrimMonad m => a -> m (MutVar (PrimState m) a) +{-# INLINE newMutVar #-} +newMutVar initialValue = primitive $ \s# -> + case newMutVar# initialValue s# of + (# s'#, mv# #) -> (# s'#, MutVar mv# #) + +-- | Read the value of a 'MutVar' +readMutVar :: PrimMonad m => MutVar (PrimState m) a -> m a +{-# INLINE readMutVar #-} +readMutVar (MutVar mv#) = primitive (readMutVar# mv#) + +-- | Write a new value into a 'MutVar' +writeMutVar :: PrimMonad m => MutVar (PrimState m) a -> a -> m () +{-# INLINE writeMutVar #-} +writeMutVar (MutVar mv#) newValue = primitive_ (writeMutVar# mv# newValue) + +-- | Atomically mutate the contents of a 'MutVar' +atomicModifyMutVar :: PrimMonad m => MutVar (PrimState m) a -> (a -> (a,b)) -> m b +{-# INLINE atomicModifyMutVar #-} +atomicModifyMutVar (MutVar mv#) f = primitive $ atomicModifyMutVar# mv# f + +-- | Strict version of 'atomicModifyMutVar'. This forces both the value stored +-- in the 'MutVar' as well as the value returned. +atomicModifyMutVar' :: PrimMonad m => MutVar (PrimState m) a -> (a -> (a, b)) -> m b +{-# INLINE atomicModifyMutVar' #-} +atomicModifyMutVar' mv f = do + b <- atomicModifyMutVar mv force + b `seq` return b + where + force x = let (a, b) = f x in (a, a `seq` b) + +-- | Mutate the contents of a 'MutVar' +modifyMutVar :: PrimMonad m => MutVar (PrimState m) a -> (a -> a) -> m () +{-# INLINE modifyMutVar #-} +modifyMutVar (MutVar mv#) g = primitive_ $ \s# -> + case readMutVar# mv# s# of + (# s'#, a #) -> writeMutVar# mv# (g a) s'# + +-- | Strict version of 'modifyMutVar' +modifyMutVar' :: PrimMonad m => MutVar (PrimState m) a -> (a -> a) -> m () +{-# INLINE modifyMutVar' #-} +modifyMutVar' (MutVar mv#) g = primitive_ $ \s# -> + case readMutVar# mv# s# of + (# s'#, a #) -> let a' = g a in a' `seq` writeMutVar# mv# a' s'# + diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/PrimArray.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/PrimArray.hs new file mode 100644 index 000000000000..33d81c2092ee --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/PrimArray.hs @@ -0,0 +1,969 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} + +{-# OPTIONS_GHC -Wall #-} + +-- | +-- Module : Data.Primitive.PrimArray +-- Copyright : (c) Roman Leshchinskiy 2009-2012 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> +-- Portability : non-portable +-- +-- Arrays of unboxed primitive types. The function provided by this module +-- match the behavior of those provided by @Data.Primitive.ByteArray@, and +-- the underlying types and primops that back them are the same. +-- However, the type constructors 'PrimArray' and 'MutablePrimArray' take one additional +-- argument than their respective counterparts 'ByteArray' and 'MutableByteArray'. +-- This argument is used to designate the type of element in the array. +-- Consequently, all function this modules accepts length and incides in +-- terms of elements, not bytes. +-- +-- @since 0.6.4.0 +module Data.Primitive.PrimArray + ( -- * Types + PrimArray(..) + , MutablePrimArray(..) + -- * Allocation + , newPrimArray + , resizeMutablePrimArray +#if __GLASGOW_HASKELL__ >= 710 + , shrinkMutablePrimArray +#endif + -- * Element Access + , readPrimArray + , writePrimArray + , indexPrimArray + -- * Freezing and Thawing + , unsafeFreezePrimArray + , unsafeThawPrimArray + -- * Block Operations + , copyPrimArray + , copyMutablePrimArray +#if __GLASGOW_HASKELL__ >= 708 + , copyPrimArrayToPtr + , copyMutablePrimArrayToPtr +#endif + , setPrimArray + -- * Information + , sameMutablePrimArray + , getSizeofMutablePrimArray + , sizeofMutablePrimArray + , sizeofPrimArray + -- * List Conversion + , primArrayToList + , primArrayFromList + , primArrayFromListN + -- * Folding + , foldrPrimArray + , foldrPrimArray' + , foldlPrimArray + , foldlPrimArray' + , foldlPrimArrayM' + -- * Effectful Folding + , traversePrimArray_ + , itraversePrimArray_ + -- * Map/Create + , mapPrimArray + , imapPrimArray + , generatePrimArray + , replicatePrimArray + , filterPrimArray + , mapMaybePrimArray + -- * Effectful Map/Create + -- $effectfulMapCreate + -- ** Lazy Applicative + , traversePrimArray + , itraversePrimArray + , generatePrimArrayA + , replicatePrimArrayA + , filterPrimArrayA + , mapMaybePrimArrayA + -- ** Strict Primitive Monadic + , traversePrimArrayP + , itraversePrimArrayP + , generatePrimArrayP + , replicatePrimArrayP + , filterPrimArrayP + , mapMaybePrimArrayP + ) where + +import GHC.Prim +import GHC.Base ( Int(..) ) +import GHC.Exts (build) +import GHC.Ptr +import Data.Primitive.Internal.Compat (isTrue#) +import Data.Primitive.Types +import Data.Primitive.ByteArray (ByteArray(..)) +import Data.Monoid (Monoid(..),(<>)) +import Control.Applicative +import Control.Monad.Primitive +import Control.Monad.ST +import qualified Data.List as L +import qualified Data.Primitive.ByteArray as PB +import qualified Data.Primitive.Types as PT + +#if MIN_VERSION_base(4,7,0) +import GHC.Exts (IsList(..)) +#endif + +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup (Semigroup) +import qualified Data.Semigroup as SG +#endif + +-- | Arrays of unboxed elements. This accepts types like 'Double', 'Char', +-- 'Int', and 'Word', as well as their fixed-length variants ('Word8', +-- 'Word16', etc.). Since the elements are unboxed, a 'PrimArray' is strict +-- in its elements. This differs from the behavior of 'Array', which is lazy +-- in its elements. +data PrimArray a = PrimArray ByteArray# + +-- | Mutable primitive arrays associated with a primitive state token. +-- These can be written to and read from in a monadic context that supports +-- sequencing such as 'IO' or 'ST'. Typically, a mutable primitive array will +-- be built and then convert to an immutable primitive array using +-- 'unsafeFreezePrimArray'. However, it is also acceptable to simply discard +-- a mutable primitive array since it lives in managed memory and will be +-- garbage collected when no longer referenced. +data MutablePrimArray s a = MutablePrimArray (MutableByteArray# s) + +sameByteArray :: ByteArray# -> ByteArray# -> Bool +sameByteArray ba1 ba2 = + case reallyUnsafePtrEquality# (unsafeCoerce# ba1 :: ()) (unsafeCoerce# ba2 :: ()) of +#if __GLASGOW_HASKELL__ >= 708 + r -> isTrue# r +#else + 1# -> True + _ -> False +#endif + +-- | @since 0.6.4.0 +instance (Eq a, Prim a) => Eq (PrimArray a) where + a1@(PrimArray ba1#) == a2@(PrimArray ba2#) + | sameByteArray ba1# ba2# = True + | sz1 /= sz2 = False + | otherwise = loop (quot sz1 (sizeOf (undefined :: a)) - 1) + where + -- Here, we take the size in bytes, not in elements. We do this + -- since it allows us to defer performing the division to + -- calculate the size in elements. + sz1 = PB.sizeofByteArray (ByteArray ba1#) + sz2 = PB.sizeofByteArray (ByteArray ba2#) + loop !i + | i < 0 = True + | otherwise = indexPrimArray a1 i == indexPrimArray a2 i && loop (i-1) + +-- | Lexicographic ordering. Subject to change between major versions. +-- +-- @since 0.6.4.0 +instance (Ord a, Prim a) => Ord (PrimArray a) where + compare a1@(PrimArray ba1#) a2@(PrimArray ba2#) + | sameByteArray ba1# ba2# = EQ + | otherwise = loop 0 + where + sz1 = PB.sizeofByteArray (ByteArray ba1#) + sz2 = PB.sizeofByteArray (ByteArray ba2#) + sz = quot (min sz1 sz2) (sizeOf (undefined :: a)) + loop !i + | i < sz = compare (indexPrimArray a1 i) (indexPrimArray a2 i) <> loop (i+1) + | otherwise = compare sz1 sz2 + +#if MIN_VERSION_base(4,7,0) +-- | @since 0.6.4.0 +instance Prim a => IsList (PrimArray a) where + type Item (PrimArray a) = a + fromList = primArrayFromList + fromListN = primArrayFromListN + toList = primArrayToList +#endif + +-- | @since 0.6.4.0 +instance (Show a, Prim a) => Show (PrimArray a) where + showsPrec p a = showParen (p > 10) $ + showString "fromListN " . shows (sizeofPrimArray a) . showString " " + . shows (primArrayToList a) + +die :: String -> String -> a +die fun problem = error $ "Data.Primitive.PrimArray." ++ fun ++ ": " ++ problem + +primArrayFromList :: Prim a => [a] -> PrimArray a +primArrayFromList vs = primArrayFromListN (L.length vs) vs + +primArrayFromListN :: forall a. Prim a => Int -> [a] -> PrimArray a +primArrayFromListN len vs = runST run where + run :: forall s. ST s (PrimArray a) + run = do + arr <- newPrimArray len + let go :: [a] -> Int -> ST s () + go [] !ix = if ix == len + then return () + else die "fromListN" "list length less than specified size" + go (a : as) !ix = if ix < len + then do + writePrimArray arr ix a + go as (ix + 1) + else die "fromListN" "list length greater than specified size" + go vs 0 + unsafeFreezePrimArray arr + +-- | Convert the primitive array to a list. +{-# INLINE primArrayToList #-} +primArrayToList :: forall a. Prim a => PrimArray a -> [a] +primArrayToList xs = build (\c n -> foldrPrimArray c n xs) + +primArrayToByteArray :: PrimArray a -> PB.ByteArray +primArrayToByteArray (PrimArray x) = PB.ByteArray x + +byteArrayToPrimArray :: ByteArray -> PrimArray a +byteArrayToPrimArray (PB.ByteArray x) = PrimArray x + +#if MIN_VERSION_base(4,9,0) +-- | @since 0.6.4.0 +instance Semigroup (PrimArray a) where + x <> y = byteArrayToPrimArray (primArrayToByteArray x SG.<> primArrayToByteArray y) + sconcat = byteArrayToPrimArray . SG.sconcat . fmap primArrayToByteArray + stimes i arr = byteArrayToPrimArray (SG.stimes i (primArrayToByteArray arr)) +#endif + +-- | @since 0.6.4.0 +instance Monoid (PrimArray a) where + mempty = emptyPrimArray +#if !(MIN_VERSION_base(4,11,0)) + mappend x y = byteArrayToPrimArray (mappend (primArrayToByteArray x) (primArrayToByteArray y)) +#endif + mconcat = byteArrayToPrimArray . mconcat . map primArrayToByteArray + +-- | The empty primitive array. +emptyPrimArray :: PrimArray a +{-# NOINLINE emptyPrimArray #-} +emptyPrimArray = runST $ primitive $ \s0# -> case newByteArray# 0# s0# of + (# s1#, arr# #) -> case unsafeFreezeByteArray# arr# s1# of + (# s2#, arr'# #) -> (# s2#, PrimArray arr'# #) + +-- | Create a new mutable primitive array of the given length. The +-- underlying memory is left uninitialized. +newPrimArray :: forall m a. (PrimMonad m, Prim a) => Int -> m (MutablePrimArray (PrimState m) a) +{-# INLINE newPrimArray #-} +newPrimArray (I# n#) + = primitive (\s# -> + case newByteArray# (n# *# sizeOf# (undefined :: a)) s# of + (# s'#, arr# #) -> (# s'#, MutablePrimArray arr# #) + ) + +-- | Resize a mutable primitive array. The new size is given in elements. +-- +-- This will either resize the array in-place or, if not possible, allocate the +-- contents into a new, unpinned array and copy the original array\'s contents. +-- +-- To avoid undefined behaviour, the original 'MutablePrimArray' shall not be +-- accessed anymore after a 'resizeMutablePrimArray' has been performed. +-- Moreover, no reference to the old one should be kept in order to allow +-- garbage collection of the original 'MutablePrimArray' in case a new +-- 'MutablePrimArray' had to be allocated. +resizeMutablePrimArray :: forall m a. (PrimMonad m, Prim a) + => MutablePrimArray (PrimState m) a + -> Int -- ^ new size + -> m (MutablePrimArray (PrimState m) a) +{-# INLINE resizeMutablePrimArray #-} +#if __GLASGOW_HASKELL__ >= 710 +resizeMutablePrimArray (MutablePrimArray arr#) (I# n#) + = primitive (\s# -> case resizeMutableByteArray# arr# (n# *# sizeOf# (undefined :: a)) s# of + (# s'#, arr'# #) -> (# s'#, MutablePrimArray arr'# #)) +#else +resizeMutablePrimArray arr n + = do arr' <- newPrimArray n + copyMutablePrimArray arr' 0 arr 0 (min (sizeofMutablePrimArray arr) n) + return arr' +#endif + +-- Although it is possible to shim resizeMutableByteArray for old GHCs, this +-- is not the case with shrinkMutablePrimArray. +#if __GLASGOW_HASKELL__ >= 710 +-- | Shrink a mutable primitive array. The new size is given in elements. +-- It must be smaller than the old size. The array will be resized in place. +-- This function is only available when compiling with GHC 7.10 or newer. +shrinkMutablePrimArray :: forall m a. (PrimMonad m, Prim a) + => MutablePrimArray (PrimState m) a + -> Int -- ^ new size + -> m () +{-# INLINE shrinkMutablePrimArray #-} +shrinkMutablePrimArray (MutablePrimArray arr#) (I# n#) + = primitive_ (shrinkMutableByteArray# arr# (n# *# sizeOf# (undefined :: a))) +#endif + +readPrimArray :: (Prim a, PrimMonad m) => MutablePrimArray (PrimState m) a -> Int -> m a +{-# INLINE readPrimArray #-} +readPrimArray (MutablePrimArray arr#) (I# i#) + = primitive (readByteArray# arr# i#) + +-- | Write an element to the given index. +writePrimArray :: + (Prim a, PrimMonad m) + => MutablePrimArray (PrimState m) a -- ^ array + -> Int -- ^ index + -> a -- ^ element + -> m () +{-# INLINE writePrimArray #-} +writePrimArray (MutablePrimArray arr#) (I# i#) x + = primitive_ (writeByteArray# arr# i# x) + +-- | Copy part of a mutable array into another mutable array. +-- In the case that the destination and +-- source arrays are the same, the regions may overlap. +copyMutablePrimArray :: forall m a. + (PrimMonad m, Prim a) + => MutablePrimArray (PrimState m) a -- ^ destination array + -> Int -- ^ offset into destination array + -> MutablePrimArray (PrimState m) a -- ^ source array + -> Int -- ^ offset into source array + -> Int -- ^ number of elements to copy + -> m () +{-# INLINE copyMutablePrimArray #-} +copyMutablePrimArray (MutablePrimArray dst#) (I# doff#) (MutablePrimArray src#) (I# soff#) (I# n#) + = primitive_ (copyMutableByteArray# + src# + (soff# *# (sizeOf# (undefined :: a))) + dst# + (doff# *# (sizeOf# (undefined :: a))) + (n# *# (sizeOf# (undefined :: a))) + ) + +-- | Copy part of an array into another mutable array. +copyPrimArray :: forall m a. + (PrimMonad m, Prim a) + => MutablePrimArray (PrimState m) a -- ^ destination array + -> Int -- ^ offset into destination array + -> PrimArray a -- ^ source array + -> Int -- ^ offset into source array + -> Int -- ^ number of elements to copy + -> m () +{-# INLINE copyPrimArray #-} +copyPrimArray (MutablePrimArray dst#) (I# doff#) (PrimArray src#) (I# soff#) (I# n#) + = primitive_ (copyByteArray# + src# + (soff# *# (sizeOf# (undefined :: a))) + dst# + (doff# *# (sizeOf# (undefined :: a))) + (n# *# (sizeOf# (undefined :: a))) + ) + +#if __GLASGOW_HASKELL__ >= 708 +-- | Copy a slice of an immutable primitive array to an address. +-- The offset and length are given in elements of type @a@. +-- This function assumes that the 'Prim' instance of @a@ +-- agrees with the 'Storable' instance. This function is only +-- available when building with GHC 7.8 or newer. +copyPrimArrayToPtr :: forall m a. (PrimMonad m, Prim a) + => Ptr a -- ^ destination pointer + -> PrimArray a -- ^ source array + -> Int -- ^ offset into source array + -> Int -- ^ number of prims to copy + -> m () +{-# INLINE copyPrimArrayToPtr #-} +copyPrimArrayToPtr (Ptr addr#) (PrimArray ba#) (I# soff#) (I# n#) = + primitive (\ s# -> + let s'# = copyByteArrayToAddr# ba# (soff# *# siz#) addr# (n# *# siz#) s# + in (# s'#, () #)) + where siz# = sizeOf# (undefined :: a) + +-- | Copy a slice of an immutable primitive array to an address. +-- The offset and length are given in elements of type @a@. +-- This function assumes that the 'Prim' instance of @a@ +-- agrees with the 'Storable' instance. This function is only +-- available when building with GHC 7.8 or newer. +copyMutablePrimArrayToPtr :: forall m a. (PrimMonad m, Prim a) + => Ptr a -- ^ destination pointer + -> MutablePrimArray (PrimState m) a -- ^ source array + -> Int -- ^ offset into source array + -> Int -- ^ number of prims to copy + -> m () +{-# INLINE copyMutablePrimArrayToPtr #-} +copyMutablePrimArrayToPtr (Ptr addr#) (MutablePrimArray mba#) (I# soff#) (I# n#) = + primitive (\ s# -> + let s'# = copyMutableByteArrayToAddr# mba# (soff# *# siz#) addr# (n# *# siz#) s# + in (# s'#, () #)) + where siz# = sizeOf# (undefined :: a) +#endif + +-- | Fill a slice of a mutable primitive array with a value. +setPrimArray + :: (Prim a, PrimMonad m) + => MutablePrimArray (PrimState m) a -- ^ array to fill + -> Int -- ^ offset into array + -> Int -- ^ number of values to fill + -> a -- ^ value to fill with + -> m () +{-# INLINE setPrimArray #-} +setPrimArray (MutablePrimArray dst#) (I# doff#) (I# sz#) x + = primitive_ (PT.setByteArray# dst# doff# sz# x) + +-- | Get the size of a mutable primitive array in elements. Unlike 'sizeofMutablePrimArray', +-- this function ensures sequencing in the presence of resizing. +getSizeofMutablePrimArray :: forall m a. (PrimMonad m, Prim a) + => MutablePrimArray (PrimState m) a -- ^ array + -> m Int +{-# INLINE getSizeofMutablePrimArray #-} +#if __GLASGOW_HASKELL__ >= 801 +getSizeofMutablePrimArray (MutablePrimArray arr#) + = primitive (\s# -> + case getSizeofMutableByteArray# arr# s# of + (# s'#, sz# #) -> (# s'#, I# (quotInt# sz# (sizeOf# (undefined :: a))) #) + ) +#else +-- On older GHCs, it is not possible to resize a byte array, so +-- this provides behavior consistent with the implementation for +-- newer GHCs. +getSizeofMutablePrimArray arr + = return (sizeofMutablePrimArray arr) +#endif + +-- | Size of the mutable primitive array in elements. This function shall not +-- be used on primitive arrays that are an argument to or a result of +-- 'resizeMutablePrimArray' or 'shrinkMutablePrimArray'. +sizeofMutablePrimArray :: forall s a. Prim a => MutablePrimArray s a -> Int +{-# INLINE sizeofMutablePrimArray #-} +sizeofMutablePrimArray (MutablePrimArray arr#) = + I# (quotInt# (sizeofMutableByteArray# arr#) (sizeOf# (undefined :: a))) + +-- | Check if the two arrays refer to the same memory block. +sameMutablePrimArray :: MutablePrimArray s a -> MutablePrimArray s a -> Bool +{-# INLINE sameMutablePrimArray #-} +sameMutablePrimArray (MutablePrimArray arr#) (MutablePrimArray brr#) + = isTrue# (sameMutableByteArray# arr# brr#) + +-- | Convert a mutable byte array to an immutable one without copying. The +-- array should not be modified after the conversion. +unsafeFreezePrimArray + :: PrimMonad m => MutablePrimArray (PrimState m) a -> m (PrimArray a) +{-# INLINE unsafeFreezePrimArray #-} +unsafeFreezePrimArray (MutablePrimArray arr#) + = primitive (\s# -> case unsafeFreezeByteArray# arr# s# of + (# s'#, arr'# #) -> (# s'#, PrimArray arr'# #)) + +-- | Convert an immutable array to a mutable one without copying. The +-- original array should not be used after the conversion. +unsafeThawPrimArray + :: PrimMonad m => PrimArray a -> m (MutablePrimArray (PrimState m) a) +{-# INLINE unsafeThawPrimArray #-} +unsafeThawPrimArray (PrimArray arr#) + = primitive (\s# -> (# s#, MutablePrimArray (unsafeCoerce# arr#) #)) + +-- | Read a primitive value from the primitive array. +indexPrimArray :: forall a. Prim a => PrimArray a -> Int -> a +{-# INLINE indexPrimArray #-} +indexPrimArray (PrimArray arr#) (I# i#) = indexByteArray# arr# i# + +-- | Get the size, in elements, of the primitive array. +sizeofPrimArray :: forall a. Prim a => PrimArray a -> Int +{-# INLINE sizeofPrimArray #-} +sizeofPrimArray (PrimArray arr#) = I# (quotInt# (sizeofByteArray# arr#) (sizeOf# (undefined :: a))) + +-- | Lazy right-associated fold over the elements of a 'PrimArray'. +{-# INLINE foldrPrimArray #-} +foldrPrimArray :: forall a b. Prim a => (a -> b -> b) -> b -> PrimArray a -> b +foldrPrimArray f z arr = go 0 + where + !sz = sizeofPrimArray arr + go !i + | sz > i = f (indexPrimArray arr i) (go (i+1)) + | otherwise = z + +-- | Strict right-associated fold over the elements of a 'PrimArray'. +{-# INLINE foldrPrimArray' #-} +foldrPrimArray' :: forall a b. Prim a => (a -> b -> b) -> b -> PrimArray a -> b +foldrPrimArray' f z0 arr = go (sizeofPrimArray arr - 1) z0 + where + go !i !acc + | i < 0 = acc + | otherwise = go (i - 1) (f (indexPrimArray arr i) acc) + +-- | Lazy left-associated fold over the elements of a 'PrimArray'. +{-# INLINE foldlPrimArray #-} +foldlPrimArray :: forall a b. Prim a => (b -> a -> b) -> b -> PrimArray a -> b +foldlPrimArray f z arr = go (sizeofPrimArray arr - 1) + where + go !i + | i < 0 = z + | otherwise = f (go (i - 1)) (indexPrimArray arr i) + +-- | Strict left-associated fold over the elements of a 'PrimArray'. +{-# INLINE foldlPrimArray' #-} +foldlPrimArray' :: forall a b. Prim a => (b -> a -> b) -> b -> PrimArray a -> b +foldlPrimArray' f z0 arr = go 0 z0 + where + !sz = sizeofPrimArray arr + go !i !acc + | i < sz = go (i + 1) (f acc (indexPrimArray arr i)) + | otherwise = acc + +-- | Strict left-associated fold over the elements of a 'PrimArray'. +{-# INLINE foldlPrimArrayM' #-} +foldlPrimArrayM' :: (Prim a, Monad m) => (b -> a -> m b) -> b -> PrimArray a -> m b +foldlPrimArrayM' f z0 arr = go 0 z0 + where + !sz = sizeofPrimArray arr + go !i !acc1 + | i < sz = do + acc2 <- f acc1 (indexPrimArray arr i) + go (i + 1) acc2 + | otherwise = return acc1 + +-- | Traverse a primitive array. The traversal forces the resulting values and +-- writes them to the new primitive array as it performs the monadic effects. +-- Consequently: +-- +-- >>> traversePrimArrayP (\x -> print x $> bool x undefined (x == 2)) (fromList [1, 2, 3 :: Int]) +-- 1 +-- 2 +-- *** Exception: Prelude.undefined +-- +-- In many situations, 'traversePrimArrayP' can replace 'traversePrimArray', +-- changing the strictness characteristics of the traversal but typically improving +-- the performance. Consider the following short-circuiting traversal: +-- +-- > incrPositiveA :: PrimArray Int -> Maybe (PrimArray Int) +-- > incrPositiveA xs = traversePrimArray (\x -> bool Nothing (Just (x + 1)) (x > 0)) xs +-- +-- This can be rewritten using 'traversePrimArrayP'. To do this, we must +-- change the traversal context to @MaybeT (ST s)@, which has a 'PrimMonad' +-- instance: +-- +-- > incrPositiveB :: PrimArray Int -> Maybe (PrimArray Int) +-- > incrPositiveB xs = runST $ runMaybeT $ traversePrimArrayP +-- > (\x -> bool (MaybeT (return Nothing)) (MaybeT (return (Just (x + 1)))) (x > 0)) +-- > xs +-- +-- Benchmarks demonstrate that the second implementation runs 150 times +-- faster than the first. It also results in fewer allocations. +{-# INLINE traversePrimArrayP #-} +traversePrimArrayP :: (PrimMonad m, Prim a, Prim b) + => (a -> m b) + -> PrimArray a + -> m (PrimArray b) +traversePrimArrayP f arr = do + let !sz = sizeofPrimArray arr + marr <- newPrimArray sz + let go !ix = if ix < sz + then do + b <- f (indexPrimArray arr ix) + writePrimArray marr ix b + go (ix + 1) + else return () + go 0 + unsafeFreezePrimArray marr + +-- | Filter the primitive array, keeping the elements for which the monadic +-- predicate evaluates true. +{-# INLINE filterPrimArrayP #-} +filterPrimArrayP :: (PrimMonad m, Prim a) + => (a -> m Bool) + -> PrimArray a + -> m (PrimArray a) +filterPrimArrayP f arr = do + let !sz = sizeofPrimArray arr + marr <- newPrimArray sz + let go !ixSrc !ixDst = if ixSrc < sz + then do + let a = indexPrimArray arr ixSrc + b <- f a + if b + then do + writePrimArray marr ixDst a + go (ixSrc + 1) (ixDst + 1) + else go (ixSrc + 1) ixDst + else return ixDst + lenDst <- go 0 0 + marr' <- resizeMutablePrimArray marr lenDst + unsafeFreezePrimArray marr' + +-- | Map over the primitive array, keeping the elements for which the monadic +-- predicate provides a 'Just'. +{-# INLINE mapMaybePrimArrayP #-} +mapMaybePrimArrayP :: (PrimMonad m, Prim a, Prim b) + => (a -> m (Maybe b)) + -> PrimArray a + -> m (PrimArray b) +mapMaybePrimArrayP f arr = do + let !sz = sizeofPrimArray arr + marr <- newPrimArray sz + let go !ixSrc !ixDst = if ixSrc < sz + then do + let a = indexPrimArray arr ixSrc + mb <- f a + case mb of + Just b -> do + writePrimArray marr ixDst b + go (ixSrc + 1) (ixDst + 1) + Nothing -> go (ixSrc + 1) ixDst + else return ixDst + lenDst <- go 0 0 + marr' <- resizeMutablePrimArray marr lenDst + unsafeFreezePrimArray marr' + +-- | Generate a primitive array by evaluating the monadic generator function +-- at each index. +{-# INLINE generatePrimArrayP #-} +generatePrimArrayP :: (PrimMonad m, Prim a) + => Int -- ^ length + -> (Int -> m a) -- ^ generator + -> m (PrimArray a) +generatePrimArrayP sz f = do + marr <- newPrimArray sz + let go !ix = if ix < sz + then do + b <- f ix + writePrimArray marr ix b + go (ix + 1) + else return () + go 0 + unsafeFreezePrimArray marr + +-- | Execute the monadic action the given number of times and store the +-- results in a primitive array. +{-# INLINE replicatePrimArrayP #-} +replicatePrimArrayP :: (PrimMonad m, Prim a) + => Int + -> m a + -> m (PrimArray a) +replicatePrimArrayP sz f = do + marr <- newPrimArray sz + let go !ix = if ix < sz + then do + b <- f + writePrimArray marr ix b + go (ix + 1) + else return () + go 0 + unsafeFreezePrimArray marr + + +-- | Map over the elements of a primitive array. +{-# INLINE mapPrimArray #-} +mapPrimArray :: (Prim a, Prim b) + => (a -> b) + -> PrimArray a + -> PrimArray b +mapPrimArray f arr = runST $ do + let !sz = sizeofPrimArray arr + marr <- newPrimArray sz + let go !ix = if ix < sz + then do + let b = f (indexPrimArray arr ix) + writePrimArray marr ix b + go (ix + 1) + else return () + go 0 + unsafeFreezePrimArray marr + +-- | Indexed map over the elements of a primitive array. +{-# INLINE imapPrimArray #-} +imapPrimArray :: (Prim a, Prim b) + => (Int -> a -> b) + -> PrimArray a + -> PrimArray b +imapPrimArray f arr = runST $ do + let !sz = sizeofPrimArray arr + marr <- newPrimArray sz + let go !ix = if ix < sz + then do + let b = f ix (indexPrimArray arr ix) + writePrimArray marr ix b + go (ix + 1) + else return () + go 0 + unsafeFreezePrimArray marr + +-- | Filter elements of a primitive array according to a predicate. +{-# INLINE filterPrimArray #-} +filterPrimArray :: Prim a + => (a -> Bool) + -> PrimArray a + -> PrimArray a +filterPrimArray p arr = runST $ do + let !sz = sizeofPrimArray arr + marr <- newPrimArray sz + let go !ixSrc !ixDst = if ixSrc < sz + then do + let !a = indexPrimArray arr ixSrc + if p a + then do + writePrimArray marr ixDst a + go (ixSrc + 1) (ixDst + 1) + else go (ixSrc + 1) ixDst + else return ixDst + dstLen <- go 0 0 + marr' <- resizeMutablePrimArray marr dstLen + unsafeFreezePrimArray marr' + +-- | Filter the primitive array, keeping the elements for which the monadic +-- predicate evaluates true. +filterPrimArrayA :: + (Applicative f, Prim a) + => (a -> f Bool) -- ^ mapping function + -> PrimArray a -- ^ primitive array + -> f (PrimArray a) +filterPrimArrayA f = \ !ary -> + let + !len = sizeofPrimArray ary + go !ixSrc + | ixSrc == len = pure $ IxSTA $ \ixDst _ -> return ixDst + | otherwise = let x = indexPrimArray ary ixSrc in + liftA2 + (\keep (IxSTA m) -> IxSTA $ \ixDst mary -> if keep + then writePrimArray (MutablePrimArray mary) ixDst x >> m (ixDst + 1) mary + else m ixDst mary + ) + (f x) + (go (ixSrc + 1)) + in if len == 0 + then pure emptyPrimArray + else runIxSTA len <$> go 0 + +-- | Map over the primitive array, keeping the elements for which the applicative +-- predicate provides a 'Just'. +mapMaybePrimArrayA :: + (Applicative f, Prim a, Prim b) + => (a -> f (Maybe b)) -- ^ mapping function + -> PrimArray a -- ^ primitive array + -> f (PrimArray b) +mapMaybePrimArrayA f = \ !ary -> + let + !len = sizeofPrimArray ary + go !ixSrc + | ixSrc == len = pure $ IxSTA $ \ixDst _ -> return ixDst + | otherwise = let x = indexPrimArray ary ixSrc in + liftA2 + (\mb (IxSTA m) -> IxSTA $ \ixDst mary -> case mb of + Just b -> writePrimArray (MutablePrimArray mary) ixDst b >> m (ixDst + 1) mary + Nothing -> m ixDst mary + ) + (f x) + (go (ixSrc + 1)) + in if len == 0 + then pure emptyPrimArray + else runIxSTA len <$> go 0 + +-- | Map over a primitive array, optionally discarding some elements. This +-- has the same behavior as @Data.Maybe.mapMaybe@. +{-# INLINE mapMaybePrimArray #-} +mapMaybePrimArray :: (Prim a, Prim b) + => (a -> Maybe b) + -> PrimArray a + -> PrimArray b +mapMaybePrimArray p arr = runST $ do + let !sz = sizeofPrimArray arr + marr <- newPrimArray sz + let go !ixSrc !ixDst = if ixSrc < sz + then do + let !a = indexPrimArray arr ixSrc + case p a of + Just b -> do + writePrimArray marr ixDst b + go (ixSrc + 1) (ixDst + 1) + Nothing -> go (ixSrc + 1) ixDst + else return ixDst + dstLen <- go 0 0 + marr' <- resizeMutablePrimArray marr dstLen + unsafeFreezePrimArray marr' + + +-- | Traverse a primitive array. The traversal performs all of the applicative +-- effects /before/ forcing the resulting values and writing them to the new +-- primitive array. Consequently: +-- +-- >>> traversePrimArray (\x -> print x $> bool x undefined (x == 2)) (fromList [1, 2, 3 :: Int]) +-- 1 +-- 2 +-- 3 +-- *** Exception: Prelude.undefined +-- +-- The function 'traversePrimArrayP' always outperforms this function, but it +-- requires a 'PrimAffineMonad' constraint, and it forces the values as +-- it performs the effects. +traversePrimArray :: + (Applicative f, Prim a, Prim b) + => (a -> f b) -- ^ mapping function + -> PrimArray a -- ^ primitive array + -> f (PrimArray b) +traversePrimArray f = \ !ary -> + let + !len = sizeofPrimArray ary + go !i + | i == len = pure $ STA $ \mary -> unsafeFreezePrimArray (MutablePrimArray mary) + | x <- indexPrimArray ary i + = liftA2 (\b (STA m) -> STA $ \mary -> + writePrimArray (MutablePrimArray mary) i b >> m mary) + (f x) (go (i + 1)) + in if len == 0 + then pure emptyPrimArray + else runSTA len <$> go 0 + +-- | Traverse a primitive array with the index of each element. +itraversePrimArray :: + (Applicative f, Prim a, Prim b) + => (Int -> a -> f b) + -> PrimArray a + -> f (PrimArray b) +itraversePrimArray f = \ !ary -> + let + !len = sizeofPrimArray ary + go !i + | i == len = pure $ STA $ \mary -> unsafeFreezePrimArray (MutablePrimArray mary) + | x <- indexPrimArray ary i + = liftA2 (\b (STA m) -> STA $ \mary -> + writePrimArray (MutablePrimArray mary) i b >> m mary) + (f i x) (go (i + 1)) + in if len == 0 + then pure emptyPrimArray + else runSTA len <$> go 0 + +-- | Traverse a primitive array with the indices. The traversal forces the +-- resulting values and writes them to the new primitive array as it performs +-- the monadic effects. +{-# INLINE itraversePrimArrayP #-} +itraversePrimArrayP :: (Prim a, Prim b, PrimMonad m) + => (Int -> a -> m b) + -> PrimArray a + -> m (PrimArray b) +itraversePrimArrayP f arr = do + let !sz = sizeofPrimArray arr + marr <- newPrimArray sz + let go !ix + | ix < sz = do + writePrimArray marr ix =<< f ix (indexPrimArray arr ix) + go (ix + 1) + | otherwise = return () + go 0 + unsafeFreezePrimArray marr + +-- | Generate a primitive array. +{-# INLINE generatePrimArray #-} +generatePrimArray :: Prim a + => Int -- ^ length + -> (Int -> a) -- ^ element from index + -> PrimArray a +generatePrimArray len f = runST $ do + marr <- newPrimArray len + let go !ix = if ix < len + then do + writePrimArray marr ix (f ix) + go (ix + 1) + else return () + go 0 + unsafeFreezePrimArray marr + +-- | Create a primitive array by copying the element the given +-- number of times. +{-# INLINE replicatePrimArray #-} +replicatePrimArray :: Prim a + => Int -- ^ length + -> a -- ^ element + -> PrimArray a +replicatePrimArray len a = runST $ do + marr <- newPrimArray len + setPrimArray marr 0 len a + unsafeFreezePrimArray marr + +-- | Generate a primitive array by evaluating the applicative generator +-- function at each index. +{-# INLINE generatePrimArrayA #-} +generatePrimArrayA :: + (Applicative f, Prim a) + => Int -- ^ length + -> (Int -> f a) -- ^ element from index + -> f (PrimArray a) +generatePrimArrayA len f = + let + go !i + | i == len = pure $ STA $ \mary -> unsafeFreezePrimArray (MutablePrimArray mary) + | otherwise + = liftA2 (\b (STA m) -> STA $ \mary -> + writePrimArray (MutablePrimArray mary) i b >> m mary) + (f i) (go (i + 1)) + in if len == 0 + then pure emptyPrimArray + else runSTA len <$> go 0 + +-- | Execute the applicative action the given number of times and store the +-- results in a vector. +{-# INLINE replicatePrimArrayA #-} +replicatePrimArrayA :: + (Applicative f, Prim a) + => Int -- ^ length + -> f a -- ^ applicative element producer + -> f (PrimArray a) +replicatePrimArrayA len f = + let + go !i + | i == len = pure $ STA $ \mary -> unsafeFreezePrimArray (MutablePrimArray mary) + | otherwise + = liftA2 (\b (STA m) -> STA $ \mary -> + writePrimArray (MutablePrimArray mary) i b >> m mary) + f (go (i + 1)) + in if len == 0 + then pure emptyPrimArray + else runSTA len <$> go 0 + +-- | Traverse the primitive array, discarding the results. There +-- is no 'PrimMonad' variant of this function since it would not provide +-- any performance benefit. +traversePrimArray_ :: + (Applicative f, Prim a) + => (a -> f b) + -> PrimArray a + -> f () +traversePrimArray_ f a = go 0 where + !sz = sizeofPrimArray a + go !ix = if ix < sz + then f (indexPrimArray a ix) *> go (ix + 1) + else pure () + +-- | Traverse the primitive array with the indices, discarding the results. +-- There is no 'PrimMonad' variant of this function since it would not +-- provide any performance benefit. +itraversePrimArray_ :: + (Applicative f, Prim a) + => (Int -> a -> f b) + -> PrimArray a + -> f () +itraversePrimArray_ f a = go 0 where + !sz = sizeofPrimArray a + go !ix = if ix < sz + then f ix (indexPrimArray a ix) *> go (ix + 1) + else pure () + +newtype IxSTA a = IxSTA {_runIxSTA :: forall s. Int -> MutableByteArray# s -> ST s Int} + +runIxSTA :: forall a. Prim a + => Int -- maximum possible size + -> IxSTA a + -> PrimArray a +runIxSTA !szUpper = \ (IxSTA m) -> runST $ do + ar :: MutablePrimArray s a <- newPrimArray szUpper + sz <- m 0 (unMutablePrimArray ar) + ar' <- resizeMutablePrimArray ar sz + unsafeFreezePrimArray ar' +{-# INLINE runIxSTA #-} + +newtype STA a = STA {_runSTA :: forall s. MutableByteArray# s -> ST s (PrimArray a)} + +runSTA :: forall a. Prim a => Int -> STA a -> PrimArray a +runSTA !sz = \ (STA m) -> runST $ newPrimArray sz >>= \ (ar :: MutablePrimArray s a) -> m (unMutablePrimArray ar) +{-# INLINE runSTA #-} + +unMutablePrimArray :: MutablePrimArray s a -> MutableByteArray# s +unMutablePrimArray (MutablePrimArray m) = m + +{- $effectfulMapCreate +The naming conventions adopted in this section are explained in the +documentation of the @Data.Primitive@ module. +-} + + diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Ptr.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Ptr.hs new file mode 100644 index 000000000000..d93ae9ac114d --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Ptr.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Data.Primitive.Ptr +-- Copyright : (c) Roman Leshchinskiy 2009-2012 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> +-- Portability : non-portable +-- +-- Primitive operations on machine addresses +-- +-- @since 0.6.4.0 + +module Data.Primitive.Ptr ( + -- * Types + Ptr(..), + + -- * Address arithmetic + nullPtr, advancePtr, subtractPtr, + + -- * Element access + indexOffPtr, readOffPtr, writeOffPtr, + + -- * Block operations + copyPtr, movePtr, setPtr + +#if __GLASGOW_HASKELL__ >= 708 + , copyPtrToMutablePrimArray +#endif +) where + +import Control.Monad.Primitive +import Data.Primitive.Types +#if __GLASGOW_HASKELL__ >= 708 +import Data.Primitive.PrimArray (MutablePrimArray(..)) +#endif + +import GHC.Base ( Int(..) ) +import GHC.Prim + +import GHC.Ptr +import Foreign.Marshal.Utils + + +-- | Offset a pointer by the given number of elements. +advancePtr :: forall a. Prim a => Ptr a -> Int -> Ptr a +{-# INLINE advancePtr #-} +advancePtr (Ptr a#) (I# i#) = Ptr (plusAddr# a# (i# *# sizeOf# (undefined :: a))) + +-- | Subtract a pointer from another pointer. The result represents +-- the number of elements of type @a@ that fit in the contiguous +-- memory range bounded by these two pointers. +subtractPtr :: forall a. Prim a => Ptr a -> Ptr a -> Int +{-# INLINE subtractPtr #-} +subtractPtr (Ptr a#) (Ptr b#) = I# (quotInt# (minusAddr# a# b#) (sizeOf# (undefined :: a))) + +-- | Read a value from a memory position given by a pointer and an offset. +-- The memory block the address refers to must be immutable. The offset is in +-- elements of type @a@ rather than in bytes. +indexOffPtr :: Prim a => Ptr a -> Int -> a +{-# INLINE indexOffPtr #-} +indexOffPtr (Ptr addr#) (I# i#) = indexOffAddr# addr# i# + +-- | Read a value from a memory position given by an address and an offset. +-- The offset is in elements of type @a@ rather than in bytes. +readOffPtr :: (Prim a, PrimMonad m) => Ptr a -> Int -> m a +{-# INLINE readOffPtr #-} +readOffPtr (Ptr addr#) (I# i#) = primitive (readOffAddr# addr# i#) + +-- | Write a value to a memory position given by an address and an offset. +-- The offset is in elements of type @a@ rather than in bytes. +writeOffPtr :: (Prim a, PrimMonad m) => Ptr a -> Int -> a -> m () +{-# INLINE writeOffPtr #-} +writeOffPtr (Ptr addr#) (I# i#) x = primitive_ (writeOffAddr# addr# i# x) + +-- | Copy the given number of elements from the second 'Ptr' to the first. The +-- areas may not overlap. +copyPtr :: forall m a. (PrimMonad m, Prim a) + => Ptr a -- ^ destination pointer + -> Ptr a -- ^ source pointer + -> Int -- ^ number of elements + -> m () +{-# INLINE copyPtr #-} +copyPtr (Ptr dst#) (Ptr src#) n + = unsafePrimToPrim $ copyBytes (Ptr dst#) (Ptr src#) (n * sizeOf (undefined :: a)) + +-- | Copy the given number of elements from the second 'Ptr' to the first. The +-- areas may overlap. +movePtr :: forall m a. (PrimMonad m, Prim a) + => Ptr a -- ^ destination address + -> Ptr a -- ^ source address + -> Int -- ^ number of elements + -> m () +{-# INLINE movePtr #-} +movePtr (Ptr dst#) (Ptr src#) n + = unsafePrimToPrim $ moveBytes (Ptr dst#) (Ptr src#) (n * sizeOf (undefined :: a)) + +-- | Fill a memory block with the given value. The length is in +-- elements of type @a@ rather than in bytes. +setPtr :: (Prim a, PrimMonad m) => Ptr a -> Int -> a -> m () +{-# INLINE setPtr #-} +setPtr (Ptr addr#) (I# n#) x = primitive_ (setOffAddr# addr# 0# n# x) + + +#if __GLASGOW_HASKELL__ >= 708 +-- | Copy from a pointer to a mutable primitive array. +-- The offset and length are given in elements of type @a@. +-- This function is only available when building with GHC 7.8 +-- or newer. +copyPtrToMutablePrimArray :: forall m a. (PrimMonad m, Prim a) + => MutablePrimArray (PrimState m) a -- ^ destination array + -> Int -- ^ destination offset + -> Ptr a -- ^ source pointer + -> Int -- ^ number of elements + -> m () +{-# INLINE copyPtrToMutablePrimArray #-} +copyPtrToMutablePrimArray (MutablePrimArray ba#) (I# doff#) (Ptr addr#) (I# n#) = + primitive_ (copyAddrToByteArray# addr# ba# (doff# *# siz#) (n# *# siz#)) + where + siz# = sizeOf# (undefined :: a) +#endif diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/SmallArray.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/SmallArray.hs new file mode 100644 index 000000000000..3a50cf218380 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/SmallArray.hs @@ -0,0 +1,967 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE BangPatterns #-} + +-- | +-- Module : Data.Primitive.SmallArray +-- Copyright: (c) 2015 Dan Doel +-- License: BSD3 +-- +-- Maintainer: libraries@haskell.org +-- Portability: non-portable +-- +-- Small arrays are boxed (im)mutable arrays. +-- +-- The underlying structure of the 'Array' type contains a card table, allowing +-- segments of the array to be marked as having been mutated. This allows the +-- garbage collector to only re-traverse segments of the array that have been +-- marked during certain phases, rather than having to traverse the entire +-- array. +-- +-- 'SmallArray' lacks this table. This means that it takes up less memory and +-- has slightly faster writes. It is also more efficient during garbage +-- collection so long as the card table would have a single entry covering the +-- entire array. These advantages make them suitable for use as arrays that are +-- known to be small. +-- +-- The card size is 128, so for uses much larger than that, 'Array' would likely +-- be superior. +-- +-- The underlying type, 'SmallArray#', was introduced in GHC 7.10, so prior to +-- that version, this module simply implements small arrays as 'Array'. + +module Data.Primitive.SmallArray + ( SmallArray(..) + , SmallMutableArray(..) + , newSmallArray + , readSmallArray + , writeSmallArray + , copySmallArray + , copySmallMutableArray + , indexSmallArray + , indexSmallArrayM + , indexSmallArray## + , cloneSmallArray + , cloneSmallMutableArray + , freezeSmallArray + , unsafeFreezeSmallArray + , thawSmallArray + , runSmallArray + , unsafeThawSmallArray + , sizeofSmallArray + , sizeofSmallMutableArray + , smallArrayFromList + , smallArrayFromListN + , mapSmallArray' + , traverseSmallArrayP + ) where + + +#if (__GLASGOW_HASKELL__ >= 710) +#define HAVE_SMALL_ARRAY 1 +#endif + +#if MIN_VERSION_base(4,7,0) +import GHC.Exts hiding (toList) +import qualified GHC.Exts +#endif + +import Control.Applicative +import Control.Monad +import Control.Monad.Fix +import Control.Monad.Primitive +import Control.Monad.ST +import Control.Monad.Zip +import Data.Data +import Data.Foldable as Foldable +import Data.Functor.Identity +#if !(MIN_VERSION_base(4,10,0)) +import Data.Monoid +#endif +#if MIN_VERSION_base(4,9,0) +import qualified GHC.ST as GHCST +import qualified Data.Semigroup as Sem +#endif +import Text.ParserCombinators.ReadP +#if MIN_VERSION_base(4,10,0) +import GHC.Exts (runRW#) +#elif MIN_VERSION_base(4,9,0) +import GHC.Base (runRW#) +#endif + +#if !(HAVE_SMALL_ARRAY) +import Data.Primitive.Array +import Data.Traversable +import qualified Data.Primitive.Array as Array +#endif + +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) +import Data.Functor.Classes (Eq1(..),Ord1(..),Show1(..),Read1(..)) +#endif + +#if HAVE_SMALL_ARRAY +data SmallArray a = SmallArray (SmallArray# a) + deriving Typeable +#else +newtype SmallArray a = SmallArray (Array a) deriving + ( Eq + , Ord + , Show + , Read + , Foldable + , Traversable + , Functor + , Applicative + , Alternative + , Monad + , MonadPlus + , MonadZip + , MonadFix + , Monoid + , Typeable +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) + , Eq1 + , Ord1 + , Show1 + , Read1 +#endif + ) + +#if MIN_VERSION_base(4,7,0) +instance IsList (SmallArray a) where + type Item (SmallArray a) = a + fromListN n l = SmallArray (fromListN n l) + fromList l = SmallArray (fromList l) + toList a = Foldable.toList a +#endif +#endif + +#if HAVE_SMALL_ARRAY +data SmallMutableArray s a = SmallMutableArray (SmallMutableArray# s a) + deriving Typeable +#else +newtype SmallMutableArray s a = SmallMutableArray (MutableArray s a) + deriving (Eq, Typeable) +#endif + +-- | Create a new small mutable array. +newSmallArray + :: PrimMonad m + => Int -- ^ size + -> a -- ^ initial contents + -> m (SmallMutableArray (PrimState m) a) +#if HAVE_SMALL_ARRAY +newSmallArray (I# i#) x = primitive $ \s -> + case newSmallArray# i# x s of + (# s', sma# #) -> (# s', SmallMutableArray sma# #) +#else +newSmallArray n e = SmallMutableArray `liftM` newArray n e +#endif +{-# INLINE newSmallArray #-} + +-- | Read the element at a given index in a mutable array. +readSmallArray + :: PrimMonad m + => SmallMutableArray (PrimState m) a -- ^ array + -> Int -- ^ index + -> m a +#if HAVE_SMALL_ARRAY +readSmallArray (SmallMutableArray sma#) (I# i#) = + primitive $ readSmallArray# sma# i# +#else +readSmallArray (SmallMutableArray a) = readArray a +#endif +{-# INLINE readSmallArray #-} + +-- | Write an element at the given idex in a mutable array. +writeSmallArray + :: PrimMonad m + => SmallMutableArray (PrimState m) a -- ^ array + -> Int -- ^ index + -> a -- ^ new element + -> m () +#if HAVE_SMALL_ARRAY +writeSmallArray (SmallMutableArray sma#) (I# i#) x = + primitive_ $ writeSmallArray# sma# i# x +#else +writeSmallArray (SmallMutableArray a) = writeArray a +#endif +{-# INLINE writeSmallArray #-} + +-- | Look up an element in an immutable array. +-- +-- The purpose of returning a result using a monad is to allow the caller to +-- avoid retaining references to the array. Evaluating the return value will +-- cause the array lookup to be performed, even though it may not require the +-- element of the array to be evaluated (which could throw an exception). For +-- instance: +-- +-- > data Box a = Box a +-- > ... +-- > +-- > f sa = case indexSmallArrayM sa 0 of +-- > Box x -> ... +-- +-- 'x' is not a closure that references 'sa' as it would be if we instead +-- wrote: +-- +-- > let x = indexSmallArray sa 0 +-- +-- And does not prevent 'sa' from being garbage collected. +-- +-- Note that 'Identity' is not adequate for this use, as it is a newtype, and +-- cannot be evaluated without evaluating the element. +indexSmallArrayM + :: Monad m + => SmallArray a -- ^ array + -> Int -- ^ index + -> m a +#if HAVE_SMALL_ARRAY +indexSmallArrayM (SmallArray sa#) (I# i#) = + case indexSmallArray# sa# i# of + (# x #) -> pure x +#else +indexSmallArrayM (SmallArray a) = indexArrayM a +#endif +{-# INLINE indexSmallArrayM #-} + +-- | Look up an element in an immutable array. +indexSmallArray + :: SmallArray a -- ^ array + -> Int -- ^ index + -> a +#if HAVE_SMALL_ARRAY +indexSmallArray sa i = runIdentity $ indexSmallArrayM sa i +#else +indexSmallArray (SmallArray a) = indexArray a +#endif +{-# INLINE indexSmallArray #-} + +-- | Read a value from the immutable array at the given index, returning +-- the result in an unboxed unary tuple. This is currently used to implement +-- folds. +indexSmallArray## :: SmallArray a -> Int -> (# a #) +#if HAVE_SMALL_ARRAY +indexSmallArray## (SmallArray ary) (I# i) = indexSmallArray# ary i +#else +indexSmallArray## (SmallArray a) = indexArray## a +#endif +{-# INLINE indexSmallArray## #-} + +-- | Create a copy of a slice of an immutable array. +cloneSmallArray + :: SmallArray a -- ^ source + -> Int -- ^ offset + -> Int -- ^ length + -> SmallArray a +#if HAVE_SMALL_ARRAY +cloneSmallArray (SmallArray sa#) (I# i#) (I# j#) = + SmallArray (cloneSmallArray# sa# i# j#) +#else +cloneSmallArray (SmallArray a) i j = SmallArray $ cloneArray a i j +#endif +{-# INLINE cloneSmallArray #-} + +-- | Create a copy of a slice of a mutable array. +cloneSmallMutableArray + :: PrimMonad m + => SmallMutableArray (PrimState m) a -- ^ source + -> Int -- ^ offset + -> Int -- ^ length + -> m (SmallMutableArray (PrimState m) a) +#if HAVE_SMALL_ARRAY +cloneSmallMutableArray (SmallMutableArray sma#) (I# o#) (I# l#) = + primitive $ \s -> case cloneSmallMutableArray# sma# o# l# s of + (# s', smb# #) -> (# s', SmallMutableArray smb# #) +#else +cloneSmallMutableArray (SmallMutableArray ma) i j = + SmallMutableArray `liftM` cloneMutableArray ma i j +#endif +{-# INLINE cloneSmallMutableArray #-} + +-- | Create an immutable array corresponding to a slice of a mutable array. +-- +-- This operation copies the portion of the array to be frozen. +freezeSmallArray + :: PrimMonad m + => SmallMutableArray (PrimState m) a -- ^ source + -> Int -- ^ offset + -> Int -- ^ length + -> m (SmallArray a) +#if HAVE_SMALL_ARRAY +freezeSmallArray (SmallMutableArray sma#) (I# i#) (I# j#) = + primitive $ \s -> case freezeSmallArray# sma# i# j# s of + (# s', sa# #) -> (# s', SmallArray sa# #) +#else +freezeSmallArray (SmallMutableArray ma) i j = + SmallArray `liftM` freezeArray ma i j +#endif +{-# INLINE freezeSmallArray #-} + +-- | Render a mutable array immutable. +-- +-- This operation performs no copying, so care must be taken not to modify the +-- input array after freezing. +unsafeFreezeSmallArray + :: PrimMonad m => SmallMutableArray (PrimState m) a -> m (SmallArray a) +#if HAVE_SMALL_ARRAY +unsafeFreezeSmallArray (SmallMutableArray sma#) = + primitive $ \s -> case unsafeFreezeSmallArray# sma# s of + (# s', sa# #) -> (# s', SmallArray sa# #) +#else +unsafeFreezeSmallArray (SmallMutableArray ma) = + SmallArray `liftM` unsafeFreezeArray ma +#endif +{-# INLINE unsafeFreezeSmallArray #-} + +-- | Create a mutable array corresponding to a slice of an immutable array. +-- +-- This operation copies the portion of the array to be thawed. +thawSmallArray + :: PrimMonad m + => SmallArray a -- ^ source + -> Int -- ^ offset + -> Int -- ^ length + -> m (SmallMutableArray (PrimState m) a) +#if HAVE_SMALL_ARRAY +thawSmallArray (SmallArray sa#) (I# o#) (I# l#) = + primitive $ \s -> case thawSmallArray# sa# o# l# s of + (# s', sma# #) -> (# s', SmallMutableArray sma# #) +#else +thawSmallArray (SmallArray a) off len = + SmallMutableArray `liftM` thawArray a off len +#endif +{-# INLINE thawSmallArray #-} + +-- | Render an immutable array mutable. +-- +-- This operation performs no copying, so care must be taken with its use. +unsafeThawSmallArray + :: PrimMonad m => SmallArray a -> m (SmallMutableArray (PrimState m) a) +#if HAVE_SMALL_ARRAY +unsafeThawSmallArray (SmallArray sa#) = + primitive $ \s -> case unsafeThawSmallArray# sa# s of + (# s', sma# #) -> (# s', SmallMutableArray sma# #) +#else +unsafeThawSmallArray (SmallArray a) = SmallMutableArray `liftM` unsafeThawArray a +#endif +{-# INLINE unsafeThawSmallArray #-} + +-- | Copy a slice of an immutable array into a mutable array. +copySmallArray + :: PrimMonad m + => SmallMutableArray (PrimState m) a -- ^ destination + -> Int -- ^ destination offset + -> SmallArray a -- ^ source + -> Int -- ^ source offset + -> Int -- ^ length + -> m () +#if HAVE_SMALL_ARRAY +copySmallArray + (SmallMutableArray dst#) (I# do#) (SmallArray src#) (I# so#) (I# l#) = + primitive_ $ copySmallArray# src# so# dst# do# l# +#else +copySmallArray (SmallMutableArray dst) i (SmallArray src) = copyArray dst i src +#endif +{-# INLINE copySmallArray #-} + +-- | Copy a slice of one mutable array into another. +copySmallMutableArray + :: PrimMonad m + => SmallMutableArray (PrimState m) a -- ^ destination + -> Int -- ^ destination offset + -> SmallMutableArray (PrimState m) a -- ^ source + -> Int -- ^ source offset + -> Int -- ^ length + -> m () +#if HAVE_SMALL_ARRAY +copySmallMutableArray + (SmallMutableArray dst#) (I# do#) + (SmallMutableArray src#) (I# so#) + (I# l#) = + primitive_ $ copySmallMutableArray# src# so# dst# do# l# +#else +copySmallMutableArray (SmallMutableArray dst) i (SmallMutableArray src) = + copyMutableArray dst i src +#endif +{-# INLINE copySmallMutableArray #-} + +sizeofSmallArray :: SmallArray a -> Int +#if HAVE_SMALL_ARRAY +sizeofSmallArray (SmallArray sa#) = I# (sizeofSmallArray# sa#) +#else +sizeofSmallArray (SmallArray a) = sizeofArray a +#endif +{-# INLINE sizeofSmallArray #-} + +sizeofSmallMutableArray :: SmallMutableArray s a -> Int +#if HAVE_SMALL_ARRAY +sizeofSmallMutableArray (SmallMutableArray sa#) = + I# (sizeofSmallMutableArray# sa#) +#else +sizeofSmallMutableArray (SmallMutableArray ma) = sizeofMutableArray ma +#endif +{-# INLINE sizeofSmallMutableArray #-} + +-- | This is the fastest, most straightforward way to traverse +-- an array, but it only works correctly with a sufficiently +-- "affine" 'PrimMonad' instance. In particular, it must only produce +-- *one* result array. 'Control.Monad.Trans.List.ListT'-transformed +-- monads, for example, will not work right at all. +traverseSmallArrayP + :: PrimMonad m + => (a -> m b) + -> SmallArray a + -> m (SmallArray b) +#if HAVE_SMALL_ARRAY +traverseSmallArrayP f = \ !ary -> + let + !sz = sizeofSmallArray ary + go !i !mary + | i == sz + = unsafeFreezeSmallArray mary + | otherwise + = do + a <- indexSmallArrayM ary i + b <- f a + writeSmallArray mary i b + go (i + 1) mary + in do + mary <- newSmallArray sz badTraverseValue + go 0 mary +#else +traverseSmallArrayP f (SmallArray ar) = SmallArray `liftM` traverseArrayP f ar +#endif +{-# INLINE traverseSmallArrayP #-} + +-- | Strict map over the elements of the array. +mapSmallArray' :: (a -> b) -> SmallArray a -> SmallArray b +#if HAVE_SMALL_ARRAY +mapSmallArray' f sa = createSmallArray (length sa) (die "mapSmallArray'" "impossible") $ \smb -> + fix ? 0 $ \go i -> + when (i < length sa) $ do + x <- indexSmallArrayM sa i + let !y = f x + writeSmallArray smb i y *> go (i+1) +#else +mapSmallArray' f (SmallArray ar) = SmallArray (mapArray' f ar) +#endif +{-# INLINE mapSmallArray' #-} + +#ifndef HAVE_SMALL_ARRAY +runSmallArray + :: (forall s. ST s (SmallMutableArray s a)) + -> SmallArray a +runSmallArray m = SmallArray $ runArray $ + m >>= \(SmallMutableArray mary) -> return mary + +#elif !MIN_VERSION_base(4,9,0) +runSmallArray + :: (forall s. ST s (SmallMutableArray s a)) + -> SmallArray a +runSmallArray m = runST $ m >>= unsafeFreezeSmallArray + +#else +-- This low-level business is designed to work with GHC's worker-wrapper +-- transformation. A lot of the time, we don't actually need an Array +-- constructor. By putting it on the outside, and being careful about +-- how we special-case the empty array, we can make GHC smarter about this. +-- The only downside is that separately created 0-length arrays won't share +-- their Array constructors, although they'll share their underlying +-- Array#s. +runSmallArray + :: (forall s. ST s (SmallMutableArray s a)) + -> SmallArray a +runSmallArray m = SmallArray (runSmallArray# m) + +runSmallArray# + :: (forall s. ST s (SmallMutableArray s a)) + -> SmallArray# a +runSmallArray# m = case runRW# $ \s -> + case unST m s of { (# s', SmallMutableArray mary# #) -> + unsafeFreezeSmallArray# mary# s'} of (# _, ary# #) -> ary# + +unST :: ST s a -> State# s -> (# State# s, a #) +unST (GHCST.ST f) = f + +#endif + +#if HAVE_SMALL_ARRAY +-- See the comment on runSmallArray for why we use emptySmallArray#. +createSmallArray + :: Int + -> a + -> (forall s. SmallMutableArray s a -> ST s ()) + -> SmallArray a +createSmallArray 0 _ _ = SmallArray (emptySmallArray# (# #)) +createSmallArray n x f = runSmallArray $ do + mary <- newSmallArray n x + f mary + pure mary + +emptySmallArray# :: (# #) -> SmallArray# a +emptySmallArray# _ = case emptySmallArray of SmallArray ar -> ar +{-# NOINLINE emptySmallArray# #-} + +die :: String -> String -> a +die fun problem = error $ "Data.Primitive.SmallArray." ++ fun ++ ": " ++ problem + +emptySmallArray :: SmallArray a +emptySmallArray = + runST $ newSmallArray 0 (die "emptySmallArray" "impossible") + >>= unsafeFreezeSmallArray +{-# NOINLINE emptySmallArray #-} + + +infixl 1 ? +(?) :: (a -> b -> c) -> (b -> a -> c) +(?) = flip +{-# INLINE (?) #-} + +noOp :: a -> ST s () +noOp = const $ pure () + +smallArrayLiftEq :: (a -> b -> Bool) -> SmallArray a -> SmallArray b -> Bool +smallArrayLiftEq p sa1 sa2 = length sa1 == length sa2 && loop (length sa1 - 1) + where + loop i + | i < 0 + = True + | (# x #) <- indexSmallArray## sa1 i + , (# y #) <- indexSmallArray## sa2 i + = p x y && loop (i-1) + +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) +-- | @since 0.6.4.0 +instance Eq1 SmallArray where +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) + liftEq = smallArrayLiftEq +#else + eq1 = smallArrayLiftEq (==) +#endif +#endif + +instance Eq a => Eq (SmallArray a) where + sa1 == sa2 = smallArrayLiftEq (==) sa1 sa2 + +instance Eq (SmallMutableArray s a) where + SmallMutableArray sma1# == SmallMutableArray sma2# = + isTrue# (sameSmallMutableArray# sma1# sma2#) + +smallArrayLiftCompare :: (a -> b -> Ordering) -> SmallArray a -> SmallArray b -> Ordering +smallArrayLiftCompare elemCompare a1 a2 = loop 0 + where + mn = length a1 `min` length a2 + loop i + | i < mn + , (# x1 #) <- indexSmallArray## a1 i + , (# x2 #) <- indexSmallArray## a2 i + = elemCompare x1 x2 `mappend` loop (i+1) + | otherwise = compare (length a1) (length a2) + +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) +-- | @since 0.6.4.0 +instance Ord1 SmallArray where +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) + liftCompare = smallArrayLiftCompare +#else + compare1 = smallArrayLiftCompare compare +#endif +#endif + +-- | Lexicographic ordering. Subject to change between major versions. +instance Ord a => Ord (SmallArray a) where + compare sa1 sa2 = smallArrayLiftCompare compare sa1 sa2 + +instance Foldable SmallArray where + -- Note: we perform the array lookups eagerly so we won't + -- create thunks to perform lookups even if GHC can't see + -- that the folding function is strict. + foldr f = \z !ary -> + let + !sz = sizeofSmallArray ary + go i + | i == sz = z + | (# x #) <- indexSmallArray## ary i + = f x (go (i+1)) + in go 0 + {-# INLINE foldr #-} + foldl f = \z !ary -> + let + go i + | i < 0 = z + | (# x #) <- indexSmallArray## ary i + = f (go (i-1)) x + in go (sizeofSmallArray ary - 1) + {-# INLINE foldl #-} + foldr1 f = \ !ary -> + let + !sz = sizeofSmallArray ary - 1 + go i = + case indexSmallArray## ary i of + (# x #) | i == sz -> x + | otherwise -> f x (go (i+1)) + in if sz < 0 + then die "foldr1" "Empty SmallArray" + else go 0 + {-# INLINE foldr1 #-} + foldl1 f = \ !ary -> + let + !sz = sizeofSmallArray ary - 1 + go i = + case indexSmallArray## ary i of + (# x #) | i == 0 -> x + | otherwise -> f (go (i - 1)) x + in if sz < 0 + then die "foldl1" "Empty SmallArray" + else go sz + {-# INLINE foldl1 #-} + foldr' f = \z !ary -> + let + go i !acc + | i == -1 = acc + | (# x #) <- indexSmallArray## ary i + = go (i-1) (f x acc) + in go (sizeofSmallArray ary - 1) z + {-# INLINE foldr' #-} + foldl' f = \z !ary -> + let + !sz = sizeofSmallArray ary + go i !acc + | i == sz = acc + | (# x #) <- indexSmallArray## ary i + = go (i+1) (f acc x) + in go 0 z + {-# INLINE foldl' #-} + null a = sizeofSmallArray a == 0 + {-# INLINE null #-} + length = sizeofSmallArray + {-# INLINE length #-} + maximum ary | sz == 0 = die "maximum" "Empty SmallArray" + | (# frst #) <- indexSmallArray## ary 0 + = go 1 frst + where + sz = sizeofSmallArray ary + go i !e + | i == sz = e + | (# x #) <- indexSmallArray## ary i + = go (i+1) (max e x) + {-# INLINE maximum #-} + minimum ary | sz == 0 = die "minimum" "Empty SmallArray" + | (# frst #) <- indexSmallArray## ary 0 + = go 1 frst + where sz = sizeofSmallArray ary + go i !e + | i == sz = e + | (# x #) <- indexSmallArray## ary i + = go (i+1) (min e x) + {-# INLINE minimum #-} + sum = foldl' (+) 0 + {-# INLINE sum #-} + product = foldl' (*) 1 + {-# INLINE product #-} + +newtype STA a = STA {_runSTA :: forall s. SmallMutableArray# s a -> ST s (SmallArray a)} + +runSTA :: Int -> STA a -> SmallArray a +runSTA !sz = \ (STA m) -> runST $ newSmallArray_ sz >>= + \ (SmallMutableArray ar#) -> m ar# +{-# INLINE runSTA #-} + +newSmallArray_ :: Int -> ST s (SmallMutableArray s a) +newSmallArray_ !n = newSmallArray n badTraverseValue + +badTraverseValue :: a +badTraverseValue = die "traverse" "bad indexing" +{-# NOINLINE badTraverseValue #-} + +instance Traversable SmallArray where + traverse f = traverseSmallArray f + {-# INLINE traverse #-} + +traverseSmallArray + :: Applicative f + => (a -> f b) -> SmallArray a -> f (SmallArray b) +traverseSmallArray f = \ !ary -> + let + !len = sizeofSmallArray ary + go !i + | i == len + = pure $ STA $ \mary -> unsafeFreezeSmallArray (SmallMutableArray mary) + | (# x #) <- indexSmallArray## ary i + = liftA2 (\b (STA m) -> STA $ \mary -> + writeSmallArray (SmallMutableArray mary) i b >> m mary) + (f x) (go (i + 1)) + in if len == 0 + then pure emptySmallArray + else runSTA len <$> go 0 +{-# INLINE [1] traverseSmallArray #-} + +{-# RULES +"traverse/ST" forall (f :: a -> ST s b). traverseSmallArray f = traverseSmallArrayP f +"traverse/IO" forall (f :: a -> IO b). traverseSmallArray f = traverseSmallArrayP f +"traverse/Id" forall (f :: a -> Identity b). traverseSmallArray f = + (coerce :: (SmallArray a -> SmallArray (Identity b)) + -> SmallArray a -> Identity (SmallArray b)) (fmap f) + #-} + + +instance Functor SmallArray where + fmap f sa = createSmallArray (length sa) (die "fmap" "impossible") $ \smb -> + fix ? 0 $ \go i -> + when (i < length sa) $ do + x <- indexSmallArrayM sa i + writeSmallArray smb i (f x) *> go (i+1) + {-# INLINE fmap #-} + + x <$ sa = createSmallArray (length sa) x noOp + +instance Applicative SmallArray where + pure x = createSmallArray 1 x noOp + + sa *> sb = createSmallArray (la*lb) (die "*>" "impossible") $ \smb -> + fix ? 0 $ \go i -> + when (i < la) $ + copySmallArray smb 0 sb 0 lb *> go (i+1) + where + la = length sa ; lb = length sb + + a <* b = createSmallArray (sza*szb) (die "<*" "impossible") $ \ma -> + let fill off i e = when (i < szb) $ + writeSmallArray ma (off+i) e >> fill off (i+1) e + go i = when (i < sza) $ do + x <- indexSmallArrayM a i + fill (i*szb) 0 x + go (i+1) + in go 0 + where sza = sizeofSmallArray a ; szb = sizeofSmallArray b + + ab <*> a = createSmallArray (szab*sza) (die "<*>" "impossible") $ \mb -> + let go1 i = when (i < szab) $ + do + f <- indexSmallArrayM ab i + go2 (i*sza) f 0 + go1 (i+1) + go2 off f j = when (j < sza) $ + do + x <- indexSmallArrayM a j + writeSmallArray mb (off + j) (f x) + go2 off f (j + 1) + in go1 0 + where szab = sizeofSmallArray ab ; sza = sizeofSmallArray a + +instance Alternative SmallArray where + empty = emptySmallArray + + sl <|> sr = + createSmallArray (length sl + length sr) (die "<|>" "impossible") $ \sma -> + copySmallArray sma 0 sl 0 (length sl) + *> copySmallArray sma (length sl) sr 0 (length sr) + + many sa | null sa = pure [] + | otherwise = die "many" "infinite arrays are not well defined" + + some sa | null sa = emptySmallArray + | otherwise = die "some" "infinite arrays are not well defined" + +data ArrayStack a + = PushArray !(SmallArray a) !(ArrayStack a) + | EmptyStack +-- TODO: This isn't terribly efficient. It would be better to wrap +-- ArrayStack with a type like +-- +-- data NES s a = NES !Int !(SmallMutableArray s a) !(ArrayStack a) +-- +-- We'd copy incoming arrays into the mutable array until we would +-- overflow it. Then we'd freeze it, push it on the stack, and continue. +-- Any sufficiently large incoming arrays would go straight on the stack. +-- Such a scheme would make the stack much more compact in the case +-- of many small arrays. + +instance Monad SmallArray where + return = pure + (>>) = (*>) + + sa >>= f = collect 0 EmptyStack (la-1) + where + la = length sa + collect sz stk i + | i < 0 = createSmallArray sz (die ">>=" "impossible") $ fill 0 stk + | (# x #) <- indexSmallArray## sa i + , let sb = f x + lsb = length sb + -- If we don't perform this check, we could end up allocating + -- a stack full of empty arrays if someone is filtering most + -- things out. So we refrain from pushing empty arrays. + = if lsb == 0 + then collect sz stk (i-1) + else collect (sz + lsb) (PushArray sb stk) (i-1) + + fill _ EmptyStack _ = return () + fill off (PushArray sb sbs) smb = + copySmallArray smb off sb 0 (length sb) + *> fill (off + length sb) sbs smb + + fail _ = emptySmallArray + +instance MonadPlus SmallArray where + mzero = empty + mplus = (<|>) + +zipW :: String -> (a -> b -> c) -> SmallArray a -> SmallArray b -> SmallArray c +zipW nm = \f sa sb -> let mn = length sa `min` length sb in + createSmallArray mn (die nm "impossible") $ \mc -> + fix ? 0 $ \go i -> when (i < mn) $ do + x <- indexSmallArrayM sa i + y <- indexSmallArrayM sb i + writeSmallArray mc i (f x y) + go (i+1) +{-# INLINE zipW #-} + +instance MonadZip SmallArray where + mzip = zipW "mzip" (,) + mzipWith = zipW "mzipWith" + {-# INLINE mzipWith #-} + munzip sab = runST $ do + let sz = length sab + sma <- newSmallArray sz $ die "munzip" "impossible" + smb <- newSmallArray sz $ die "munzip" "impossible" + fix ? 0 $ \go i -> + when (i < sz) $ case indexSmallArray sab i of + (x, y) -> do writeSmallArray sma i x + writeSmallArray smb i y + go $ i+1 + (,) <$> unsafeFreezeSmallArray sma + <*> unsafeFreezeSmallArray smb + +instance MonadFix SmallArray where + mfix f = createSmallArray (sizeofSmallArray (f err)) + (die "mfix" "impossible") $ flip fix 0 $ + \r !i !mary -> when (i < sz) $ do + writeSmallArray mary i (fix (\xi -> f xi `indexSmallArray` i)) + r (i + 1) mary + where + sz = sizeofSmallArray (f err) + err = error "mfix for Data.Primitive.SmallArray applied to strict function." + +#if MIN_VERSION_base(4,9,0) +-- | @since 0.6.3.0 +instance Sem.Semigroup (SmallArray a) where + (<>) = (<|>) + sconcat = mconcat . toList +#endif + +instance Monoid (SmallArray a) where + mempty = empty +#if !(MIN_VERSION_base(4,11,0)) + mappend = (<|>) +#endif + mconcat l = createSmallArray n (die "mconcat" "impossible") $ \ma -> + let go !_ [ ] = return () + go off (a:as) = + copySmallArray ma off a 0 (sizeofSmallArray a) >> go (off + sizeofSmallArray a) as + in go 0 l + where n = sum . fmap length $ l + +instance IsList (SmallArray a) where + type Item (SmallArray a) = a + fromListN = smallArrayFromListN + fromList = smallArrayFromList + toList = Foldable.toList + +smallArrayLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> SmallArray a -> ShowS +smallArrayLiftShowsPrec elemShowsPrec elemListShowsPrec p sa = showParen (p > 10) $ + showString "fromListN " . shows (length sa) . showString " " + . listLiftShowsPrec elemShowsPrec elemListShowsPrec 11 (toList sa) + +-- this need to be included for older ghcs +listLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> [a] -> ShowS +listLiftShowsPrec _ sl _ = sl + +instance Show a => Show (SmallArray a) where + showsPrec p sa = smallArrayLiftShowsPrec showsPrec showList p sa + +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) +-- | @since 0.6.4.0 +instance Show1 SmallArray where +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) + liftShowsPrec = smallArrayLiftShowsPrec +#else + showsPrec1 = smallArrayLiftShowsPrec showsPrec showList +#endif +#endif + +smallArrayLiftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (SmallArray a) +smallArrayLiftReadsPrec _ listReadsPrec p = readParen (p > 10) . readP_to_S $ do + () <$ string "fromListN" + skipSpaces + n <- readS_to_P reads + skipSpaces + l <- readS_to_P listReadsPrec + return $ smallArrayFromListN n l + +instance Read a => Read (SmallArray a) where + readsPrec = smallArrayLiftReadsPrec readsPrec readList + +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) +-- | @since 0.6.4.0 +instance Read1 SmallArray where +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) + liftReadsPrec = smallArrayLiftReadsPrec +#else + readsPrec1 = smallArrayLiftReadsPrec readsPrec readList +#endif +#endif + + + +smallArrayDataType :: DataType +smallArrayDataType = + mkDataType "Data.Primitive.SmallArray.SmallArray" [fromListConstr] + +fromListConstr :: Constr +fromListConstr = mkConstr smallArrayDataType "fromList" [] Prefix + +instance Data a => Data (SmallArray a) where + toConstr _ = fromListConstr + dataTypeOf _ = smallArrayDataType + gunfold k z c = case constrIndex c of + 1 -> k (z fromList) + _ -> die "gunfold" "SmallArray" + gfoldl f z m = z fromList `f` toList m + +instance (Typeable s, Typeable a) => Data (SmallMutableArray s a) where + toConstr _ = die "toConstr" "SmallMutableArray" + gunfold _ _ = die "gunfold" "SmallMutableArray" + dataTypeOf _ = mkNoRepType "Data.Primitive.SmallArray.SmallMutableArray" +#endif + +-- | Create a 'SmallArray' from a list of a known length. If the length +-- of the list does not match the given length, this throws an exception. +smallArrayFromListN :: Int -> [a] -> SmallArray a +#if HAVE_SMALL_ARRAY +smallArrayFromListN n l = + createSmallArray n + (die "smallArrayFromListN" "uninitialized element") $ \sma -> + let go !ix [] = if ix == n + then return () + else die "smallArrayFromListN" "list length less than specified size" + go !ix (x : xs) = if ix < n + then do + writeSmallArray sma ix x + go (ix+1) xs + else die "smallArrayFromListN" "list length greater than specified size" + in go 0 l +#else +smallArrayFromListN n l = SmallArray (Array.fromListN n l) +#endif + +-- | Create a 'SmallArray' from a list. +smallArrayFromList :: [a] -> SmallArray a +smallArrayFromList l = smallArrayFromListN (length l) l diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Types.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Types.hs new file mode 100644 index 000000000000..fd36ea0c9455 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Types.hs @@ -0,0 +1,395 @@ +{-# LANGUAGE CPP, UnboxedTuples, MagicHash, DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE TypeInType #-} +#endif + +#include "HsBaseConfig.h" + +-- | +-- Module : Data.Primitive.Types +-- Copyright : (c) Roman Leshchinskiy 2009-2012 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> +-- Portability : non-portable +-- +-- Basic types and classes for primitive array operations +-- + +module Data.Primitive.Types ( + Prim(..), + sizeOf, alignment, defaultSetByteArray#, defaultSetOffAddr#, + + Addr(..), + PrimStorable(..) +) where + +import Control.Monad.Primitive +import Data.Primitive.MachDeps +import Data.Primitive.Internal.Operations +import Foreign.C.Types +import System.Posix.Types + +import GHC.Base ( + Int(..), Char(..), + ) +import GHC.Float ( + Float(..), Double(..) + ) +import GHC.Word ( + Word(..), Word8(..), Word16(..), Word32(..), Word64(..) + ) +import GHC.Int ( + Int8(..), Int16(..), Int32(..), Int64(..) + ) + +import GHC.Ptr ( + Ptr(..), FunPtr(..) + ) + +import GHC.Prim +#if __GLASGOW_HASKELL__ >= 706 + hiding (setByteArray#) +#endif + +import Data.Typeable ( Typeable ) +import Data.Data ( Data(..) ) +import Data.Primitive.Internal.Compat ( isTrue#, mkNoRepType ) +import Foreign.Storable (Storable) +import Numeric + +import qualified Foreign.Storable as FS + +-- | A machine address +data Addr = Addr Addr# deriving ( Typeable ) + +instance Show Addr where + showsPrec _ (Addr a) = + showString "0x" . showHex (fromIntegral (I# (addr2Int# a)) :: Word) + +instance Eq Addr where + Addr a# == Addr b# = isTrue# (eqAddr# a# b#) + Addr a# /= Addr b# = isTrue# (neAddr# a# b#) + +instance Ord Addr where + Addr a# > Addr b# = isTrue# (gtAddr# a# b#) + Addr a# >= Addr b# = isTrue# (geAddr# a# b#) + Addr a# < Addr b# = isTrue# (ltAddr# a# b#) + Addr a# <= Addr b# = isTrue# (leAddr# a# b#) + +instance Data Addr where + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Data.Primitive.Types.Addr" + + +-- | Class of types supporting primitive array operations +class Prim a where + + -- | Size of values of type @a@. The argument is not used. + sizeOf# :: a -> Int# + + -- | Alignment of values of type @a@. The argument is not used. + alignment# :: a -> Int# + + -- | Read a value from the array. The offset is in elements of type + -- @a@ rather than in bytes. + indexByteArray# :: ByteArray# -> Int# -> a + + -- | Read a value from the mutable array. The offset is in elements of type + -- @a@ rather than in bytes. + readByteArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, a #) + + -- | Write a value to the mutable array. The offset is in elements of type + -- @a@ rather than in bytes. + writeByteArray# :: MutableByteArray# s -> Int# -> a -> State# s -> State# s + + -- | Fill a slice of the mutable array with a value. The offset and length + -- of the chunk are in elements of type @a@ rather than in bytes. + setByteArray# :: MutableByteArray# s -> Int# -> Int# -> a -> State# s -> State# s + + -- | Read a value from a memory position given by an address and an offset. + -- The memory block the address refers to must be immutable. The offset is in + -- elements of type @a@ rather than in bytes. + indexOffAddr# :: Addr# -> Int# -> a + + -- | Read a value from a memory position given by an address and an offset. + -- The offset is in elements of type @a@ rather than in bytes. + readOffAddr# :: Addr# -> Int# -> State# s -> (# State# s, a #) + + -- | Write a value to a memory position given by an address and an offset. + -- The offset is in elements of type @a@ rather than in bytes. + writeOffAddr# :: Addr# -> Int# -> a -> State# s -> State# s + + -- | Fill a memory block given by an address, an offset and a length. + -- The offset and length are in elements of type @a@ rather than in bytes. + setOffAddr# :: Addr# -> Int# -> Int# -> a -> State# s -> State# s + +-- | Size of values of type @a@. The argument is not used. +-- +-- This function has existed since 0.1, but was moved from 'Data.Primitive' +-- to 'Data.Primitive.Types' in version 0.6.3.0 +sizeOf :: Prim a => a -> Int +sizeOf x = I# (sizeOf# x) + +-- | Alignment of values of type @a@. The argument is not used. +-- +-- This function has existed since 0.1, but was moved from 'Data.Primitive' +-- to 'Data.Primitive.Types' in version 0.6.3.0 +alignment :: Prim a => a -> Int +alignment x = I# (alignment# x) + +-- | An implementation of 'setByteArray#' that calls 'writeByteArray#' +-- to set each element. This is helpful when writing a 'Prim' instance +-- for a multi-word data type for which there is no cpu-accelerated way +-- to broadcast a value to contiguous memory. It is typically used +-- alongside 'defaultSetOffAddr#'. For example: +-- +-- > data Trip = Trip Int Int Int +-- > +-- > instance Prim Trip +-- > sizeOf# _ = 3# *# sizeOf# (undefined :: Int) +-- > alignment# _ = alignment# (undefined :: Int) +-- > indexByteArray# arr# i# = ... +-- > readByteArray# arr# i# = ... +-- > writeByteArray# arr# i# (Trip a b c) = +-- > \s0 -> case writeByteArray# arr# (3# *# i#) a s0 of +-- > s1 -> case writeByteArray# arr# ((3# *# i#) +# 1#) b s1 of +-- > s2 -> case writeByteArray# arr# ((3# *# i#) +# 2# ) c s2 of +-- > s3 -> s3 +-- > setByteArray# = defaultSetByteArray# +-- > indexOffAddr# addr# i# = ... +-- > readOffAddr# addr# i# = ... +-- > writeOffAddr# addr# i# (Trip a b c) = +-- > \s0 -> case writeOffAddr# addr# (3# *# i#) a s0 of +-- > s1 -> case writeOffAddr# addr# ((3# *# i#) +# 1#) b s1 of +-- > s2 -> case writeOffAddr# addr# ((3# *# i#) +# 2# ) c s2 of +-- > s3 -> s3 +-- > setOffAddr# = defaultSetOffAddr# +defaultSetByteArray# :: Prim a => MutableByteArray# s -> Int# -> Int# -> a -> State# s -> State# s +defaultSetByteArray# arr# i# len# ident = go 0# + where + go ix# s0 = if isTrue# (ix# <# len#) + then case writeByteArray# arr# (i# +# ix#) ident s0 of + s1 -> go (ix# +# 1#) s1 + else s0 + +-- | An implementation of 'setOffAddr#' that calls 'writeOffAddr#' +-- to set each element. The documentation of 'defaultSetByteArray#' +-- provides an example of how to use this. +defaultSetOffAddr# :: Prim a => Addr# -> Int# -> Int# -> a -> State# s -> State# s +defaultSetOffAddr# addr# i# len# ident = go 0# + where + go ix# s0 = if isTrue# (ix# <# len#) + then case writeOffAddr# addr# (i# +# ix#) ident s0 of + s1 -> go (ix# +# 1#) s1 + else s0 + +-- | Newtype that uses a 'Prim' instance to give rise to a 'Storable' instance. +-- This type is intended to be used with the @DerivingVia@ extension available +-- in GHC 8.6 and up. For example, consider a user-defined 'Prim' instance for +-- a multi-word data type. +-- +-- > data Uuid = Uuid Word64 Word64 +-- > deriving Storable via (PrimStorable Uuid) +-- > instance Prim Uuid where ... +-- +-- Writing the 'Prim' instance is tedious and unavoidable, but the 'Storable' +-- instance comes for free once the 'Prim' instance is written. +newtype PrimStorable a = PrimStorable { getPrimStorable :: a } + +instance Prim a => Storable (PrimStorable a) where + sizeOf _ = sizeOf (undefined :: a) + alignment _ = alignment (undefined :: a) + peekElemOff (Ptr addr#) (I# i#) = + primitive $ \s0# -> case readOffAddr# addr# i# s0# of + (# s1, x #) -> (# s1, PrimStorable x #) + pokeElemOff (Ptr addr#) (I# i#) (PrimStorable a) = primitive_ $ \s# -> + writeOffAddr# addr# i# a s# + +#define derivePrim(ty, ctr, sz, align, idx_arr, rd_arr, wr_arr, set_arr, idx_addr, rd_addr, wr_addr, set_addr) \ +instance Prim (ty) where { \ + sizeOf# _ = unI# sz \ +; alignment# _ = unI# align \ +; indexByteArray# arr# i# = ctr (idx_arr arr# i#) \ +; readByteArray# arr# i# s# = case rd_arr arr# i# s# of \ + { (# s1#, x# #) -> (# s1#, ctr x# #) } \ +; writeByteArray# arr# i# (ctr x#) s# = wr_arr arr# i# x# s# \ +; setByteArray# arr# i# n# (ctr x#) s# \ + = let { i = fromIntegral (I# i#) \ + ; n = fromIntegral (I# n#) \ + } in \ + case unsafeCoerce# (internal (set_arr arr# i n x#)) s# of \ + { (# s1#, _ #) -> s1# } \ + \ +; indexOffAddr# addr# i# = ctr (idx_addr addr# i#) \ +; readOffAddr# addr# i# s# = case rd_addr addr# i# s# of \ + { (# s1#, x# #) -> (# s1#, ctr x# #) } \ +; writeOffAddr# addr# i# (ctr x#) s# = wr_addr addr# i# x# s# \ +; setOffAddr# addr# i# n# (ctr x#) s# \ + = let { i = fromIntegral (I# i#) \ + ; n = fromIntegral (I# n#) \ + } in \ + case unsafeCoerce# (internal (set_addr addr# i n x#)) s# of \ + { (# s1#, _ #) -> s1# } \ +; {-# INLINE sizeOf# #-} \ +; {-# INLINE alignment# #-} \ +; {-# INLINE indexByteArray# #-} \ +; {-# INLINE readByteArray# #-} \ +; {-# INLINE writeByteArray# #-} \ +; {-# INLINE setByteArray# #-} \ +; {-# INLINE indexOffAddr# #-} \ +; {-# INLINE readOffAddr# #-} \ +; {-# INLINE writeOffAddr# #-} \ +; {-# INLINE setOffAddr# #-} \ +} + +unI# :: Int -> Int# +unI# (I# n#) = n# + +derivePrim(Word, W#, sIZEOF_WORD, aLIGNMENT_WORD, + indexWordArray#, readWordArray#, writeWordArray#, setWordArray#, + indexWordOffAddr#, readWordOffAddr#, writeWordOffAddr#, setWordOffAddr#) +derivePrim(Word8, W8#, sIZEOF_WORD8, aLIGNMENT_WORD8, + indexWord8Array#, readWord8Array#, writeWord8Array#, setWord8Array#, + indexWord8OffAddr#, readWord8OffAddr#, writeWord8OffAddr#, setWord8OffAddr#) +derivePrim(Word16, W16#, sIZEOF_WORD16, aLIGNMENT_WORD16, + indexWord16Array#, readWord16Array#, writeWord16Array#, setWord16Array#, + indexWord16OffAddr#, readWord16OffAddr#, writeWord16OffAddr#, setWord16OffAddr#) +derivePrim(Word32, W32#, sIZEOF_WORD32, aLIGNMENT_WORD32, + indexWord32Array#, readWord32Array#, writeWord32Array#, setWord32Array#, + indexWord32OffAddr#, readWord32OffAddr#, writeWord32OffAddr#, setWord32OffAddr#) +derivePrim(Word64, W64#, sIZEOF_WORD64, aLIGNMENT_WORD64, + indexWord64Array#, readWord64Array#, writeWord64Array#, setWord64Array#, + indexWord64OffAddr#, readWord64OffAddr#, writeWord64OffAddr#, setWord64OffAddr#) +derivePrim(Int, I#, sIZEOF_INT, aLIGNMENT_INT, + indexIntArray#, readIntArray#, writeIntArray#, setIntArray#, + indexIntOffAddr#, readIntOffAddr#, writeIntOffAddr#, setIntOffAddr#) +derivePrim(Int8, I8#, sIZEOF_INT8, aLIGNMENT_INT8, + indexInt8Array#, readInt8Array#, writeInt8Array#, setInt8Array#, + indexInt8OffAddr#, readInt8OffAddr#, writeInt8OffAddr#, setInt8OffAddr#) +derivePrim(Int16, I16#, sIZEOF_INT16, aLIGNMENT_INT16, + indexInt16Array#, readInt16Array#, writeInt16Array#, setInt16Array#, + indexInt16OffAddr#, readInt16OffAddr#, writeInt16OffAddr#, setInt16OffAddr#) +derivePrim(Int32, I32#, sIZEOF_INT32, aLIGNMENT_INT32, + indexInt32Array#, readInt32Array#, writeInt32Array#, setInt32Array#, + indexInt32OffAddr#, readInt32OffAddr#, writeInt32OffAddr#, setInt32OffAddr#) +derivePrim(Int64, I64#, sIZEOF_INT64, aLIGNMENT_INT64, + indexInt64Array#, readInt64Array#, writeInt64Array#, setInt64Array#, + indexInt64OffAddr#, readInt64OffAddr#, writeInt64OffAddr#, setInt64OffAddr#) +derivePrim(Float, F#, sIZEOF_FLOAT, aLIGNMENT_FLOAT, + indexFloatArray#, readFloatArray#, writeFloatArray#, setFloatArray#, + indexFloatOffAddr#, readFloatOffAddr#, writeFloatOffAddr#, setFloatOffAddr#) +derivePrim(Double, D#, sIZEOF_DOUBLE, aLIGNMENT_DOUBLE, + indexDoubleArray#, readDoubleArray#, writeDoubleArray#, setDoubleArray#, + indexDoubleOffAddr#, readDoubleOffAddr#, writeDoubleOffAddr#, setDoubleOffAddr#) +derivePrim(Char, C#, sIZEOF_CHAR, aLIGNMENT_CHAR, + indexWideCharArray#, readWideCharArray#, writeWideCharArray#, setWideCharArray#, + indexWideCharOffAddr#, readWideCharOffAddr#, writeWideCharOffAddr#, setWideCharOffAddr#) +derivePrim(Addr, Addr, sIZEOF_PTR, aLIGNMENT_PTR, + indexAddrArray#, readAddrArray#, writeAddrArray#, setAddrArray#, + indexAddrOffAddr#, readAddrOffAddr#, writeAddrOffAddr#, setAddrOffAddr#) +derivePrim(Ptr a, Ptr, sIZEOF_PTR, aLIGNMENT_PTR, + indexAddrArray#, readAddrArray#, writeAddrArray#, setAddrArray#, + indexAddrOffAddr#, readAddrOffAddr#, writeAddrOffAddr#, setAddrOffAddr#) +derivePrim(FunPtr a, FunPtr, sIZEOF_PTR, aLIGNMENT_PTR, + indexAddrArray#, readAddrArray#, writeAddrArray#, setAddrArray#, + indexAddrOffAddr#, readAddrOffAddr#, writeAddrOffAddr#, setAddrOffAddr#) + +-- Prim instances for newtypes in Foreign.C.Types +deriving instance Prim CChar +deriving instance Prim CSChar +deriving instance Prim CUChar +deriving instance Prim CShort +deriving instance Prim CUShort +deriving instance Prim CInt +deriving instance Prim CUInt +deriving instance Prim CLong +deriving instance Prim CULong +deriving instance Prim CPtrdiff +deriving instance Prim CSize +deriving instance Prim CWchar +deriving instance Prim CSigAtomic +deriving instance Prim CLLong +deriving instance Prim CULLong +#if MIN_VERSION_base(4,10,0) +deriving instance Prim CBool +#endif +deriving instance Prim CIntPtr +deriving instance Prim CUIntPtr +deriving instance Prim CIntMax +deriving instance Prim CUIntMax +deriving instance Prim CClock +deriving instance Prim CTime +deriving instance Prim CUSeconds +deriving instance Prim CSUSeconds +deriving instance Prim CFloat +deriving instance Prim CDouble + +-- Prim instances for newtypes in System.Posix.Types +#if defined(HTYPE_DEV_T) +deriving instance Prim CDev +#endif +#if defined(HTYPE_INO_T) +deriving instance Prim CIno +#endif +#if defined(HTYPE_MODE_T) +deriving instance Prim CMode +#endif +#if defined(HTYPE_OFF_T) +deriving instance Prim COff +#endif +#if defined(HTYPE_PID_T) +deriving instance Prim CPid +#endif +#if defined(HTYPE_SSIZE_T) +deriving instance Prim CSsize +#endif +#if defined(HTYPE_GID_T) +deriving instance Prim CGid +#endif +#if defined(HTYPE_NLINK_T) +deriving instance Prim CNlink +#endif +#if defined(HTYPE_UID_T) +deriving instance Prim CUid +#endif +#if defined(HTYPE_CC_T) +deriving instance Prim CCc +#endif +#if defined(HTYPE_SPEED_T) +deriving instance Prim CSpeed +#endif +#if defined(HTYPE_TCFLAG_T) +deriving instance Prim CTcflag +#endif +#if defined(HTYPE_RLIM_T) +deriving instance Prim CRLim +#endif +#if defined(HTYPE_BLKSIZE_T) +deriving instance Prim CBlkSize +#endif +#if defined(HTYPE_BLKCNT_T) +deriving instance Prim CBlkCnt +#endif +#if defined(HTYPE_CLOCKID_T) +deriving instance Prim CClockId +#endif +#if defined(HTYPE_FSBLKCNT_T) +deriving instance Prim CFsBlkCnt +#endif +#if defined(HTYPE_FSFILCNT_T) +deriving instance Prim CFsFilCnt +#endif +#if defined(HTYPE_ID_T) +deriving instance Prim CId +#endif +#if defined(HTYPE_KEY_T) +deriving instance Prim CKey +#endif +#if defined(HTYPE_TIMER_T) +deriving instance Prim CTimer +#endif +deriving instance Prim Fd diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/UnliftedArray.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/UnliftedArray.hs new file mode 100644 index 000000000000..75a4847364dc --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/UnliftedArray.hs @@ -0,0 +1,638 @@ +{-# Language BangPatterns #-} +{-# Language CPP #-} +{-# Language DeriveDataTypeable #-} +{-# Language MagicHash #-} +{-# Language RankNTypes #-} +{-# Language ScopedTypeVariables #-} +{-# Language TypeFamilies #-} +{-# Language UnboxedTuples #-} + +-- | +-- Module : Data.Primitive.UnliftedArray +-- Copyright : (c) Dan Doel 2016 +-- License : BSD-style +-- +-- Maintainer : Libraries <libraries@haskell.org> +-- Portability : non-portable +-- +-- GHC contains three general classes of value types: +-- +-- 1. Unboxed types: values are machine values made up of fixed numbers of bytes +-- 2. Unlifted types: values are pointers, but strictly evaluated +-- 3. Lifted types: values are pointers, lazily evaluated +-- +-- The first category can be stored in a 'ByteArray', and this allows types in +-- category 3 that are simple wrappers around category 1 types to be stored +-- more efficiently using a 'ByteArray'. This module provides the same facility +-- for category 2 types. +-- +-- GHC has two primitive types, 'ArrayArray#' and 'MutableArrayArray#'. These +-- are arrays of pointers, but of category 2 values, so they are known to not +-- be bottom. This allows types that are wrappers around such types to be stored +-- in an array without an extra level of indirection. +-- +-- The way that the 'ArrayArray#' API works is that one can read and write +-- 'ArrayArray#' values to the positions. This works because all category 2 +-- types share a uniform representation, unlike unboxed values which are +-- represented by varying (by type) numbers of bytes. However, using the +-- this makes the internal API very unsafe to use, as one has to coerce values +-- to and from 'ArrayArray#'. +-- +-- The API presented by this module is more type safe. 'UnliftedArray' and +-- 'MutableUnliftedArray' are parameterized by the type of arrays they contain, and +-- the coercions necessary are abstracted into a class, 'PrimUnlifted', of things +-- that are eligible to be stored. + +module Data.Primitive.UnliftedArray + ( -- * Types + UnliftedArray(..) + , MutableUnliftedArray(..) + , PrimUnlifted(..) + -- * Operations + , unsafeNewUnliftedArray + , newUnliftedArray + , setUnliftedArray + , sizeofUnliftedArray + , sizeofMutableUnliftedArray + , readUnliftedArray + , writeUnliftedArray + , indexUnliftedArray + , indexUnliftedArrayM + , unsafeFreezeUnliftedArray + , freezeUnliftedArray + , thawUnliftedArray + , runUnliftedArray + , sameMutableUnliftedArray + , copyUnliftedArray + , copyMutableUnliftedArray + , cloneUnliftedArray + , cloneMutableUnliftedArray + -- * List Conversion + , unliftedArrayToList + , unliftedArrayFromList + , unliftedArrayFromListN + -- * Folding + , foldrUnliftedArray + , foldrUnliftedArray' + , foldlUnliftedArray + , foldlUnliftedArray' + -- * Mapping + , mapUnliftedArray +-- Missing operations: +-- , unsafeThawUnliftedArray + ) where + +import Data.Typeable +import Control.Applicative + +import GHC.Prim +import GHC.Base (Int(..),build) + +import Control.Monad.Primitive + +import Control.Monad.ST (runST,ST) + +import Data.Monoid (Monoid,mappend) +import Data.Primitive.Internal.Compat ( isTrue# ) + +import qualified Data.List as L +import Data.Primitive.Array (Array) +import qualified Data.Primitive.Array as A +import Data.Primitive.ByteArray (ByteArray) +import qualified Data.Primitive.ByteArray as BA +import qualified Data.Primitive.PrimArray as PA +import qualified Data.Primitive.SmallArray as SA +import qualified Data.Primitive.MutVar as MV +import qualified Data.Monoid +import qualified GHC.MVar as GM (MVar(..)) +import qualified GHC.Conc as GC (TVar(..)) +import qualified GHC.Stable as GSP (StablePtr(..)) +import qualified GHC.Weak as GW (Weak(..)) +import qualified GHC.Conc.Sync as GCS (ThreadId(..)) +import qualified GHC.Exts as E +import qualified GHC.ST as GHCST + +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup (Semigroup) +import qualified Data.Semigroup +#endif + +#if MIN_VERSION_base(4,10,0) +import GHC.Exts (runRW#) +#elif MIN_VERSION_base(4,9,0) +import GHC.Base (runRW#) +#endif + +-- | Immutable arrays that efficiently store types that are simple wrappers +-- around unlifted primitive types. The values of the unlifted type are +-- stored directly, eliminating a layer of indirection. +data UnliftedArray e = UnliftedArray ArrayArray# + deriving (Typeable) + +-- | Mutable arrays that efficiently store types that are simple wrappers +-- around unlifted primitive types. The values of the unlifted type are +-- stored directly, eliminating a layer of indirection. +data MutableUnliftedArray s e = MutableUnliftedArray (MutableArrayArray# s) + deriving (Typeable) + +-- | Classifies the types that are able to be stored in 'UnliftedArray' and +-- 'MutableUnliftedArray'. These should be types that are just liftings of the +-- unlifted pointer types, so that their internal contents can be safely coerced +-- into an 'ArrayArray#'. +class PrimUnlifted a where + toArrayArray# :: a -> ArrayArray# + fromArrayArray# :: ArrayArray# -> a + +instance PrimUnlifted (UnliftedArray e) where + toArrayArray# (UnliftedArray aa#) = aa# + fromArrayArray# aa# = UnliftedArray aa# + +instance PrimUnlifted (MutableUnliftedArray s e) where + toArrayArray# (MutableUnliftedArray maa#) = unsafeCoerce# maa# + fromArrayArray# aa# = MutableUnliftedArray (unsafeCoerce# aa#) + +instance PrimUnlifted (Array a) where + toArrayArray# (A.Array a#) = unsafeCoerce# a# + fromArrayArray# aa# = A.Array (unsafeCoerce# aa#) + +instance PrimUnlifted (A.MutableArray s a) where + toArrayArray# (A.MutableArray ma#) = unsafeCoerce# ma# + fromArrayArray# aa# = A.MutableArray (unsafeCoerce# aa#) + +instance PrimUnlifted ByteArray where + toArrayArray# (BA.ByteArray ba#) = unsafeCoerce# ba# + fromArrayArray# aa# = BA.ByteArray (unsafeCoerce# aa#) + +instance PrimUnlifted (BA.MutableByteArray s) where + toArrayArray# (BA.MutableByteArray mba#) = unsafeCoerce# mba# + fromArrayArray# aa# = BA.MutableByteArray (unsafeCoerce# aa#) + +-- | @since 0.6.4.0 +instance PrimUnlifted (PA.PrimArray a) where + toArrayArray# (PA.PrimArray ba#) = unsafeCoerce# ba# + fromArrayArray# aa# = PA.PrimArray (unsafeCoerce# aa#) + +-- | @since 0.6.4.0 +instance PrimUnlifted (PA.MutablePrimArray s a) where + toArrayArray# (PA.MutablePrimArray mba#) = unsafeCoerce# mba# + fromArrayArray# aa# = PA.MutablePrimArray (unsafeCoerce# aa#) + +instance PrimUnlifted (SA.SmallArray a) where + toArrayArray# (SA.SmallArray sa#) = unsafeCoerce# sa# + fromArrayArray# aa# = SA.SmallArray (unsafeCoerce# aa#) + +instance PrimUnlifted (SA.SmallMutableArray s a) where + toArrayArray# (SA.SmallMutableArray sma#) = unsafeCoerce# sma# + fromArrayArray# aa# = SA.SmallMutableArray (unsafeCoerce# aa#) + +instance PrimUnlifted (MV.MutVar s a) where + toArrayArray# (MV.MutVar mv#) = unsafeCoerce# mv# + fromArrayArray# aa# = MV.MutVar (unsafeCoerce# aa#) + +-- | @since 0.6.4.0 +instance PrimUnlifted (GM.MVar a) where + toArrayArray# (GM.MVar mv#) = unsafeCoerce# mv# + fromArrayArray# mv# = GM.MVar (unsafeCoerce# mv#) + +-- | @since 0.6.4.0 +instance PrimUnlifted (GC.TVar a) where + toArrayArray# (GC.TVar tv#) = unsafeCoerce# tv# + fromArrayArray# tv# = GC.TVar (unsafeCoerce# tv#) + +-- | @since 0.6.4.0 +instance PrimUnlifted (GSP.StablePtr a) where + toArrayArray# (GSP.StablePtr tv#) = unsafeCoerce# tv# + fromArrayArray# tv# = GSP.StablePtr (unsafeCoerce# tv#) + +-- | @since 0.6.4.0 +instance PrimUnlifted (GW.Weak a) where + toArrayArray# (GW.Weak tv#) = unsafeCoerce# tv# + fromArrayArray# tv# = GW.Weak (unsafeCoerce# tv#) + +-- | @since 0.6.4.0 +instance PrimUnlifted GCS.ThreadId where + toArrayArray# (GCS.ThreadId tv#) = unsafeCoerce# tv# + fromArrayArray# tv# = GCS.ThreadId (unsafeCoerce# tv#) + +die :: String -> String -> a +die fun problem = error $ "Data.Primitive.UnliftedArray." ++ fun ++ ": " ++ problem + +-- | Creates a new 'MutableUnliftedArray'. This function is unsafe because it +-- initializes all elements of the array as pointers to the array itself. Attempting +-- to read one of these elements before writing to it is in effect an unsafe +-- coercion from the @MutableUnliftedArray s a@ to the element type. +unsafeNewUnliftedArray + :: (PrimMonad m) + => Int -- ^ size + -> m (MutableUnliftedArray (PrimState m) a) +unsafeNewUnliftedArray (I# i#) = primitive $ \s -> case newArrayArray# i# s of + (# s', maa# #) -> (# s', MutableUnliftedArray maa# #) +{-# inline unsafeNewUnliftedArray #-} + +-- | Sets all the positions in an unlifted array to the designated value. +setUnliftedArray + :: (PrimMonad m, PrimUnlifted a) + => MutableUnliftedArray (PrimState m) a -- ^ destination + -> a -- ^ value to fill with + -> m () +setUnliftedArray mua v = loop $ sizeofMutableUnliftedArray mua - 1 + where + loop i | i < 0 = return () + | otherwise = writeUnliftedArray mua i v >> loop (i-1) +{-# inline setUnliftedArray #-} + +-- | Creates a new 'MutableUnliftedArray' with the specified value as initial +-- contents. This is slower than 'unsafeNewUnliftedArray', but safer. +newUnliftedArray + :: (PrimMonad m, PrimUnlifted a) + => Int -- ^ size + -> a -- ^ initial value + -> m (MutableUnliftedArray (PrimState m) a) +newUnliftedArray len v = + unsafeNewUnliftedArray len >>= \mua -> setUnliftedArray mua v >> return mua +{-# inline newUnliftedArray #-} + +-- | Yields the length of an 'UnliftedArray'. +sizeofUnliftedArray :: UnliftedArray e -> Int +sizeofUnliftedArray (UnliftedArray aa#) = I# (sizeofArrayArray# aa#) +{-# inline sizeofUnliftedArray #-} + +-- | Yields the length of a 'MutableUnliftedArray'. +sizeofMutableUnliftedArray :: MutableUnliftedArray s e -> Int +sizeofMutableUnliftedArray (MutableUnliftedArray maa#) + = I# (sizeofMutableArrayArray# maa#) +{-# inline sizeofMutableUnliftedArray #-} + +-- Internal indexing function. +-- +-- Note: ArrayArray# is strictly evaluated, so this should have similar +-- consequences to indexArray#, where matching on the unboxed single causes the +-- array access to happen. +indexUnliftedArrayU + :: PrimUnlifted a + => UnliftedArray a + -> Int + -> (# a #) +indexUnliftedArrayU (UnliftedArray src#) (I# i#) + = case indexArrayArrayArray# src# i# of + aa# -> (# fromArrayArray# aa# #) +{-# inline indexUnliftedArrayU #-} + +-- | Gets the value at the specified position of an 'UnliftedArray'. +indexUnliftedArray + :: PrimUnlifted a + => UnliftedArray a -- ^ source + -> Int -- ^ index + -> a +indexUnliftedArray ua i + = case indexUnliftedArrayU ua i of (# v #) -> v +{-# inline indexUnliftedArray #-} + +-- | Gets the value at the specified position of an 'UnliftedArray'. +-- The purpose of the 'Monad' is to allow for being eager in the +-- 'UnliftedArray' value without having to introduce a data dependency +-- directly on the result value. +-- +-- It should be noted that this is not as much of a problem as with a normal +-- 'Array', because elements of an 'UnliftedArray' are guaranteed to not +-- be exceptional. This function is provided in case it is more desirable +-- than being strict in the result value. +indexUnliftedArrayM + :: (PrimUnlifted a, Monad m) + => UnliftedArray a -- ^ source + -> Int -- ^ index + -> m a +indexUnliftedArrayM ua i + = case indexUnliftedArrayU ua i of + (# v #) -> return v +{-# inline indexUnliftedArrayM #-} + +-- | Gets the value at the specified position of a 'MutableUnliftedArray'. +readUnliftedArray + :: (PrimMonad m, PrimUnlifted a) + => MutableUnliftedArray (PrimState m) a -- ^ source + -> Int -- ^ index + -> m a +readUnliftedArray (MutableUnliftedArray maa#) (I# i#) + = primitive $ \s -> case readArrayArrayArray# maa# i# s of + (# s', aa# #) -> (# s', fromArrayArray# aa# #) +{-# inline readUnliftedArray #-} + +-- | Sets the value at the specified position of a 'MutableUnliftedArray'. +writeUnliftedArray + :: (PrimMonad m, PrimUnlifted a) + => MutableUnliftedArray (PrimState m) a -- ^ destination + -> Int -- ^ index + -> a -- ^ value + -> m () +writeUnliftedArray (MutableUnliftedArray maa#) (I# i#) a + = primitive_ (writeArrayArrayArray# maa# i# (toArrayArray# a)) +{-# inline writeUnliftedArray #-} + +-- | Freezes a 'MutableUnliftedArray', yielding an 'UnliftedArray'. This simply +-- marks the array as frozen in place, so it should only be used when no further +-- modifications to the mutable array will be performed. +unsafeFreezeUnliftedArray + :: (PrimMonad m) + => MutableUnliftedArray (PrimState m) a + -> m (UnliftedArray a) +unsafeFreezeUnliftedArray (MutableUnliftedArray maa#) + = primitive $ \s -> case unsafeFreezeArrayArray# maa# s of + (# s', aa# #) -> (# s', UnliftedArray aa# #) +{-# inline unsafeFreezeUnliftedArray #-} + +-- | Determines whether two 'MutableUnliftedArray' values are the same. This is +-- object/pointer identity, not based on the contents. +sameMutableUnliftedArray + :: MutableUnliftedArray s a + -> MutableUnliftedArray s a + -> Bool +sameMutableUnliftedArray (MutableUnliftedArray maa1#) (MutableUnliftedArray maa2#) + = isTrue# (sameMutableArrayArray# maa1# maa2#) +{-# inline sameMutableUnliftedArray #-} + +-- | Copies the contents of an immutable array into a mutable array. +copyUnliftedArray + :: (PrimMonad m) + => MutableUnliftedArray (PrimState m) a -- ^ destination + -> Int -- ^ offset into destination + -> UnliftedArray a -- ^ source + -> Int -- ^ offset into source + -> Int -- ^ number of elements to copy + -> m () +copyUnliftedArray + (MutableUnliftedArray dst) (I# doff) + (UnliftedArray src) (I# soff) (I# ln) = + primitive_ $ copyArrayArray# src soff dst doff ln +{-# inline copyUnliftedArray #-} + +-- | Copies the contents of one mutable array into another. +copyMutableUnliftedArray + :: (PrimMonad m) + => MutableUnliftedArray (PrimState m) a -- ^ destination + -> Int -- ^ offset into destination + -> MutableUnliftedArray (PrimState m) a -- ^ source + -> Int -- ^ offset into source + -> Int -- ^ number of elements to copy + -> m () +copyMutableUnliftedArray + (MutableUnliftedArray dst) (I# doff) + (MutableUnliftedArray src) (I# soff) (I# ln) = + primitive_ $ copyMutableArrayArray# src soff dst doff ln +{-# inline copyMutableUnliftedArray #-} + +-- | Freezes a portion of a 'MutableUnliftedArray', yielding an 'UnliftedArray'. +-- This operation is safe, in that it copies the frozen portion, and the +-- existing mutable array may still be used afterward. +freezeUnliftedArray + :: (PrimMonad m) + => MutableUnliftedArray (PrimState m) a -- ^ source + -> Int -- ^ offset + -> Int -- ^ length + -> m (UnliftedArray a) +freezeUnliftedArray src off len = do + dst <- unsafeNewUnliftedArray len + copyMutableUnliftedArray dst 0 src off len + unsafeFreezeUnliftedArray dst +{-# inline freezeUnliftedArray #-} + +-- | Thaws a portion of an 'UnliftedArray', yielding a 'MutableUnliftedArray'. +-- This copies the thawed portion, so mutations will not affect the original +-- array. +thawUnliftedArray + :: (PrimMonad m) + => UnliftedArray a -- ^ source + -> Int -- ^ offset + -> Int -- ^ length + -> m (MutableUnliftedArray (PrimState m) a) +thawUnliftedArray src off len = do + dst <- unsafeNewUnliftedArray len + copyUnliftedArray dst 0 src off len + return dst +{-# inline thawUnliftedArray #-} + +#if !MIN_VERSION_base(4,9,0) +unsafeCreateUnliftedArray + :: Int + -> (forall s. MutableUnliftedArray s a -> ST s ()) + -> UnliftedArray a +unsafeCreateUnliftedArray 0 _ = emptyUnliftedArray +unsafeCreateUnliftedArray n f = runUnliftedArray $ do + mary <- unsafeNewUnliftedArray n + f mary + pure mary + +-- | Execute a stateful computation and freeze the resulting array. +runUnliftedArray + :: (forall s. ST s (MutableUnliftedArray s a)) + -> UnliftedArray a +runUnliftedArray m = runST $ m >>= unsafeFreezeUnliftedArray + +#else /* Below, runRW# is available. */ + +-- This low-level business is designed to work with GHC's worker-wrapper +-- transformation. A lot of the time, we don't actually need an Array +-- constructor. By putting it on the outside, and being careful about +-- how we special-case the empty array, we can make GHC smarter about this. +-- The only downside is that separately created 0-length arrays won't share +-- their Array constructors, although they'll share their underlying +-- Array#s. +unsafeCreateUnliftedArray + :: Int + -> (forall s. MutableUnliftedArray s a -> ST s ()) + -> UnliftedArray a +unsafeCreateUnliftedArray 0 _ = UnliftedArray (emptyArrayArray# (# #)) +unsafeCreateUnliftedArray n f = runUnliftedArray $ do + mary <- unsafeNewUnliftedArray n + f mary + pure mary + +-- | Execute a stateful computation and freeze the resulting array. +runUnliftedArray + :: (forall s. ST s (MutableUnliftedArray s a)) + -> UnliftedArray a +runUnliftedArray m = UnliftedArray (runUnliftedArray# m) + +runUnliftedArray# + :: (forall s. ST s (MutableUnliftedArray s a)) + -> ArrayArray# +runUnliftedArray# m = case runRW# $ \s -> + case unST m s of { (# s', MutableUnliftedArray mary# #) -> + unsafeFreezeArrayArray# mary# s'} of (# _, ary# #) -> ary# + +unST :: ST s a -> State# s -> (# State# s, a #) +unST (GHCST.ST f) = f + +emptyArrayArray# :: (# #) -> ArrayArray# +emptyArrayArray# _ = case emptyUnliftedArray of UnliftedArray ar -> ar +{-# NOINLINE emptyArrayArray# #-} +#endif + +-- | Creates a copy of a portion of an 'UnliftedArray' +cloneUnliftedArray + :: UnliftedArray a -- ^ source + -> Int -- ^ offset + -> Int -- ^ length + -> UnliftedArray a +cloneUnliftedArray src off len = + runUnliftedArray (thawUnliftedArray src off len) +{-# inline cloneUnliftedArray #-} + +-- | Creates a new 'MutableUnliftedArray' containing a copy of a portion of +-- another mutable array. +cloneMutableUnliftedArray + :: (PrimMonad m) + => MutableUnliftedArray (PrimState m) a -- ^ source + -> Int -- ^ offset + -> Int -- ^ length + -> m (MutableUnliftedArray (PrimState m) a) +cloneMutableUnliftedArray src off len = do + dst <- unsafeNewUnliftedArray len + copyMutableUnliftedArray dst 0 src off len + return dst +{-# inline cloneMutableUnliftedArray #-} + +instance Eq (MutableUnliftedArray s a) where + (==) = sameMutableUnliftedArray + +instance (Eq a, PrimUnlifted a) => Eq (UnliftedArray a) where + aa1 == aa2 = sizeofUnliftedArray aa1 == sizeofUnliftedArray aa2 + && loop (sizeofUnliftedArray aa1 - 1) + where + loop i + | i < 0 = True + | otherwise = indexUnliftedArray aa1 i == indexUnliftedArray aa2 i && loop (i-1) + +-- | Lexicographic ordering. Subject to change between major versions. +-- +-- @since 0.6.4.0 +instance (Ord a, PrimUnlifted a) => Ord (UnliftedArray a) where + compare a1 a2 = loop 0 + where + mn = sizeofUnliftedArray a1 `min` sizeofUnliftedArray a2 + loop i + | i < mn + , x1 <- indexUnliftedArray a1 i + , x2 <- indexUnliftedArray a2 i + = compare x1 x2 `mappend` loop (i+1) + | otherwise = compare (sizeofUnliftedArray a1) (sizeofUnliftedArray a2) + +-- | @since 0.6.4.0 +instance (Show a, PrimUnlifted a) => Show (UnliftedArray a) where + showsPrec p a = showParen (p > 10) $ + showString "fromListN " . shows (sizeofUnliftedArray a) . showString " " + . shows (unliftedArrayToList a) + +#if MIN_VERSION_base(4,9,0) +-- | @since 0.6.4.0 +instance PrimUnlifted a => Semigroup (UnliftedArray a) where + (<>) = concatUnliftedArray +#endif + +-- | @since 0.6.4.0 +instance PrimUnlifted a => Monoid (UnliftedArray a) where + mempty = emptyUnliftedArray +#if !(MIN_VERSION_base(4,11,0)) + mappend = concatUnliftedArray +#endif + +emptyUnliftedArray :: UnliftedArray a +emptyUnliftedArray = runUnliftedArray (unsafeNewUnliftedArray 0) +{-# NOINLINE emptyUnliftedArray #-} + +concatUnliftedArray :: UnliftedArray a -> UnliftedArray a -> UnliftedArray a +concatUnliftedArray x y = unsafeCreateUnliftedArray (sizeofUnliftedArray x + sizeofUnliftedArray y) $ \m -> do + copyUnliftedArray m 0 x 0 (sizeofUnliftedArray x) + copyUnliftedArray m (sizeofUnliftedArray x) y 0 (sizeofUnliftedArray y) + +-- | Lazy right-associated fold over the elements of an 'UnliftedArray'. +{-# INLINE foldrUnliftedArray #-} +foldrUnliftedArray :: forall a b. PrimUnlifted a => (a -> b -> b) -> b -> UnliftedArray a -> b +foldrUnliftedArray f z arr = go 0 + where + !sz = sizeofUnliftedArray arr + go !i + | sz > i = f (indexUnliftedArray arr i) (go (i+1)) + | otherwise = z + +-- | Strict right-associated fold over the elements of an 'UnliftedArray. +{-# INLINE foldrUnliftedArray' #-} +foldrUnliftedArray' :: forall a b. PrimUnlifted a => (a -> b -> b) -> b -> UnliftedArray a -> b +foldrUnliftedArray' f z0 arr = go (sizeofUnliftedArray arr - 1) z0 + where + go !i !acc + | i < 0 = acc + | otherwise = go (i - 1) (f (indexUnliftedArray arr i) acc) + +-- | Lazy left-associated fold over the elements of an 'UnliftedArray'. +{-# INLINE foldlUnliftedArray #-} +foldlUnliftedArray :: forall a b. PrimUnlifted a => (b -> a -> b) -> b -> UnliftedArray a -> b +foldlUnliftedArray f z arr = go (sizeofUnliftedArray arr - 1) + where + go !i + | i < 0 = z + | otherwise = f (go (i - 1)) (indexUnliftedArray arr i) + +-- | Strict left-associated fold over the elements of an 'UnliftedArray'. +{-# INLINE foldlUnliftedArray' #-} +foldlUnliftedArray' :: forall a b. PrimUnlifted a => (b -> a -> b) -> b -> UnliftedArray a -> b +foldlUnliftedArray' f z0 arr = go 0 z0 + where + !sz = sizeofUnliftedArray arr + go !i !acc + | i < sz = go (i + 1) (f acc (indexUnliftedArray arr i)) + | otherwise = acc + +-- | Map over the elements of an 'UnliftedArray'. +{-# INLINE mapUnliftedArray #-} +mapUnliftedArray :: (PrimUnlifted a, PrimUnlifted b) + => (a -> b) + -> UnliftedArray a + -> UnliftedArray b +mapUnliftedArray f arr = unsafeCreateUnliftedArray sz $ \marr -> do + let go !ix = if ix < sz + then do + let b = f (indexUnliftedArray arr ix) + writeUnliftedArray marr ix b + go (ix + 1) + else return () + go 0 + where + !sz = sizeofUnliftedArray arr + +-- | Convert the unlifted array to a list. +{-# INLINE unliftedArrayToList #-} +unliftedArrayToList :: PrimUnlifted a => UnliftedArray a -> [a] +unliftedArrayToList xs = build (\c n -> foldrUnliftedArray c n xs) + +unliftedArrayFromList :: PrimUnlifted a => [a] -> UnliftedArray a +unliftedArrayFromList xs = unliftedArrayFromListN (L.length xs) xs + +unliftedArrayFromListN :: forall a. PrimUnlifted a => Int -> [a] -> UnliftedArray a +unliftedArrayFromListN len vs = unsafeCreateUnliftedArray len run where + run :: forall s. MutableUnliftedArray s a -> ST s () + run arr = do + let go :: [a] -> Int -> ST s () + go [] !ix = if ix == len + -- The size check is mandatory since failure to initialize all elements + -- introduces the possibility of a segfault happening when someone attempts + -- to read the unitialized element. See the docs for unsafeNewUnliftedArray. + then return () + else die "unliftedArrayFromListN" "list length less than specified size" + go (a : as) !ix = if ix < len + then do + writeUnliftedArray arr ix a + go as (ix + 1) + else die "unliftedArrayFromListN" "list length greater than specified size" + go vs 0 + + +#if MIN_VERSION_base(4,7,0) +-- | @since 0.6.4.0 +instance PrimUnlifted a => E.IsList (UnliftedArray a) where + type Item (UnliftedArray a) = a + fromList = unliftedArrayFromList + fromListN = unliftedArrayFromListN + toList = unliftedArrayToList +#endif + diff --git a/third_party/bazel/rules_haskell/examples/primitive/LICENSE b/third_party/bazel/rules_haskell/examples/primitive/LICENSE new file mode 100644 index 000000000000..fc213a6ffbfe --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/LICENSE @@ -0,0 +1,30 @@ +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. + diff --git a/third_party/bazel/rules_haskell/examples/primitive/Setup.hs b/third_party/bazel/rules_haskell/examples/primitive/Setup.hs new file mode 100644 index 000000000000..200a2e51d0b4 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/third_party/bazel/rules_haskell/examples/primitive/cbits/primitive-memops.c b/third_party/bazel/rules_haskell/examples/primitive/cbits/primitive-memops.c new file mode 100644 index 000000000000..81b1d6f57530 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/cbits/primitive-memops.c @@ -0,0 +1,56 @@ +#include <string.h> +#include "primitive-memops.h" + +void hsprimitive_memcpy( void *dst, ptrdiff_t doff, void *src, ptrdiff_t soff, size_t len ) +{ + memcpy( (char *)dst + doff, (char *)src + soff, len ); +} + +void hsprimitive_memmove( void *dst, ptrdiff_t doff, void *src, ptrdiff_t soff, size_t len ) +{ + memmove( (char *)dst + doff, (char *)src + soff, len ); +} + +#define MEMSET(TYPE, ATYPE) \ +void hsprimitive_memset_ ## TYPE (Hs ## TYPE *p, ptrdiff_t off, size_t n, ATYPE x) \ +{ \ + p += off; \ + if (x == 0) \ + memset(p, 0, n * sizeof(Hs ## TYPE)); \ + else if (sizeof(Hs ## TYPE) == sizeof(int)*2) { \ + int *q = (int *)p; \ + const int *r = (const int *)(void *)&x; \ + while (n>0) { \ + q[0] = r[0]; \ + q[1] = r[1]; \ + q += 2; \ + --n; \ + } \ + } \ + else { \ + while (n>0) { \ + *p++ = x; \ + --n; \ + } \ + } \ +} + +int hsprimitive_memcmp( HsWord8 *s1, HsWord8 *s2, size_t n ) +{ + return memcmp( s1, s2, n ); +} + +void hsprimitive_memset_Word8 (HsWord8 *p, ptrdiff_t off, size_t n, HsWord x) +{ + memset( (char *)(p+off), x, n ); +} + +/* MEMSET(HsWord8, HsWord) */ +MEMSET(Word16, HsWord) +MEMSET(Word32, HsWord) +MEMSET(Word64, HsWord64) +MEMSET(Word, HsWord) +MEMSET(Ptr, HsPtr) +MEMSET(Float, HsFloat) +MEMSET(Double, HsDouble) +MEMSET(Char, HsChar) diff --git a/third_party/bazel/rules_haskell/examples/primitive/cbits/primitive-memops.h b/third_party/bazel/rules_haskell/examples/primitive/cbits/primitive-memops.h new file mode 100644 index 000000000000..d7c3396f8f8b --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/cbits/primitive-memops.h @@ -0,0 +1,23 @@ +#ifndef haskell_primitive_memops_h +#define haskell_primitive_memops_h + +#include <stdlib.h> +#include <stddef.h> +#include <HsFFI.h> + +void hsprimitive_memcpy( void *dst, ptrdiff_t doff, void *src, ptrdiff_t soff, size_t len ); +void hsprimitive_memmove( void *dst, ptrdiff_t doff, void *src, ptrdiff_t soff, size_t len ); +int hsprimitive_memcmp( HsWord8 *s1, HsWord8 *s2, size_t n ); + +void hsprimitive_memset_Word8 (HsWord8 *, ptrdiff_t, size_t, HsWord); +void hsprimitive_memset_Word16 (HsWord16 *, ptrdiff_t, size_t, HsWord); +void hsprimitive_memset_Word32 (HsWord32 *, ptrdiff_t, size_t, HsWord); +void hsprimitive_memset_Word64 (HsWord64 *, ptrdiff_t, size_t, HsWord64); +void hsprimitive_memset_Word (HsWord *, ptrdiff_t, size_t, HsWord); +void hsprimitive_memset_Ptr (HsPtr *, ptrdiff_t, size_t, HsPtr); +void hsprimitive_memset_Float (HsFloat *, ptrdiff_t, size_t, HsFloat); +void hsprimitive_memset_Double (HsDouble *, ptrdiff_t, size_t, HsDouble); +void hsprimitive_memset_Char (HsChar *, ptrdiff_t, size_t, HsChar); + +#endif + diff --git a/third_party/bazel/rules_haskell/examples/primitive/changelog.md b/third_party/bazel/rules_haskell/examples/primitive/changelog.md new file mode 100644 index 000000000000..53485f664428 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/changelog.md @@ -0,0 +1,164 @@ +## Changes in version 0.6.4.0 + + * Introduce `Data.Primitive.PrimArray`, which offers types and function + for dealing with a `ByteArray` tagged with a phantom type variable for + tracking the element type. + + * Implement `isByteArrayPinned` and `isMutableByteArrayPinned`. + + * Add `Eq1`, `Ord1`, `Show1`, and `Read1` instances for `Array` and + `SmallArray`. + + * Improve the test suite. This includes having property tests for + typeclasses from `base` such as `Eq`, `Ord`, `Functor`, `Applicative`, + `Monad`, `IsList`, `Monoid`, `Foldable`, and `Traversable`. + + * Fix the broken `IsList` instance for `ByteArray`. The old definition + would allocate a byte array of the correct size and then leave the + memory unitialized instead of writing the list elements to it. + + * Fix the broken `Functor` instance for `Array`. The old definition + would allocate an array of the correct size with thunks for erroring + installed at every index. It failed to replace these thunks with + the result of the function applied to the elements of the argument array. + + * Fix the broken `Applicative` instances of `Array` and `SmallArray`. + The old implementation of `<*>` for `Array` failed to initialize + some elements but correctly initialized others in the resulting + `Array`. It is unclear what the old behavior of `<*>` was for + `SmallArray`, but it was incorrect. + + * Fix the broken `Monad` instances for `Array` and `SmallArray`. + + * Fix the implementation of `foldl1` in the `Foldable` instances for + `Array` and `SmallArray`. In both cases, the old implementation + simply returned the first element of the array and made no use of + the other elements in the array. + + * Fix the implementation of `mconcat` in the `Monoid` instance for + `SmallArray`. + + * Implement `Data.Primitive.Ptr`, implementations of `Ptr` functions + that require a `Prim` constraint instead of a `Storable` constraint. + + + * Add `PrimUnlifted` instances for `TVar` and `MVar`. + + * Use `compareByteArrays#` for the `Eq` and `Ord` instances of + `ByteArray` when building with GHC 8.4 and newer. + + * Add `Prim` instances for lots of types in `Foreign.C.Types` and + `System.Posix.Types`. + + * Reexport `Data.Primitive.SmallArray` and `Data.Primitive.UnliftedArray` + from `Data.Primitive`. + + * Add fold functions and map function to `Data.Primitive.UnliftedArray`. + Add typeclass instances for `IsList`, `Ord`, and `Show`. + + * Add `defaultSetByteArray#` and `defaultSetOffAddr#` to + `Data.Primitive.Types`. + +## Changes in version 0.6.3.0 + + * Add `PrimMonad` instances for `ContT`, `AccumT`, and `SelectT` from + `transformers` + + * Add `Eq`, `Ord`, `Show`, and `IsList` instances for `ByteArray` + + * Add `Semigroup` instances for `Array` and `SmallArray`. This allows + `primitive` to build on GHC 8.4 and later. + +## Changes in version 0.6.2.0 + + * Drop support for GHCs before 7.4 + + * `SmallArray` support + + * `ArrayArray#` based support for more efficient arrays of unlifted pointer types + + * Make `Array` and the like instances of various classes for convenient use + + * Add `Prim` instances for Ptr and FunPtr + + * Add `ioToPrim`, `stToPrim` and unsafe counterparts for situations that would + otherwise require type ascriptions on `primToPrim` + + * Add `evalPrim` + + * Add `PrimBase` instance for `IdentityT` + +## Changes in version 0.6.1.0 + + * Use more appropriate types in internal memset functions, which prevents + overflows/segfaults on 64-bit systems. + + * Fixed a warning on GHC 7.10 + + * Worked around a -dcore-lint bug in GHC 7.6/7.7 + +## Changes in version 0.6 + + * Split PrimMonad into two classes to allow automatic lifting of primitive + operations into monad transformers. The `internal` operation has moved to the + `PrimBase` class. + + * Fixed the test suite on older GHCs + +## Changes in version 0.5.4.0 + + * Changed primitive_ to work around an oddity with GHC's code generation + on certain versions that led to side effects not happening when used + in conjunction with certain very unsafe IO performers. + + * Allow primitive to build on GHC 7.9 + +## Changes in version 0.5.3.0 + + * Implement `cloneArray` and `cloneMutableArray` primitives + (with fall-back implementations for GHCs prior to version 7.2.1) + +## Changes in version 0.5.2.1 + + * Add strict variants of `MutVar` modification functions + `atomicModifyMutVar'` and `modifyMutVar'` + + * Fix compilation on Solaris 10 with GNU C 3.4.3 + +## Changes in version 0.5.1.0 + + * Add support for GHC 7.7's new primitive `Bool` representation + +## Changes in version 0.5.0.1 + + * Disable array copying primitives for GHC 7.6.* and earlier + +## Changes in version 0.5 + + * New in `Data.Primitive.MutVar`: `atomicModifyMutVar` + + * Efficient block fill operations: `setByteArray`, `setAddr` + +## Changes in version 0.4.1 + + * New module `Data.Primitive.MutVar` + +## Changes in version 0.4.0.1 + + * Critical bug fix in `fillByteArray` + +## Changes in version 0.4 + + * Support for GHC 7.2 array copying primitives + + * New in `Data.Primitive.ByteArray`: `copyByteArray`, + `copyMutableByteArray`, `moveByteArray`, `fillByteArray` + + * Deprecated in `Data.Primitive.ByteArray`: `memcpyByteArray`, + `memcpyByteArray'`, `memmoveByteArray`, `memsetByteArray` + + * New in `Data.Primitive.Array`: `copyArray`, `copyMutableByteArray` + + * New in `Data.Primitive.Addr`: `copyAddr`, `moveAddr` + + * Deprecated in `Data.Primitive.Addr`: `memcpyAddr` diff --git a/third_party/bazel/rules_haskell/examples/primitive/primitive.cabal b/third_party/bazel/rules_haskell/examples/primitive/primitive.cabal new file mode 100644 index 000000000000..e370f6d005a1 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/primitive.cabal @@ -0,0 +1,74 @@ +Name: primitive +Version: 0.6.4.0 +x-revision: 1 +License: BSD3 +License-File: LICENSE + +Author: Roman Leshchinskiy <rl@cse.unsw.edu.au> +Maintainer: libraries@haskell.org +Copyright: (c) Roman Leshchinskiy 2009-2012 +Homepage: https://github.com/haskell/primitive +Bug-Reports: https://github.com/haskell/primitive/issues +Category: Data +Synopsis: Primitive memory-related operations +Cabal-Version: >= 1.10 +Build-Type: Simple +Description: This package provides various primitive memory-related operations. + +Extra-Source-Files: changelog.md + test/*.hs + test/LICENSE + test/primitive-tests.cabal + +Tested-With: + GHC == 7.4.2, + GHC == 7.6.3, + GHC == 7.8.4, + GHC == 7.10.3, + GHC == 8.0.2, + GHC == 8.2.2, + GHC == 8.4.2 + +Library + Default-Language: Haskell2010 + Other-Extensions: + BangPatterns, CPP, DeriveDataTypeable, + MagicHash, TypeFamilies, UnboxedTuples, UnliftedFFITypes + + Exposed-Modules: + Control.Monad.Primitive + Data.Primitive + Data.Primitive.MachDeps + Data.Primitive.Types + Data.Primitive.Array + Data.Primitive.ByteArray + Data.Primitive.PrimArray + Data.Primitive.SmallArray + Data.Primitive.UnliftedArray + Data.Primitive.Addr + Data.Primitive.Ptr + Data.Primitive.MutVar + Data.Primitive.MVar + + Other-Modules: + Data.Primitive.Internal.Compat + Data.Primitive.Internal.Operations + + Build-Depends: base >= 4.5 && < 4.13 + , ghc-prim >= 0.2 && < 0.6 + , transformers >= 0.2 && < 0.6 + + Ghc-Options: -O2 + + Include-Dirs: cbits + Install-Includes: primitive-memops.h + includes: primitive-memops.h + c-sources: cbits/primitive-memops.c + if !os(solaris) + cc-options: -ftree-vectorize + if arch(i386) || arch(x86_64) + cc-options: -msse2 + +source-repository head + type: git + location: https://github.com/haskell/primitive diff --git a/third_party/bazel/rules_haskell/examples/primitive/test/LICENSE b/third_party/bazel/rules_haskell/examples/primitive/test/LICENSE new file mode 100644 index 000000000000..fc213a6ffbfe --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/test/LICENSE @@ -0,0 +1,30 @@ +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. + diff --git a/third_party/bazel/rules_haskell/examples/primitive/test/main.hs b/third_party/bazel/rules_haskell/examples/primitive/test/main.hs new file mode 100644 index 000000000000..abec96df032d --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/test/main.hs @@ -0,0 +1,342 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ScopedTypeVariables #-} + +import Control.Applicative +import Control.Monad +import Control.Monad.Fix (fix) +import Control.Monad.Primitive +import Control.Monad.ST +import Data.Monoid +import Data.Primitive +import Data.Primitive.Array +import Data.Primitive.ByteArray +import Data.Primitive.Types +import Data.Primitive.SmallArray +import Data.Primitive.PrimArray +import Data.Word +import Data.Proxy (Proxy(..)) +import GHC.Int +import GHC.IO +import GHC.Prim +import Data.Function (on) +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup (stimes) +#endif + +import Test.Tasty (defaultMain,testGroup,TestTree) +import Test.QuickCheck (Arbitrary,Arbitrary1,Gen,(===),CoArbitrary,Function) +import qualified Test.Tasty.QuickCheck as TQC +import qualified Test.QuickCheck as QC +import qualified Test.QuickCheck.Classes as QCC +import qualified Test.QuickCheck.Classes.IsList as QCCL +import qualified Data.List as L + +main :: IO () +main = do + testArray + testByteArray + defaultMain $ testGroup "properties" + [ testGroup "Array" + [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (Array Int))) + , lawsToTest (QCC.ordLaws (Proxy :: Proxy (Array Int))) + , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (Array Int))) + , lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int))) +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) + , lawsToTest (QCC.functorLaws (Proxy1 :: Proxy1 Array)) + , lawsToTest (QCC.applicativeLaws (Proxy1 :: Proxy1 Array)) + , lawsToTest (QCC.monadLaws (Proxy1 :: Proxy1 Array)) + , lawsToTest (QCC.foldableLaws (Proxy1 :: Proxy1 Array)) + , lawsToTest (QCC.traversableLaws (Proxy1 :: Proxy1 Array)) +#endif +#if MIN_VERSION_base(4,7,0) + , lawsToTest (QCC.isListLaws (Proxy :: Proxy (Array Int))) + , TQC.testProperty "mapArray'" (QCCL.mapProp int16 int32 mapArray') +#endif + ] + , testGroup "SmallArray" + [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (SmallArray Int))) + , lawsToTest (QCC.ordLaws (Proxy :: Proxy (SmallArray Int))) + , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (SmallArray Int))) + , lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int))) +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) + , lawsToTest (QCC.functorLaws (Proxy1 :: Proxy1 SmallArray)) + , lawsToTest (QCC.applicativeLaws (Proxy1 :: Proxy1 SmallArray)) + , lawsToTest (QCC.monadLaws (Proxy1 :: Proxy1 SmallArray)) + , lawsToTest (QCC.foldableLaws (Proxy1 :: Proxy1 SmallArray)) + , lawsToTest (QCC.traversableLaws (Proxy1 :: Proxy1 SmallArray)) +#endif +#if MIN_VERSION_base(4,7,0) + , lawsToTest (QCC.isListLaws (Proxy :: Proxy (SmallArray Int))) + , TQC.testProperty "mapSmallArray'" (QCCL.mapProp int16 int32 mapSmallArray') +#endif + ] + , testGroup "ByteArray" + [ testGroup "Ordering" + [ TQC.testProperty "equality" byteArrayEqProp + , TQC.testProperty "compare" byteArrayCompareProp + ] + , testGroup "Resize" + [ TQC.testProperty "shrink" byteArrayShrinkProp + , TQC.testProperty "grow" byteArrayGrowProp + ] + , lawsToTest (QCC.eqLaws (Proxy :: Proxy ByteArray)) + , lawsToTest (QCC.ordLaws (Proxy :: Proxy ByteArray)) + , lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int))) +#if MIN_VERSION_base(4,7,0) + , lawsToTest (QCC.isListLaws (Proxy :: Proxy ByteArray)) +#endif + ] + , testGroup "PrimArray" + [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (PrimArray Word16))) + , lawsToTest (QCC.ordLaws (Proxy :: Proxy (PrimArray Word16))) + , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (PrimArray Word16))) +#if MIN_VERSION_base(4,7,0) + , lawsToTest (QCC.isListLaws (Proxy :: Proxy (PrimArray Word16))) + , TQC.testProperty "foldrPrimArray" (QCCL.foldrProp int16 foldrPrimArray) + , TQC.testProperty "foldrPrimArray'" (QCCL.foldrProp int16 foldrPrimArray') + , TQC.testProperty "foldlPrimArray" (QCCL.foldlProp int16 foldlPrimArray) + , TQC.testProperty "foldlPrimArray'" (QCCL.foldlProp int16 foldlPrimArray') + , TQC.testProperty "foldlPrimArrayM'" (QCCL.foldlMProp int16 foldlPrimArrayM') + , TQC.testProperty "mapPrimArray" (QCCL.mapProp int16 int32 mapPrimArray) + , TQC.testProperty "traversePrimArray" (QCCL.traverseProp int16 int32 traversePrimArray) + , TQC.testProperty "traversePrimArrayP" (QCCL.traverseProp int16 int32 traversePrimArrayP) + , TQC.testProperty "imapPrimArray" (QCCL.imapProp int16 int32 imapPrimArray) + , TQC.testProperty "itraversePrimArray" (QCCL.imapMProp int16 int32 itraversePrimArray) + , TQC.testProperty "itraversePrimArrayP" (QCCL.imapMProp int16 int32 itraversePrimArrayP) + , TQC.testProperty "generatePrimArray" (QCCL.generateProp int16 generatePrimArray) + , TQC.testProperty "generatePrimArrayA" (QCCL.generateMProp int16 generatePrimArrayA) + , TQC.testProperty "generatePrimArrayP" (QCCL.generateMProp int16 generatePrimArrayP) + , TQC.testProperty "replicatePrimArray" (QCCL.replicateProp int16 replicatePrimArray) + , TQC.testProperty "replicatePrimArrayA" (QCCL.replicateMProp int16 replicatePrimArrayA) + , TQC.testProperty "replicatePrimArrayP" (QCCL.replicateMProp int16 replicatePrimArrayP) + , TQC.testProperty "filterPrimArray" (QCCL.filterProp int16 filterPrimArray) + , TQC.testProperty "filterPrimArrayA" (QCCL.filterMProp int16 filterPrimArrayA) + , TQC.testProperty "filterPrimArrayP" (QCCL.filterMProp int16 filterPrimArrayP) + , TQC.testProperty "mapMaybePrimArray" (QCCL.mapMaybeProp int16 int32 mapMaybePrimArray) + , TQC.testProperty "mapMaybePrimArrayA" (QCCL.mapMaybeMProp int16 int32 mapMaybePrimArrayA) + , TQC.testProperty "mapMaybePrimArrayP" (QCCL.mapMaybeMProp int16 int32 mapMaybePrimArrayP) +#endif + ] + , testGroup "UnliftedArray" + [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (UnliftedArray (PrimArray Int16)))) + , lawsToTest (QCC.ordLaws (Proxy :: Proxy (UnliftedArray (PrimArray Int16)))) + , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (UnliftedArray (PrimArray Int16)))) +#if MIN_VERSION_base(4,7,0) + , lawsToTest (QCC.isListLaws (Proxy :: Proxy (UnliftedArray (PrimArray Int16)))) + , TQC.testProperty "mapUnliftedArray" (QCCL.mapProp arrInt16 arrInt32 mapUnliftedArray) + , TQC.testProperty "foldrUnliftedArray" (QCCL.foldrProp arrInt16 foldrUnliftedArray) + , TQC.testProperty "foldrUnliftedArray'" (QCCL.foldrProp arrInt16 foldrUnliftedArray') + , TQC.testProperty "foldlUnliftedArray" (QCCL.foldlProp arrInt16 foldlUnliftedArray) + , TQC.testProperty "foldlUnliftedArray'" (QCCL.foldlProp arrInt16 foldlUnliftedArray') +#endif + ] + , testGroup "DefaultSetMethod" + [ lawsToTest (QCC.primLaws (Proxy :: Proxy DefaultSetMethod)) + ] + -- , testGroup "PrimStorable" + -- [ lawsToTest (QCC.storableLaws (Proxy :: Proxy Derived)) + -- ] + ] + +int16 :: Proxy Int16 +int16 = Proxy + +int32 :: Proxy Int32 +int32 = Proxy + +arrInt16 :: Proxy (PrimArray Int16) +arrInt16 = Proxy + +arrInt32 :: Proxy (PrimArray Int16) +arrInt32 = Proxy + +-- Tests that using resizeByteArray to shrink a byte array produces +-- the same results as calling Data.List.take on the list that the +-- byte array corresponds to. +byteArrayShrinkProp :: QC.Property +byteArrayShrinkProp = QC.property $ \(QC.NonNegative (n :: Int)) (QC.NonNegative (m :: Int)) -> + let large = max n m + small = min n m + xs = intsLessThan large + ys = byteArrayFromList xs + largeBytes = large * sizeOf (undefined :: Int) + smallBytes = small * sizeOf (undefined :: Int) + expected = byteArrayFromList (L.take small xs) + actual = runST $ do + mzs0 <- newByteArray largeBytes + copyByteArray mzs0 0 ys 0 largeBytes + mzs1 <- resizeMutableByteArray mzs0 smallBytes + unsafeFreezeByteArray mzs1 + in expected === actual + +-- Tests that using resizeByteArray with copyByteArray (to fill in the +-- new empty space) to grow a byte array produces the same results as +-- calling Data.List.++ on the lists corresponding to the original +-- byte array and the appended byte array. +byteArrayGrowProp :: QC.Property +byteArrayGrowProp = QC.property $ \(QC.NonNegative (n :: Int)) (QC.NonNegative (m :: Int)) -> + let large = max n m + small = min n m + xs1 = intsLessThan small + xs2 = intsLessThan (large - small) + ys1 = byteArrayFromList xs1 + ys2 = byteArrayFromList xs2 + largeBytes = large * sizeOf (undefined :: Int) + smallBytes = small * sizeOf (undefined :: Int) + expected = byteArrayFromList (xs1 ++ xs2) + actual = runST $ do + mzs0 <- newByteArray smallBytes + copyByteArray mzs0 0 ys1 0 smallBytes + mzs1 <- resizeMutableByteArray mzs0 largeBytes + copyByteArray mzs1 smallBytes ys2 0 ((large - small) * sizeOf (undefined :: Int)) + unsafeFreezeByteArray mzs1 + in expected === actual + +-- Provide the non-negative integers up to the bound. For example: +-- +-- >>> intsLessThan 5 +-- [0,1,2,3,4] +intsLessThan :: Int -> [Int] +intsLessThan i = if i < 1 + then [] + else (i - 1) : intsLessThan (i - 1) + +byteArrayCompareProp :: QC.Property +byteArrayCompareProp = QC.property $ \(xs :: [Word8]) (ys :: [Word8]) -> + compareLengthFirst xs ys === compare (byteArrayFromList xs) (byteArrayFromList ys) + +byteArrayEqProp :: QC.Property +byteArrayEqProp = QC.property $ \(xs :: [Word8]) (ys :: [Word8]) -> + (compareLengthFirst xs ys == EQ) === (byteArrayFromList xs == byteArrayFromList ys) + +compareLengthFirst :: [Word8] -> [Word8] -> Ordering +compareLengthFirst xs ys = (compare `on` length) xs ys <> compare xs ys + +-- on GHC 7.4, Proxy is not polykinded, so we need this instead. +data Proxy1 (f :: * -> *) = Proxy1 + +lawsToTest :: QCC.Laws -> TestTree +lawsToTest (QCC.Laws name pairs) = testGroup name (map (uncurry TQC.testProperty) pairs) + +testArray :: IO () +testArray = do + arr <- newArray 1 'A' + let unit = + case writeArray arr 0 'B' of + IO f -> + case f realWorld# of + (# _, _ #) -> () + c1 <- readArray arr 0 + return $! unit + c2 <- readArray arr 0 + if c1 == 'A' && c2 == 'B' + then return () + else error $ "Expected AB, got: " ++ show (c1, c2) + +testByteArray :: IO () +testByteArray = do + let arr1 = mkByteArray ([0xde, 0xad, 0xbe, 0xef] :: [Word8]) + arr2 = mkByteArray ([0xde, 0xad, 0xbe, 0xef] :: [Word8]) + arr3 = mkByteArray ([0xde, 0xad, 0xbe, 0xee] :: [Word8]) + arr4 = mkByteArray ([0xde, 0xad, 0xbe, 0xdd] :: [Word8]) + arr5 = mkByteArray ([0xde, 0xad, 0xbe, 0xef, 0xde, 0xad, 0xbe, 0xdd] :: [Word8]) + when (show arr1 /= "[0xde, 0xad, 0xbe, 0xef]") $ + fail $ "ByteArray Show incorrect: "++show arr1 + unless (arr1 > arr3) $ + fail $ "ByteArray Ord incorrect" + unless (arr1 == arr2) $ + fail $ "ByteArray Eq incorrect" + unless (mappend arr1 arr4 == arr5) $ + fail $ "ByteArray Monoid mappend incorrect" + unless (mappend arr1 (mappend arr3 arr4) == mappend (mappend arr1 arr3) arr4) $ + fail $ "ByteArray Monoid mappend not associative" + unless (mconcat [arr1,arr2,arr3,arr4,arr5] == (arr1 <> arr2 <> arr3 <> arr4 <> arr5)) $ + fail $ "ByteArray Monoid mconcat incorrect" +#if MIN_VERSION_base(4,9,0) + unless (stimes (3 :: Int) arr4 == (arr4 <> arr4 <> arr4)) $ + fail $ "ByteArray Semigroup stimes incorrect" +#endif + +mkByteArray :: Prim a => [a] -> ByteArray +mkByteArray xs = runST $ do + marr <- newByteArray (length xs * sizeOf (head xs)) + sequence $ zipWith (writeByteArray marr) [0..] xs + unsafeFreezeByteArray marr + +instance Arbitrary1 Array where + liftArbitrary elemGen = fmap fromList (QC.liftArbitrary elemGen) + +instance Arbitrary a => Arbitrary (Array a) where + arbitrary = fmap fromList QC.arbitrary + +instance Arbitrary1 SmallArray where + liftArbitrary elemGen = fmap smallArrayFromList (QC.liftArbitrary elemGen) + +instance Arbitrary a => Arbitrary (SmallArray a) where + arbitrary = fmap smallArrayFromList QC.arbitrary + +instance Arbitrary ByteArray where + arbitrary = do + xs <- QC.arbitrary :: Gen [Word8] + return $ runST $ do + a <- newByteArray (L.length xs) + iforM_ xs $ \ix x -> do + writeByteArray a ix x + unsafeFreezeByteArray a + +instance (Arbitrary a, Prim a) => Arbitrary (PrimArray a) where + arbitrary = do + xs <- QC.arbitrary :: Gen [a] + return $ runST $ do + a <- newPrimArray (L.length xs) + iforM_ xs $ \ix x -> do + writePrimArray a ix x + unsafeFreezePrimArray a + +instance (Arbitrary a, PrimUnlifted a) => Arbitrary (UnliftedArray a) where + arbitrary = do + xs <- QC.vector =<< QC.choose (0,3) + return (unliftedArrayFromList xs) + +instance (Prim a, CoArbitrary a) => CoArbitrary (PrimArray a) where + coarbitrary x = QC.coarbitrary (primArrayToList x) + +instance (Prim a, Function a) => Function (PrimArray a) where + function = QC.functionMap primArrayToList primArrayFromList + +iforM_ :: Monad m => [a] -> (Int -> a -> m b) -> m () +iforM_ xs0 f = go 0 xs0 where + go !_ [] = return () + go !ix (x : xs) = f ix x >> go (ix + 1) xs + +newtype DefaultSetMethod = DefaultSetMethod Int16 + deriving (Eq,Show,Arbitrary) + +instance Prim DefaultSetMethod where + sizeOf# _ = sizeOf# (undefined :: Int16) + alignment# _ = alignment# (undefined :: Int16) + indexByteArray# arr ix = DefaultSetMethod (indexByteArray# arr ix) + readByteArray# arr ix s0 = case readByteArray# arr ix s0 of + (# s1, n #) -> (# s1, DefaultSetMethod n #) + writeByteArray# arr ix (DefaultSetMethod n) s0 = writeByteArray# arr ix n s0 + setByteArray# = defaultSetByteArray# + indexOffAddr# addr off = DefaultSetMethod (indexOffAddr# addr off) + readOffAddr# addr off s0 = case readOffAddr# addr off s0 of + (# s1, n #) -> (# s1, DefaultSetMethod n #) + writeOffAddr# addr off (DefaultSetMethod n) s0 = writeOffAddr# addr off n s0 + setOffAddr# = defaultSetOffAddr# + +-- TODO: Uncomment this out when GHC 8.6 is release. Also, uncomment +-- the corresponding PrimStorable test group above. +-- +-- newtype Derived = Derived Int16 +-- deriving newtype (Prim) +-- deriving Storable via (PrimStorable Derived) + + + diff --git a/third_party/bazel/rules_haskell/examples/primitive/test/primitive-tests.cabal b/third_party/bazel/rules_haskell/examples/primitive/test/primitive-tests.cabal new file mode 100644 index 000000000000..957fe5ee1f64 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/test/primitive-tests.cabal @@ -0,0 +1,45 @@ +Name: primitive-tests +Version: 0.1 +License: BSD3 +License-File: LICENSE + +Author: Roman Leshchinskiy <rl@cse.unsw.edu.au> +Maintainer: libraries@haskell.org +Copyright: (c) Roman Leshchinskiy 2009-2012 +Homepage: https://github.com/haskell/primitive +Bug-Reports: https://github.com/haskell/primitive/issues +Category: Data +Synopsis: primitive tests +Cabal-Version: >= 1.10 +Build-Type: Simple +Description: @primitive@ tests + +Tested-With: + GHC == 7.4.2, + GHC == 7.6.3, + GHC == 7.8.4, + GHC == 7.10.3, + GHC == 8.0.2, + GHC == 8.2.2, + GHC == 8.4.2 + +test-suite test + Default-Language: Haskell2010 + hs-source-dirs: . + main-is: main.hs + type: exitcode-stdio-1.0 + build-depends: base >= 4.5 && < 4.12 + , ghc-prim + , primitive + , QuickCheck + , tasty + , tasty-quickcheck + , tagged + , transformers >= 0.3 + , quickcheck-classes >= 0.4.11.1 + ghc-options: -O2 + +source-repository head + type: git + location: https://github.com/haskell/primitive + subdir: test diff --git a/third_party/bazel/rules_haskell/examples/rts/BUILD.bazel b/third_party/bazel/rules_haskell/examples/rts/BUILD.bazel new file mode 100644 index 000000000000..1bbf94b1c0a9 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/rts/BUILD.bazel @@ -0,0 +1,29 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "cc_haskell_import", + "haskell_library", + "haskell_toolchain_library", +) + +haskell_toolchain_library(name = "base") + +haskell_library( + name = "add-one-hs", + srcs = ["One.hs"], + deps = [":base"], +) + +cc_haskell_import( + name = "add-one-so", + dep = ":add-one-hs", +) + +cc_test( + name = "add-one", + srcs = [ + "main.c", + ":add-one-so", + ], + visibility = ["//visibility:public"], + deps = ["@ghc//:threaded-rts"], +) diff --git a/third_party/bazel/rules_haskell/examples/rts/One.hs b/third_party/bazel/rules_haskell/examples/rts/One.hs new file mode 100644 index 000000000000..bc24fb7cb274 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/rts/One.hs @@ -0,0 +1,6 @@ +module One () where + +add_one_hs :: Int -> Int +add_one_hs x = x + 1 + +foreign export ccall add_one_hs :: Int -> Int diff --git a/third_party/bazel/rules_haskell/examples/rts/main.c b/third_party/bazel/rules_haskell/examples/rts/main.c new file mode 100644 index 000000000000..28624227d8c0 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/rts/main.c @@ -0,0 +1,11 @@ +#include <stdio.h> +#include "HsFFI.h" + +extern HsInt add_one_hs(HsInt a0); + +int main(int argc, char *argv[]) { + hs_init(&argc, &argv); + printf("Adding one to 5 through Haskell is %ld\n", add_one_hs(5)); + hs_exit(); + return 0; +} diff --git a/third_party/bazel/rules_haskell/examples/transformers/BUILD.bazel b/third_party/bazel/rules_haskell/examples/transformers/BUILD.bazel new file mode 100644 index 000000000000..092111f9f19a --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/BUILD.bazel @@ -0,0 +1,19 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_cc_import", + "haskell_library", + "haskell_toolchain_library", +) + +haskell_toolchain_library(name = "base") + +haskell_library( + name = "transformers", + srcs = glob([ + "Data/**/*.hs", + "Control/**/*.hs", + ]), + version = "0", + visibility = ["//visibility:public"], + deps = [":base"], +) diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Applicative/Backwards.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Applicative/Backwards.hs new file mode 100644 index 000000000000..7ed74acbace0 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Applicative/Backwards.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE PolyKinds #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Applicative.Backwards +-- Copyright : (c) Russell O'Connor 2009 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- Making functors with an 'Applicative' instance that performs actions +-- in the reverse order. +----------------------------------------------------------------------------- + +module Control.Applicative.Backwards ( + Backwards(..), + ) where + +import Data.Functor.Classes +#if MIN_VERSION_base(4,12,0) +import Data.Functor.Contravariant +#endif + +import Prelude hiding (foldr, foldr1, foldl, foldl1, null, length) +import Control.Applicative +import Data.Foldable +import Data.Traversable + +-- | The same functor, but with an 'Applicative' instance that performs +-- actions in the reverse order. +newtype Backwards f a = Backwards { forwards :: f a } + +instance (Eq1 f) => Eq1 (Backwards f) where + liftEq eq (Backwards x) (Backwards y) = liftEq eq x y + {-# INLINE liftEq #-} + +instance (Ord1 f) => Ord1 (Backwards f) where + liftCompare comp (Backwards x) (Backwards y) = liftCompare comp x y + {-# INLINE liftCompare #-} + +instance (Read1 f) => Read1 (Backwards f) where + liftReadsPrec rp rl = readsData $ + readsUnaryWith (liftReadsPrec rp rl) "Backwards" Backwards + +instance (Show1 f) => Show1 (Backwards f) where + liftShowsPrec sp sl d (Backwards x) = + showsUnaryWith (liftShowsPrec sp sl) "Backwards" d x + +instance (Eq1 f, Eq a) => Eq (Backwards f a) where (==) = eq1 +instance (Ord1 f, Ord a) => Ord (Backwards f a) where compare = compare1 +instance (Read1 f, Read a) => Read (Backwards f a) where readsPrec = readsPrec1 +instance (Show1 f, Show a) => Show (Backwards f a) where showsPrec = showsPrec1 + +-- | Derived instance. +instance (Functor f) => Functor (Backwards f) where + fmap f (Backwards a) = Backwards (fmap f a) + {-# INLINE fmap #-} + +-- | Apply @f@-actions in the reverse order. +instance (Applicative f) => Applicative (Backwards f) where + pure a = Backwards (pure a) + {-# INLINE pure #-} + Backwards f <*> Backwards a = Backwards (a <**> f) + {-# INLINE (<*>) #-} + +-- | Try alternatives in the same order as @f@. +instance (Alternative f) => Alternative (Backwards f) where + empty = Backwards empty + {-# INLINE empty #-} + Backwards x <|> Backwards y = Backwards (x <|> y) + {-# INLINE (<|>) #-} + +-- | Derived instance. +instance (Foldable f) => Foldable (Backwards f) where + foldMap f (Backwards t) = foldMap f t + {-# INLINE foldMap #-} + foldr f z (Backwards t) = foldr f z t + {-# INLINE foldr #-} + foldl f z (Backwards t) = foldl f z t + {-# INLINE foldl #-} + foldr1 f (Backwards t) = foldr1 f t + {-# INLINE foldr1 #-} + foldl1 f (Backwards t) = foldl1 f t + {-# INLINE foldl1 #-} +#if MIN_VERSION_base(4,8,0) + null (Backwards t) = null t + length (Backwards t) = length t +#endif + +-- | Derived instance. +instance (Traversable f) => Traversable (Backwards f) where + traverse f (Backwards t) = fmap Backwards (traverse f t) + {-# INLINE traverse #-} + sequenceA (Backwards t) = fmap Backwards (sequenceA t) + {-# INLINE sequenceA #-} + +#if MIN_VERSION_base(4,12,0) +-- | Derived instance. +instance Contravariant f => Contravariant (Backwards f) where + contramap f = Backwards . contramap f . forwards + {-# INLINE contramap #-} +#endif diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Applicative/Lift.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Applicative/Lift.hs new file mode 100644 index 000000000000..8d35e288c025 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Applicative/Lift.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Applicative.Lift +-- Copyright : (c) Ross Paterson 2010 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- Adding a new kind of pure computation to an applicative functor. +----------------------------------------------------------------------------- + +module Control.Applicative.Lift ( + -- * Lifting an applicative + Lift(..), + unLift, + mapLift, + elimLift, + -- * Collecting errors + Errors, + runErrors, + failure, + eitherToErrors + ) where + +import Data.Functor.Classes + +import Control.Applicative +import Data.Foldable (Foldable(foldMap)) +import Data.Functor.Constant +import Data.Monoid (Monoid(..)) +import Data.Traversable (Traversable(traverse)) + +-- | Applicative functor formed by adding pure computations to a given +-- applicative functor. +data Lift f a = Pure a | Other (f a) + +instance (Eq1 f) => Eq1 (Lift f) where + liftEq eq (Pure x1) (Pure x2) = eq x1 x2 + liftEq _ (Pure _) (Other _) = False + liftEq _ (Other _) (Pure _) = False + liftEq eq (Other y1) (Other y2) = liftEq eq y1 y2 + {-# INLINE liftEq #-} + +instance (Ord1 f) => Ord1 (Lift f) where + liftCompare comp (Pure x1) (Pure x2) = comp x1 x2 + liftCompare _ (Pure _) (Other _) = LT + liftCompare _ (Other _) (Pure _) = GT + liftCompare comp (Other y1) (Other y2) = liftCompare comp y1 y2 + {-# INLINE liftCompare #-} + +instance (Read1 f) => Read1 (Lift f) where + liftReadsPrec rp rl = readsData $ + readsUnaryWith rp "Pure" Pure `mappend` + readsUnaryWith (liftReadsPrec rp rl) "Other" Other + +instance (Show1 f) => Show1 (Lift f) where + liftShowsPrec sp _ d (Pure x) = showsUnaryWith sp "Pure" d x + liftShowsPrec sp sl d (Other y) = + showsUnaryWith (liftShowsPrec sp sl) "Other" d y + +instance (Eq1 f, Eq a) => Eq (Lift f a) where (==) = eq1 +instance (Ord1 f, Ord a) => Ord (Lift f a) where compare = compare1 +instance (Read1 f, Read a) => Read (Lift f a) where readsPrec = readsPrec1 +instance (Show1 f, Show a) => Show (Lift f a) where showsPrec = showsPrec1 + +instance (Functor f) => Functor (Lift f) where + fmap f (Pure x) = Pure (f x) + fmap f (Other y) = Other (fmap f y) + {-# INLINE fmap #-} + +instance (Foldable f) => Foldable (Lift f) where + foldMap f (Pure x) = f x + foldMap f (Other y) = foldMap f y + {-# INLINE foldMap #-} + +instance (Traversable f) => Traversable (Lift f) where + traverse f (Pure x) = Pure <$> f x + traverse f (Other y) = Other <$> traverse f y + {-# INLINE traverse #-} + +-- | A combination is 'Pure' only if both parts are. +instance (Applicative f) => Applicative (Lift f) where + pure = Pure + {-# INLINE pure #-} + Pure f <*> Pure x = Pure (f x) + Pure f <*> Other y = Other (f <$> y) + Other f <*> Pure x = Other (($ x) <$> f) + Other f <*> Other y = Other (f <*> y) + {-# INLINE (<*>) #-} + +-- | A combination is 'Pure' only either part is. +instance (Alternative f) => Alternative (Lift f) where + empty = Other empty + {-# INLINE empty #-} + Pure x <|> _ = Pure x + Other _ <|> Pure y = Pure y + Other x <|> Other y = Other (x <|> y) + {-# INLINE (<|>) #-} + +-- | Projection to the other functor. +unLift :: (Applicative f) => Lift f a -> f a +unLift (Pure x) = pure x +unLift (Other e) = e +{-# INLINE unLift #-} + +-- | Apply a transformation to the other computation. +mapLift :: (f a -> g a) -> Lift f a -> Lift g a +mapLift _ (Pure x) = Pure x +mapLift f (Other e) = Other (f e) +{-# INLINE mapLift #-} + +-- | Eliminator for 'Lift'. +-- +-- * @'elimLift' f g . 'pure' = f@ +-- +-- * @'elimLift' f g . 'Other' = g@ +-- +elimLift :: (a -> r) -> (f a -> r) -> Lift f a -> r +elimLift f _ (Pure x) = f x +elimLift _ g (Other e) = g e +{-# INLINE elimLift #-} + +-- | An applicative functor that collects a monoid (e.g. lists) of errors. +-- A sequence of computations fails if any of its components do, but +-- unlike monads made with 'ExceptT' from "Control.Monad.Trans.Except", +-- these computations continue after an error, collecting all the errors. +-- +-- * @'pure' f '<*>' 'pure' x = 'pure' (f x)@ +-- +-- * @'pure' f '<*>' 'failure' e = 'failure' e@ +-- +-- * @'failure' e '<*>' 'pure' x = 'failure' e@ +-- +-- * @'failure' e1 '<*>' 'failure' e2 = 'failure' (e1 '<>' e2)@ +-- +type Errors e = Lift (Constant e) + +-- | Extractor for computations with accumulating errors. +-- +-- * @'runErrors' ('pure' x) = 'Right' x@ +-- +-- * @'runErrors' ('failure' e) = 'Left' e@ +-- +runErrors :: Errors e a -> Either e a +runErrors (Other (Constant e)) = Left e +runErrors (Pure x) = Right x +{-# INLINE runErrors #-} + +-- | Report an error. +failure :: e -> Errors e a +failure e = Other (Constant e) +{-# INLINE failure #-} + +-- | Convert from 'Either' to 'Errors' (inverse of 'runErrors'). +eitherToErrors :: Either e a -> Errors e a +eitherToErrors = either failure Pure diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Signatures.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Signatures.hs new file mode 100644 index 000000000000..ce128ee182e1 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Signatures.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE PolyKinds #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Signatures +-- Copyright : (c) Ross Paterson 2012 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- Signatures for monad operations that require specialized lifting. +-- Each signature has a uniformity property that the lifting should satisfy. +----------------------------------------------------------------------------- + +module Control.Monad.Signatures ( + CallCC, Catch, Listen, Pass + ) where + +-- | Signature of the @callCC@ operation, +-- introduced in "Control.Monad.Trans.Cont". +-- Any lifting function @liftCallCC@ should satisfy +-- +-- * @'lift' (f k) = f' ('lift' . k) => 'lift' (cf f) = liftCallCC cf f'@ +-- +type CallCC m a b = ((a -> m b) -> m a) -> m a + +-- | Signature of the @catchE@ operation, +-- introduced in "Control.Monad.Trans.Except". +-- Any lifting function @liftCatch@ should satisfy +-- +-- * @'lift' (cf m f) = liftCatch ('lift' . cf) ('lift' f)@ +-- +type Catch e m a = m a -> (e -> m a) -> m a + +-- | Signature of the @listen@ operation, +-- introduced in "Control.Monad.Trans.Writer". +-- Any lifting function @liftListen@ should satisfy +-- +-- * @'lift' . liftListen = liftListen . 'lift'@ +-- +type Listen w m a = m a -> m (a, w) + +-- | Signature of the @pass@ operation, +-- introduced in "Control.Monad.Trans.Writer". +-- Any lifting function @liftPass@ should satisfy +-- +-- * @'lift' . liftPass = liftPass . 'lift'@ +-- +type Pass w m a = m (a, w -> w) -> m a diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Accum.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Accum.hs new file mode 100644 index 000000000000..0a85c43f62bb --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Accum.hs @@ -0,0 +1,292 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Accum +-- Copyright : (c) Nickolay Kudasov 2016 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- The lazy 'AccumT' monad transformer, which adds accumulation +-- capabilities (such as declarations or document patches) to a given monad. +-- +-- This monad transformer provides append-only accumulation +-- during the computation. For more general access, use +-- "Control.Monad.Trans.State" instead. +----------------------------------------------------------------------------- + +module Control.Monad.Trans.Accum ( + -- * The Accum monad + Accum, + accum, + runAccum, + execAccum, + evalAccum, + mapAccum, + -- * The AccumT monad transformer + AccumT(AccumT), + runAccumT, + execAccumT, + evalAccumT, + mapAccumT, + -- * Accum operations + look, + looks, + add, + -- * Lifting other operations + liftCallCC, + liftCallCC', + liftCatch, + liftListen, + liftPass, + -- * Monad transformations + readerToAccumT, + writerToAccumT, + accumToStateT, + ) where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader (ReaderT(..)) +import Control.Monad.Trans.Writer (WriterT(..)) +import Control.Monad.Trans.State (StateT(..)) +import Data.Functor.Identity + +import Control.Applicative +import Control.Monad +#if MIN_VERSION_base(4,9,0) +import qualified Control.Monad.Fail as Fail +#endif +import Control.Monad.Fix +import Control.Monad.Signatures +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid +#endif + +-- --------------------------------------------------------------------------- +-- | An accumulation monad parameterized by the type @w@ of output to accumulate. +-- +-- The 'return' function produces the output 'mempty', while @>>=@ +-- combines the outputs of the subcomputations using 'mappend'. +type Accum w = AccumT w Identity + +-- | Construct an accumulation computation from a (result, output) pair. +-- (The inverse of 'runAccum'.) +accum :: (Monad m) => (w -> (a, w)) -> AccumT w m a +accum f = AccumT $ \ w -> return (f w) +{-# INLINE accum #-} + +-- | Unwrap an accumulation computation as a (result, output) pair. +-- (The inverse of 'accum'.) +runAccum :: Accum w a -> w -> (a, w) +runAccum m = runIdentity . runAccumT m +{-# INLINE runAccum #-} + +-- | Extract the output from an accumulation computation. +-- +-- * @'execAccum' m w = 'snd' ('runAccum' m w)@ +execAccum :: Accum w a -> w -> w +execAccum m w = snd (runAccum m w) +{-# INLINE execAccum #-} + +-- | Evaluate an accumulation computation with the given initial output history +-- and return the final value, discarding the final output. +-- +-- * @'evalAccum' m w = 'fst' ('runAccum' m w)@ +evalAccum :: (Monoid w) => Accum w a -> w -> a +evalAccum m w = fst (runAccum m w) +{-# INLINE evalAccum #-} + +-- | Map both the return value and output of a computation using +-- the given function. +-- +-- * @'runAccum' ('mapAccum' f m) = f . 'runAccum' m@ +mapAccum :: ((a, w) -> (b, w)) -> Accum w a -> Accum w b +mapAccum f = mapAccumT (Identity . f . runIdentity) +{-# INLINE mapAccum #-} + +-- --------------------------------------------------------------------------- +-- | An accumulation monad parameterized by: +-- +-- * @w@ - the output to accumulate. +-- +-- * @m@ - The inner monad. +-- +-- The 'return' function produces the output 'mempty', while @>>=@ +-- combines the outputs of the subcomputations using 'mappend'. +-- +-- This monad transformer is similar to both state and writer monad transformers. +-- Thus it can be seen as +-- +-- * a restricted append-only version of a state monad transformer or +-- +-- * a writer monad transformer with the extra ability to read all previous output. +newtype AccumT w m a = AccumT (w -> m (a, w)) + +-- | Unwrap an accumulation computation. +runAccumT :: AccumT w m a -> w -> m (a, w) +runAccumT (AccumT f) = f +{-# INLINE runAccumT #-} + +-- | Extract the output from an accumulation computation. +-- +-- * @'execAccumT' m w = 'liftM' 'snd' ('runAccumT' m w)@ +execAccumT :: (Monad m) => AccumT w m a -> w -> m w +execAccumT m w = do + ~(_, w') <- runAccumT m w + return w' +{-# INLINE execAccumT #-} + +-- | Evaluate an accumulation computation with the given initial output history +-- and return the final value, discarding the final output. +-- +-- * @'evalAccumT' m w = 'liftM' 'fst' ('runAccumT' m w)@ +evalAccumT :: (Monad m, Monoid w) => AccumT w m a -> w -> m a +evalAccumT m w = do + ~(a, _) <- runAccumT m w + return a +{-# INLINE evalAccumT #-} + +-- | Map both the return value and output of a computation using +-- the given function. +-- +-- * @'runAccumT' ('mapAccumT' f m) = f . 'runAccumT' m@ +mapAccumT :: (m (a, w) -> n (b, w)) -> AccumT w m a -> AccumT w n b +mapAccumT f m = AccumT (f . runAccumT m) +{-# INLINE mapAccumT #-} + +instance (Functor m) => Functor (AccumT w m) where + fmap f = mapAccumT $ fmap $ \ ~(a, w) -> (f a, w) + {-# INLINE fmap #-} + +instance (Monoid w, Functor m, Monad m) => Applicative (AccumT w m) where + pure a = AccumT $ const $ return (a, mempty) + {-# INLINE pure #-} + mf <*> mv = AccumT $ \ w -> do + ~(f, w') <- runAccumT mf w + ~(v, w'') <- runAccumT mv (w `mappend` w') + return (f v, w' `mappend` w'') + {-# INLINE (<*>) #-} + +instance (Monoid w, Functor m, MonadPlus m) => Alternative (AccumT w m) where + empty = AccumT $ const mzero + {-# INLINE empty #-} + m <|> n = AccumT $ \ w -> runAccumT m w `mplus` runAccumT n w + {-# INLINE (<|>) #-} + +instance (Monoid w, Functor m, Monad m) => Monad (AccumT w m) where +#if !(MIN_VERSION_base(4,8,0)) + return a = AccumT $ const $ return (a, mempty) + {-# INLINE return #-} +#endif + m >>= k = AccumT $ \ w -> do + ~(a, w') <- runAccumT m w + ~(b, w'') <- runAccumT (k a) (w `mappend` w') + return (b, w' `mappend` w'') + {-# INLINE (>>=) #-} +#if !(MIN_VERSION_base(4,13,0)) + fail msg = AccumT $ const (fail msg) + {-# INLINE fail #-} +#endif + +#if MIN_VERSION_base(4,9,0) +instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (AccumT w m) where + fail msg = AccumT $ const (Fail.fail msg) + {-# INLINE fail #-} +#endif + +instance (Monoid w, Functor m, MonadPlus m) => MonadPlus (AccumT w m) where + mzero = AccumT $ const mzero + {-# INLINE mzero #-} + m `mplus` n = AccumT $ \ w -> runAccumT m w `mplus` runAccumT n w + {-# INLINE mplus #-} + +instance (Monoid w, Functor m, MonadFix m) => MonadFix (AccumT w m) where + mfix m = AccumT $ \ w -> mfix $ \ ~(a, _) -> runAccumT (m a) w + {-# INLINE mfix #-} + +instance (Monoid w) => MonadTrans (AccumT w) where + lift m = AccumT $ const $ do + a <- m + return (a, mempty) + {-# INLINE lift #-} + +instance (Monoid w, Functor m, MonadIO m) => MonadIO (AccumT w m) where + liftIO = lift . liftIO + {-# INLINE liftIO #-} + +-- | @'look'@ is an action that fetches all the previously accumulated output. +look :: (Monoid w, Monad m) => AccumT w m w +look = AccumT $ \ w -> return (w, mempty) + +-- | @'look'@ is an action that retrieves a function of the previously accumulated output. +looks :: (Monoid w, Monad m) => (w -> a) -> AccumT w m a +looks f = AccumT $ \ w -> return (f w, mempty) + +-- | @'add' w@ is an action that produces the output @w@. +add :: (Monad m) => w -> AccumT w m () +add w = accum $ const ((), w) +{-# INLINE add #-} + +-- | Uniform lifting of a @callCC@ operation to the new monad. +-- This version rolls back to the original output history on entering the +-- continuation. +liftCallCC :: CallCC m (a, w) (b, w) -> CallCC (AccumT w m) a b +liftCallCC callCC f = AccumT $ \ w -> + callCC $ \ c -> + runAccumT (f (\ a -> AccumT $ \ _ -> c (a, w))) w +{-# INLINE liftCallCC #-} + +-- | In-situ lifting of a @callCC@ operation to the new monad. +-- This version uses the current output history on entering the continuation. +-- It does not satisfy the uniformity property (see "Control.Monad.Signatures"). +liftCallCC' :: CallCC m (a, w) (b, w) -> CallCC (AccumT w m) a b +liftCallCC' callCC f = AccumT $ \ s -> + callCC $ \ c -> + runAccumT (f (\ a -> AccumT $ \ s' -> c (a, s'))) s +{-# INLINE liftCallCC' #-} + +-- | Lift a @catchE@ operation to the new monad. +liftCatch :: Catch e m (a, w) -> Catch e (AccumT w m) a +liftCatch catchE m h = + AccumT $ \ w -> runAccumT m w `catchE` \ e -> runAccumT (h e) w +{-# INLINE liftCatch #-} + +-- | Lift a @listen@ operation to the new monad. +liftListen :: (Monad m) => Listen w m (a, s) -> Listen w (AccumT s m) a +liftListen listen m = AccumT $ \ s -> do + ~((a, s'), w) <- listen (runAccumT m s) + return ((a, w), s') +{-# INLINE liftListen #-} + +-- | Lift a @pass@ operation to the new monad. +liftPass :: (Monad m) => Pass w m (a, s) -> Pass w (AccumT s m) a +liftPass pass m = AccumT $ \ s -> pass $ do + ~((a, f), s') <- runAccumT m s + return ((a, s'), f) +{-# INLINE liftPass #-} + +-- | Convert a read-only computation into an accumulation computation. +readerToAccumT :: (Functor m, Monoid w) => ReaderT w m a -> AccumT w m a +readerToAccumT (ReaderT f) = AccumT $ \ w -> fmap (\ a -> (a, mempty)) (f w) +{-# INLINE readerToAccumT #-} + +-- | Convert a writer computation into an accumulation computation. +writerToAccumT :: WriterT w m a -> AccumT w m a +writerToAccumT (WriterT m) = AccumT $ const $ m +{-# INLINE writerToAccumT #-} + +-- | Convert an accumulation (append-only) computation into a fully +-- stateful computation. +accumToStateT :: (Functor m, Monoid s) => AccumT s m a -> StateT s m a +accumToStateT (AccumT f) = + StateT $ \ w -> fmap (\ ~(a, w') -> (a, w `mappend` w')) (f w) +{-# INLINE accumToStateT #-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Class.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Class.hs new file mode 100644 index 000000000000..b92bc0e8b0f6 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Class.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Class +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- The class of monad transformers. +-- +-- A monad transformer makes a new monad out of an existing monad, such +-- that computations of the old monad may be embedded in the new one. +-- To construct a monad with a desired set of features, one typically +-- starts with a base monad, such as 'Data.Functor.Identity.Identity', @[]@ or 'IO', and +-- applies a sequence of monad transformers. +----------------------------------------------------------------------------- + +module Control.Monad.Trans.Class ( + -- * Transformer class + MonadTrans(..) + + -- * Conventions + -- $conventions + + -- * Strict monads + -- $strict + + -- * Examples + -- ** Parsing + -- $example1 + + -- ** Parsing and counting + -- $example2 + + -- ** Interpreter monad + -- $example3 + ) where + +-- | The class of monad transformers. Instances should satisfy the +-- following laws, which state that 'lift' is a monad transformation: +-- +-- * @'lift' . 'return' = 'return'@ +-- +-- * @'lift' (m >>= f) = 'lift' m >>= ('lift' . f)@ + +class MonadTrans t where + -- | Lift a computation from the argument monad to the constructed monad. + lift :: (Monad m) => m a -> t m a + +{- $conventions +Most monad transformer modules include the special case of applying +the transformer to 'Data.Functor.Identity.Identity'. For example, +@'Control.Monad.Trans.State.Lazy.State' s@ is an abbreviation for +@'Control.Monad.Trans.State.Lazy.StateT' s 'Data.Functor.Identity.Identity'@. + +Each monad transformer also comes with an operation @run@/XXX/@T@ to +unwrap the transformer, exposing a computation of the inner monad. +(Currently these functions are defined as field labels, but in the next +major release they will be separate functions.) + +All of the monad transformers except 'Control.Monad.Trans.Cont.ContT' +and 'Control.Monad.Trans.Cont.SelectT' are functors on the category +of monads: in addition to defining a mapping of monads, they +also define a mapping from transformations between base monads to +transformations between transformed monads, called @map@/XXX/@T@. +Thus given a monad transformation @t :: M a -> N a@, the combinator +'Control.Monad.Trans.State.Lazy.mapStateT' constructs a monad +transformation + +> mapStateT t :: StateT s M a -> StateT s N a + +For these monad transformers, 'lift' is a natural transformation in the +category of monads, i.e. for any monad transformation @t :: M a -> N a@, + +* @map@/XXX/@T t . 'lift' = 'lift' . t@ + +Each of the monad transformers introduces relevant operations. +In a sequence of monad transformers, most of these operations.can be +lifted through other transformers using 'lift' or the @map@/XXX/@T@ +combinator, but a few with more complex type signatures require +specialized lifting combinators, called @lift@/Op/ +(see "Control.Monad.Signatures"). +-} + +{- $strict + +A monad is said to be /strict/ if its '>>=' operation is strict in its first +argument. The base monads 'Maybe', @[]@ and 'IO' are strict: + +>>> undefined >> return 2 :: Maybe Integer +*** Exception: Prelude.undefined + +However the monad 'Data.Functor.Identity.Identity' is not: + +>>> runIdentity (undefined >> return 2) +2 + +In a strict monad you know when each action is executed, but the monad +is not necessarily strict in the return value, or in other components +of the monad, such as a state. However you can use 'seq' to create +an action that is strict in the component you want evaluated. +-} + +{- $example1 + +The first example is a parser monad in the style of + +* \"Monadic parsing in Haskell\", by Graham Hutton and Erik Meijer, +/Journal of Functional Programming/ 8(4):437-444, July 1998 +(<http://www.cs.nott.ac.uk/~pszgmh/bib.html#pearl>). + +We can define such a parser monad by adding a state (the 'String' remaining +to be parsed) to the @[]@ monad, which provides non-determinism: + +> import Control.Monad.Trans.State +> +> type Parser = StateT String [] + +Then @Parser@ is an instance of @MonadPlus@: monadic sequencing implements +concatenation of parsers, while @mplus@ provides choice. To use parsers, +we need a primitive to run a constructed parser on an input string: + +> runParser :: Parser a -> String -> [a] +> runParser p s = [x | (x, "") <- runStateT p s] + +Finally, we need a primitive parser that matches a single character, +from which arbitrarily complex parsers may be constructed: + +> item :: Parser Char +> item = do +> c:cs <- get +> put cs +> return c + +In this example we use the operations @get@ and @put@ from +"Control.Monad.Trans.State", which are defined only for monads that are +applications of 'Control.Monad.Trans.State.Lazy.StateT'. Alternatively one +could use monad classes from the @mtl@ package or similar, which contain +methods @get@ and @put@ with types generalized over all suitable monads. +-} + +{- $example2 + +We can define a parser that also counts by adding a +'Control.Monad.Trans.Writer.Lazy.WriterT' transformer: + +> import Control.Monad.Trans.Class +> import Control.Monad.Trans.State +> import Control.Monad.Trans.Writer +> import Data.Monoid +> +> type Parser = WriterT (Sum Int) (StateT String []) + +The function that applies a parser must now unwrap each of the monad +transformers in turn: + +> runParser :: Parser a -> String -> [(a, Int)] +> runParser p s = [(x, n) | ((x, Sum n), "") <- runStateT (runWriterT p) s] + +To define the @item@ parser, we need to lift the +'Control.Monad.Trans.State.Lazy.StateT' operations through the +'Control.Monad.Trans.Writer.Lazy.WriterT' transformer. + +> item :: Parser Char +> item = do +> c:cs <- lift get +> lift (put cs) +> return c + +In this case, we were able to do this with 'lift', but operations with +more complex types require special lifting functions, which are provided +by monad transformers for which they can be implemented. If you use the +monad classes of the @mtl@ package or similar, this lifting is handled +automatically by the instances of the classes, and you need only use +the generalized methods @get@ and @put@. + +We can also define a primitive using the Writer: + +> tick :: Parser () +> tick = tell (Sum 1) + +Then the parser will keep track of how many @tick@s it executes. +-} + +{- $example3 + +This example is a cut-down version of the one in + +* \"Monad Transformers and Modular Interpreters\", +by Sheng Liang, Paul Hudak and Mark Jones in /POPL'95/ +(<http://web.cecs.pdx.edu/~mpj/pubs/modinterp.html>). + +Suppose we want to define an interpreter that can do I\/O and has +exceptions, an environment and a modifiable store. We can define +a monad that supports all these things as a stack of monad transformers: + +> import Control.Monad.Trans.Class +> import Control.Monad.Trans.State +> import qualified Control.Monad.Trans.Reader as R +> import qualified Control.Monad.Trans.Except as E +> import Control.Monad.IO.Class +> +> type InterpM = StateT Store (R.ReaderT Env (E.ExceptT Err IO)) + +for suitable types @Store@, @Env@ and @Err@. + +Now we would like to be able to use the operations associated with each +of those monad transformers on @InterpM@ actions. Since the uppermost +monad transformer of @InterpM@ is 'Control.Monad.Trans.State.Lazy.StateT', +it already has the state operations @get@ and @set@. + +The first of the 'Control.Monad.Trans.Reader.ReaderT' operations, +'Control.Monad.Trans.Reader.ask', is a simple action, so we can lift it +through 'Control.Monad.Trans.State.Lazy.StateT' to @InterpM@ using 'lift': + +> ask :: InterpM Env +> ask = lift R.ask + +The other 'Control.Monad.Trans.Reader.ReaderT' operation, +'Control.Monad.Trans.Reader.local', has a suitable type for lifting +using 'Control.Monad.Trans.State.Lazy.mapStateT': + +> local :: (Env -> Env) -> InterpM a -> InterpM a +> local f = mapStateT (R.local f) + +We also wish to lift the operations of 'Control.Monad.Trans.Except.ExceptT' +through both 'Control.Monad.Trans.Reader.ReaderT' and +'Control.Monad.Trans.State.Lazy.StateT'. For the operation +'Control.Monad.Trans.Except.throwE', we know @throwE e@ is a simple +action, so we can lift it through the two monad transformers to @InterpM@ +with two 'lift's: + +> throwE :: Err -> InterpM a +> throwE e = lift (lift (E.throwE e)) + +The 'Control.Monad.Trans.Except.catchE' operation has a more +complex type, so we need to use the special-purpose lifting function +@liftCatch@ provided by most monad transformers. Here we use +the 'Control.Monad.Trans.Reader.ReaderT' version followed by the +'Control.Monad.Trans.State.Lazy.StateT' version: + +> catchE :: InterpM a -> (Err -> InterpM a) -> InterpM a +> catchE = liftCatch (R.liftCatch E.catchE) + +We could lift 'IO' actions to @InterpM@ using three 'lift's, but @InterpM@ +is automatically an instance of 'Control.Monad.IO.Class.MonadIO', +so we can use 'Control.Monad.IO.Class.liftIO' instead: + +> putStr :: String -> InterpM () +> putStr s = liftIO (Prelude.putStr s) + +-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Cont.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Cont.hs new file mode 100644 index 000000000000..ce2005d4b29f --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Cont.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE PolyKinds #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Cont +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- Continuation monads. +-- +-- Delimited continuation operators are taken from Kenichi Asai and Oleg +-- Kiselyov's tutorial at CW 2011, \"Introduction to programming with +-- shift and reset\" (<http://okmij.org/ftp/continuations/#tutorial>). +-- +----------------------------------------------------------------------------- + +module Control.Monad.Trans.Cont ( + -- * The Cont monad + Cont, + cont, + runCont, + evalCont, + mapCont, + withCont, + -- ** Delimited continuations + reset, shift, + -- * The ContT monad transformer + ContT(..), + evalContT, + mapContT, + withContT, + callCC, + -- ** Delimited continuations + resetT, shiftT, + -- * Lifting other operations + liftLocal, + ) where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Data.Functor.Identity + +import Control.Applicative +#if MIN_VERSION_base(4,9,0) +import qualified Control.Monad.Fail as Fail +#endif + +{- | +Continuation monad. +@Cont r a@ is a CPS ("continuation-passing style") computation that produces an +intermediate result of type @a@ within a CPS computation whose final result type +is @r@. + +The @return@ function simply creates a continuation which passes the value on. + +The @>>=@ operator adds the bound function into the continuation chain. +-} +type Cont r = ContT r Identity + +-- | Construct a continuation-passing computation from a function. +-- (The inverse of 'runCont') +cont :: ((a -> r) -> r) -> Cont r a +cont f = ContT (\ c -> Identity (f (runIdentity . c))) +{-# INLINE cont #-} + +-- | The result of running a CPS computation with a given final continuation. +-- (The inverse of 'cont') +runCont + :: Cont r a -- ^ continuation computation (@Cont@). + -> (a -> r) -- ^ the final continuation, which produces + -- the final result (often 'id'). + -> r +runCont m k = runIdentity (runContT m (Identity . k)) +{-# INLINE runCont #-} + +-- | The result of running a CPS computation with the identity as the +-- final continuation. +-- +-- * @'evalCont' ('return' x) = x@ +evalCont :: Cont r r -> r +evalCont m = runIdentity (evalContT m) +{-# INLINE evalCont #-} + +-- | Apply a function to transform the result of a continuation-passing +-- computation. +-- +-- * @'runCont' ('mapCont' f m) = f . 'runCont' m@ +mapCont :: (r -> r) -> Cont r a -> Cont r a +mapCont f = mapContT (Identity . f . runIdentity) +{-# INLINE mapCont #-} + +-- | Apply a function to transform the continuation passed to a CPS +-- computation. +-- +-- * @'runCont' ('withCont' f m) = 'runCont' m . f@ +withCont :: ((b -> r) -> (a -> r)) -> Cont r a -> Cont r b +withCont f = withContT ((Identity .) . f . (runIdentity .)) +{-# INLINE withCont #-} + +-- | @'reset' m@ delimits the continuation of any 'shift' inside @m@. +-- +-- * @'reset' ('return' m) = 'return' m@ +-- +reset :: Cont r r -> Cont r' r +reset = resetT +{-# INLINE reset #-} + +-- | @'shift' f@ captures the continuation up to the nearest enclosing +-- 'reset' and passes it to @f@: +-- +-- * @'reset' ('shift' f >>= k) = 'reset' (f ('evalCont' . k))@ +-- +shift :: ((a -> r) -> Cont r r) -> Cont r a +shift f = shiftT (f . (runIdentity .)) +{-# INLINE shift #-} + +-- | The continuation monad transformer. +-- Can be used to add continuation handling to any type constructor: +-- the 'Monad' instance and most of the operations do not require @m@ +-- to be a monad. +-- +-- 'ContT' is not a functor on the category of monads, and many operations +-- cannot be lifted through it. +newtype ContT r m a = ContT { runContT :: (a -> m r) -> m r } + +-- | The result of running a CPS computation with 'return' as the +-- final continuation. +-- +-- * @'evalContT' ('lift' m) = m@ +evalContT :: (Monad m) => ContT r m r -> m r +evalContT m = runContT m return +{-# INLINE evalContT #-} + +-- | Apply a function to transform the result of a continuation-passing +-- computation. This has a more restricted type than the @map@ operations +-- for other monad transformers, because 'ContT' does not define a functor +-- in the category of monads. +-- +-- * @'runContT' ('mapContT' f m) = f . 'runContT' m@ +mapContT :: (m r -> m r) -> ContT r m a -> ContT r m a +mapContT f m = ContT $ f . runContT m +{-# INLINE mapContT #-} + +-- | Apply a function to transform the continuation passed to a CPS +-- computation. +-- +-- * @'runContT' ('withContT' f m) = 'runContT' m . f@ +withContT :: ((b -> m r) -> (a -> m r)) -> ContT r m a -> ContT r m b +withContT f m = ContT $ runContT m . f +{-# INLINE withContT #-} + +instance Functor (ContT r m) where + fmap f m = ContT $ \ c -> runContT m (c . f) + {-# INLINE fmap #-} + +instance Applicative (ContT r m) where + pure x = ContT ($ x) + {-# INLINE pure #-} + f <*> v = ContT $ \ c -> runContT f $ \ g -> runContT v (c . g) + {-# INLINE (<*>) #-} + m *> k = m >>= \_ -> k + {-# INLINE (*>) #-} + +instance Monad (ContT r m) where +#if !(MIN_VERSION_base(4,8,0)) + return x = ContT ($ x) + {-# INLINE return #-} +#endif + m >>= k = ContT $ \ c -> runContT m (\ x -> runContT (k x) c) + {-# INLINE (>>=) #-} + +#if MIN_VERSION_base(4,9,0) +instance (Fail.MonadFail m) => Fail.MonadFail (ContT r m) where + fail msg = ContT $ \ _ -> Fail.fail msg + {-# INLINE fail #-} +#endif + +instance MonadTrans (ContT r) where + lift m = ContT (m >>=) + {-# INLINE lift #-} + +instance (MonadIO m) => MonadIO (ContT r m) where + liftIO = lift . liftIO + {-# INLINE liftIO #-} + +-- | @callCC@ (call-with-current-continuation) calls its argument +-- function, passing it the current continuation. It provides +-- an escape continuation mechanism for use with continuation +-- monads. Escape continuations one allow to abort the current +-- computation and return a value immediately. They achieve +-- a similar effect to 'Control.Monad.Trans.Except.throwE' +-- and 'Control.Monad.Trans.Except.catchE' within an +-- 'Control.Monad.Trans.Except.ExceptT' monad. The advantage of this +-- function over calling 'return' is that it makes the continuation +-- explicit, allowing more flexibility and better control. +-- +-- The standard idiom used with @callCC@ is to provide a lambda-expression +-- to name the continuation. Then calling the named continuation anywhere +-- within its scope will escape from the computation, even if it is many +-- layers deep within nested computations. +callCC :: ((a -> ContT r m b) -> ContT r m a) -> ContT r m a +callCC f = ContT $ \ c -> runContT (f (\ x -> ContT $ \ _ -> c x)) c +{-# INLINE callCC #-} + +-- | @'resetT' m@ delimits the continuation of any 'shiftT' inside @m@. +-- +-- * @'resetT' ('lift' m) = 'lift' m@ +-- +resetT :: (Monad m) => ContT r m r -> ContT r' m r +resetT = lift . evalContT +{-# INLINE resetT #-} + +-- | @'shiftT' f@ captures the continuation up to the nearest enclosing +-- 'resetT' and passes it to @f@: +-- +-- * @'resetT' ('shiftT' f >>= k) = 'resetT' (f ('evalContT' . k))@ +-- +shiftT :: (Monad m) => ((a -> m r) -> ContT r m r) -> ContT r m a +shiftT f = ContT (evalContT . f) +{-# INLINE shiftT #-} + +-- | @'liftLocal' ask local@ yields a @local@ function for @'ContT' r m@. +liftLocal :: (Monad m) => m r' -> ((r' -> r') -> m r -> m r) -> + (r' -> r') -> ContT r m a -> ContT r m a +liftLocal ask local f m = ContT $ \ c -> do + r <- ask + local f (runContT m (local (const r) . c)) +{-# INLINE liftLocal #-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Error.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Error.hs new file mode 100644 index 000000000000..6eda4b3e015a --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Error.hs @@ -0,0 +1,333 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +#if !(MIN_VERSION_base(4,9,0)) +{-# OPTIONS_GHC -fno-warn-orphans #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Error +-- Copyright : (c) Michael Weber <michael.weber@post.rwth-aachen.de> 2001, +-- (c) Jeff Newbern 2003-2006, +-- (c) Andriy Palamarchuk 2006 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- This monad transformer adds the ability to fail or throw exceptions +-- to a monad. +-- +-- A sequence of actions succeeds, producing a value, only if all the +-- actions in the sequence are successful. If one fails with an error, +-- the rest of the sequence is skipped and the composite action fails +-- with that error. +-- +-- If the value of the error is not required, the variant in +-- "Control.Monad.Trans.Maybe" may be used instead. +-- +-- /Note:/ This module will be removed in a future release. +-- Instead, use "Control.Monad.Trans.Except", which does not restrict +-- the exception type, and also includes a base exception monad. +----------------------------------------------------------------------------- + +module Control.Monad.Trans.Error + {-# DEPRECATED "Use Control.Monad.Trans.Except instead" #-} ( + -- * The ErrorT monad transformer + Error(..), + ErrorList(..), + ErrorT(..), + mapErrorT, + -- * Error operations + throwError, + catchError, + -- * Lifting other operations + liftCallCC, + liftListen, + liftPass, + -- * Examples + -- $examples + ) where + +import Control.Monad.IO.Class +import Control.Monad.Signatures +import Control.Monad.Trans.Class +import Data.Functor.Classes +#if MIN_VERSION_base(4,12,0) +import Data.Functor.Contravariant +#endif + +import Control.Applicative +import Control.Exception (IOException) +import Control.Monad +#if MIN_VERSION_base(4,9,0) +import qualified Control.Monad.Fail as Fail +#endif +import Control.Monad.Fix +#if !(MIN_VERSION_base(4,6,0)) +import Control.Monad.Instances () -- deprecated from base-4.6 +#endif +import Data.Foldable (Foldable(foldMap)) +import Data.Monoid (mempty) +import Data.Traversable (Traversable(traverse)) +import System.IO.Error + +#if !(MIN_VERSION_base(4,9,0)) +-- These instances are in base-4.9.0 + +instance MonadPlus IO where + mzero = ioError (userError "mzero") + m `mplus` n = m `catchIOError` \ _ -> n + +instance Alternative IO where + empty = mzero + (<|>) = mplus + +# if !(MIN_VERSION_base(4,4,0)) +-- exported by System.IO.Error from base-4.4 +catchIOError :: IO a -> (IOError -> IO a) -> IO a +catchIOError = catch +# endif +#endif + +instance (Error e) => Alternative (Either e) where + empty = Left noMsg + Left _ <|> n = n + m <|> _ = m + +instance (Error e) => MonadPlus (Either e) where + mzero = Left noMsg + Left _ `mplus` n = n + m `mplus` _ = m + +#if !(MIN_VERSION_base(4,3,0)) +-- These instances are in base-4.3 + +instance Applicative (Either e) where + pure = Right + Left e <*> _ = Left e + Right f <*> r = fmap f r + +instance Monad (Either e) where + return = Right + Left l >>= _ = Left l + Right r >>= k = k r + +instance MonadFix (Either e) where + mfix f = let + a = f $ case a of + Right r -> r + _ -> error "empty mfix argument" + in a + +#endif /* base to 4.2.0.x */ + +-- | An exception to be thrown. +-- +-- Minimal complete definition: 'noMsg' or 'strMsg'. +class Error a where + -- | Creates an exception without a message. + -- The default implementation is @'strMsg' \"\"@. + noMsg :: a + -- | Creates an exception with a message. + -- The default implementation of @'strMsg' s@ is 'noMsg'. + strMsg :: String -> a + + noMsg = strMsg "" + strMsg _ = noMsg + +instance Error IOException where + strMsg = userError + +-- | A string can be thrown as an error. +instance (ErrorList a) => Error [a] where + strMsg = listMsg + +-- | Workaround so that we can have a Haskell 98 instance @'Error' 'String'@. +class ErrorList a where + listMsg :: String -> [a] + +instance ErrorList Char where + listMsg = id + +-- | The error monad transformer. It can be used to add error handling +-- to other monads. +-- +-- The @ErrorT@ Monad structure is parameterized over two things: +-- +-- * e - The error type. +-- +-- * m - The inner monad. +-- +-- The 'return' function yields a successful computation, while @>>=@ +-- sequences two subcomputations, failing on the first error. +newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) } + +instance (Eq e, Eq1 m) => Eq1 (ErrorT e m) where + liftEq eq (ErrorT x) (ErrorT y) = liftEq (liftEq eq) x y + +instance (Ord e, Ord1 m) => Ord1 (ErrorT e m) where + liftCompare comp (ErrorT x) (ErrorT y) = liftCompare (liftCompare comp) x y + +instance (Read e, Read1 m) => Read1 (ErrorT e m) where + liftReadsPrec rp rl = readsData $ + readsUnaryWith (liftReadsPrec rp' rl') "ErrorT" ErrorT + where + rp' = liftReadsPrec rp rl + rl' = liftReadList rp rl + +instance (Show e, Show1 m) => Show1 (ErrorT e m) where + liftShowsPrec sp sl d (ErrorT m) = + showsUnaryWith (liftShowsPrec sp' sl') "ErrorT" d m + where + sp' = liftShowsPrec sp sl + sl' = liftShowList sp sl + +instance (Eq e, Eq1 m, Eq a) => Eq (ErrorT e m a) where (==) = eq1 +instance (Ord e, Ord1 m, Ord a) => Ord (ErrorT e m a) where compare = compare1 +instance (Read e, Read1 m, Read a) => Read (ErrorT e m a) where + readsPrec = readsPrec1 +instance (Show e, Show1 m, Show a) => Show (ErrorT e m a) where + showsPrec = showsPrec1 + +-- | Map the unwrapped computation using the given function. +-- +-- * @'runErrorT' ('mapErrorT' f m) = f ('runErrorT' m)@ +mapErrorT :: (m (Either e a) -> n (Either e' b)) + -> ErrorT e m a + -> ErrorT e' n b +mapErrorT f m = ErrorT $ f (runErrorT m) + +instance (Functor m) => Functor (ErrorT e m) where + fmap f = ErrorT . fmap (fmap f) . runErrorT + +instance (Foldable f) => Foldable (ErrorT e f) where + foldMap f (ErrorT a) = foldMap (either (const mempty) f) a + +instance (Traversable f) => Traversable (ErrorT e f) where + traverse f (ErrorT a) = + ErrorT <$> traverse (either (pure . Left) (fmap Right . f)) a + +instance (Functor m, Monad m) => Applicative (ErrorT e m) where + pure a = ErrorT $ return (Right a) + f <*> v = ErrorT $ do + mf <- runErrorT f + case mf of + Left e -> return (Left e) + Right k -> do + mv <- runErrorT v + case mv of + Left e -> return (Left e) + Right x -> return (Right (k x)) + +instance (Functor m, Monad m, Error e) => Alternative (ErrorT e m) where + empty = mzero + (<|>) = mplus + +instance (Monad m, Error e) => Monad (ErrorT e m) where +#if !(MIN_VERSION_base(4,8,0)) + return a = ErrorT $ return (Right a) +#endif + m >>= k = ErrorT $ do + a <- runErrorT m + case a of + Left l -> return (Left l) + Right r -> runErrorT (k r) +#if !(MIN_VERSION_base(4,13,0)) + fail msg = ErrorT $ return (Left (strMsg msg)) +#endif + +#if MIN_VERSION_base(4,9,0) +instance (Monad m, Error e) => Fail.MonadFail (ErrorT e m) where + fail msg = ErrorT $ return (Left (strMsg msg)) +#endif + +instance (Monad m, Error e) => MonadPlus (ErrorT e m) where + mzero = ErrorT $ return (Left noMsg) + m `mplus` n = ErrorT $ do + a <- runErrorT m + case a of + Left _ -> runErrorT n + Right r -> return (Right r) + +instance (MonadFix m, Error e) => MonadFix (ErrorT e m) where + mfix f = ErrorT $ mfix $ \ a -> runErrorT $ f $ case a of + Right r -> r + _ -> error "empty mfix argument" + +instance MonadTrans (ErrorT e) where + lift m = ErrorT $ do + a <- m + return (Right a) + +instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where + liftIO = lift . liftIO + +#if MIN_VERSION_base(4,12,0) +instance Contravariant m => Contravariant (ErrorT e m) where + contramap f = ErrorT . contramap (fmap f) . runErrorT +#endif + +-- | Signal an error value @e@. +-- +-- * @'runErrorT' ('throwError' e) = 'return' ('Left' e)@ +-- +-- * @'throwError' e >>= m = 'throwError' e@ +throwError :: (Monad m) => e -> ErrorT e m a +throwError l = ErrorT $ return (Left l) + +-- | Handle an error. +-- +-- * @'catchError' h ('lift' m) = 'lift' m@ +-- +-- * @'catchError' h ('throwError' e) = h e@ +catchError :: (Monad m) => + ErrorT e m a -- ^ the inner computation + -> (e -> ErrorT e m a) -- ^ a handler for errors in the inner + -- computation + -> ErrorT e m a +m `catchError` h = ErrorT $ do + a <- runErrorT m + case a of + Left l -> runErrorT (h l) + Right r -> return (Right r) + +-- | Lift a @callCC@ operation to the new monad. +liftCallCC :: CallCC m (Either e a) (Either e b) -> CallCC (ErrorT e m) a b +liftCallCC callCC f = ErrorT $ + callCC $ \ c -> + runErrorT (f (\ a -> ErrorT $ c (Right a))) + +-- | Lift a @listen@ operation to the new monad. +liftListen :: (Monad m) => Listen w m (Either e a) -> Listen w (ErrorT e m) a +liftListen listen = mapErrorT $ \ m -> do + (a, w) <- listen m + return $! fmap (\ r -> (r, w)) a + +-- | Lift a @pass@ operation to the new monad. +liftPass :: (Monad m) => Pass w m (Either e a) -> Pass w (ErrorT e m) a +liftPass pass = mapErrorT $ \ m -> pass $ do + a <- m + return $! case a of + Left l -> (Left l, id) + Right (r, f) -> (Right r, f) + +{- $examples + +Wrapping an IO action that can throw an error @e@: + +> type ErrorWithIO e a = ErrorT e IO a +> ==> ErrorT (IO (Either e a)) + +An IO monad wrapped in @StateT@ inside of @ErrorT@: + +> type ErrorAndStateWithIO e s a = ErrorT e (StateT s IO) a +> ==> ErrorT (StateT s IO (Either e a)) +> ==> ErrorT (StateT (s -> IO (Either e a,s))) + +-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Except.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Except.hs new file mode 100644 index 000000000000..477b9dd4826c --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Except.hs @@ -0,0 +1,316 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Except +-- Copyright : (C) 2013 Ross Paterson +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- This monad transformer extends a monad with the ability to throw exceptions. +-- +-- A sequence of actions terminates normally, producing a value, +-- only if none of the actions in the sequence throws an exception. +-- If one throws an exception, the rest of the sequence is skipped and +-- the composite action exits with that exception. +-- +-- If the value of the exception is not required, the variant in +-- "Control.Monad.Trans.Maybe" may be used instead. +----------------------------------------------------------------------------- + +module Control.Monad.Trans.Except ( + -- * The Except monad + Except, + except, + runExcept, + mapExcept, + withExcept, + -- * The ExceptT monad transformer + ExceptT(ExceptT), + runExceptT, + mapExceptT, + withExceptT, + -- * Exception operations + throwE, + catchE, + -- * Lifting other operations + liftCallCC, + liftListen, + liftPass, + ) where + +import Control.Monad.IO.Class +import Control.Monad.Signatures +import Control.Monad.Trans.Class +import Data.Functor.Classes +#if MIN_VERSION_base(4,12,0) +import Data.Functor.Contravariant +#endif +import Data.Functor.Identity + +import Control.Applicative +import Control.Monad +#if MIN_VERSION_base(4,9,0) +import qualified Control.Monad.Fail as Fail +#endif +import Control.Monad.Fix +#if MIN_VERSION_base(4,4,0) +import Control.Monad.Zip (MonadZip(mzipWith)) +#endif +import Data.Foldable (Foldable(foldMap)) +import Data.Monoid +import Data.Traversable (Traversable(traverse)) + +-- | The parameterizable exception monad. +-- +-- Computations are either exceptions or normal values. +-- +-- The 'return' function returns a normal value, while @>>=@ exits on +-- the first exception. For a variant that continues after an error +-- and collects all the errors, see 'Control.Applicative.Lift.Errors'. +type Except e = ExceptT e Identity + +-- | Constructor for computations in the exception monad. +-- (The inverse of 'runExcept'). +except :: (Monad m) => Either e a -> ExceptT e m a +except m = ExceptT (return m) +{-# INLINE except #-} + +-- | Extractor for computations in the exception monad. +-- (The inverse of 'except'). +runExcept :: Except e a -> Either e a +runExcept (ExceptT m) = runIdentity m +{-# INLINE runExcept #-} + +-- | Map the unwrapped computation using the given function. +-- +-- * @'runExcept' ('mapExcept' f m) = f ('runExcept' m)@ +mapExcept :: (Either e a -> Either e' b) + -> Except e a + -> Except e' b +mapExcept f = mapExceptT (Identity . f . runIdentity) +{-# INLINE mapExcept #-} + +-- | Transform any exceptions thrown by the computation using the given +-- function (a specialization of 'withExceptT'). +withExcept :: (e -> e') -> Except e a -> Except e' a +withExcept = withExceptT +{-# INLINE withExcept #-} + +-- | A monad transformer that adds exceptions to other monads. +-- +-- @ExceptT@ constructs a monad parameterized over two things: +-- +-- * e - The exception type. +-- +-- * m - The inner monad. +-- +-- The 'return' function yields a computation that produces the given +-- value, while @>>=@ sequences two subcomputations, exiting on the +-- first exception. +newtype ExceptT e m a = ExceptT (m (Either e a)) + +instance (Eq e, Eq1 m) => Eq1 (ExceptT e m) where + liftEq eq (ExceptT x) (ExceptT y) = liftEq (liftEq eq) x y + {-# INLINE liftEq #-} + +instance (Ord e, Ord1 m) => Ord1 (ExceptT e m) where + liftCompare comp (ExceptT x) (ExceptT y) = + liftCompare (liftCompare comp) x y + {-# INLINE liftCompare #-} + +instance (Read e, Read1 m) => Read1 (ExceptT e m) where + liftReadsPrec rp rl = readsData $ + readsUnaryWith (liftReadsPrec rp' rl') "ExceptT" ExceptT + where + rp' = liftReadsPrec rp rl + rl' = liftReadList rp rl + +instance (Show e, Show1 m) => Show1 (ExceptT e m) where + liftShowsPrec sp sl d (ExceptT m) = + showsUnaryWith (liftShowsPrec sp' sl') "ExceptT" d m + where + sp' = liftShowsPrec sp sl + sl' = liftShowList sp sl + +instance (Eq e, Eq1 m, Eq a) => Eq (ExceptT e m a) + where (==) = eq1 +instance (Ord e, Ord1 m, Ord a) => Ord (ExceptT e m a) + where compare = compare1 +instance (Read e, Read1 m, Read a) => Read (ExceptT e m a) where + readsPrec = readsPrec1 +instance (Show e, Show1 m, Show a) => Show (ExceptT e m a) where + showsPrec = showsPrec1 + +-- | The inverse of 'ExceptT'. +runExceptT :: ExceptT e m a -> m (Either e a) +runExceptT (ExceptT m) = m +{-# INLINE runExceptT #-} + +-- | Map the unwrapped computation using the given function. +-- +-- * @'runExceptT' ('mapExceptT' f m) = f ('runExceptT' m)@ +mapExceptT :: (m (Either e a) -> n (Either e' b)) + -> ExceptT e m a + -> ExceptT e' n b +mapExceptT f m = ExceptT $ f (runExceptT m) +{-# INLINE mapExceptT #-} + +-- | Transform any exceptions thrown by the computation using the +-- given function. +withExceptT :: (Functor m) => (e -> e') -> ExceptT e m a -> ExceptT e' m a +withExceptT f = mapExceptT $ fmap $ either (Left . f) Right +{-# INLINE withExceptT #-} + +instance (Functor m) => Functor (ExceptT e m) where + fmap f = ExceptT . fmap (fmap f) . runExceptT + {-# INLINE fmap #-} + +instance (Foldable f) => Foldable (ExceptT e f) where + foldMap f (ExceptT a) = foldMap (either (const mempty) f) a + {-# INLINE foldMap #-} + +instance (Traversable f) => Traversable (ExceptT e f) where + traverse f (ExceptT a) = + ExceptT <$> traverse (either (pure . Left) (fmap Right . f)) a + {-# INLINE traverse #-} + +instance (Functor m, Monad m) => Applicative (ExceptT e m) where + pure a = ExceptT $ return (Right a) + {-# INLINE pure #-} + ExceptT f <*> ExceptT v = ExceptT $ do + mf <- f + case mf of + Left e -> return (Left e) + Right k -> do + mv <- v + case mv of + Left e -> return (Left e) + Right x -> return (Right (k x)) + {-# INLINEABLE (<*>) #-} + m *> k = m >>= \_ -> k + {-# INLINE (*>) #-} + +instance (Functor m, Monad m, Monoid e) => Alternative (ExceptT e m) where + empty = ExceptT $ return (Left mempty) + {-# INLINE empty #-} + ExceptT mx <|> ExceptT my = ExceptT $ do + ex <- mx + case ex of + Left e -> liftM (either (Left . mappend e) Right) my + Right x -> return (Right x) + {-# INLINEABLE (<|>) #-} + +instance (Monad m) => Monad (ExceptT e m) where +#if !(MIN_VERSION_base(4,8,0)) + return a = ExceptT $ return (Right a) + {-# INLINE return #-} +#endif + m >>= k = ExceptT $ do + a <- runExceptT m + case a of + Left e -> return (Left e) + Right x -> runExceptT (k x) + {-# INLINE (>>=) #-} +#if !(MIN_VERSION_base(4,13,0)) + fail = ExceptT . fail + {-# INLINE fail #-} +#endif + +#if MIN_VERSION_base(4,9,0) +instance (Fail.MonadFail m) => Fail.MonadFail (ExceptT e m) where + fail = ExceptT . Fail.fail + {-# INLINE fail #-} +#endif + +instance (Monad m, Monoid e) => MonadPlus (ExceptT e m) where + mzero = ExceptT $ return (Left mempty) + {-# INLINE mzero #-} + ExceptT mx `mplus` ExceptT my = ExceptT $ do + ex <- mx + case ex of + Left e -> liftM (either (Left . mappend e) Right) my + Right x -> return (Right x) + {-# INLINEABLE mplus #-} + +instance (MonadFix m) => MonadFix (ExceptT e m) where + mfix f = ExceptT (mfix (runExceptT . f . either (const bomb) id)) + where bomb = error "mfix (ExceptT): inner computation returned Left value" + {-# INLINE mfix #-} + +instance MonadTrans (ExceptT e) where + lift = ExceptT . liftM Right + {-# INLINE lift #-} + +instance (MonadIO m) => MonadIO (ExceptT e m) where + liftIO = lift . liftIO + {-# INLINE liftIO #-} + +#if MIN_VERSION_base(4,4,0) +instance (MonadZip m) => MonadZip (ExceptT e m) where + mzipWith f (ExceptT a) (ExceptT b) = ExceptT $ mzipWith (liftA2 f) a b + {-# INLINE mzipWith #-} +#endif + +#if MIN_VERSION_base(4,12,0) +instance Contravariant m => Contravariant (ExceptT e m) where + contramap f = ExceptT . contramap (fmap f) . runExceptT + {-# INLINE contramap #-} +#endif + +-- | Signal an exception value @e@. +-- +-- * @'runExceptT' ('throwE' e) = 'return' ('Left' e)@ +-- +-- * @'throwE' e >>= m = 'throwE' e@ +throwE :: (Monad m) => e -> ExceptT e m a +throwE = ExceptT . return . Left +{-# INLINE throwE #-} + +-- | Handle an exception. +-- +-- * @'catchE' ('lift' m) h = 'lift' m@ +-- +-- * @'catchE' ('throwE' e) h = h e@ +catchE :: (Monad m) => + ExceptT e m a -- ^ the inner computation + -> (e -> ExceptT e' m a) -- ^ a handler for exceptions in the inner + -- computation + -> ExceptT e' m a +m `catchE` h = ExceptT $ do + a <- runExceptT m + case a of + Left l -> runExceptT (h l) + Right r -> return (Right r) +{-# INLINE catchE #-} + +-- | Lift a @callCC@ operation to the new monad. +liftCallCC :: CallCC m (Either e a) (Either e b) -> CallCC (ExceptT e m) a b +liftCallCC callCC f = ExceptT $ + callCC $ \ c -> + runExceptT (f (\ a -> ExceptT $ c (Right a))) +{-# INLINE liftCallCC #-} + +-- | Lift a @listen@ operation to the new monad. +liftListen :: (Monad m) => Listen w m (Either e a) -> Listen w (ExceptT e m) a +liftListen listen = mapExceptT $ \ m -> do + (a, w) <- listen m + return $! fmap (\ r -> (r, w)) a +{-# INLINE liftListen #-} + +-- | Lift a @pass@ operation to the new monad. +liftPass :: (Monad m) => Pass w m (Either e a) -> Pass w (ExceptT e m) a +liftPass pass = mapExceptT $ \ m -> pass $ do + a <- m + return $! case a of + Left l -> (Left l, id) + Right (r, f) -> (Right r, f) +{-# INLINE liftPass #-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Identity.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Identity.hs new file mode 100644 index 000000000000..2a0db5e5a165 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Identity.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE PolyKinds #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Identity +-- Copyright : (c) 2007 Magnus Therning +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- The identity monad transformer. +-- +-- This is useful for functions parameterized by a monad transformer. +----------------------------------------------------------------------------- + +module Control.Monad.Trans.Identity ( + -- * The identity monad transformer + IdentityT(..), + mapIdentityT, + -- * Lifting other operations + liftCatch, + liftCallCC, + ) where + +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Control.Monad.Signatures +import Control.Monad.Trans.Class (MonadTrans(lift)) +import Data.Functor.Classes +#if MIN_VERSION_base(4,12,0) +import Data.Functor.Contravariant +#endif + +import Control.Applicative +import Control.Monad (MonadPlus(mzero, mplus)) +#if MIN_VERSION_base(4,9,0) +import qualified Control.Monad.Fail as Fail +#endif +import Control.Monad.Fix (MonadFix(mfix)) +#if MIN_VERSION_base(4,4,0) +import Control.Monad.Zip (MonadZip(mzipWith)) +#endif +import Data.Foldable +import Data.Traversable (Traversable(traverse)) +import Prelude hiding (foldr, foldr1, foldl, foldl1, null, length) + +-- | The trivial monad transformer, which maps a monad to an equivalent monad. +newtype IdentityT f a = IdentityT { runIdentityT :: f a } + +instance (Eq1 f) => Eq1 (IdentityT f) where + liftEq eq (IdentityT x) (IdentityT y) = liftEq eq x y + {-# INLINE liftEq #-} + +instance (Ord1 f) => Ord1 (IdentityT f) where + liftCompare comp (IdentityT x) (IdentityT y) = liftCompare comp x y + {-# INLINE liftCompare #-} + +instance (Read1 f) => Read1 (IdentityT f) where + liftReadsPrec rp rl = readsData $ + readsUnaryWith (liftReadsPrec rp rl) "IdentityT" IdentityT + +instance (Show1 f) => Show1 (IdentityT f) where + liftShowsPrec sp sl d (IdentityT m) = + showsUnaryWith (liftShowsPrec sp sl) "IdentityT" d m + +instance (Eq1 f, Eq a) => Eq (IdentityT f a) where (==) = eq1 +instance (Ord1 f, Ord a) => Ord (IdentityT f a) where compare = compare1 +instance (Read1 f, Read a) => Read (IdentityT f a) where readsPrec = readsPrec1 +instance (Show1 f, Show a) => Show (IdentityT f a) where showsPrec = showsPrec1 + +instance (Functor m) => Functor (IdentityT m) where + fmap f = mapIdentityT (fmap f) + {-# INLINE fmap #-} + +instance (Foldable f) => Foldable (IdentityT f) where + foldMap f (IdentityT t) = foldMap f t + {-# INLINE foldMap #-} + foldr f z (IdentityT t) = foldr f z t + {-# INLINE foldr #-} + foldl f z (IdentityT t) = foldl f z t + {-# INLINE foldl #-} + foldr1 f (IdentityT t) = foldr1 f t + {-# INLINE foldr1 #-} + foldl1 f (IdentityT t) = foldl1 f t + {-# INLINE foldl1 #-} +#if MIN_VERSION_base(4,8,0) + null (IdentityT t) = null t + length (IdentityT t) = length t +#endif + +instance (Traversable f) => Traversable (IdentityT f) where + traverse f (IdentityT a) = IdentityT <$> traverse f a + {-# INLINE traverse #-} + +instance (Applicative m) => Applicative (IdentityT m) where + pure x = IdentityT (pure x) + {-# INLINE pure #-} + (<*>) = lift2IdentityT (<*>) + {-# INLINE (<*>) #-} + (*>) = lift2IdentityT (*>) + {-# INLINE (*>) #-} + (<*) = lift2IdentityT (<*) + {-# INLINE (<*) #-} + +instance (Alternative m) => Alternative (IdentityT m) where + empty = IdentityT empty + {-# INLINE empty #-} + (<|>) = lift2IdentityT (<|>) + {-# INLINE (<|>) #-} + +instance (Monad m) => Monad (IdentityT m) where +#if !(MIN_VERSION_base(4,8,0)) + return = IdentityT . return + {-# INLINE return #-} +#endif + m >>= k = IdentityT $ runIdentityT . k =<< runIdentityT m + {-# INLINE (>>=) #-} +#if !(MIN_VERSION_base(4,13,0)) + fail msg = IdentityT $ fail msg + {-# INLINE fail #-} +#endif + +#if MIN_VERSION_base(4,9,0) +instance (Fail.MonadFail m) => Fail.MonadFail (IdentityT m) where + fail msg = IdentityT $ Fail.fail msg + {-# INLINE fail #-} +#endif + +instance (MonadPlus m) => MonadPlus (IdentityT m) where + mzero = IdentityT mzero + {-# INLINE mzero #-} + mplus = lift2IdentityT mplus + {-# INLINE mplus #-} + +instance (MonadFix m) => MonadFix (IdentityT m) where + mfix f = IdentityT (mfix (runIdentityT . f)) + {-# INLINE mfix #-} + +instance (MonadIO m) => MonadIO (IdentityT m) where + liftIO = IdentityT . liftIO + {-# INLINE liftIO #-} + +#if MIN_VERSION_base(4,4,0) +instance (MonadZip m) => MonadZip (IdentityT m) where + mzipWith f = lift2IdentityT (mzipWith f) + {-# INLINE mzipWith #-} +#endif + +instance MonadTrans IdentityT where + lift = IdentityT + {-# INLINE lift #-} + +#if MIN_VERSION_base(4,12,0) +instance Contravariant f => Contravariant (IdentityT f) where + contramap f = IdentityT . contramap f . runIdentityT + {-# INLINE contramap #-} +#endif + +-- | Lift a unary operation to the new monad. +mapIdentityT :: (m a -> n b) -> IdentityT m a -> IdentityT n b +mapIdentityT f = IdentityT . f . runIdentityT +{-# INLINE mapIdentityT #-} + +-- | Lift a binary operation to the new monad. +lift2IdentityT :: + (m a -> n b -> p c) -> IdentityT m a -> IdentityT n b -> IdentityT p c +lift2IdentityT f a b = IdentityT (f (runIdentityT a) (runIdentityT b)) +{-# INLINE lift2IdentityT #-} + +-- | Lift a @callCC@ operation to the new monad. +liftCallCC :: CallCC m a b -> CallCC (IdentityT m) a b +liftCallCC callCC f = + IdentityT $ callCC $ \ c -> runIdentityT (f (IdentityT . c)) +{-# INLINE liftCallCC #-} + +-- | Lift a @catchE@ operation to the new monad. +liftCatch :: Catch e m a -> Catch e (IdentityT m) a +liftCatch f m h = IdentityT $ f (runIdentityT m) (runIdentityT . h) +{-# INLINE liftCatch #-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/List.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/List.hs new file mode 100644 index 000000000000..0bdbcc732e83 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/List.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.List +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- The ListT monad transformer, adding backtracking to a given monad, +-- which must be commutative. +----------------------------------------------------------------------------- + +module Control.Monad.Trans.List + {-# DEPRECATED "This transformer is invalid on most monads" #-} ( + -- * The ListT monad transformer + ListT(..), + mapListT, + -- * Lifting other operations + liftCallCC, + liftCatch, + ) where + +import Control.Monad.IO.Class +import Control.Monad.Signatures +import Control.Monad.Trans.Class +import Data.Functor.Classes +#if MIN_VERSION_base(4,12,0) +import Data.Functor.Contravariant +#endif + +import Control.Applicative +import Control.Monad +#if MIN_VERSION_base(4,9,0) +import qualified Control.Monad.Fail as Fail +#endif +import Control.Monad.Fix +#if MIN_VERSION_base(4,4,0) +import Control.Monad.Zip (MonadZip(mzipWith)) +#endif +import Data.Foldable (Foldable(foldMap)) +import Data.Traversable (Traversable(traverse)) + +-- | Parameterizable list monad, with an inner monad. +-- +-- /Note:/ this does not yield a monad unless the argument monad is commutative. +newtype ListT m a = ListT { runListT :: m [a] } + +instance (Eq1 m) => Eq1 (ListT m) where + liftEq eq (ListT x) (ListT y) = liftEq (liftEq eq) x y + {-# INLINE liftEq #-} + +instance (Ord1 m) => Ord1 (ListT m) where + liftCompare comp (ListT x) (ListT y) = liftCompare (liftCompare comp) x y + {-# INLINE liftCompare #-} + +instance (Read1 m) => Read1 (ListT m) where + liftReadsPrec rp rl = readsData $ + readsUnaryWith (liftReadsPrec rp' rl') "ListT" ListT + where + rp' = liftReadsPrec rp rl + rl' = liftReadList rp rl + +instance (Show1 m) => Show1 (ListT m) where + liftShowsPrec sp sl d (ListT m) = + showsUnaryWith (liftShowsPrec sp' sl') "ListT" d m + where + sp' = liftShowsPrec sp sl + sl' = liftShowList sp sl + +instance (Eq1 m, Eq a) => Eq (ListT m a) where (==) = eq1 +instance (Ord1 m, Ord a) => Ord (ListT m a) where compare = compare1 +instance (Read1 m, Read a) => Read (ListT m a) where readsPrec = readsPrec1 +instance (Show1 m, Show a) => Show (ListT m a) where showsPrec = showsPrec1 + +-- | Map between 'ListT' computations. +-- +-- * @'runListT' ('mapListT' f m) = f ('runListT' m)@ +mapListT :: (m [a] -> n [b]) -> ListT m a -> ListT n b +mapListT f m = ListT $ f (runListT m) +{-# INLINE mapListT #-} + +instance (Functor m) => Functor (ListT m) where + fmap f = mapListT $ fmap $ map f + {-# INLINE fmap #-} + +instance (Foldable f) => Foldable (ListT f) where + foldMap f (ListT a) = foldMap (foldMap f) a + {-# INLINE foldMap #-} + +instance (Traversable f) => Traversable (ListT f) where + traverse f (ListT a) = ListT <$> traverse (traverse f) a + {-# INLINE traverse #-} + +instance (Applicative m) => Applicative (ListT m) where + pure a = ListT $ pure [a] + {-# INLINE pure #-} + f <*> v = ListT $ (<*>) <$> runListT f <*> runListT v + {-# INLINE (<*>) #-} + +instance (Applicative m) => Alternative (ListT m) where + empty = ListT $ pure [] + {-# INLINE empty #-} + m <|> n = ListT $ (++) <$> runListT m <*> runListT n + {-# INLINE (<|>) #-} + +instance (Monad m) => Monad (ListT m) where +#if !(MIN_VERSION_base(4,8,0)) + return a = ListT $ return [a] + {-# INLINE return #-} +#endif + m >>= k = ListT $ do + a <- runListT m + b <- mapM (runListT . k) a + return (concat b) + {-# INLINE (>>=) #-} +#if !(MIN_VERSION_base(4,13,0)) + fail _ = ListT $ return [] + {-# INLINE fail #-} +#endif + +#if MIN_VERSION_base(4,9,0) +instance (Monad m) => Fail.MonadFail (ListT m) where + fail _ = ListT $ return [] + {-# INLINE fail #-} +#endif + +instance (Monad m) => MonadPlus (ListT m) where + mzero = ListT $ return [] + {-# INLINE mzero #-} + m `mplus` n = ListT $ do + a <- runListT m + b <- runListT n + return (a ++ b) + {-# INLINE mplus #-} + +instance (MonadFix m) => MonadFix (ListT m) where + mfix f = ListT $ mfix (runListT . f . head) >>= \ xs -> case xs of + [] -> return [] + x:_ -> liftM (x:) (runListT (mfix (mapListT (liftM tail) . f))) + {-# INLINE mfix #-} + +instance MonadTrans ListT where + lift m = ListT $ do + a <- m + return [a] + {-# INLINE lift #-} + +instance (MonadIO m) => MonadIO (ListT m) where + liftIO = lift . liftIO + {-# INLINE liftIO #-} + +#if MIN_VERSION_base(4,4,0) +instance (MonadZip m) => MonadZip (ListT m) where + mzipWith f (ListT a) (ListT b) = ListT $ mzipWith (zipWith f) a b + {-# INLINE mzipWith #-} +#endif + +#if MIN_VERSION_base(4,12,0) +instance Contravariant m => Contravariant (ListT m) where + contramap f = ListT . contramap (fmap f) . runListT + {-# INLINE contramap #-} +#endif + +-- | Lift a @callCC@ operation to the new monad. +liftCallCC :: CallCC m [a] [b] -> CallCC (ListT m) a b +liftCallCC callCC f = ListT $ + callCC $ \ c -> + runListT (f (\ a -> ListT $ c [a])) +{-# INLINE liftCallCC #-} + +-- | Lift a @catchE@ operation to the new monad. +liftCatch :: Catch e m [a] -> Catch e (ListT m) a +liftCatch catchE m h = ListT $ runListT m + `catchE` \ e -> runListT (h e) +{-# INLINE liftCatch #-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Maybe.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Maybe.hs new file mode 100644 index 000000000000..f02b225444f8 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Maybe.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Maybe +-- Copyright : (c) 2007 Yitzak Gale, Eric Kidd +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- The 'MaybeT' monad transformer extends a monad with the ability to exit +-- the computation without returning a value. +-- +-- A sequence of actions produces a value only if all the actions in +-- the sequence do. If one exits, the rest of the sequence is skipped +-- and the composite action exits. +-- +-- For a variant allowing a range of exception values, see +-- "Control.Monad.Trans.Except". +----------------------------------------------------------------------------- + +module Control.Monad.Trans.Maybe ( + -- * The MaybeT monad transformer + MaybeT(..), + mapMaybeT, + -- * Monad transformations + maybeToExceptT, + exceptToMaybeT, + -- * Lifting other operations + liftCallCC, + liftCatch, + liftListen, + liftPass, + ) where + +import Control.Monad.IO.Class +import Control.Monad.Signatures +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except (ExceptT(..)) +import Data.Functor.Classes +#if MIN_VERSION_base(4,12,0) +import Data.Functor.Contravariant +#endif + +import Control.Applicative +import Control.Monad (MonadPlus(mzero, mplus), liftM) +#if MIN_VERSION_base(4,9,0) +import qualified Control.Monad.Fail as Fail +#endif +import Control.Monad.Fix (MonadFix(mfix)) +#if MIN_VERSION_base(4,4,0) +import Control.Monad.Zip (MonadZip(mzipWith)) +#endif +import Data.Foldable (Foldable(foldMap)) +import Data.Maybe (fromMaybe) +import Data.Traversable (Traversable(traverse)) + +-- | The parameterizable maybe monad, obtained by composing an arbitrary +-- monad with the 'Maybe' monad. +-- +-- Computations are actions that may produce a value or exit. +-- +-- The 'return' function yields a computation that produces that +-- value, while @>>=@ sequences two subcomputations, exiting if either +-- computation does. +newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) } + +instance (Eq1 m) => Eq1 (MaybeT m) where + liftEq eq (MaybeT x) (MaybeT y) = liftEq (liftEq eq) x y + {-# INLINE liftEq #-} + +instance (Ord1 m) => Ord1 (MaybeT m) where + liftCompare comp (MaybeT x) (MaybeT y) = liftCompare (liftCompare comp) x y + {-# INLINE liftCompare #-} + +instance (Read1 m) => Read1 (MaybeT m) where + liftReadsPrec rp rl = readsData $ + readsUnaryWith (liftReadsPrec rp' rl') "MaybeT" MaybeT + where + rp' = liftReadsPrec rp rl + rl' = liftReadList rp rl + +instance (Show1 m) => Show1 (MaybeT m) where + liftShowsPrec sp sl d (MaybeT m) = + showsUnaryWith (liftShowsPrec sp' sl') "MaybeT" d m + where + sp' = liftShowsPrec sp sl + sl' = liftShowList sp sl + +instance (Eq1 m, Eq a) => Eq (MaybeT m a) where (==) = eq1 +instance (Ord1 m, Ord a) => Ord (MaybeT m a) where compare = compare1 +instance (Read1 m, Read a) => Read (MaybeT m a) where readsPrec = readsPrec1 +instance (Show1 m, Show a) => Show (MaybeT m a) where showsPrec = showsPrec1 + +-- | Transform the computation inside a @MaybeT@. +-- +-- * @'runMaybeT' ('mapMaybeT' f m) = f ('runMaybeT' m)@ +mapMaybeT :: (m (Maybe a) -> n (Maybe b)) -> MaybeT m a -> MaybeT n b +mapMaybeT f = MaybeT . f . runMaybeT +{-# INLINE mapMaybeT #-} + +-- | Convert a 'MaybeT' computation to 'ExceptT', with a default +-- exception value. +maybeToExceptT :: (Functor m) => e -> MaybeT m a -> ExceptT e m a +maybeToExceptT e (MaybeT m) = ExceptT $ fmap (maybe (Left e) Right) m +{-# INLINE maybeToExceptT #-} + +-- | Convert a 'ExceptT' computation to 'MaybeT', discarding the +-- value of any exception. +exceptToMaybeT :: (Functor m) => ExceptT e m a -> MaybeT m a +exceptToMaybeT (ExceptT m) = MaybeT $ fmap (either (const Nothing) Just) m +{-# INLINE exceptToMaybeT #-} + +instance (Functor m) => Functor (MaybeT m) where + fmap f = mapMaybeT (fmap (fmap f)) + {-# INLINE fmap #-} + +instance (Foldable f) => Foldable (MaybeT f) where + foldMap f (MaybeT a) = foldMap (foldMap f) a + {-# INLINE foldMap #-} + +instance (Traversable f) => Traversable (MaybeT f) where + traverse f (MaybeT a) = MaybeT <$> traverse (traverse f) a + {-# INLINE traverse #-} + +instance (Functor m, Monad m) => Applicative (MaybeT m) where + pure = MaybeT . return . Just + {-# INLINE pure #-} + mf <*> mx = MaybeT $ do + mb_f <- runMaybeT mf + case mb_f of + Nothing -> return Nothing + Just f -> do + mb_x <- runMaybeT mx + case mb_x of + Nothing -> return Nothing + Just x -> return (Just (f x)) + {-# INLINE (<*>) #-} + m *> k = m >>= \_ -> k + {-# INLINE (*>) #-} + +instance (Functor m, Monad m) => Alternative (MaybeT m) where + empty = MaybeT (return Nothing) + {-# INLINE empty #-} + x <|> y = MaybeT $ do + v <- runMaybeT x + case v of + Nothing -> runMaybeT y + Just _ -> return v + {-# INLINE (<|>) #-} + +instance (Monad m) => Monad (MaybeT m) where +#if !(MIN_VERSION_base(4,8,0)) + return = MaybeT . return . Just + {-# INLINE return #-} +#endif + x >>= f = MaybeT $ do + v <- runMaybeT x + case v of + Nothing -> return Nothing + Just y -> runMaybeT (f y) + {-# INLINE (>>=) #-} +#if !(MIN_VERSION_base(4,13,0)) + fail _ = MaybeT (return Nothing) + {-# INLINE fail #-} +#endif + +#if MIN_VERSION_base(4,9,0) +instance (Monad m) => Fail.MonadFail (MaybeT m) where + fail _ = MaybeT (return Nothing) + {-# INLINE fail #-} +#endif + +instance (Monad m) => MonadPlus (MaybeT m) where + mzero = MaybeT (return Nothing) + {-# INLINE mzero #-} + mplus x y = MaybeT $ do + v <- runMaybeT x + case v of + Nothing -> runMaybeT y + Just _ -> return v + {-# INLINE mplus #-} + +instance (MonadFix m) => MonadFix (MaybeT m) where + mfix f = MaybeT (mfix (runMaybeT . f . fromMaybe bomb)) + where bomb = error "mfix (MaybeT): inner computation returned Nothing" + {-# INLINE mfix #-} + +instance MonadTrans MaybeT where + lift = MaybeT . liftM Just + {-# INLINE lift #-} + +instance (MonadIO m) => MonadIO (MaybeT m) where + liftIO = lift . liftIO + {-# INLINE liftIO #-} + +#if MIN_VERSION_base(4,4,0) +instance (MonadZip m) => MonadZip (MaybeT m) where + mzipWith f (MaybeT a) (MaybeT b) = MaybeT $ mzipWith (liftA2 f) a b + {-# INLINE mzipWith #-} +#endif + +#if MIN_VERSION_base(4,12,0) +instance Contravariant m => Contravariant (MaybeT m) where + contramap f = MaybeT . contramap (fmap f) . runMaybeT + {-# INLINE contramap #-} +#endif + +-- | Lift a @callCC@ operation to the new monad. +liftCallCC :: CallCC m (Maybe a) (Maybe b) -> CallCC (MaybeT m) a b +liftCallCC callCC f = + MaybeT $ callCC $ \ c -> runMaybeT (f (MaybeT . c . Just)) +{-# INLINE liftCallCC #-} + +-- | Lift a @catchE@ operation to the new monad. +liftCatch :: Catch e m (Maybe a) -> Catch e (MaybeT m) a +liftCatch f m h = MaybeT $ f (runMaybeT m) (runMaybeT . h) +{-# INLINE liftCatch #-} + +-- | Lift a @listen@ operation to the new monad. +liftListen :: (Monad m) => Listen w m (Maybe a) -> Listen w (MaybeT m) a +liftListen listen = mapMaybeT $ \ m -> do + (a, w) <- listen m + return $! fmap (\ r -> (r, w)) a +{-# INLINE liftListen #-} + +-- | Lift a @pass@ operation to the new monad. +liftPass :: (Monad m) => Pass w m (Maybe a) -> Pass w (MaybeT m) a +liftPass pass = mapMaybeT $ \ m -> pass $ do + a <- m + return $! case a of + Nothing -> (Nothing, id) + Just (v, f) -> (Just v, f) +{-# INLINE liftPass #-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS.hs new file mode 100644 index 000000000000..b4cc6adaad78 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.RWS +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- A monad transformer that combines 'ReaderT', 'WriterT' and 'StateT'. +-- This version is lazy; for a constant-space version with almost the +-- same interface, see "Control.Monad.Trans.RWS.CPS". +----------------------------------------------------------------------------- + +module Control.Monad.Trans.RWS ( + module Control.Monad.Trans.RWS.Lazy + ) where + +import Control.Monad.Trans.RWS.Lazy diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS/CPS.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS/CPS.hs new file mode 100644 index 000000000000..8a565e1652c3 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS/CPS.hs @@ -0,0 +1,406 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.RWS.CPS +-- Copyright : (c) Daniel Mendler 2016, +-- (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- A monad transformer that combines 'ReaderT', 'WriterT' and 'StateT'. +-- This version uses continuation-passing-style for the writer part +-- to achieve constant space usage. +-- For a lazy version with the same interface, +-- see "Control.Monad.Trans.RWS.Lazy". +----------------------------------------------------------------------------- + +module Control.Monad.Trans.RWS.CPS ( + -- * The RWS monad + RWS, + rws, + runRWS, + evalRWS, + execRWS, + mapRWS, + withRWS, + -- * The RWST monad transformer + RWST, + rwsT, + runRWST, + evalRWST, + execRWST, + mapRWST, + withRWST, + -- * Reader operations + reader, + ask, + local, + asks, + -- * Writer operations + writer, + tell, + listen, + listens, + pass, + censor, + -- * State operations + state, + get, + put, + modify, + gets, + -- * Lifting other operations + liftCallCC, + liftCallCC', + liftCatch, + ) where + +import Control.Applicative +import Control.Monad +import Control.Monad.Fix +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Signatures +import Data.Functor.Identity + +#if !(MIN_VERSION_base(4,8,0)) +import Data.Monoid +#endif + +#if MIN_VERSION_base(4,9,0) +import qualified Control.Monad.Fail as Fail +#endif + +-- | A monad containing an environment of type @r@, output of type @w@ +-- and an updatable state of type @s@. +type RWS r w s = RWST r w s Identity + +-- | Construct an RWS computation from a function. +-- (The inverse of 'runRWS'.) +rws :: (Monoid w) => (r -> s -> (a, s, w)) -> RWS r w s a +rws f = RWST $ \ r s w -> + let (a, s', w') = f r s; wt = w `mappend` w' in wt `seq` return (a, s', wt) +{-# INLINE rws #-} + +-- | Unwrap an RWS computation as a function. +-- (The inverse of 'rws'.) +runRWS :: (Monoid w) => RWS r w s a -> r -> s -> (a, s, w) +runRWS m r s = runIdentity (runRWST m r s) +{-# INLINE runRWS #-} + +-- | Evaluate a computation with the given initial state and environment, +-- returning the final value and output, discarding the final state. +evalRWS :: (Monoid w) + => RWS r w s a -- ^RWS computation to execute + -> r -- ^initial environment + -> s -- ^initial value + -> (a, w) -- ^final value and output +evalRWS m r s = let + (a, _, w) = runRWS m r s + in (a, w) +{-# INLINE evalRWS #-} + +-- | Evaluate a computation with the given initial state and environment, +-- returning the final state and output, discarding the final value. +execRWS :: (Monoid w) + => RWS r w s a -- ^RWS computation to execute + -> r -- ^initial environment + -> s -- ^initial value + -> (s, w) -- ^final state and output +execRWS m r s = let + (_, s', w) = runRWS m r s + in (s', w) +{-# INLINE execRWS #-} + +-- | Map the return value, final state and output of a computation using +-- the given function. +-- +-- * @'runRWS' ('mapRWS' f m) r s = f ('runRWS' m r s)@ +mapRWS :: (Monoid w, Monoid w') => ((a, s, w) -> (b, s, w')) -> RWS r w s a -> RWS r w' s b +mapRWS f = mapRWST (Identity . f . runIdentity) +{-# INLINE mapRWS #-} + +-- | @'withRWS' f m@ executes action @m@ with an initial environment +-- and state modified by applying @f@. +-- +-- * @'runRWS' ('withRWS' f m) r s = 'uncurry' ('runRWS' m) (f r s)@ +withRWS :: (r' -> s -> (r, s)) -> RWS r w s a -> RWS r' w s a +withRWS = withRWST +{-# INLINE withRWS #-} + +-- --------------------------------------------------------------------------- +-- | A monad transformer adding reading an environment of type @r@, +-- collecting an output of type @w@ and updating a state of type @s@ +-- to an inner monad @m@. +newtype RWST r w s m a = RWST { unRWST :: r -> s -> w -> m (a, s, w) } + +-- | Construct an RWST computation from a function. +-- (The inverse of 'runRWST'.) +rwsT :: (Functor m, Monoid w) => (r -> s -> m (a, s, w)) -> RWST r w s m a +rwsT f = RWST $ \ r s w -> + (\ (a, s', w') -> let wt = w `mappend` w' in wt `seq` (a, s', wt)) <$> f r s +{-# INLINE rwsT #-} + +-- | Unwrap an RWST computation as a function. +-- (The inverse of 'rwsT'.) +runRWST :: (Monoid w) => RWST r w s m a -> r -> s -> m (a, s, w) +runRWST m r s = unRWST m r s mempty +{-# INLINE runRWST #-} + +-- | Evaluate a computation with the given initial state and environment, +-- returning the final value and output, discarding the final state. +evalRWST :: (Monad m, Monoid w) + => RWST r w s m a -- ^computation to execute + -> r -- ^initial environment + -> s -- ^initial value + -> m (a, w) -- ^computation yielding final value and output +evalRWST m r s = do + (a, _, w) <- runRWST m r s + return (a, w) +{-# INLINE evalRWST #-} + +-- | Evaluate a computation with the given initial state and environment, +-- returning the final state and output, discarding the final value. +execRWST :: (Monad m, Monoid w) + => RWST r w s m a -- ^computation to execute + -> r -- ^initial environment + -> s -- ^initial value + -> m (s, w) -- ^computation yielding final state and output +execRWST m r s = do + (_, s', w) <- runRWST m r s + return (s', w) +{-# INLINE execRWST #-} + +-- | Map the inner computation using the given function. +-- +-- * @'runRWST' ('mapRWST' f m) r s = f ('runRWST' m r s)@ +--mapRWST :: (m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b +mapRWST :: (Monad n, Monoid w, Monoid w') => + (m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b +mapRWST f m = RWST $ \ r s w -> do + (a, s', w') <- f (runRWST m r s) + let wt = w `mappend` w' + wt `seq` return (a, s', wt) +{-# INLINE mapRWST #-} + +-- | @'withRWST' f m@ executes action @m@ with an initial environment +-- and state modified by applying @f@. +-- +-- * @'runRWST' ('withRWST' f m) r s = 'uncurry' ('runRWST' m) (f r s)@ +withRWST :: (r' -> s -> (r, s)) -> RWST r w s m a -> RWST r' w s m a +withRWST f m = RWST $ \ r s -> uncurry (unRWST m) (f r s) +{-# INLINE withRWST #-} + +instance (Functor m) => Functor (RWST r w s m) where + fmap f m = RWST $ \ r s w -> (\ (a, s', w') -> (f a, s', w')) <$> unRWST m r s w + {-# INLINE fmap #-} + +instance (Functor m, Monad m) => Applicative (RWST r w s m) where + pure a = RWST $ \ _ s w -> return (a, s, w) + {-# INLINE pure #-} + + RWST mf <*> RWST mx = RWST $ \ r s w -> do + (f, s', w') <- mf r s w + (x, s'', w'') <- mx r s' w' + return (f x, s'', w'') + {-# INLINE (<*>) #-} + +instance (Functor m, MonadPlus m) => Alternative (RWST r w s m) where + empty = RWST $ \ _ _ _ -> mzero + {-# INLINE empty #-} + + RWST m <|> RWST n = RWST $ \ r s w -> m r s w `mplus` n r s w + {-# INLINE (<|>) #-} + +instance (Monad m) => Monad (RWST r w s m) where +#if !(MIN_VERSION_base(4,8,0)) + return a = RWST $ \ _ s w -> return (a, s, w) + {-# INLINE return #-} +#endif + + m >>= k = RWST $ \ r s w -> do + (a, s', w') <- unRWST m r s w + unRWST (k a) r s' w' + {-# INLINE (>>=) #-} + +#if !(MIN_VERSION_base(4,13,0)) + fail msg = RWST $ \ _ _ _ -> fail msg + {-# INLINE fail #-} +#endif + +#if MIN_VERSION_base(4,9,0) +instance (Fail.MonadFail m) => Fail.MonadFail (RWST r w s m) where + fail msg = RWST $ \ _ _ _ -> Fail.fail msg + {-# INLINE fail #-} +#endif + +instance (Functor m, MonadPlus m) => MonadPlus (RWST r w s m) where + mzero = empty + {-# INLINE mzero #-} + mplus = (<|>) + {-# INLINE mplus #-} + +instance (MonadFix m) => MonadFix (RWST r w s m) where + mfix f = RWST $ \ r s w -> mfix $ \ ~(a, _, _) -> unRWST (f a) r s w + {-# INLINE mfix #-} + +instance MonadTrans (RWST r w s) where + lift m = RWST $ \ _ s w -> do + a <- m + return (a, s, w) + {-# INLINE lift #-} + +instance (MonadIO m) => MonadIO (RWST r w s m) where + liftIO = lift . liftIO + {-# INLINE liftIO #-} +-- --------------------------------------------------------------------------- +-- Reader operations + +-- | Constructor for computations in the reader monad (equivalent to 'asks'). +reader :: (Monad m) => (r -> a) -> RWST r w s m a +reader = asks +{-# INLINE reader #-} + +-- | Fetch the value of the environment. +ask :: (Monad m) => RWST r w s m r +ask = asks id +{-# INLINE ask #-} + +-- | Execute a computation in a modified environment +-- +-- * @'runRWST' ('local' f m) r s = 'runRWST' m (f r) s@ +local :: (r -> r) -> RWST r w s m a -> RWST r w s m a +local f m = RWST $ \ r s w -> unRWST m (f r) s w +{-# INLINE local #-} + +-- | Retrieve a function of the current environment. +-- +-- * @'asks' f = 'liftM' f 'ask'@ +asks :: (Monad m) => (r -> a) -> RWST r w s m a +asks f = RWST $ \ r s w -> return (f r, s, w) +{-# INLINE asks #-} + +-- --------------------------------------------------------------------------- +-- Writer operations + +-- | Construct a writer computation from a (result, output) pair. +writer :: (Monoid w, Monad m) => (a, w) -> RWST r w s m a +writer (a, w') = RWST $ \ _ s w -> let wt = w `mappend` w' in wt `seq` return (a, s, wt) +{-# INLINE writer #-} + +-- | @'tell' w@ is an action that produces the output @w@. +tell :: (Monoid w, Monad m) => w -> RWST r w s m () +tell w' = writer ((), w') +{-# INLINE tell #-} + +-- | @'listen' m@ is an action that executes the action @m@ and adds its +-- output to the value of the computation. +-- +-- * @'runRWST' ('listen' m) r s = 'liftM' (\\ (a, w) -> ((a, w), w)) ('runRWST' m r s)@ +listen :: (Monoid w, Monad m) => RWST r w s m a -> RWST r w s m (a, w) +listen = listens id +{-# INLINE listen #-} + +-- | @'listens' f m@ is an action that executes the action @m@ and adds +-- the result of applying @f@ to the output to the value of the computation. +-- +-- * @'listens' f m = 'liftM' (id *** f) ('listen' m)@ +-- +-- * @'runRWST' ('listens' f m) r s = 'liftM' (\\ (a, w) -> ((a, f w), w)) ('runRWST' m r s)@ +listens :: (Monoid w, Monad m) => (w -> b) -> RWST r w s m a -> RWST r w s m (a, b) +listens f m = RWST $ \ r s w -> do + (a, s', w') <- runRWST m r s + let wt = w `mappend` w' + wt `seq` return ((a, f w'), s', wt) +{-# INLINE listens #-} + +-- | @'pass' m@ is an action that executes the action @m@, which returns +-- a value and a function, and returns the value, applying the function +-- to the output. +-- +-- * @'runRWST' ('pass' m) r s = 'liftM' (\\ ((a, f), w) -> (a, f w)) ('runRWST' m r s)@ +pass :: (Monoid w, Monoid w', Monad m) => RWST r w s m (a, w -> w') -> RWST r w' s m a +pass m = RWST $ \ r s w -> do + ((a, f), s', w') <- runRWST m r s + let wt = w `mappend` f w' + wt `seq` return (a, s', wt) +{-# INLINE pass #-} + +-- | @'censor' f m@ is an action that executes the action @m@ and +-- applies the function @f@ to its output, leaving the return value +-- unchanged. +-- +-- * @'censor' f m = 'pass' ('liftM' (\\ x -> (x,f)) m)@ +-- +-- * @'runRWST' ('censor' f m) r s = 'liftM' (\\ (a, w) -> (a, f w)) ('runRWST' m r s)@ +censor :: (Monoid w, Monad m) => (w -> w) -> RWST r w s m a -> RWST r w s m a +censor f m = RWST $ \ r s w -> do + (a, s', w') <- runRWST m r s + let wt = w `mappend` f w' + wt `seq` return (a, s', wt) +{-# INLINE censor #-} + +-- --------------------------------------------------------------------------- +-- State operations + +-- | Construct a state monad computation from a state transformer function. +state :: (Monad m) => (s -> (a, s)) -> RWST r w s m a +state f = RWST $ \ _ s w -> let (a, s') = f s in return (a, s', w) +{-# INLINE state #-} + +-- | Fetch the current value of the state within the monad. +get :: (Monad m) =>RWST r w s m s +get = gets id +{-# INLINE get #-} + +-- | @'put' s@ sets the state within the monad to @s@. +put :: (Monad m) =>s -> RWST r w s m () +put s = RWST $ \ _ _ w -> return ((), s, w) +{-# INLINE put #-} + +-- | @'modify' f@ is an action that updates the state to the result of +-- applying @f@ to the current state. +-- +-- * @'modify' f = 'get' >>= ('put' . f)@ +modify :: (Monad m) =>(s -> s) -> RWST r w s m () +modify f = RWST $ \ _ s w -> return ((), f s, w) +{-# INLINE modify #-} + +-- | Get a specific component of the state, using a projection function +-- supplied. +-- +-- * @'gets' f = 'liftM' f 'get'@ +gets :: (Monad m) =>(s -> a) -> RWST r w s m a +gets f = RWST $ \ _ s w -> return (f s, s, w) +{-# INLINE gets #-} + +-- | Uniform lifting of a @callCC@ operation to the new monad. +-- This version rolls back to the original state on entering the +-- continuation. +liftCallCC :: CallCC m (a,s,w) (b,s,w) -> CallCC (RWST r w s m) a b +liftCallCC callCC f = RWST $ \ r s w -> + callCC $ \ c -> unRWST (f (\ a -> RWST $ \ _ _ _ -> c (a, s, w))) r s w +{-# INLINE liftCallCC #-} + +-- | In-situ lifting of a @callCC@ operation to the new monad. +-- This version uses the current state on entering the continuation. +liftCallCC' :: CallCC m (a,s,w) (b,s,w) -> CallCC (RWST r w s m) a b +liftCallCC' callCC f = RWST $ \ r s w -> + callCC $ \ c -> unRWST (f (\ a -> RWST $ \ _ s' _ -> c (a, s', w))) r s w +{-# INLINE liftCallCC' #-} + +-- | Lift a @catchE@ operation to the new monad. +liftCatch :: Catch e m (a,s,w) -> Catch e (RWST r w s m) a +liftCatch catchE m h = + RWST $ \ r s w -> unRWST m r s w `catchE` \ e -> unRWST (h e) r s w +{-# INLINE liftCatch #-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS/Lazy.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS/Lazy.hs new file mode 100644 index 000000000000..8f98b2c5e05a --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS/Lazy.hs @@ -0,0 +1,389 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.RWS.Lazy +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- A monad transformer that combines 'ReaderT', 'WriterT' and 'StateT'. +-- This version is lazy; for a constant-space version with almost the +-- same interface, see "Control.Monad.Trans.RWS.CPS". +----------------------------------------------------------------------------- + +module Control.Monad.Trans.RWS.Lazy ( + -- * The RWS monad + RWS, + rws, + runRWS, + evalRWS, + execRWS, + mapRWS, + withRWS, + -- * The RWST monad transformer + RWST(..), + evalRWST, + execRWST, + mapRWST, + withRWST, + -- * Reader operations + reader, + ask, + local, + asks, + -- * Writer operations + writer, + tell, + listen, + listens, + pass, + censor, + -- * State operations + state, + get, + put, + modify, + gets, + -- * Lifting other operations + liftCallCC, + liftCallCC', + liftCatch, + ) where + +import Control.Monad.IO.Class +import Control.Monad.Signatures +import Control.Monad.Trans.Class +#if MIN_VERSION_base(4,12,0) +import Data.Functor.Contravariant +#endif +import Data.Functor.Identity + +import Control.Applicative +import Control.Monad +#if MIN_VERSION_base(4,9,0) +import qualified Control.Monad.Fail as Fail +#endif +import Control.Monad.Fix +import Data.Monoid + +-- | A monad containing an environment of type @r@, output of type @w@ +-- and an updatable state of type @s@. +type RWS r w s = RWST r w s Identity + +-- | Construct an RWS computation from a function. +-- (The inverse of 'runRWS'.) +rws :: (r -> s -> (a, s, w)) -> RWS r w s a +rws f = RWST (\ r s -> Identity (f r s)) +{-# INLINE rws #-} + +-- | Unwrap an RWS computation as a function. +-- (The inverse of 'rws'.) +runRWS :: RWS r w s a -> r -> s -> (a, s, w) +runRWS m r s = runIdentity (runRWST m r s) +{-# INLINE runRWS #-} + +-- | Evaluate a computation with the given initial state and environment, +-- returning the final value and output, discarding the final state. +evalRWS :: RWS r w s a -- ^RWS computation to execute + -> r -- ^initial environment + -> s -- ^initial value + -> (a, w) -- ^final value and output +evalRWS m r s = let + (a, _, w) = runRWS m r s + in (a, w) +{-# INLINE evalRWS #-} + +-- | Evaluate a computation with the given initial state and environment, +-- returning the final state and output, discarding the final value. +execRWS :: RWS r w s a -- ^RWS computation to execute + -> r -- ^initial environment + -> s -- ^initial value + -> (s, w) -- ^final state and output +execRWS m r s = let + (_, s', w) = runRWS m r s + in (s', w) +{-# INLINE execRWS #-} + +-- | Map the return value, final state and output of a computation using +-- the given function. +-- +-- * @'runRWS' ('mapRWS' f m) r s = f ('runRWS' m r s)@ +mapRWS :: ((a, s, w) -> (b, s, w')) -> RWS r w s a -> RWS r w' s b +mapRWS f = mapRWST (Identity . f . runIdentity) +{-# INLINE mapRWS #-} + +-- | @'withRWS' f m@ executes action @m@ with an initial environment +-- and state modified by applying @f@. +-- +-- * @'runRWS' ('withRWS' f m) r s = 'uncurry' ('runRWS' m) (f r s)@ +withRWS :: (r' -> s -> (r, s)) -> RWS r w s a -> RWS r' w s a +withRWS = withRWST +{-# INLINE withRWS #-} + +-- --------------------------------------------------------------------------- +-- | A monad transformer adding reading an environment of type @r@, +-- collecting an output of type @w@ and updating a state of type @s@ +-- to an inner monad @m@. +newtype RWST r w s m a = RWST { runRWST :: r -> s -> m (a, s, w) } + +-- | Evaluate a computation with the given initial state and environment, +-- returning the final value and output, discarding the final state. +evalRWST :: (Monad m) + => RWST r w s m a -- ^computation to execute + -> r -- ^initial environment + -> s -- ^initial value + -> m (a, w) -- ^computation yielding final value and output +evalRWST m r s = do + ~(a, _, w) <- runRWST m r s + return (a, w) +{-# INLINE evalRWST #-} + +-- | Evaluate a computation with the given initial state and environment, +-- returning the final state and output, discarding the final value. +execRWST :: (Monad m) + => RWST r w s m a -- ^computation to execute + -> r -- ^initial environment + -> s -- ^initial value + -> m (s, w) -- ^computation yielding final state and output +execRWST m r s = do + ~(_, s', w) <- runRWST m r s + return (s', w) +{-# INLINE execRWST #-} + +-- | Map the inner computation using the given function. +-- +-- * @'runRWST' ('mapRWST' f m) r s = f ('runRWST' m r s)@ +mapRWST :: (m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b +mapRWST f m = RWST $ \ r s -> f (runRWST m r s) +{-# INLINE mapRWST #-} + +-- | @'withRWST' f m@ executes action @m@ with an initial environment +-- and state modified by applying @f@. +-- +-- * @'runRWST' ('withRWST' f m) r s = 'uncurry' ('runRWST' m) (f r s)@ +withRWST :: (r' -> s -> (r, s)) -> RWST r w s m a -> RWST r' w s m a +withRWST f m = RWST $ \ r s -> uncurry (runRWST m) (f r s) +{-# INLINE withRWST #-} + +instance (Functor m) => Functor (RWST r w s m) where + fmap f m = RWST $ \ r s -> + fmap (\ ~(a, s', w) -> (f a, s', w)) $ runRWST m r s + {-# INLINE fmap #-} + +instance (Monoid w, Functor m, Monad m) => Applicative (RWST r w s m) where + pure a = RWST $ \ _ s -> return (a, s, mempty) + {-# INLINE pure #-} + RWST mf <*> RWST mx = RWST $ \ r s -> do + ~(f, s', w) <- mf r s + ~(x, s'',w') <- mx r s' + return (f x, s'', w `mappend` w') + {-# INLINE (<*>) #-} + +instance (Monoid w, Functor m, MonadPlus m) => Alternative (RWST r w s m) where + empty = RWST $ \ _ _ -> mzero + {-# INLINE empty #-} + RWST m <|> RWST n = RWST $ \ r s -> m r s `mplus` n r s + {-# INLINE (<|>) #-} + +instance (Monoid w, Monad m) => Monad (RWST r w s m) where +#if !(MIN_VERSION_base(4,8,0)) + return a = RWST $ \ _ s -> return (a, s, mempty) + {-# INLINE return #-} +#endif + m >>= k = RWST $ \ r s -> do + ~(a, s', w) <- runRWST m r s + ~(b, s'',w') <- runRWST (k a) r s' + return (b, s'', w `mappend` w') + {-# INLINE (>>=) #-} +#if !(MIN_VERSION_base(4,13,0)) + fail msg = RWST $ \ _ _ -> fail msg + {-# INLINE fail #-} +#endif + +#if MIN_VERSION_base(4,9,0) +instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (RWST r w s m) where + fail msg = RWST $ \ _ _ -> Fail.fail msg + {-# INLINE fail #-} +#endif + +instance (Monoid w, MonadPlus m) => MonadPlus (RWST r w s m) where + mzero = RWST $ \ _ _ -> mzero + {-# INLINE mzero #-} + RWST m `mplus` RWST n = RWST $ \ r s -> m r s `mplus` n r s + {-# INLINE mplus #-} + +instance (Monoid w, MonadFix m) => MonadFix (RWST r w s m) where + mfix f = RWST $ \ r s -> mfix $ \ ~(a, _, _) -> runRWST (f a) r s + {-# INLINE mfix #-} + +instance (Monoid w) => MonadTrans (RWST r w s) where + lift m = RWST $ \ _ s -> do + a <- m + return (a, s, mempty) + {-# INLINE lift #-} + +instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where + liftIO = lift . liftIO + {-# INLINE liftIO #-} + +#if MIN_VERSION_base(4,12,0) +instance Contravariant m => Contravariant (RWST r w s m) where + contramap f m = RWST $ \r s -> + contramap (\ ~(a, s', w) -> (f a, s', w)) $ runRWST m r s + {-# INLINE contramap #-} +#endif + +-- --------------------------------------------------------------------------- +-- Reader operations + +-- | Constructor for computations in the reader monad (equivalent to 'asks'). +reader :: (Monoid w, Monad m) => (r -> a) -> RWST r w s m a +reader = asks +{-# INLINE reader #-} + +-- | Fetch the value of the environment. +ask :: (Monoid w, Monad m) => RWST r w s m r +ask = RWST $ \ r s -> return (r, s, mempty) +{-# INLINE ask #-} + +-- | Execute a computation in a modified environment +-- +-- * @'runRWST' ('local' f m) r s = 'runRWST' m (f r) s@ +local :: (r -> r) -> RWST r w s m a -> RWST r w s m a +local f m = RWST $ \ r s -> runRWST m (f r) s +{-# INLINE local #-} + +-- | Retrieve a function of the current environment. +-- +-- * @'asks' f = 'liftM' f 'ask'@ +asks :: (Monoid w, Monad m) => (r -> a) -> RWST r w s m a +asks f = RWST $ \ r s -> return (f r, s, mempty) +{-# INLINE asks #-} + +-- --------------------------------------------------------------------------- +-- Writer operations + +-- | Construct a writer computation from a (result, output) pair. +writer :: (Monad m) => (a, w) -> RWST r w s m a +writer (a, w) = RWST $ \ _ s -> return (a, s, w) +{-# INLINE writer #-} + +-- | @'tell' w@ is an action that produces the output @w@. +tell :: (Monad m) => w -> RWST r w s m () +tell w = RWST $ \ _ s -> return ((),s,w) +{-# INLINE tell #-} + +-- | @'listen' m@ is an action that executes the action @m@ and adds its +-- output to the value of the computation. +-- +-- * @'runRWST' ('listen' m) r s = 'liftM' (\\ (a, w) -> ((a, w), w)) ('runRWST' m r s)@ +listen :: (Monad m) => RWST r w s m a -> RWST r w s m (a, w) +listen m = RWST $ \ r s -> do + ~(a, s', w) <- runRWST m r s + return ((a, w), s', w) +{-# INLINE listen #-} + +-- | @'listens' f m@ is an action that executes the action @m@ and adds +-- the result of applying @f@ to the output to the value of the computation. +-- +-- * @'listens' f m = 'liftM' (id *** f) ('listen' m)@ +-- +-- * @'runRWST' ('listens' f m) r s = 'liftM' (\\ (a, w) -> ((a, f w), w)) ('runRWST' m r s)@ +listens :: (Monad m) => (w -> b) -> RWST r w s m a -> RWST r w s m (a, b) +listens f m = RWST $ \ r s -> do + ~(a, s', w) <- runRWST m r s + return ((a, f w), s', w) +{-# INLINE listens #-} + +-- | @'pass' m@ is an action that executes the action @m@, which returns +-- a value and a function, and returns the value, applying the function +-- to the output. +-- +-- * @'runRWST' ('pass' m) r s = 'liftM' (\\ ((a, f), w) -> (a, f w)) ('runRWST' m r s)@ +pass :: (Monad m) => RWST r w s m (a, w -> w) -> RWST r w s m a +pass m = RWST $ \ r s -> do + ~((a, f), s', w) <- runRWST m r s + return (a, s', f w) +{-# INLINE pass #-} + +-- | @'censor' f m@ is an action that executes the action @m@ and +-- applies the function @f@ to its output, leaving the return value +-- unchanged. +-- +-- * @'censor' f m = 'pass' ('liftM' (\\ x -> (x,f)) m)@ +-- +-- * @'runRWST' ('censor' f m) r s = 'liftM' (\\ (a, w) -> (a, f w)) ('runRWST' m r s)@ +censor :: (Monad m) => (w -> w) -> RWST r w s m a -> RWST r w s m a +censor f m = RWST $ \ r s -> do + ~(a, s', w) <- runRWST m r s + return (a, s', f w) +{-# INLINE censor #-} + +-- --------------------------------------------------------------------------- +-- State operations + +-- | Construct a state monad computation from a state transformer function. +state :: (Monoid w, Monad m) => (s -> (a,s)) -> RWST r w s m a +state f = RWST $ \ _ s -> let (a,s') = f s in return (a, s', mempty) +{-# INLINE state #-} + +-- | Fetch the current value of the state within the monad. +get :: (Monoid w, Monad m) => RWST r w s m s +get = RWST $ \ _ s -> return (s, s, mempty) +{-# INLINE get #-} + +-- | @'put' s@ sets the state within the monad to @s@. +put :: (Monoid w, Monad m) => s -> RWST r w s m () +put s = RWST $ \ _ _ -> return ((), s, mempty) +{-# INLINE put #-} + +-- | @'modify' f@ is an action that updates the state to the result of +-- applying @f@ to the current state. +-- +-- * @'modify' f = 'get' >>= ('put' . f)@ +modify :: (Monoid w, Monad m) => (s -> s) -> RWST r w s m () +modify f = RWST $ \ _ s -> return ((), f s, mempty) +{-# INLINE modify #-} + +-- | Get a specific component of the state, using a projection function +-- supplied. +-- +-- * @'gets' f = 'liftM' f 'get'@ +gets :: (Monoid w, Monad m) => (s -> a) -> RWST r w s m a +gets f = RWST $ \ _ s -> return (f s, s, mempty) +{-# INLINE gets #-} + +-- | Uniform lifting of a @callCC@ operation to the new monad. +-- This version rolls back to the original state on entering the +-- continuation. +liftCallCC :: (Monoid w) => + CallCC m (a,s,w) (b,s,w) -> CallCC (RWST r w s m) a b +liftCallCC callCC f = RWST $ \ r s -> + callCC $ \ c -> + runRWST (f (\ a -> RWST $ \ _ _ -> c (a, s, mempty))) r s +{-# INLINE liftCallCC #-} + +-- | In-situ lifting of a @callCC@ operation to the new monad. +-- This version uses the current state on entering the continuation. +liftCallCC' :: (Monoid w) => + CallCC m (a,s,w) (b,s,w) -> CallCC (RWST r w s m) a b +liftCallCC' callCC f = RWST $ \ r s -> + callCC $ \ c -> + runRWST (f (\ a -> RWST $ \ _ s' -> c (a, s', mempty))) r s +{-# INLINE liftCallCC' #-} + +-- | Lift a @catchE@ operation to the new monad. +liftCatch :: Catch e m (a,s,w) -> Catch e (RWST r w s m) a +liftCatch catchE m h = + RWST $ \ r s -> runRWST m r s `catchE` \ e -> runRWST (h e) r s +{-# INLINE liftCatch #-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS/Strict.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS/Strict.hs new file mode 100644 index 000000000000..557dd2028dd0 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS/Strict.hs @@ -0,0 +1,392 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.RWS.Strict +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- A monad transformer that combines 'ReaderT', 'WriterT' and 'StateT'. +-- This version is strict; for a lazy version with the same interface, +-- see "Control.Monad.Trans.RWS.Lazy". +-- Although the output is built strictly, it is not possible to +-- achieve constant space behaviour with this transformer: for that, +-- use "Control.Monad.Trans.RWS.CPS" instead. +----------------------------------------------------------------------------- + +module Control.Monad.Trans.RWS.Strict ( + -- * The RWS monad + RWS, + rws, + runRWS, + evalRWS, + execRWS, + mapRWS, + withRWS, + -- * The RWST monad transformer + RWST(..), + evalRWST, + execRWST, + mapRWST, + withRWST, + -- * Reader operations + reader, + ask, + local, + asks, + -- * Writer operations + writer, + tell, + listen, + listens, + pass, + censor, + -- * State operations + state, + get, + put, + modify, + gets, + -- * Lifting other operations + liftCallCC, + liftCallCC', + liftCatch, + ) where + +import Control.Monad.IO.Class +import Control.Monad.Signatures +import Control.Monad.Trans.Class +#if MIN_VERSION_base(4,12,0) +import Data.Functor.Contravariant +#endif +import Data.Functor.Identity + +import Control.Applicative +import Control.Monad +#if MIN_VERSION_base(4,9,0) +import qualified Control.Monad.Fail as Fail +#endif +import Control.Monad.Fix +import Data.Monoid + +-- | A monad containing an environment of type @r@, output of type @w@ +-- and an updatable state of type @s@. +type RWS r w s = RWST r w s Identity + +-- | Construct an RWS computation from a function. +-- (The inverse of 'runRWS'.) +rws :: (r -> s -> (a, s, w)) -> RWS r w s a +rws f = RWST (\ r s -> Identity (f r s)) +{-# INLINE rws #-} + +-- | Unwrap an RWS computation as a function. +-- (The inverse of 'rws'.) +runRWS :: RWS r w s a -> r -> s -> (a, s, w) +runRWS m r s = runIdentity (runRWST m r s) +{-# INLINE runRWS #-} + +-- | Evaluate a computation with the given initial state and environment, +-- returning the final value and output, discarding the final state. +evalRWS :: RWS r w s a -- ^RWS computation to execute + -> r -- ^initial environment + -> s -- ^initial value + -> (a, w) -- ^final value and output +evalRWS m r s = let + (a, _, w) = runRWS m r s + in (a, w) +{-# INLINE evalRWS #-} + +-- | Evaluate a computation with the given initial state and environment, +-- returning the final state and output, discarding the final value. +execRWS :: RWS r w s a -- ^RWS computation to execute + -> r -- ^initial environment + -> s -- ^initial value + -> (s, w) -- ^final state and output +execRWS m r s = let + (_, s', w) = runRWS m r s + in (s', w) +{-# INLINE execRWS #-} + +-- | Map the return value, final state and output of a computation using +-- the given function. +-- +-- * @'runRWS' ('mapRWS' f m) r s = f ('runRWS' m r s)@ +mapRWS :: ((a, s, w) -> (b, s, w')) -> RWS r w s a -> RWS r w' s b +mapRWS f = mapRWST (Identity . f . runIdentity) +{-# INLINE mapRWS #-} + +-- | @'withRWS' f m@ executes action @m@ with an initial environment +-- and state modified by applying @f@. +-- +-- * @'runRWS' ('withRWS' f m) r s = 'uncurry' ('runRWS' m) (f r s)@ +withRWS :: (r' -> s -> (r, s)) -> RWS r w s a -> RWS r' w s a +withRWS = withRWST +{-# INLINE withRWS #-} + +-- --------------------------------------------------------------------------- +-- | A monad transformer adding reading an environment of type @r@, +-- collecting an output of type @w@ and updating a state of type @s@ +-- to an inner monad @m@. +newtype RWST r w s m a = RWST { runRWST :: r -> s -> m (a, s, w) } + +-- | Evaluate a computation with the given initial state and environment, +-- returning the final value and output, discarding the final state. +evalRWST :: (Monad m) + => RWST r w s m a -- ^computation to execute + -> r -- ^initial environment + -> s -- ^initial value + -> m (a, w) -- ^computation yielding final value and output +evalRWST m r s = do + (a, _, w) <- runRWST m r s + return (a, w) +{-# INLINE evalRWST #-} + +-- | Evaluate a computation with the given initial state and environment, +-- returning the final state and output, discarding the final value. +execRWST :: (Monad m) + => RWST r w s m a -- ^computation to execute + -> r -- ^initial environment + -> s -- ^initial value + -> m (s, w) -- ^computation yielding final state and output +execRWST m r s = do + (_, s', w) <- runRWST m r s + return (s', w) +{-# INLINE execRWST #-} + +-- | Map the inner computation using the given function. +-- +-- * @'runRWST' ('mapRWST' f m) r s = f ('runRWST' m r s)@ +mapRWST :: (m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b +mapRWST f m = RWST $ \ r s -> f (runRWST m r s) +{-# INLINE mapRWST #-} + +-- | @'withRWST' f m@ executes action @m@ with an initial environment +-- and state modified by applying @f@. +-- +-- * @'runRWST' ('withRWST' f m) r s = 'uncurry' ('runRWST' m) (f r s)@ +withRWST :: (r' -> s -> (r, s)) -> RWST r w s m a -> RWST r' w s m a +withRWST f m = RWST $ \ r s -> uncurry (runRWST m) (f r s) +{-# INLINE withRWST #-} + +instance (Functor m) => Functor (RWST r w s m) where + fmap f m = RWST $ \ r s -> + fmap (\ (a, s', w) -> (f a, s', w)) $ runRWST m r s + {-# INLINE fmap #-} + +instance (Monoid w, Functor m, Monad m) => Applicative (RWST r w s m) where + pure a = RWST $ \ _ s -> return (a, s, mempty) + {-# INLINE pure #-} + RWST mf <*> RWST mx = RWST $ \ r s -> do + (f, s', w) <- mf r s + (x, s'',w') <- mx r s' + return (f x, s'', w `mappend` w') + {-# INLINE (<*>) #-} + +instance (Monoid w, Functor m, MonadPlus m) => Alternative (RWST r w s m) where + empty = RWST $ \ _ _ -> mzero + {-# INLINE empty #-} + RWST m <|> RWST n = RWST $ \ r s -> m r s `mplus` n r s + {-# INLINE (<|>) #-} + +instance (Monoid w, Monad m) => Monad (RWST r w s m) where +#if !(MIN_VERSION_base(4,8,0)) + return a = RWST $ \ _ s -> return (a, s, mempty) + {-# INLINE return #-} +#endif + m >>= k = RWST $ \ r s -> do + (a, s', w) <- runRWST m r s + (b, s'',w') <- runRWST (k a) r s' + return (b, s'', w `mappend` w') + {-# INLINE (>>=) #-} +#if !(MIN_VERSION_base(4,13,0)) + fail msg = RWST $ \ _ _ -> fail msg + {-# INLINE fail #-} +#endif + +#if MIN_VERSION_base(4,9,0) +instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (RWST r w s m) where + fail msg = RWST $ \ _ _ -> Fail.fail msg + {-# INLINE fail #-} +#endif + +instance (Monoid w, MonadPlus m) => MonadPlus (RWST r w s m) where + mzero = RWST $ \ _ _ -> mzero + {-# INLINE mzero #-} + RWST m `mplus` RWST n = RWST $ \ r s -> m r s `mplus` n r s + {-# INLINE mplus #-} + +instance (Monoid w, MonadFix m) => MonadFix (RWST r w s m) where + mfix f = RWST $ \ r s -> mfix $ \ ~(a, _, _) -> runRWST (f a) r s + {-# INLINE mfix #-} + +instance (Monoid w) => MonadTrans (RWST r w s) where + lift m = RWST $ \ _ s -> do + a <- m + return (a, s, mempty) + {-# INLINE lift #-} + +instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where + liftIO = lift . liftIO + {-# INLINE liftIO #-} + +#if MIN_VERSION_base(4,12,0) +instance Contravariant m => Contravariant (RWST r w s m) where + contramap f m = RWST $ \r s -> + contramap (\ (a, s', w) -> (f a, s', w)) $ runRWST m r s + {-# INLINE contramap #-} +#endif + +-- --------------------------------------------------------------------------- +-- Reader operations + +-- | Constructor for computations in the reader monad (equivalent to 'asks'). +reader :: (Monoid w, Monad m) => (r -> a) -> RWST r w s m a +reader = asks +{-# INLINE reader #-} + +-- | Fetch the value of the environment. +ask :: (Monoid w, Monad m) => RWST r w s m r +ask = RWST $ \ r s -> return (r, s, mempty) +{-# INLINE ask #-} + +-- | Execute a computation in a modified environment +-- +-- * @'runRWST' ('local' f m) r s = 'runRWST' m (f r) s@ +local :: (r -> r) -> RWST r w s m a -> RWST r w s m a +local f m = RWST $ \ r s -> runRWST m (f r) s +{-# INLINE local #-} + +-- | Retrieve a function of the current environment. +-- +-- * @'asks' f = 'liftM' f 'ask'@ +asks :: (Monoid w, Monad m) => (r -> a) -> RWST r w s m a +asks f = RWST $ \ r s -> return (f r, s, mempty) +{-# INLINE asks #-} + +-- --------------------------------------------------------------------------- +-- Writer operations + +-- | Construct a writer computation from a (result, output) pair. +writer :: (Monad m) => (a, w) -> RWST r w s m a +writer (a, w) = RWST $ \ _ s -> return (a, s, w) +{-# INLINE writer #-} + +-- | @'tell' w@ is an action that produces the output @w@. +tell :: (Monad m) => w -> RWST r w s m () +tell w = RWST $ \ _ s -> return ((),s,w) +{-# INLINE tell #-} + +-- | @'listen' m@ is an action that executes the action @m@ and adds its +-- output to the value of the computation. +-- +-- * @'runRWST' ('listen' m) r s = 'liftM' (\\ (a, w) -> ((a, w), w)) ('runRWST' m r s)@ +listen :: (Monad m) => RWST r w s m a -> RWST r w s m (a, w) +listen m = RWST $ \ r s -> do + (a, s', w) <- runRWST m r s + return ((a, w), s', w) +{-# INLINE listen #-} + +-- | @'listens' f m@ is an action that executes the action @m@ and adds +-- the result of applying @f@ to the output to the value of the computation. +-- +-- * @'listens' f m = 'liftM' (id *** f) ('listen' m)@ +-- +-- * @'runRWST' ('listens' f m) r s = 'liftM' (\\ (a, w) -> ((a, f w), w)) ('runRWST' m r s)@ +listens :: (Monad m) => (w -> b) -> RWST r w s m a -> RWST r w s m (a, b) +listens f m = RWST $ \ r s -> do + (a, s', w) <- runRWST m r s + return ((a, f w), s', w) +{-# INLINE listens #-} + +-- | @'pass' m@ is an action that executes the action @m@, which returns +-- a value and a function, and returns the value, applying the function +-- to the output. +-- +-- * @'runRWST' ('pass' m) r s = 'liftM' (\\ ((a, f), w) -> (a, f w)) ('runRWST' m r s)@ +pass :: (Monad m) => RWST r w s m (a, w -> w) -> RWST r w s m a +pass m = RWST $ \ r s -> do + ((a, f), s', w) <- runRWST m r s + return (a, s', f w) +{-# INLINE pass #-} + +-- | @'censor' f m@ is an action that executes the action @m@ and +-- applies the function @f@ to its output, leaving the return value +-- unchanged. +-- +-- * @'censor' f m = 'pass' ('liftM' (\\ x -> (x,f)) m)@ +-- +-- * @'runRWST' ('censor' f m) r s = 'liftM' (\\ (a, w) -> (a, f w)) ('runRWST' m r s)@ +censor :: (Monad m) => (w -> w) -> RWST r w s m a -> RWST r w s m a +censor f m = RWST $ \ r s -> do + (a, s', w) <- runRWST m r s + return (a, s', f w) +{-# INLINE censor #-} + +-- --------------------------------------------------------------------------- +-- State operations + +-- | Construct a state monad computation from a state transformer function. +state :: (Monoid w, Monad m) => (s -> (a,s)) -> RWST r w s m a +state f = RWST $ \ _ s -> case f s of (a,s') -> return (a, s', mempty) +{-# INLINE state #-} + +-- | Fetch the current value of the state within the monad. +get :: (Monoid w, Monad m) => RWST r w s m s +get = RWST $ \ _ s -> return (s, s, mempty) +{-# INLINE get #-} + +-- | @'put' s@ sets the state within the monad to @s@. +put :: (Monoid w, Monad m) => s -> RWST r w s m () +put s = RWST $ \ _ _ -> return ((), s, mempty) +{-# INLINE put #-} + +-- | @'modify' f@ is an action that updates the state to the result of +-- applying @f@ to the current state. +-- +-- * @'modify' f = 'get' >>= ('put' . f)@ +modify :: (Monoid w, Monad m) => (s -> s) -> RWST r w s m () +modify f = RWST $ \ _ s -> return ((), f s, mempty) +{-# INLINE modify #-} + +-- | Get a specific component of the state, using a projection function +-- supplied. +-- +-- * @'gets' f = 'liftM' f 'get'@ +gets :: (Monoid w, Monad m) => (s -> a) -> RWST r w s m a +gets f = RWST $ \ _ s -> return (f s, s, mempty) +{-# INLINE gets #-} + +-- | Uniform lifting of a @callCC@ operation to the new monad. +-- This version rolls back to the original state on entering the +-- continuation. +liftCallCC :: (Monoid w) => + CallCC m (a,s,w) (b,s,w) -> CallCC (RWST r w s m) a b +liftCallCC callCC f = RWST $ \ r s -> + callCC $ \ c -> + runRWST (f (\ a -> RWST $ \ _ _ -> c (a, s, mempty))) r s +{-# INLINE liftCallCC #-} + +-- | In-situ lifting of a @callCC@ operation to the new monad. +-- This version uses the current state on entering the continuation. +liftCallCC' :: (Monoid w) => + CallCC m (a,s,w) (b,s,w) -> CallCC (RWST r w s m) a b +liftCallCC' callCC f = RWST $ \ r s -> + callCC $ \ c -> + runRWST (f (\ a -> RWST $ \ _ s' -> c (a, s', mempty))) r s +{-# INLINE liftCallCC' #-} + +-- | Lift a @catchE@ operation to the new monad. +liftCatch :: Catch e m (a,s,w) -> Catch e (RWST r w s m) a +liftCatch catchE m h = + RWST $ \ r s -> runRWST m r s `catchE` \ e -> runRWST (h e) r s +{-# INLINE liftCatch #-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Reader.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Reader.hs new file mode 100644 index 000000000000..25e3ad27c3c6 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Reader.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Reader +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- Declaration of the 'ReaderT' monad transformer, which adds a static +-- environment to a given monad. +-- +-- If the computation is to modify the stored information, use +-- "Control.Monad.Trans.State" instead. +----------------------------------------------------------------------------- + +module Control.Monad.Trans.Reader ( + -- * The Reader monad + Reader, + reader, + runReader, + mapReader, + withReader, + -- * The ReaderT monad transformer + ReaderT(..), + mapReaderT, + withReaderT, + -- * Reader operations + ask, + local, + asks, + -- * Lifting other operations + liftCallCC, + liftCatch, + ) where + +import Control.Monad.IO.Class +import Control.Monad.Signatures +import Control.Monad.Trans.Class +#if MIN_VERSION_base(4,12,0) +import Data.Functor.Contravariant +#endif +import Data.Functor.Identity + +import Control.Applicative +import Control.Monad +#if MIN_VERSION_base(4,9,0) +import qualified Control.Monad.Fail as Fail +#endif +import Control.Monad.Fix +#if !(MIN_VERSION_base(4,6,0)) +import Control.Monad.Instances () -- deprecated from base-4.6 +#endif +#if MIN_VERSION_base(4,4,0) +import Control.Monad.Zip (MonadZip(mzipWith)) +#endif +#if MIN_VERSION_base(4,2,0) +import Data.Functor(Functor(..)) +#endif + +-- | The parameterizable reader monad. +-- +-- Computations are functions of a shared environment. +-- +-- The 'return' function ignores the environment, while @>>=@ passes +-- the inherited environment to both subcomputations. +type Reader r = ReaderT r Identity + +-- | Constructor for computations in the reader monad (equivalent to 'asks'). +reader :: (Monad m) => (r -> a) -> ReaderT r m a +reader f = ReaderT (return . f) +{-# INLINE reader #-} + +-- | Runs a @Reader@ and extracts the final value from it. +-- (The inverse of 'reader'.) +runReader + :: Reader r a -- ^ A @Reader@ to run. + -> r -- ^ An initial environment. + -> a +runReader m = runIdentity . runReaderT m +{-# INLINE runReader #-} + +-- | Transform the value returned by a @Reader@. +-- +-- * @'runReader' ('mapReader' f m) = f . 'runReader' m@ +mapReader :: (a -> b) -> Reader r a -> Reader r b +mapReader f = mapReaderT (Identity . f . runIdentity) +{-# INLINE mapReader #-} + +-- | Execute a computation in a modified environment +-- (a specialization of 'withReaderT'). +-- +-- * @'runReader' ('withReader' f m) = 'runReader' m . f@ +withReader + :: (r' -> r) -- ^ The function to modify the environment. + -> Reader r a -- ^ Computation to run in the modified environment. + -> Reader r' a +withReader = withReaderT +{-# INLINE withReader #-} + +-- | The reader monad transformer, +-- which adds a read-only environment to the given monad. +-- +-- The 'return' function ignores the environment, while @>>=@ passes +-- the inherited environment to both subcomputations. +newtype ReaderT r m a = ReaderT { runReaderT :: r -> m a } + +-- | Transform the computation inside a @ReaderT@. +-- +-- * @'runReaderT' ('mapReaderT' f m) = f . 'runReaderT' m@ +mapReaderT :: (m a -> n b) -> ReaderT r m a -> ReaderT r n b +mapReaderT f m = ReaderT $ f . runReaderT m +{-# INLINE mapReaderT #-} + +-- | Execute a computation in a modified environment +-- (a more general version of 'local'). +-- +-- * @'runReaderT' ('withReaderT' f m) = 'runReaderT' m . f@ +withReaderT + :: (r' -> r) -- ^ The function to modify the environment. + -> ReaderT r m a -- ^ Computation to run in the modified environment. + -> ReaderT r' m a +withReaderT f m = ReaderT $ runReaderT m . f +{-# INLINE withReaderT #-} + +instance (Functor m) => Functor (ReaderT r m) where + fmap f = mapReaderT (fmap f) + {-# INLINE fmap #-} +#if MIN_VERSION_base(4,2,0) + x <$ v = mapReaderT (x <$) v + {-# INLINE (<$) #-} +#endif + +instance (Applicative m) => Applicative (ReaderT r m) where + pure = liftReaderT . pure + {-# INLINE pure #-} + f <*> v = ReaderT $ \ r -> runReaderT f r <*> runReaderT v r + {-# INLINE (<*>) #-} +#if MIN_VERSION_base(4,2,0) + u *> v = ReaderT $ \ r -> runReaderT u r *> runReaderT v r + {-# INLINE (*>) #-} + u <* v = ReaderT $ \ r -> runReaderT u r <* runReaderT v r + {-# INLINE (<*) #-} +#endif +#if MIN_VERSION_base(4,10,0) + liftA2 f x y = ReaderT $ \ r -> liftA2 f (runReaderT x r) (runReaderT y r) + {-# INLINE liftA2 #-} +#endif + +instance (Alternative m) => Alternative (ReaderT r m) where + empty = liftReaderT empty + {-# INLINE empty #-} + m <|> n = ReaderT $ \ r -> runReaderT m r <|> runReaderT n r + {-# INLINE (<|>) #-} + +instance (Monad m) => Monad (ReaderT r m) where +#if !(MIN_VERSION_base(4,8,0)) + return = lift . return + {-# INLINE return #-} +#endif + m >>= k = ReaderT $ \ r -> do + a <- runReaderT m r + runReaderT (k a) r + {-# INLINE (>>=) #-} +#if MIN_VERSION_base(4,8,0) + (>>) = (*>) +#else + m >> k = ReaderT $ \ r -> runReaderT m r >> runReaderT k r +#endif + {-# INLINE (>>) #-} +#if !(MIN_VERSION_base(4,13,0)) + fail msg = lift (fail msg) + {-# INLINE fail #-} +#endif + +#if MIN_VERSION_base(4,9,0) +instance (Fail.MonadFail m) => Fail.MonadFail (ReaderT r m) where + fail msg = lift (Fail.fail msg) + {-# INLINE fail #-} +#endif + +instance (MonadPlus m) => MonadPlus (ReaderT r m) where + mzero = lift mzero + {-# INLINE mzero #-} + m `mplus` n = ReaderT $ \ r -> runReaderT m r `mplus` runReaderT n r + {-# INLINE mplus #-} + +instance (MonadFix m) => MonadFix (ReaderT r m) where + mfix f = ReaderT $ \ r -> mfix $ \ a -> runReaderT (f a) r + {-# INLINE mfix #-} + +instance MonadTrans (ReaderT r) where + lift = liftReaderT + {-# INLINE lift #-} + +instance (MonadIO m) => MonadIO (ReaderT r m) where + liftIO = lift . liftIO + {-# INLINE liftIO #-} + +#if MIN_VERSION_base(4,4,0) +instance (MonadZip m) => MonadZip (ReaderT r m) where + mzipWith f (ReaderT m) (ReaderT n) = ReaderT $ \ a -> + mzipWith f (m a) (n a) + {-# INLINE mzipWith #-} +#endif + +#if MIN_VERSION_base(4,12,0) +instance Contravariant m => Contravariant (ReaderT r m) where + contramap f = ReaderT . fmap (contramap f) . runReaderT + {-# INLINE contramap #-} +#endif + +liftReaderT :: m a -> ReaderT r m a +liftReaderT m = ReaderT (const m) +{-# INLINE liftReaderT #-} + +-- | Fetch the value of the environment. +ask :: (Monad m) => ReaderT r m r +ask = ReaderT return +{-# INLINE ask #-} + +-- | Execute a computation in a modified environment +-- (a specialization of 'withReaderT'). +-- +-- * @'runReaderT' ('local' f m) = 'runReaderT' m . f@ +local + :: (r -> r) -- ^ The function to modify the environment. + -> ReaderT r m a -- ^ Computation to run in the modified environment. + -> ReaderT r m a +local = withReaderT +{-# INLINE local #-} + +-- | Retrieve a function of the current environment. +-- +-- * @'asks' f = 'liftM' f 'ask'@ +asks :: (Monad m) + => (r -> a) -- ^ The selector function to apply to the environment. + -> ReaderT r m a +asks f = ReaderT (return . f) +{-# INLINE asks #-} + +-- | Lift a @callCC@ operation to the new monad. +liftCallCC :: CallCC m a b -> CallCC (ReaderT r m) a b +liftCallCC callCC f = ReaderT $ \ r -> + callCC $ \ c -> + runReaderT (f (ReaderT . const . c)) r +{-# INLINE liftCallCC #-} + +-- | Lift a @catchE@ operation to the new monad. +liftCatch :: Catch e m a -> Catch e (ReaderT r m) a +liftCatch f m h = + ReaderT $ \ r -> f (runReaderT m r) (\ e -> runReaderT (h e) r) +{-# INLINE liftCatch #-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Select.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Select.hs new file mode 100644 index 000000000000..22fdf8fd8abc --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Select.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE PolyKinds #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Select +-- Copyright : (c) Ross Paterson 2017 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- Selection monad transformer, modelling search algorithms. +-- +-- * Martin Escardo and Paulo Oliva. +-- "Selection functions, bar recursion and backward induction", +-- /Mathematical Structures in Computer Science/ 20:2 (2010), pp. 127-168. +-- <https://www.cs.bham.ac.uk/~mhe/papers/selection-escardo-oliva.pdf> +-- +-- * Jules Hedges. "Monad transformers for backtracking search". +-- In /Proceedings of MSFP 2014/. <https://arxiv.org/abs/1406.2058> +----------------------------------------------------------------------------- + +module Control.Monad.Trans.Select ( + -- * The Select monad + Select, + select, + runSelect, + mapSelect, + -- * The SelectT monad transformer + SelectT(SelectT), + runSelectT, + mapSelectT, + -- * Monad transformation + selectToContT, + selectToCont, + ) where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Cont + +import Control.Applicative +import Control.Monad +#if MIN_VERSION_base(4,9,0) +import qualified Control.Monad.Fail as Fail +#endif +import Data.Functor.Identity + +-- | Selection monad. +type Select r = SelectT r Identity + +-- | Constructor for computations in the selection monad. +select :: ((a -> r) -> a) -> Select r a +select f = SelectT $ \ k -> Identity (f (runIdentity . k)) +{-# INLINE select #-} + +-- | Runs a @Select@ computation with a function for evaluating answers +-- to select a particular answer. (The inverse of 'select'.) +runSelect :: Select r a -> (a -> r) -> a +runSelect m k = runIdentity (runSelectT m (Identity . k)) +{-# INLINE runSelect #-} + +-- | Apply a function to transform the result of a selection computation. +-- +-- * @'runSelect' ('mapSelect' f m) = f . 'runSelect' m@ +mapSelect :: (a -> a) -> Select r a -> Select r a +mapSelect f = mapSelectT (Identity . f . runIdentity) +{-# INLINE mapSelect #-} + +-- | Selection monad transformer. +-- +-- 'SelectT' is not a functor on the category of monads, and many operations +-- cannot be lifted through it. +newtype SelectT r m a = SelectT ((a -> m r) -> m a) + +-- | Runs a @SelectT@ computation with a function for evaluating answers +-- to select a particular answer. (The inverse of 'select'.) +runSelectT :: SelectT r m a -> (a -> m r) -> m a +runSelectT (SelectT g) = g +{-# INLINE runSelectT #-} + +-- | Apply a function to transform the result of a selection computation. +-- This has a more restricted type than the @map@ operations for other +-- monad transformers, because 'SelectT' does not define a functor in +-- the category of monads. +-- +-- * @'runSelectT' ('mapSelectT' f m) = f . 'runSelectT' m@ +mapSelectT :: (m a -> m a) -> SelectT r m a -> SelectT r m a +mapSelectT f m = SelectT $ f . runSelectT m +{-# INLINE mapSelectT #-} + +instance (Functor m) => Functor (SelectT r m) where + fmap f (SelectT g) = SelectT (fmap f . g . (. f)) + {-# INLINE fmap #-} + +instance (Functor m, Monad m) => Applicative (SelectT r m) where + pure = lift . return + {-# INLINE pure #-} + SelectT gf <*> SelectT gx = SelectT $ \ k -> do + let h f = liftM f (gx (k . f)) + f <- gf ((>>= k) . h) + h f + {-# INLINE (<*>) #-} + m *> k = m >>= \_ -> k + {-# INLINE (*>) #-} + +instance (Functor m, MonadPlus m) => Alternative (SelectT r m) where + empty = mzero + {-# INLINE empty #-} + (<|>) = mplus + {-# INLINE (<|>) #-} + +instance (Monad m) => Monad (SelectT r m) where +#if !(MIN_VERSION_base(4,8,0)) + return = lift . return + {-# INLINE return #-} +#endif + SelectT g >>= f = SelectT $ \ k -> do + let h x = runSelectT (f x) k + y <- g ((>>= k) . h) + h y + {-# INLINE (>>=) #-} + +#if MIN_VERSION_base(4,9,0) +instance (Fail.MonadFail m) => Fail.MonadFail (SelectT r m) where + fail msg = lift (Fail.fail msg) + {-# INLINE fail #-} +#endif + +instance (MonadPlus m) => MonadPlus (SelectT r m) where + mzero = SelectT (const mzero) + {-# INLINE mzero #-} + SelectT f `mplus` SelectT g = SelectT $ \ k -> f k `mplus` g k + {-# INLINE mplus #-} + +instance MonadTrans (SelectT r) where + lift = SelectT . const + {-# INLINE lift #-} + +instance (MonadIO m) => MonadIO (SelectT r m) where + liftIO = lift . liftIO + {-# INLINE liftIO #-} + +-- | Convert a selection computation to a continuation-passing computation. +selectToContT :: (Monad m) => SelectT r m a -> ContT r m a +selectToContT (SelectT g) = ContT $ \ k -> g k >>= k +{-# INLINE selectToCont #-} + +-- | Deprecated name for 'selectToContT'. +{-# DEPRECATED selectToCont "Use selectToContT instead" #-} +selectToCont :: (Monad m) => SelectT r m a -> ContT r m a +selectToCont = selectToContT diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/State.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/State.hs new file mode 100644 index 000000000000..36de964ea1d3 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/State.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.State +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- State monads, passing an updatable state through a computation. +-- +-- Some computations may not require the full power of state transformers: +-- +-- * For a read-only state, see "Control.Monad.Trans.Reader". +-- +-- * To accumulate a value without using it on the way, see +-- "Control.Monad.Trans.Writer". +-- +-- This version is lazy; for a strict version, see +-- "Control.Monad.Trans.State.Strict", which has the same interface. +----------------------------------------------------------------------------- + +module Control.Monad.Trans.State ( + module Control.Monad.Trans.State.Lazy + ) where + +import Control.Monad.Trans.State.Lazy diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/State/Lazy.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/State/Lazy.hs new file mode 100644 index 000000000000..d7cdde5444a8 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/State/Lazy.hs @@ -0,0 +1,428 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.State.Lazy +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- Lazy state monads, passing an updatable state through a computation. +-- See below for examples. +-- +-- Some computations may not require the full power of state transformers: +-- +-- * For a read-only state, see "Control.Monad.Trans.Reader". +-- +-- * To accumulate a value without using it on the way, see +-- "Control.Monad.Trans.Writer". +-- +-- In this version, sequencing of computations is lazy, so that for +-- example the following produces a usable result: +-- +-- > evalState (sequence $ repeat $ do { n <- get; put (n*2); return n }) 1 +-- +-- For a strict version with the same interface, see +-- "Control.Monad.Trans.State.Strict". +----------------------------------------------------------------------------- + +module Control.Monad.Trans.State.Lazy ( + -- * The State monad + State, + state, + runState, + evalState, + execState, + mapState, + withState, + -- * The StateT monad transformer + StateT(..), + evalStateT, + execStateT, + mapStateT, + withStateT, + -- * State operations + get, + put, + modify, + modify', + gets, + -- * Lifting other operations + liftCallCC, + liftCallCC', + liftCatch, + liftListen, + liftPass, + -- * Examples + -- ** State monads + -- $examples + + -- ** Counting + -- $counting + + -- ** Labelling trees + -- $labelling + ) where + +import Control.Monad.IO.Class +import Control.Monad.Signatures +import Control.Monad.Trans.Class +#if MIN_VERSION_base(4,12,0) +import Data.Functor.Contravariant +#endif +import Data.Functor.Identity + +import Control.Applicative +import Control.Monad +#if MIN_VERSION_base(4,9,0) +import qualified Control.Monad.Fail as Fail +#endif +import Control.Monad.Fix + +-- --------------------------------------------------------------------------- +-- | A state monad parameterized by the type @s@ of the state to carry. +-- +-- The 'return' function leaves the state unchanged, while @>>=@ uses +-- the final state of the first computation as the initial state of +-- the second. +type State s = StateT s Identity + +-- | Construct a state monad computation from a function. +-- (The inverse of 'runState'.) +state :: (Monad m) + => (s -> (a, s)) -- ^pure state transformer + -> StateT s m a -- ^equivalent state-passing computation +state f = StateT (return . f) +{-# INLINE state #-} + +-- | Unwrap a state monad computation as a function. +-- (The inverse of 'state'.) +runState :: State s a -- ^state-passing computation to execute + -> s -- ^initial state + -> (a, s) -- ^return value and final state +runState m = runIdentity . runStateT m +{-# INLINE runState #-} + +-- | Evaluate a state computation with the given initial state +-- and return the final value, discarding the final state. +-- +-- * @'evalState' m s = 'fst' ('runState' m s)@ +evalState :: State s a -- ^state-passing computation to execute + -> s -- ^initial value + -> a -- ^return value of the state computation +evalState m s = fst (runState m s) +{-# INLINE evalState #-} + +-- | Evaluate a state computation with the given initial state +-- and return the final state, discarding the final value. +-- +-- * @'execState' m s = 'snd' ('runState' m s)@ +execState :: State s a -- ^state-passing computation to execute + -> s -- ^initial value + -> s -- ^final state +execState m s = snd (runState m s) +{-# INLINE execState #-} + +-- | Map both the return value and final state of a computation using +-- the given function. +-- +-- * @'runState' ('mapState' f m) = f . 'runState' m@ +mapState :: ((a, s) -> (b, s)) -> State s a -> State s b +mapState f = mapStateT (Identity . f . runIdentity) +{-# INLINE mapState #-} + +-- | @'withState' f m@ executes action @m@ on a state modified by +-- applying @f@. +-- +-- * @'withState' f m = 'modify' f >> m@ +withState :: (s -> s) -> State s a -> State s a +withState = withStateT +{-# INLINE withState #-} + +-- --------------------------------------------------------------------------- +-- | A state transformer monad parameterized by: +-- +-- * @s@ - The state. +-- +-- * @m@ - The inner monad. +-- +-- The 'return' function leaves the state unchanged, while @>>=@ uses +-- the final state of the first computation as the initial state of +-- the second. +newtype StateT s m a = StateT { runStateT :: s -> m (a,s) } + +-- | Evaluate a state computation with the given initial state +-- and return the final value, discarding the final state. +-- +-- * @'evalStateT' m s = 'liftM' 'fst' ('runStateT' m s)@ +evalStateT :: (Monad m) => StateT s m a -> s -> m a +evalStateT m s = do + ~(a, _) <- runStateT m s + return a +{-# INLINE evalStateT #-} + +-- | Evaluate a state computation with the given initial state +-- and return the final state, discarding the final value. +-- +-- * @'execStateT' m s = 'liftM' 'snd' ('runStateT' m s)@ +execStateT :: (Monad m) => StateT s m a -> s -> m s +execStateT m s = do + ~(_, s') <- runStateT m s + return s' +{-# INLINE execStateT #-} + +-- | Map both the return value and final state of a computation using +-- the given function. +-- +-- * @'runStateT' ('mapStateT' f m) = f . 'runStateT' m@ +mapStateT :: (m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b +mapStateT f m = StateT $ f . runStateT m +{-# INLINE mapStateT #-} + +-- | @'withStateT' f m@ executes action @m@ on a state modified by +-- applying @f@. +-- +-- * @'withStateT' f m = 'modify' f >> m@ +withStateT :: (s -> s) -> StateT s m a -> StateT s m a +withStateT f m = StateT $ runStateT m . f +{-# INLINE withStateT #-} + +instance (Functor m) => Functor (StateT s m) where + fmap f m = StateT $ \ s -> + fmap (\ ~(a, s') -> (f a, s')) $ runStateT m s + {-# INLINE fmap #-} + +instance (Functor m, Monad m) => Applicative (StateT s m) where + pure a = StateT $ \ s -> return (a, s) + {-# INLINE pure #-} + StateT mf <*> StateT mx = StateT $ \ s -> do + ~(f, s') <- mf s + ~(x, s'') <- mx s' + return (f x, s'') + {-# INLINE (<*>) #-} + m *> k = m >>= \_ -> k + {-# INLINE (*>) #-} + +instance (Functor m, MonadPlus m) => Alternative (StateT s m) where + empty = StateT $ \ _ -> mzero + {-# INLINE empty #-} + StateT m <|> StateT n = StateT $ \ s -> m s `mplus` n s + {-# INLINE (<|>) #-} + +instance (Monad m) => Monad (StateT s m) where +#if !(MIN_VERSION_base(4,8,0)) + return a = StateT $ \ s -> return (a, s) + {-# INLINE return #-} +#endif + m >>= k = StateT $ \ s -> do + ~(a, s') <- runStateT m s + runStateT (k a) s' + {-# INLINE (>>=) #-} +#if !(MIN_VERSION_base(4,13,0)) + fail str = StateT $ \ _ -> fail str + {-# INLINE fail #-} +#endif + +#if MIN_VERSION_base(4,9,0) +instance (Fail.MonadFail m) => Fail.MonadFail (StateT s m) where + fail str = StateT $ \ _ -> Fail.fail str + {-# INLINE fail #-} +#endif + +instance (MonadPlus m) => MonadPlus (StateT s m) where + mzero = StateT $ \ _ -> mzero + {-# INLINE mzero #-} + StateT m `mplus` StateT n = StateT $ \ s -> m s `mplus` n s + {-# INLINE mplus #-} + +instance (MonadFix m) => MonadFix (StateT s m) where + mfix f = StateT $ \ s -> mfix $ \ ~(a, _) -> runStateT (f a) s + {-# INLINE mfix #-} + +instance MonadTrans (StateT s) where + lift m = StateT $ \ s -> do + a <- m + return (a, s) + {-# INLINE lift #-} + +instance (MonadIO m) => MonadIO (StateT s m) where + liftIO = lift . liftIO + {-# INLINE liftIO #-} + +#if MIN_VERSION_base(4,12,0) +instance Contravariant m => Contravariant (StateT s m) where + contramap f m = StateT $ \s -> + contramap (\ ~(a, s') -> (f a, s')) $ runStateT m s + {-# INLINE contramap #-} +#endif + +-- | Fetch the current value of the state within the monad. +get :: (Monad m) => StateT s m s +get = state $ \ s -> (s, s) +{-# INLINE get #-} + +-- | @'put' s@ sets the state within the monad to @s@. +put :: (Monad m) => s -> StateT s m () +put s = state $ \ _ -> ((), s) +{-# INLINE put #-} + +-- | @'modify' f@ is an action that updates the state to the result of +-- applying @f@ to the current state. +-- +-- * @'modify' f = 'get' >>= ('put' . f)@ +modify :: (Monad m) => (s -> s) -> StateT s m () +modify f = state $ \ s -> ((), f s) +{-# INLINE modify #-} + +-- | A variant of 'modify' in which the computation is strict in the +-- new state. +-- +-- * @'modify'' f = 'get' >>= (('$!') 'put' . f)@ +modify' :: (Monad m) => (s -> s) -> StateT s m () +modify' f = do + s <- get + put $! f s +{-# INLINE modify' #-} + +-- | Get a specific component of the state, using a projection function +-- supplied. +-- +-- * @'gets' f = 'liftM' f 'get'@ +gets :: (Monad m) => (s -> a) -> StateT s m a +gets f = state $ \ s -> (f s, s) +{-# INLINE gets #-} + +-- | Uniform lifting of a @callCC@ operation to the new monad. +-- This version rolls back to the original state on entering the +-- continuation. +liftCallCC :: CallCC m (a,s) (b,s) -> CallCC (StateT s m) a b +liftCallCC callCC f = StateT $ \ s -> + callCC $ \ c -> + runStateT (f (\ a -> StateT $ \ _ -> c (a, s))) s +{-# INLINE liftCallCC #-} + +-- | In-situ lifting of a @callCC@ operation to the new monad. +-- This version uses the current state on entering the continuation. +-- It does not satisfy the uniformity property (see "Control.Monad.Signatures"). +liftCallCC' :: CallCC m (a,s) (b,s) -> CallCC (StateT s m) a b +liftCallCC' callCC f = StateT $ \ s -> + callCC $ \ c -> + runStateT (f (\ a -> StateT $ \ s' -> c (a, s'))) s +{-# INLINE liftCallCC' #-} + +-- | Lift a @catchE@ operation to the new monad. +liftCatch :: Catch e m (a,s) -> Catch e (StateT s m) a +liftCatch catchE m h = + StateT $ \ s -> runStateT m s `catchE` \ e -> runStateT (h e) s +{-# INLINE liftCatch #-} + +-- | Lift a @listen@ operation to the new monad. +liftListen :: (Monad m) => Listen w m (a,s) -> Listen w (StateT s m) a +liftListen listen m = StateT $ \ s -> do + ~((a, s'), w) <- listen (runStateT m s) + return ((a, w), s') +{-# INLINE liftListen #-} + +-- | Lift a @pass@ operation to the new monad. +liftPass :: (Monad m) => Pass w m (a,s) -> Pass w (StateT s m) a +liftPass pass m = StateT $ \ s -> pass $ do + ~((a, f), s') <- runStateT m s + return ((a, s'), f) +{-# INLINE liftPass #-} + +{- $examples + +Parser from ParseLib with Hugs: + +> type Parser a = StateT String [] a +> ==> StateT (String -> [(a,String)]) + +For example, item can be written as: + +> item = do (x:xs) <- get +> put xs +> return x +> +> type BoringState s a = StateT s Identity a +> ==> StateT (s -> Identity (a,s)) +> +> type StateWithIO s a = StateT s IO a +> ==> StateT (s -> IO (a,s)) +> +> type StateWithErr s a = StateT s Maybe a +> ==> StateT (s -> Maybe (a,s)) + +-} + +{- $counting + +A function to increment a counter. +Taken from the paper \"Generalising Monads to Arrows\", +John Hughes (<http://www.cse.chalmers.se/~rjmh/>), November 1998: + +> tick :: State Int Int +> tick = do n <- get +> put (n+1) +> return n + +Add one to the given number using the state monad: + +> plusOne :: Int -> Int +> plusOne n = execState tick n + +A contrived addition example. Works only with positive numbers: + +> plus :: Int -> Int -> Int +> plus n x = execState (sequence $ replicate n tick) x + +-} + +{- $labelling + +An example from /The Craft of Functional Programming/, Simon +Thompson (<http://www.cs.kent.ac.uk/people/staff/sjt/>), +Addison-Wesley 1999: \"Given an arbitrary tree, transform it to a +tree of integers in which the original elements are replaced by +natural numbers, starting from 0. The same element has to be +replaced by the same number at every occurrence, and when we meet +an as-yet-unvisited element we have to find a \'new\' number to match +it with:\" + +> data Tree a = Nil | Node a (Tree a) (Tree a) deriving (Show, Eq) +> type Table a = [a] + +> numberTree :: Eq a => Tree a -> State (Table a) (Tree Int) +> numberTree Nil = return Nil +> numberTree (Node x t1 t2) = do +> num <- numberNode x +> nt1 <- numberTree t1 +> nt2 <- numberTree t2 +> return (Node num nt1 nt2) +> where +> numberNode :: Eq a => a -> State (Table a) Int +> numberNode x = do +> table <- get +> case elemIndex x table of +> Nothing -> do +> put (table ++ [x]) +> return (length table) +> Just i -> return i + +numTree applies numberTree with an initial state: + +> numTree :: (Eq a) => Tree a -> Tree Int +> numTree t = evalState (numberTree t) [] + +> testTree = Node "Zero" (Node "One" (Node "Two" Nil Nil) (Node "One" (Node "Zero" Nil Nil) Nil)) Nil +> numTree testTree => Node 0 (Node 1 (Node 2 Nil Nil) (Node 1 (Node 0 Nil Nil) Nil)) Nil + +-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/State/Strict.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/State/Strict.hs new file mode 100644 index 000000000000..d0fb58edb4cf --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/State/Strict.hs @@ -0,0 +1,425 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.State.Strict +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- Strict state monads, passing an updatable state through a computation. +-- See below for examples. +-- +-- Some computations may not require the full power of state transformers: +-- +-- * For a read-only state, see "Control.Monad.Trans.Reader". +-- +-- * To accumulate a value without using it on the way, see +-- "Control.Monad.Trans.Writer". +-- +-- In this version, sequencing of computations is strict (but computations +-- are not strict in the state unless you force it with 'seq' or the like). +-- For a lazy version with the same interface, see +-- "Control.Monad.Trans.State.Lazy". +----------------------------------------------------------------------------- + +module Control.Monad.Trans.State.Strict ( + -- * The State monad + State, + state, + runState, + evalState, + execState, + mapState, + withState, + -- * The StateT monad transformer + StateT(..), + evalStateT, + execStateT, + mapStateT, + withStateT, + -- * State operations + get, + put, + modify, + modify', + gets, + -- * Lifting other operations + liftCallCC, + liftCallCC', + liftCatch, + liftListen, + liftPass, + -- * Examples + -- ** State monads + -- $examples + + -- ** Counting + -- $counting + + -- ** Labelling trees + -- $labelling + ) where + +import Control.Monad.IO.Class +import Control.Monad.Signatures +import Control.Monad.Trans.Class +#if MIN_VERSION_base(4,12,0) +import Data.Functor.Contravariant +#endif +import Data.Functor.Identity + +import Control.Applicative +import Control.Monad +#if MIN_VERSION_base(4,9,0) +import qualified Control.Monad.Fail as Fail +#endif +import Control.Monad.Fix + +-- --------------------------------------------------------------------------- +-- | A state monad parameterized by the type @s@ of the state to carry. +-- +-- The 'return' function leaves the state unchanged, while @>>=@ uses +-- the final state of the first computation as the initial state of +-- the second. +type State s = StateT s Identity + +-- | Construct a state monad computation from a function. +-- (The inverse of 'runState'.) +state :: (Monad m) + => (s -> (a, s)) -- ^pure state transformer + -> StateT s m a -- ^equivalent state-passing computation +state f = StateT (return . f) +{-# INLINE state #-} + +-- | Unwrap a state monad computation as a function. +-- (The inverse of 'state'.) +runState :: State s a -- ^state-passing computation to execute + -> s -- ^initial state + -> (a, s) -- ^return value and final state +runState m = runIdentity . runStateT m +{-# INLINE runState #-} + +-- | Evaluate a state computation with the given initial state +-- and return the final value, discarding the final state. +-- +-- * @'evalState' m s = 'fst' ('runState' m s)@ +evalState :: State s a -- ^state-passing computation to execute + -> s -- ^initial value + -> a -- ^return value of the state computation +evalState m s = fst (runState m s) +{-# INLINE evalState #-} + +-- | Evaluate a state computation with the given initial state +-- and return the final state, discarding the final value. +-- +-- * @'execState' m s = 'snd' ('runState' m s)@ +execState :: State s a -- ^state-passing computation to execute + -> s -- ^initial value + -> s -- ^final state +execState m s = snd (runState m s) +{-# INLINE execState #-} + +-- | Map both the return value and final state of a computation using +-- the given function. +-- +-- * @'runState' ('mapState' f m) = f . 'runState' m@ +mapState :: ((a, s) -> (b, s)) -> State s a -> State s b +mapState f = mapStateT (Identity . f . runIdentity) +{-# INLINE mapState #-} + +-- | @'withState' f m@ executes action @m@ on a state modified by +-- applying @f@. +-- +-- * @'withState' f m = 'modify' f >> m@ +withState :: (s -> s) -> State s a -> State s a +withState = withStateT +{-# INLINE withState #-} + +-- --------------------------------------------------------------------------- +-- | A state transformer monad parameterized by: +-- +-- * @s@ - The state. +-- +-- * @m@ - The inner monad. +-- +-- The 'return' function leaves the state unchanged, while @>>=@ uses +-- the final state of the first computation as the initial state of +-- the second. +newtype StateT s m a = StateT { runStateT :: s -> m (a,s) } + +-- | Evaluate a state computation with the given initial state +-- and return the final value, discarding the final state. +-- +-- * @'evalStateT' m s = 'liftM' 'fst' ('runStateT' m s)@ +evalStateT :: (Monad m) => StateT s m a -> s -> m a +evalStateT m s = do + (a, _) <- runStateT m s + return a +{-# INLINE evalStateT #-} + +-- | Evaluate a state computation with the given initial state +-- and return the final state, discarding the final value. +-- +-- * @'execStateT' m s = 'liftM' 'snd' ('runStateT' m s)@ +execStateT :: (Monad m) => StateT s m a -> s -> m s +execStateT m s = do + (_, s') <- runStateT m s + return s' +{-# INLINE execStateT #-} + +-- | Map both the return value and final state of a computation using +-- the given function. +-- +-- * @'runStateT' ('mapStateT' f m) = f . 'runStateT' m@ +mapStateT :: (m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b +mapStateT f m = StateT $ f . runStateT m +{-# INLINE mapStateT #-} + +-- | @'withStateT' f m@ executes action @m@ on a state modified by +-- applying @f@. +-- +-- * @'withStateT' f m = 'modify' f >> m@ +withStateT :: (s -> s) -> StateT s m a -> StateT s m a +withStateT f m = StateT $ runStateT m . f +{-# INLINE withStateT #-} + +instance (Functor m) => Functor (StateT s m) where + fmap f m = StateT $ \ s -> + fmap (\ (a, s') -> (f a, s')) $ runStateT m s + {-# INLINE fmap #-} + +instance (Functor m, Monad m) => Applicative (StateT s m) where + pure a = StateT $ \ s -> return (a, s) + {-# INLINE pure #-} + StateT mf <*> StateT mx = StateT $ \ s -> do + (f, s') <- mf s + (x, s'') <- mx s' + return (f x, s'') + {-# INLINE (<*>) #-} + m *> k = m >>= \_ -> k + {-# INLINE (*>) #-} + +instance (Functor m, MonadPlus m) => Alternative (StateT s m) where + empty = StateT $ \ _ -> mzero + {-# INLINE empty #-} + StateT m <|> StateT n = StateT $ \ s -> m s `mplus` n s + {-# INLINE (<|>) #-} + +instance (Monad m) => Monad (StateT s m) where +#if !(MIN_VERSION_base(4,8,0)) + return a = StateT $ \ s -> return (a, s) + {-# INLINE return #-} +#endif + m >>= k = StateT $ \ s -> do + (a, s') <- runStateT m s + runStateT (k a) s' + {-# INLINE (>>=) #-} +#if !(MIN_VERSION_base(4,13,0)) + fail str = StateT $ \ _ -> fail str + {-# INLINE fail #-} +#endif + +#if MIN_VERSION_base(4,9,0) +instance (Fail.MonadFail m) => Fail.MonadFail (StateT s m) where + fail str = StateT $ \ _ -> Fail.fail str + {-# INLINE fail #-} +#endif + +instance (MonadPlus m) => MonadPlus (StateT s m) where + mzero = StateT $ \ _ -> mzero + {-# INLINE mzero #-} + StateT m `mplus` StateT n = StateT $ \ s -> m s `mplus` n s + {-# INLINE mplus #-} + +instance (MonadFix m) => MonadFix (StateT s m) where + mfix f = StateT $ \ s -> mfix $ \ ~(a, _) -> runStateT (f a) s + {-# INLINE mfix #-} + +instance MonadTrans (StateT s) where + lift m = StateT $ \ s -> do + a <- m + return (a, s) + {-# INLINE lift #-} + +instance (MonadIO m) => MonadIO (StateT s m) where + liftIO = lift . liftIO + {-# INLINE liftIO #-} + +#if MIN_VERSION_base(4,12,0) +instance Contravariant m => Contravariant (StateT s m) where + contramap f m = StateT $ \s -> + contramap (\ (a, s') -> (f a, s')) $ runStateT m s + {-# INLINE contramap #-} +#endif + +-- | Fetch the current value of the state within the monad. +get :: (Monad m) => StateT s m s +get = state $ \ s -> (s, s) +{-# INLINE get #-} + +-- | @'put' s@ sets the state within the monad to @s@. +put :: (Monad m) => s -> StateT s m () +put s = state $ \ _ -> ((), s) +{-# INLINE put #-} + +-- | @'modify' f@ is an action that updates the state to the result of +-- applying @f@ to the current state. +-- +-- * @'modify' f = 'get' >>= ('put' . f)@ +modify :: (Monad m) => (s -> s) -> StateT s m () +modify f = state $ \ s -> ((), f s) +{-# INLINE modify #-} + +-- | A variant of 'modify' in which the computation is strict in the +-- new state. +-- +-- * @'modify'' f = 'get' >>= (('$!') 'put' . f)@ +modify' :: (Monad m) => (s -> s) -> StateT s m () +modify' f = do + s <- get + put $! f s +{-# INLINE modify' #-} + +-- | Get a specific component of the state, using a projection function +-- supplied. +-- +-- * @'gets' f = 'liftM' f 'get'@ +gets :: (Monad m) => (s -> a) -> StateT s m a +gets f = state $ \ s -> (f s, s) +{-# INLINE gets #-} + +-- | Uniform lifting of a @callCC@ operation to the new monad. +-- This version rolls back to the original state on entering the +-- continuation. +liftCallCC :: CallCC m (a,s) (b,s) -> CallCC (StateT s m) a b +liftCallCC callCC f = StateT $ \ s -> + callCC $ \ c -> + runStateT (f (\ a -> StateT $ \ _ -> c (a, s))) s +{-# INLINE liftCallCC #-} + +-- | In-situ lifting of a @callCC@ operation to the new monad. +-- This version uses the current state on entering the continuation. +-- It does not satisfy the uniformity property (see "Control.Monad.Signatures"). +liftCallCC' :: CallCC m (a,s) (b,s) -> CallCC (StateT s m) a b +liftCallCC' callCC f = StateT $ \ s -> + callCC $ \ c -> + runStateT (f (\ a -> StateT $ \ s' -> c (a, s'))) s +{-# INLINE liftCallCC' #-} + +-- | Lift a @catchE@ operation to the new monad. +liftCatch :: Catch e m (a,s) -> Catch e (StateT s m) a +liftCatch catchE m h = + StateT $ \ s -> runStateT m s `catchE` \ e -> runStateT (h e) s +{-# INLINE liftCatch #-} + +-- | Lift a @listen@ operation to the new monad. +liftListen :: (Monad m) => Listen w m (a,s) -> Listen w (StateT s m) a +liftListen listen m = StateT $ \ s -> do + ((a, s'), w) <- listen (runStateT m s) + return ((a, w), s') +{-# INLINE liftListen #-} + +-- | Lift a @pass@ operation to the new monad. +liftPass :: (Monad m) => Pass w m (a,s) -> Pass w (StateT s m) a +liftPass pass m = StateT $ \ s -> pass $ do + ((a, f), s') <- runStateT m s + return ((a, s'), f) +{-# INLINE liftPass #-} + +{- $examples + +Parser from ParseLib with Hugs: + +> type Parser a = StateT String [] a +> ==> StateT (String -> [(a,String)]) + +For example, item can be written as: + +> item = do (x:xs) <- get +> put xs +> return x +> +> type BoringState s a = StateT s Identity a +> ==> StateT (s -> Identity (a,s)) +> +> type StateWithIO s a = StateT s IO a +> ==> StateT (s -> IO (a,s)) +> +> type StateWithErr s a = StateT s Maybe a +> ==> StateT (s -> Maybe (a,s)) + +-} + +{- $counting + +A function to increment a counter. +Taken from the paper \"Generalising Monads to Arrows\", +John Hughes (<http://www.cse.chalmers.se/~rjmh/>), November 1998: + +> tick :: State Int Int +> tick = do n <- get +> put (n+1) +> return n + +Add one to the given number using the state monad: + +> plusOne :: Int -> Int +> plusOne n = execState tick n + +A contrived addition example. Works only with positive numbers: + +> plus :: Int -> Int -> Int +> plus n x = execState (sequence $ replicate n tick) x + +-} + +{- $labelling + +An example from /The Craft of Functional Programming/, Simon +Thompson (<http://www.cs.kent.ac.uk/people/staff/sjt/>), +Addison-Wesley 1999: \"Given an arbitrary tree, transform it to a +tree of integers in which the original elements are replaced by +natural numbers, starting from 0. The same element has to be +replaced by the same number at every occurrence, and when we meet +an as-yet-unvisited element we have to find a \'new\' number to match +it with:\" + +> data Tree a = Nil | Node a (Tree a) (Tree a) deriving (Show, Eq) +> type Table a = [a] + +> numberTree :: Eq a => Tree a -> State (Table a) (Tree Int) +> numberTree Nil = return Nil +> numberTree (Node x t1 t2) = do +> num <- numberNode x +> nt1 <- numberTree t1 +> nt2 <- numberTree t2 +> return (Node num nt1 nt2) +> where +> numberNode :: Eq a => a -> State (Table a) Int +> numberNode x = do +> table <- get +> case elemIndex x table of +> Nothing -> do +> put (table ++ [x]) +> return (length table) +> Just i -> return i + +numTree applies numberTree with an initial state: + +> numTree :: (Eq a) => Tree a -> Tree Int +> numTree t = evalState (numberTree t) [] + +> testTree = Node "Zero" (Node "One" (Node "Two" Nil Nil) (Node "One" (Node "Zero" Nil Nil) Nil)) Nil +> numTree testTree => Node 0 (Node 1 (Node 2 Nil Nil) (Node 1 (Node 0 Nil Nil) Nil)) Nil + +-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer.hs new file mode 100644 index 000000000000..f45f4d27687c --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Writer +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- The WriterT monad transformer. +-- This version builds its output lazily; for a constant-space version +-- with almost the same interface, see "Control.Monad.Trans.Writer.CPS". +----------------------------------------------------------------------------- + +module Control.Monad.Trans.Writer ( + module Control.Monad.Trans.Writer.Lazy + ) where + +import Control.Monad.Trans.Writer.Lazy diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer/CPS.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer/CPS.hs new file mode 100644 index 000000000000..28951016cf81 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer/CPS.hs @@ -0,0 +1,283 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Writer.CPS +-- Copyright : (c) Daniel Mendler 2016, +-- (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- The strict 'WriterT' monad transformer, which adds collection of +-- outputs (such as a count or string output) to a given monad. +-- +-- This monad transformer provides only limited access to the output +-- during the computation. For more general access, use +-- "Control.Monad.Trans.State" instead. +-- +-- This version builds its output strictly and uses continuation-passing-style +-- to achieve constant space usage. This transformer can be used as a +-- drop-in replacement for "Control.Monad.Trans.Writer.Strict". +----------------------------------------------------------------------------- + +module Control.Monad.Trans.Writer.CPS ( + -- * The Writer monad + Writer, + writer, + runWriter, + execWriter, + mapWriter, + -- * The WriterT monad transformer + WriterT, + writerT, + runWriterT, + execWriterT, + mapWriterT, + -- * Writer operations + tell, + listen, + listens, + pass, + censor, + -- * Lifting other operations + liftCallCC, + liftCatch, + ) where + +import Control.Applicative +import Control.Monad +import Control.Monad.Fix +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Signatures +import Data.Functor.Identity + +#if !(MIN_VERSION_base(4,8,0)) +import Data.Monoid +#endif + +#if MIN_VERSION_base(4,9,0) +import qualified Control.Monad.Fail as Fail +#endif + +-- --------------------------------------------------------------------------- +-- | A writer monad parameterized by the type @w@ of output to accumulate. +-- +-- The 'return' function produces the output 'mempty', while '>>=' +-- combines the outputs of the subcomputations using 'mappend'. +type Writer w = WriterT w Identity + +-- | Construct a writer computation from a (result, output) pair. +-- (The inverse of 'runWriter'.) +writer :: (Monoid w, Monad m) => (a, w) -> WriterT w m a +writer (a, w') = WriterT $ \ w -> + let wt = w `mappend` w' in wt `seq` return (a, wt) +{-# INLINE writer #-} + +-- | Unwrap a writer computation as a (result, output) pair. +-- (The inverse of 'writer'.) +runWriter :: (Monoid w) => Writer w a -> (a, w) +runWriter = runIdentity . runWriterT +{-# INLINE runWriter #-} + +-- | Extract the output from a writer computation. +-- +-- * @'execWriter' m = 'snd' ('runWriter' m)@ +execWriter :: (Monoid w) => Writer w a -> w +execWriter = runIdentity . execWriterT +{-# INLINE execWriter #-} + +-- | Map both the return value and output of a computation using +-- the given function. +-- +-- * @'runWriter' ('mapWriter' f m) = f ('runWriter' m)@ +mapWriter :: (Monoid w, Monoid w') => + ((a, w) -> (b, w')) -> Writer w a -> Writer w' b +mapWriter f = mapWriterT (Identity . f . runIdentity) +{-# INLINE mapWriter #-} + +-- --------------------------------------------------------------------------- +-- | A writer monad parameterized by: +-- +-- * @w@ - the output to accumulate. +-- +-- * @m@ - The inner monad. +-- +-- The 'return' function produces the output 'mempty', while '>>=' +-- combines the outputs of the subcomputations using 'mappend'. + +newtype WriterT w m a = WriterT { unWriterT :: w -> m (a, w) } + +-- | Construct a writer computation from a (result, output) computation. +-- (The inverse of 'runWriterT'.) +writerT :: (Functor m, Monoid w) => m (a, w) -> WriterT w m a +writerT f = WriterT $ \ w -> + (\ (a, w') -> let wt = w `mappend` w' in wt `seq` (a, wt)) <$> f +{-# INLINE writerT #-} + +-- | Unwrap a writer computation. +-- (The inverse of 'writerT'.) +runWriterT :: (Monoid w) => WriterT w m a -> m (a, w) +runWriterT m = unWriterT m mempty +{-# INLINE runWriterT #-} + +-- | Extract the output from a writer computation. +-- +-- * @'execWriterT' m = 'liftM' 'snd' ('runWriterT' m)@ +execWriterT :: (Monad m, Monoid w) => WriterT w m a -> m w +execWriterT m = do + (_, w) <- runWriterT m + return w +{-# INLINE execWriterT #-} + +-- | Map both the return value and output of a computation using +-- the given function. +-- +-- * @'runWriterT' ('mapWriterT' f m) = f ('runWriterT' m)@ +mapWriterT :: (Monad n, Monoid w, Monoid w') => + (m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b +mapWriterT f m = WriterT $ \ w -> do + (a, w') <- f (runWriterT m) + let wt = w `mappend` w' + wt `seq` return (a, wt) +{-# INLINE mapWriterT #-} + +instance (Functor m) => Functor (WriterT w m) where + fmap f m = WriterT $ \ w -> (\ (a, w') -> (f a, w')) <$> unWriterT m w + {-# INLINE fmap #-} + +instance (Functor m, Monad m) => Applicative (WriterT w m) where + pure a = WriterT $ \ w -> return (a, w) + {-# INLINE pure #-} + + WriterT mf <*> WriterT mx = WriterT $ \ w -> do + (f, w') <- mf w + (x, w'') <- mx w' + return (f x, w'') + {-# INLINE (<*>) #-} + +instance (Functor m, MonadPlus m) => Alternative (WriterT w m) where + empty = WriterT $ const mzero + {-# INLINE empty #-} + + WriterT m <|> WriterT n = WriterT $ \ w -> m w `mplus` n w + {-# INLINE (<|>) #-} + +instance (Monad m) => Monad (WriterT w m) where +#if !(MIN_VERSION_base(4,8,0)) + return a = WriterT $ \ w -> return (a, w) + {-# INLINE return #-} +#endif + + m >>= k = WriterT $ \ w -> do + (a, w') <- unWriterT m w + unWriterT (k a) w' + {-# INLINE (>>=) #-} + +#if !(MIN_VERSION_base(4,13,0)) + fail msg = WriterT $ \ _ -> fail msg + {-# INLINE fail #-} +#endif + +#if MIN_VERSION_base(4,9,0) +instance (Fail.MonadFail m) => Fail.MonadFail (WriterT w m) where + fail msg = WriterT $ \ _ -> Fail.fail msg + {-# INLINE fail #-} +#endif + +instance (Functor m, MonadPlus m) => MonadPlus (WriterT w m) where + mzero = empty + {-# INLINE mzero #-} + mplus = (<|>) + {-# INLINE mplus #-} + +instance (MonadFix m) => MonadFix (WriterT w m) where + mfix f = WriterT $ \ w -> mfix $ \ ~(a, _) -> unWriterT (f a) w + {-# INLINE mfix #-} + +instance MonadTrans (WriterT w) where + lift m = WriterT $ \ w -> do + a <- m + return (a, w) + {-# INLINE lift #-} + +instance (MonadIO m) => MonadIO (WriterT w m) where + liftIO = lift . liftIO + {-# INLINE liftIO #-} + +-- | @'tell' w@ is an action that produces the output @w@. +tell :: (Monoid w, Monad m) => w -> WriterT w m () +tell w = writer ((), w) +{-# INLINE tell #-} + +-- | @'listen' m@ is an action that executes the action @m@ and adds its +-- output to the value of the computation. +-- +-- * @'runWriterT' ('listen' m) = 'liftM' (\\ (a, w) -> ((a, w), w)) ('runWriterT' m)@ +listen :: (Monoid w, Monad m) => WriterT w m a -> WriterT w m (a, w) +listen = listens id +{-# INLINE listen #-} + +-- | @'listens' f m@ is an action that executes the action @m@ and adds +-- the result of applying @f@ to the output to the value of the computation. +-- +-- * @'listens' f m = 'liftM' (id *** f) ('listen' m)@ +-- +-- * @'runWriterT' ('listens' f m) = 'liftM' (\\ (a, w) -> ((a, f w), w)) ('runWriterT' m)@ +listens :: (Monoid w, Monad m) => + (w -> b) -> WriterT w m a -> WriterT w m (a, b) +listens f m = WriterT $ \ w -> do + (a, w') <- runWriterT m + let wt = w `mappend` w' + wt `seq` return ((a, f w'), wt) +{-# INLINE listens #-} + +-- | @'pass' m@ is an action that executes the action @m@, which returns +-- a value and a function, and returns the value, applying the function +-- to the output. +-- +-- * @'runWriterT' ('pass' m) = 'liftM' (\\ ((a, f), w) -> (a, f w)) ('runWriterT' m)@ +pass :: (Monoid w, Monoid w', Monad m) => + WriterT w m (a, w -> w') -> WriterT w' m a +pass m = WriterT $ \ w -> do + ((a, f), w') <- runWriterT m + let wt = w `mappend` f w' + wt `seq` return (a, wt) +{-# INLINE pass #-} + +-- | @'censor' f m@ is an action that executes the action @m@ and +-- applies the function @f@ to its output, leaving the return value +-- unchanged. +-- +-- * @'censor' f m = 'pass' ('liftM' (\\ x -> (x,f)) m)@ +-- +-- * @'runWriterT' ('censor' f m) = 'liftM' (\\ (a, w) -> (a, f w)) ('runWriterT' m)@ +censor :: (Monoid w, Monad m) => (w -> w) -> WriterT w m a -> WriterT w m a +censor f m = WriterT $ \ w -> do + (a, w') <- runWriterT m + let wt = w `mappend` f w' + wt `seq` return (a, wt) +{-# INLINE censor #-} + +-- | Uniform lifting of a @callCC@ operation to the new monad. +-- This version rolls back to the original state on entering the +-- continuation. +liftCallCC :: CallCC m (a, w) (b, w) -> CallCC (WriterT w m) a b +liftCallCC callCC f = WriterT $ \ w -> + callCC $ \ c -> unWriterT (f (\ a -> WriterT $ \ _ -> c (a, w))) w +{-# INLINE liftCallCC #-} + +-- | Lift a @catchE@ operation to the new monad. +liftCatch :: Catch e m (a, w) -> Catch e (WriterT w m) a +liftCatch catchE m h = WriterT $ \ w -> + unWriterT m w `catchE` \ e -> unWriterT (h e) w +{-# INLINE liftCatch #-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer/Lazy.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer/Lazy.hs new file mode 100644 index 000000000000..d12b0e7d583c --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer/Lazy.hs @@ -0,0 +1,313 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Writer.Lazy +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- The lazy 'WriterT' monad transformer, which adds collection of +-- outputs (such as a count or string output) to a given monad. +-- +-- This monad transformer provides only limited access to the output +-- during the computation. For more general access, use +-- "Control.Monad.Trans.State" instead. +-- +-- This version builds its output lazily; for a constant-space version +-- with almost the same interface, see "Control.Monad.Trans.Writer.CPS". +----------------------------------------------------------------------------- + +module Control.Monad.Trans.Writer.Lazy ( + -- * The Writer monad + Writer, + writer, + runWriter, + execWriter, + mapWriter, + -- * The WriterT monad transformer + WriterT(..), + execWriterT, + mapWriterT, + -- * Writer operations + tell, + listen, + listens, + pass, + censor, + -- * Lifting other operations + liftCallCC, + liftCatch, + ) where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Data.Functor.Classes +#if MIN_VERSION_base(4,12,0) +import Data.Functor.Contravariant +#endif +import Data.Functor.Identity + +import Control.Applicative +import Control.Monad +#if MIN_VERSION_base(4,9,0) +import qualified Control.Monad.Fail as Fail +#endif +import Control.Monad.Fix +import Control.Monad.Signatures +#if MIN_VERSION_base(4,4,0) +import Control.Monad.Zip (MonadZip(mzipWith)) +#endif +import Data.Foldable +import Data.Monoid +import Data.Traversable (Traversable(traverse)) +import Prelude hiding (null, length) + +-- --------------------------------------------------------------------------- +-- | A writer monad parameterized by the type @w@ of output to accumulate. +-- +-- The 'return' function produces the output 'mempty', while @>>=@ +-- combines the outputs of the subcomputations using 'mappend'. +type Writer w = WriterT w Identity + +-- | Construct a writer computation from a (result, output) pair. +-- (The inverse of 'runWriter'.) +writer :: (Monad m) => (a, w) -> WriterT w m a +writer = WriterT . return +{-# INLINE writer #-} + +-- | Unwrap a writer computation as a (result, output) pair. +-- (The inverse of 'writer'.) +runWriter :: Writer w a -> (a, w) +runWriter = runIdentity . runWriterT +{-# INLINE runWriter #-} + +-- | Extract the output from a writer computation. +-- +-- * @'execWriter' m = 'snd' ('runWriter' m)@ +execWriter :: Writer w a -> w +execWriter m = snd (runWriter m) +{-# INLINE execWriter #-} + +-- | Map both the return value and output of a computation using +-- the given function. +-- +-- * @'runWriter' ('mapWriter' f m) = f ('runWriter' m)@ +mapWriter :: ((a, w) -> (b, w')) -> Writer w a -> Writer w' b +mapWriter f = mapWriterT (Identity . f . runIdentity) +{-# INLINE mapWriter #-} + +-- --------------------------------------------------------------------------- +-- | A writer monad parameterized by: +-- +-- * @w@ - the output to accumulate. +-- +-- * @m@ - The inner monad. +-- +-- The 'return' function produces the output 'mempty', while @>>=@ +-- combines the outputs of the subcomputations using 'mappend'. +newtype WriterT w m a = WriterT { runWriterT :: m (a, w) } + +instance (Eq w, Eq1 m) => Eq1 (WriterT w m) where + liftEq eq (WriterT m1) (WriterT m2) = liftEq (liftEq2 eq (==)) m1 m2 + {-# INLINE liftEq #-} + +instance (Ord w, Ord1 m) => Ord1 (WriterT w m) where + liftCompare comp (WriterT m1) (WriterT m2) = + liftCompare (liftCompare2 comp compare) m1 m2 + {-# INLINE liftCompare #-} + +instance (Read w, Read1 m) => Read1 (WriterT w m) where + liftReadsPrec rp rl = readsData $ + readsUnaryWith (liftReadsPrec rp' rl') "WriterT" WriterT + where + rp' = liftReadsPrec2 rp rl readsPrec readList + rl' = liftReadList2 rp rl readsPrec readList + +instance (Show w, Show1 m) => Show1 (WriterT w m) where + liftShowsPrec sp sl d (WriterT m) = + showsUnaryWith (liftShowsPrec sp' sl') "WriterT" d m + where + sp' = liftShowsPrec2 sp sl showsPrec showList + sl' = liftShowList2 sp sl showsPrec showList + +instance (Eq w, Eq1 m, Eq a) => Eq (WriterT w m a) where (==) = eq1 +instance (Ord w, Ord1 m, Ord a) => Ord (WriterT w m a) where compare = compare1 +instance (Read w, Read1 m, Read a) => Read (WriterT w m a) where + readsPrec = readsPrec1 +instance (Show w, Show1 m, Show a) => Show (WriterT w m a) where + showsPrec = showsPrec1 + +-- | Extract the output from a writer computation. +-- +-- * @'execWriterT' m = 'liftM' 'snd' ('runWriterT' m)@ +execWriterT :: (Monad m) => WriterT w m a -> m w +execWriterT m = do + ~(_, w) <- runWriterT m + return w +{-# INLINE execWriterT #-} + +-- | Map both the return value and output of a computation using +-- the given function. +-- +-- * @'runWriterT' ('mapWriterT' f m) = f ('runWriterT' m)@ +mapWriterT :: (m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b +mapWriterT f m = WriterT $ f (runWriterT m) +{-# INLINE mapWriterT #-} + +instance (Functor m) => Functor (WriterT w m) where + fmap f = mapWriterT $ fmap $ \ ~(a, w) -> (f a, w) + {-# INLINE fmap #-} + +instance (Foldable f) => Foldable (WriterT w f) where + foldMap f = foldMap (f . fst) . runWriterT + {-# INLINE foldMap #-} +#if MIN_VERSION_base(4,8,0) + null (WriterT t) = null t + length (WriterT t) = length t +#endif + +instance (Traversable f) => Traversable (WriterT w f) where + traverse f = fmap WriterT . traverse f' . runWriterT where + f' (a, b) = fmap (\ c -> (c, b)) (f a) + {-# INLINE traverse #-} + +instance (Monoid w, Applicative m) => Applicative (WriterT w m) where + pure a = WriterT $ pure (a, mempty) + {-# INLINE pure #-} + f <*> v = WriterT $ liftA2 k (runWriterT f) (runWriterT v) + where k ~(a, w) ~(b, w') = (a b, w `mappend` w') + {-# INLINE (<*>) #-} + +instance (Monoid w, Alternative m) => Alternative (WriterT w m) where + empty = WriterT empty + {-# INLINE empty #-} + m <|> n = WriterT $ runWriterT m <|> runWriterT n + {-# INLINE (<|>) #-} + +instance (Monoid w, Monad m) => Monad (WriterT w m) where +#if !(MIN_VERSION_base(4,8,0)) + return a = writer (a, mempty) + {-# INLINE return #-} +#endif + m >>= k = WriterT $ do + ~(a, w) <- runWriterT m + ~(b, w') <- runWriterT (k a) + return (b, w `mappend` w') + {-# INLINE (>>=) #-} +#if !(MIN_VERSION_base(4,13,0)) + fail msg = WriterT $ fail msg + {-# INLINE fail #-} +#endif + +#if MIN_VERSION_base(4,9,0) +instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (WriterT w m) where + fail msg = WriterT $ Fail.fail msg + {-# INLINE fail #-} +#endif + +instance (Monoid w, MonadPlus m) => MonadPlus (WriterT w m) where + mzero = WriterT mzero + {-# INLINE mzero #-} + m `mplus` n = WriterT $ runWriterT m `mplus` runWriterT n + {-# INLINE mplus #-} + +instance (Monoid w, MonadFix m) => MonadFix (WriterT w m) where + mfix m = WriterT $ mfix $ \ ~(a, _) -> runWriterT (m a) + {-# INLINE mfix #-} + +instance (Monoid w) => MonadTrans (WriterT w) where + lift m = WriterT $ do + a <- m + return (a, mempty) + {-# INLINE lift #-} + +instance (Monoid w, MonadIO m) => MonadIO (WriterT w m) where + liftIO = lift . liftIO + {-# INLINE liftIO #-} + +#if MIN_VERSION_base(4,4,0) +instance (Monoid w, MonadZip m) => MonadZip (WriterT w m) where + mzipWith f (WriterT x) (WriterT y) = WriterT $ + mzipWith (\ ~(a, w) ~(b, w') -> (f a b, w `mappend` w')) x y + {-# INLINE mzipWith #-} +#endif + +#if MIN_VERSION_base(4,12,0) +instance Contravariant m => Contravariant (WriterT w m) where + contramap f = mapWriterT $ contramap $ \ ~(a, w) -> (f a, w) + {-# INLINE contramap #-} +#endif + +-- | @'tell' w@ is an action that produces the output @w@. +tell :: (Monad m) => w -> WriterT w m () +tell w = writer ((), w) +{-# INLINE tell #-} + +-- | @'listen' m@ is an action that executes the action @m@ and adds its +-- output to the value of the computation. +-- +-- * @'runWriterT' ('listen' m) = 'liftM' (\\ (a, w) -> ((a, w), w)) ('runWriterT' m)@ +listen :: (Monad m) => WriterT w m a -> WriterT w m (a, w) +listen m = WriterT $ do + ~(a, w) <- runWriterT m + return ((a, w), w) +{-# INLINE listen #-} + +-- | @'listens' f m@ is an action that executes the action @m@ and adds +-- the result of applying @f@ to the output to the value of the computation. +-- +-- * @'listens' f m = 'liftM' (id *** f) ('listen' m)@ +-- +-- * @'runWriterT' ('listens' f m) = 'liftM' (\\ (a, w) -> ((a, f w), w)) ('runWriterT' m)@ +listens :: (Monad m) => (w -> b) -> WriterT w m a -> WriterT w m (a, b) +listens f m = WriterT $ do + ~(a, w) <- runWriterT m + return ((a, f w), w) +{-# INLINE listens #-} + +-- | @'pass' m@ is an action that executes the action @m@, which returns +-- a value and a function, and returns the value, applying the function +-- to the output. +-- +-- * @'runWriterT' ('pass' m) = 'liftM' (\\ ((a, f), w) -> (a, f w)) ('runWriterT' m)@ +pass :: (Monad m) => WriterT w m (a, w -> w) -> WriterT w m a +pass m = WriterT $ do + ~((a, f), w) <- runWriterT m + return (a, f w) +{-# INLINE pass #-} + +-- | @'censor' f m@ is an action that executes the action @m@ and +-- applies the function @f@ to its output, leaving the return value +-- unchanged. +-- +-- * @'censor' f m = 'pass' ('liftM' (\\ x -> (x,f)) m)@ +-- +-- * @'runWriterT' ('censor' f m) = 'liftM' (\\ (a, w) -> (a, f w)) ('runWriterT' m)@ +censor :: (Monad m) => (w -> w) -> WriterT w m a -> WriterT w m a +censor f m = WriterT $ do + ~(a, w) <- runWriterT m + return (a, f w) +{-# INLINE censor #-} + +-- | Lift a @callCC@ operation to the new monad. +liftCallCC :: (Monoid w) => CallCC m (a,w) (b,w) -> CallCC (WriterT w m) a b +liftCallCC callCC f = WriterT $ + callCC $ \ c -> + runWriterT (f (\ a -> WriterT $ c (a, mempty))) +{-# INLINE liftCallCC #-} + +-- | Lift a @catchE@ operation to the new monad. +liftCatch :: Catch e m (a,w) -> Catch e (WriterT w m) a +liftCatch catchE m h = + WriterT $ runWriterT m `catchE` \ e -> runWriterT (h e) +{-# INLINE liftCatch #-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer/Strict.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer/Strict.hs new file mode 100644 index 000000000000..f39862c02044 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer/Strict.hs @@ -0,0 +1,316 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Writer.Strict +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- The strict 'WriterT' monad transformer, which adds collection of +-- outputs (such as a count or string output) to a given monad. +-- +-- This monad transformer provides only limited access to the output +-- during the computation. For more general access, use +-- "Control.Monad.Trans.State" instead. +-- +-- This version builds its output strictly; for a lazy version with +-- the same interface, see "Control.Monad.Trans.Writer.Lazy". +-- Although the output is built strictly, it is not possible to +-- achieve constant space behaviour with this transformer: for that, +-- use "Control.Monad.Trans.Writer.CPS" instead. +----------------------------------------------------------------------------- + +module Control.Monad.Trans.Writer.Strict ( + -- * The Writer monad + Writer, + writer, + runWriter, + execWriter, + mapWriter, + -- * The WriterT monad transformer + WriterT(..), + execWriterT, + mapWriterT, + -- * Writer operations + tell, + listen, + listens, + pass, + censor, + -- * Lifting other operations + liftCallCC, + liftCatch, + ) where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Data.Functor.Classes +#if MIN_VERSION_base(4,12,0) +import Data.Functor.Contravariant +#endif +import Data.Functor.Identity + +import Control.Applicative +import Control.Monad +#if MIN_VERSION_base(4,9,0) +import qualified Control.Monad.Fail as Fail +#endif +import Control.Monad.Fix +import Control.Monad.Signatures +#if MIN_VERSION_base(4,4,0) +import Control.Monad.Zip (MonadZip(mzipWith)) +#endif +import Data.Foldable +import Data.Monoid +import Data.Traversable (Traversable(traverse)) +import Prelude hiding (null, length) + +-- --------------------------------------------------------------------------- +-- | A writer monad parameterized by the type @w@ of output to accumulate. +-- +-- The 'return' function produces the output 'mempty', while @>>=@ +-- combines the outputs of the subcomputations using 'mappend'. +type Writer w = WriterT w Identity + +-- | Construct a writer computation from a (result, output) pair. +-- (The inverse of 'runWriter'.) +writer :: (Monad m) => (a, w) -> WriterT w m a +writer = WriterT . return +{-# INLINE writer #-} + +-- | Unwrap a writer computation as a (result, output) pair. +-- (The inverse of 'writer'.) +runWriter :: Writer w a -> (a, w) +runWriter = runIdentity . runWriterT +{-# INLINE runWriter #-} + +-- | Extract the output from a writer computation. +-- +-- * @'execWriter' m = 'snd' ('runWriter' m)@ +execWriter :: Writer w a -> w +execWriter m = snd (runWriter m) +{-# INLINE execWriter #-} + +-- | Map both the return value and output of a computation using +-- the given function. +-- +-- * @'runWriter' ('mapWriter' f m) = f ('runWriter' m)@ +mapWriter :: ((a, w) -> (b, w')) -> Writer w a -> Writer w' b +mapWriter f = mapWriterT (Identity . f . runIdentity) +{-# INLINE mapWriter #-} + +-- --------------------------------------------------------------------------- +-- | A writer monad parameterized by: +-- +-- * @w@ - the output to accumulate. +-- +-- * @m@ - The inner monad. +-- +-- The 'return' function produces the output 'mempty', while @>>=@ +-- combines the outputs of the subcomputations using 'mappend'. +newtype WriterT w m a = WriterT { runWriterT :: m (a, w) } + +instance (Eq w, Eq1 m) => Eq1 (WriterT w m) where + liftEq eq (WriterT m1) (WriterT m2) = liftEq (liftEq2 eq (==)) m1 m2 + {-# INLINE liftEq #-} + +instance (Ord w, Ord1 m) => Ord1 (WriterT w m) where + liftCompare comp (WriterT m1) (WriterT m2) = + liftCompare (liftCompare2 comp compare) m1 m2 + {-# INLINE liftCompare #-} + +instance (Read w, Read1 m) => Read1 (WriterT w m) where + liftReadsPrec rp rl = readsData $ + readsUnaryWith (liftReadsPrec rp' rl') "WriterT" WriterT + where + rp' = liftReadsPrec2 rp rl readsPrec readList + rl' = liftReadList2 rp rl readsPrec readList + +instance (Show w, Show1 m) => Show1 (WriterT w m) where + liftShowsPrec sp sl d (WriterT m) = + showsUnaryWith (liftShowsPrec sp' sl') "WriterT" d m + where + sp' = liftShowsPrec2 sp sl showsPrec showList + sl' = liftShowList2 sp sl showsPrec showList + +instance (Eq w, Eq1 m, Eq a) => Eq (WriterT w m a) where (==) = eq1 +instance (Ord w, Ord1 m, Ord a) => Ord (WriterT w m a) where compare = compare1 +instance (Read w, Read1 m, Read a) => Read (WriterT w m a) where + readsPrec = readsPrec1 +instance (Show w, Show1 m, Show a) => Show (WriterT w m a) where + showsPrec = showsPrec1 + +-- | Extract the output from a writer computation. +-- +-- * @'execWriterT' m = 'liftM' 'snd' ('runWriterT' m)@ +execWriterT :: (Monad m) => WriterT w m a -> m w +execWriterT m = do + (_, w) <- runWriterT m + return w +{-# INLINE execWriterT #-} + +-- | Map both the return value and output of a computation using +-- the given function. +-- +-- * @'runWriterT' ('mapWriterT' f m) = f ('runWriterT' m)@ +mapWriterT :: (m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b +mapWriterT f m = WriterT $ f (runWriterT m) +{-# INLINE mapWriterT #-} + +instance (Functor m) => Functor (WriterT w m) where + fmap f = mapWriterT $ fmap $ \ (a, w) -> (f a, w) + {-# INLINE fmap #-} + +instance (Foldable f) => Foldable (WriterT w f) where + foldMap f = foldMap (f . fst) . runWriterT + {-# INLINE foldMap #-} +#if MIN_VERSION_base(4,8,0) + null (WriterT t) = null t + length (WriterT t) = length t +#endif + +instance (Traversable f) => Traversable (WriterT w f) where + traverse f = fmap WriterT . traverse f' . runWriterT where + f' (a, b) = fmap (\ c -> (c, b)) (f a) + {-# INLINE traverse #-} + +instance (Monoid w, Applicative m) => Applicative (WriterT w m) where + pure a = WriterT $ pure (a, mempty) + {-# INLINE pure #-} + f <*> v = WriterT $ liftA2 k (runWriterT f) (runWriterT v) + where k (a, w) (b, w') = (a b, w `mappend` w') + {-# INLINE (<*>) #-} + +instance (Monoid w, Alternative m) => Alternative (WriterT w m) where + empty = WriterT empty + {-# INLINE empty #-} + m <|> n = WriterT $ runWriterT m <|> runWriterT n + {-# INLINE (<|>) #-} + +instance (Monoid w, Monad m) => Monad (WriterT w m) where +#if !(MIN_VERSION_base(4,8,0)) + return a = writer (a, mempty) + {-# INLINE return #-} +#endif + m >>= k = WriterT $ do + (a, w) <- runWriterT m + (b, w') <- runWriterT (k a) + return (b, w `mappend` w') + {-# INLINE (>>=) #-} +#if !(MIN_VERSION_base(4,13,0)) + fail msg = WriterT $ fail msg + {-# INLINE fail #-} +#endif + +#if MIN_VERSION_base(4,9,0) +instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (WriterT w m) where + fail msg = WriterT $ Fail.fail msg + {-# INLINE fail #-} +#endif + +instance (Monoid w, MonadPlus m) => MonadPlus (WriterT w m) where + mzero = WriterT mzero + {-# INLINE mzero #-} + m `mplus` n = WriterT $ runWriterT m `mplus` runWriterT n + {-# INLINE mplus #-} + +instance (Monoid w, MonadFix m) => MonadFix (WriterT w m) where + mfix m = WriterT $ mfix $ \ ~(a, _) -> runWriterT (m a) + {-# INLINE mfix #-} + +instance (Monoid w) => MonadTrans (WriterT w) where + lift m = WriterT $ do + a <- m + return (a, mempty) + {-# INLINE lift #-} + +instance (Monoid w, MonadIO m) => MonadIO (WriterT w m) where + liftIO = lift . liftIO + {-# INLINE liftIO #-} + +#if MIN_VERSION_base(4,4,0) +instance (Monoid w, MonadZip m) => MonadZip (WriterT w m) where + mzipWith f (WriterT x) (WriterT y) = WriterT $ + mzipWith (\ (a, w) (b, w') -> (f a b, w `mappend` w')) x y + {-# INLINE mzipWith #-} +#endif + +#if MIN_VERSION_base(4,12,0) +instance Contravariant m => Contravariant (WriterT w m) where + contramap f = mapWriterT $ contramap $ \ (a, w) -> (f a, w) + {-# INLINE contramap #-} +#endif + +-- | @'tell' w@ is an action that produces the output @w@. +tell :: (Monad m) => w -> WriterT w m () +tell w = writer ((), w) +{-# INLINE tell #-} + +-- | @'listen' m@ is an action that executes the action @m@ and adds its +-- output to the value of the computation. +-- +-- * @'runWriterT' ('listen' m) = 'liftM' (\\ (a, w) -> ((a, w), w)) ('runWriterT' m)@ +listen :: (Monad m) => WriterT w m a -> WriterT w m (a, w) +listen m = WriterT $ do + (a, w) <- runWriterT m + return ((a, w), w) +{-# INLINE listen #-} + +-- | @'listens' f m@ is an action that executes the action @m@ and adds +-- the result of applying @f@ to the output to the value of the computation. +-- +-- * @'listens' f m = 'liftM' (id *** f) ('listen' m)@ +-- +-- * @'runWriterT' ('listens' f m) = 'liftM' (\\ (a, w) -> ((a, f w), w)) ('runWriterT' m)@ +listens :: (Monad m) => (w -> b) -> WriterT w m a -> WriterT w m (a, b) +listens f m = WriterT $ do + (a, w) <- runWriterT m + return ((a, f w), w) +{-# INLINE listens #-} + +-- | @'pass' m@ is an action that executes the action @m@, which returns +-- a value and a function, and returns the value, applying the function +-- to the output. +-- +-- * @'runWriterT' ('pass' m) = 'liftM' (\\ ((a, f), w) -> (a, f w)) ('runWriterT' m)@ +pass :: (Monad m) => WriterT w m (a, w -> w) -> WriterT w m a +pass m = WriterT $ do + ((a, f), w) <- runWriterT m + return (a, f w) +{-# INLINE pass #-} + +-- | @'censor' f m@ is an action that executes the action @m@ and +-- applies the function @f@ to its output, leaving the return value +-- unchanged. +-- +-- * @'censor' f m = 'pass' ('liftM' (\\ x -> (x,f)) m)@ +-- +-- * @'runWriterT' ('censor' f m) = 'liftM' (\\ (a, w) -> (a, f w)) ('runWriterT' m)@ +censor :: (Monad m) => (w -> w) -> WriterT w m a -> WriterT w m a +censor f m = WriterT $ do + (a, w) <- runWriterT m + return (a, f w) +{-# INLINE censor #-} + +-- | Lift a @callCC@ operation to the new monad. +liftCallCC :: (Monoid w) => CallCC m (a,w) (b,w) -> CallCC (WriterT w m) a b +liftCallCC callCC f = WriterT $ + callCC $ \ c -> + runWriterT (f (\ a -> WriterT $ c (a, mempty))) +{-# INLINE liftCallCC #-} + +-- | Lift a @catchE@ operation to the new monad. +liftCatch :: Catch e m (a,w) -> Catch e (WriterT w m) a +liftCatch catchE m h = + WriterT $ runWriterT m `catchE` \ e -> runWriterT (h e) +{-# INLINE liftCatch #-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Data/Functor/Constant.hs b/third_party/bazel/rules_haskell/examples/transformers/Data/Functor/Constant.hs new file mode 100644 index 000000000000..9c0b8d42dcad --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Data/Functor/Constant.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE PolyKinds #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Data.Functor.Constant +-- Copyright : (c) Ross Paterson 2010 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- The constant functor. +----------------------------------------------------------------------------- + +module Data.Functor.Constant ( + Constant(..), + ) where + +import Data.Functor.Classes +#if MIN_VERSION_base(4,12,0) +import Data.Functor.Contravariant +#endif + +import Control.Applicative +import Data.Foldable +import Data.Monoid (Monoid(..)) +import Data.Traversable (Traversable(traverse)) +#if MIN_VERSION_base(4,8,0) +import Data.Bifunctor (Bifunctor(..)) +#endif +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup (Semigroup(..)) +#endif +#if MIN_VERSION_base(4,10,0) +import Data.Bifoldable (Bifoldable(..)) +import Data.Bitraversable (Bitraversable(..)) +#endif +import Prelude hiding (null, length) + +-- | Constant functor. +newtype Constant a b = Constant { getConstant :: a } + deriving (Eq, Ord) + +-- These instances would be equivalent to the derived instances of the +-- newtype if the field were removed. + +instance (Read a) => Read (Constant a b) where + readsPrec = readsData $ + readsUnaryWith readsPrec "Constant" Constant + +instance (Show a) => Show (Constant a b) where + showsPrec d (Constant x) = showsUnaryWith showsPrec "Constant" d x + +-- Instances of lifted Prelude classes + +instance Eq2 Constant where + liftEq2 eq _ (Constant x) (Constant y) = eq x y + {-# INLINE liftEq2 #-} + +instance Ord2 Constant where + liftCompare2 comp _ (Constant x) (Constant y) = comp x y + {-# INLINE liftCompare2 #-} + +instance Read2 Constant where + liftReadsPrec2 rp _ _ _ = readsData $ + readsUnaryWith rp "Constant" Constant + +instance Show2 Constant where + liftShowsPrec2 sp _ _ _ d (Constant x) = showsUnaryWith sp "Constant" d x + +instance (Eq a) => Eq1 (Constant a) where + liftEq = liftEq2 (==) + {-# INLINE liftEq #-} +instance (Ord a) => Ord1 (Constant a) where + liftCompare = liftCompare2 compare + {-# INLINE liftCompare #-} +instance (Read a) => Read1 (Constant a) where + liftReadsPrec = liftReadsPrec2 readsPrec readList + {-# INLINE liftReadsPrec #-} +instance (Show a) => Show1 (Constant a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + {-# INLINE liftShowsPrec #-} + +instance Functor (Constant a) where + fmap _ (Constant x) = Constant x + {-# INLINE fmap #-} + +instance Foldable (Constant a) where + foldMap _ (Constant _) = mempty + {-# INLINE foldMap #-} +#if MIN_VERSION_base(4,8,0) + null (Constant _) = True + length (Constant _) = 0 +#endif + +instance Traversable (Constant a) where + traverse _ (Constant x) = pure (Constant x) + {-# INLINE traverse #-} + +#if MIN_VERSION_base(4,9,0) +instance (Semigroup a) => Semigroup (Constant a b) where + Constant x <> Constant y = Constant (x <> y) + {-# INLINE (<>) #-} +#endif + +instance (Monoid a) => Applicative (Constant a) where + pure _ = Constant mempty + {-# INLINE pure #-} + Constant x <*> Constant y = Constant (x `mappend` y) + {-# INLINE (<*>) #-} + +instance (Monoid a) => Monoid (Constant a b) where + mempty = Constant mempty + {-# INLINE mempty #-} +#if !MIN_VERSION_base(4,11,0) + -- From base-4.11, Monoid(mappend) defaults to Semigroup((<>)) + Constant x `mappend` Constant y = Constant (x `mappend` y) + {-# INLINE mappend #-} +#endif + +#if MIN_VERSION_base(4,8,0) +instance Bifunctor Constant where + first f (Constant x) = Constant (f x) + {-# INLINE first #-} + second _ (Constant x) = Constant x + {-# INLINE second #-} +#endif + +#if MIN_VERSION_base(4,10,0) +instance Bifoldable Constant where + bifoldMap f _ (Constant a) = f a + {-# INLINE bifoldMap #-} + +instance Bitraversable Constant where + bitraverse f _ (Constant a) = Constant <$> f a + {-# INLINE bitraverse #-} +#endif + +#if MIN_VERSION_base(4,12,0) +instance Contravariant (Constant a) where + contramap _ (Constant a) = Constant a + {-# INLINE contramap #-} +#endif diff --git a/third_party/bazel/rules_haskell/examples/transformers/Data/Functor/Reverse.hs b/third_party/bazel/rules_haskell/examples/transformers/Data/Functor/Reverse.hs new file mode 100644 index 000000000000..5d8c41fa15c1 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Data/Functor/Reverse.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE PolyKinds #-} +#endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE AutoDeriveTypeable #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Data.Functor.Reverse +-- Copyright : (c) Russell O'Connor 2009 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- Making functors whose elements are notionally in the reverse order +-- from the original functor. +----------------------------------------------------------------------------- + +module Data.Functor.Reverse ( + Reverse(..), + ) where + +import Control.Applicative.Backwards +import Data.Functor.Classes +#if MIN_VERSION_base(4,12,0) +import Data.Functor.Contravariant +#endif + +import Prelude hiding (foldr, foldr1, foldl, foldl1, null, length) +import Control.Applicative +import Control.Monad +#if MIN_VERSION_base(4,9,0) +import qualified Control.Monad.Fail as Fail +#endif +import Data.Foldable +import Data.Traversable +import Data.Monoid + +-- | The same functor, but with 'Foldable' and 'Traversable' instances +-- that process the elements in the reverse order. +newtype Reverse f a = Reverse { getReverse :: f a } + +instance (Eq1 f) => Eq1 (Reverse f) where + liftEq eq (Reverse x) (Reverse y) = liftEq eq x y + {-# INLINE liftEq #-} + +instance (Ord1 f) => Ord1 (Reverse f) where + liftCompare comp (Reverse x) (Reverse y) = liftCompare comp x y + {-# INLINE liftCompare #-} + +instance (Read1 f) => Read1 (Reverse f) where + liftReadsPrec rp rl = readsData $ + readsUnaryWith (liftReadsPrec rp rl) "Reverse" Reverse + +instance (Show1 f) => Show1 (Reverse f) where + liftShowsPrec sp sl d (Reverse x) = + showsUnaryWith (liftShowsPrec sp sl) "Reverse" d x + +instance (Eq1 f, Eq a) => Eq (Reverse f a) where (==) = eq1 +instance (Ord1 f, Ord a) => Ord (Reverse f a) where compare = compare1 +instance (Read1 f, Read a) => Read (Reverse f a) where readsPrec = readsPrec1 +instance (Show1 f, Show a) => Show (Reverse f a) where showsPrec = showsPrec1 + +-- | Derived instance. +instance (Functor f) => Functor (Reverse f) where + fmap f (Reverse a) = Reverse (fmap f a) + {-# INLINE fmap #-} + +-- | Derived instance. +instance (Applicative f) => Applicative (Reverse f) where + pure a = Reverse (pure a) + {-# INLINE pure #-} + Reverse f <*> Reverse a = Reverse (f <*> a) + {-# INLINE (<*>) #-} + +-- | Derived instance. +instance (Alternative f) => Alternative (Reverse f) where + empty = Reverse empty + {-# INLINE empty #-} + Reverse x <|> Reverse y = Reverse (x <|> y) + {-# INLINE (<|>) #-} + +-- | Derived instance. +instance (Monad m) => Monad (Reverse m) where +#if !(MIN_VERSION_base(4,8,0)) + return a = Reverse (return a) + {-# INLINE return #-} +#endif + m >>= f = Reverse (getReverse m >>= getReverse . f) + {-# INLINE (>>=) #-} +#if !(MIN_VERSION_base(4,13,0)) + fail msg = Reverse (fail msg) + {-# INLINE fail #-} +#endif + +#if MIN_VERSION_base(4,9,0) +instance (Fail.MonadFail m) => Fail.MonadFail (Reverse m) where + fail msg = Reverse (Fail.fail msg) + {-# INLINE fail #-} +#endif + +-- | Derived instance. +instance (MonadPlus m) => MonadPlus (Reverse m) where + mzero = Reverse mzero + {-# INLINE mzero #-} + Reverse x `mplus` Reverse y = Reverse (x `mplus` y) + {-# INLINE mplus #-} + +-- | Fold from right to left. +instance (Foldable f) => Foldable (Reverse f) where + foldMap f (Reverse t) = getDual (foldMap (Dual . f) t) + {-# INLINE foldMap #-} + foldr f z (Reverse t) = foldl (flip f) z t + {-# INLINE foldr #-} + foldl f z (Reverse t) = foldr (flip f) z t + {-# INLINE foldl #-} + foldr1 f (Reverse t) = foldl1 (flip f) t + {-# INLINE foldr1 #-} + foldl1 f (Reverse t) = foldr1 (flip f) t + {-# INLINE foldl1 #-} +#if MIN_VERSION_base(4,8,0) + null (Reverse t) = null t + length (Reverse t) = length t +#endif + +-- | Traverse from right to left. +instance (Traversable f) => Traversable (Reverse f) where + traverse f (Reverse t) = + fmap Reverse . forwards $ traverse (Backwards . f) t + {-# INLINE traverse #-} + +#if MIN_VERSION_base(4,12,0) +-- | Derived instance. +instance Contravariant f => Contravariant (Reverse f) where + contramap f = Reverse . contramap f . getReverse + {-# INLINE contramap #-} +#endif diff --git a/third_party/bazel/rules_haskell/examples/transformers/LICENSE b/third_party/bazel/rules_haskell/examples/transformers/LICENSE new file mode 100644 index 000000000000..92337b951eb0 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/LICENSE @@ -0,0 +1,31 @@ +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. diff --git a/third_party/bazel/rules_haskell/examples/transformers/Setup.hs b/third_party/bazel/rules_haskell/examples/transformers/Setup.hs new file mode 100644 index 000000000000..9a994af677b0 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/third_party/bazel/rules_haskell/examples/transformers/changelog b/third_party/bazel/rules_haskell/examples/transformers/changelog new file mode 100644 index 000000000000..5dd688f35b78 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/changelog @@ -0,0 +1,124 @@ +-*-change-log-*- + +0.5.6.2 Ross Paterson <R.Paterson@city.ac.uk> Feb 2019 + * Further backward compatability fix + +0.5.6.1 Ross Paterson <R.Paterson@city.ac.uk> Feb 2019 + * Backward compatability fix for MonadFix ListT instance + +0.5.6.0 Ross Paterson <R.Paterson@city.ac.uk> Feb 2019 + * Generalized type of except + * Added Control.Monad.Trans.Writer.CPS and Control.Monad.Trans.RWS.CPS + * Added Contravariant instances + * Added MonadFix instance for ListT + +0.5.5.0 Ross Paterson <R.Paterson@city.ac.uk> Oct 2017 + * Added mapSelect and mapSelectT + * Renamed selectToCont to selectToContT for consistency + * Defined explicit method definitions to fix space leaks + * Added missing Semigroup instance to `Constant` functor + +0.5.4.0 Ross Paterson <R.Paterson@city.ac.uk> Feb 2017 + * Migrate Bifoldable and Bitraversable instances for Constant + +0.5.3.1 Ross Paterson <R.Paterson@city.ac.uk> Feb 2017 + * Fixed for pre-AMP environments + +0.5.3.0 Ross Paterson <R.Paterson@city.ac.uk> Feb 2017 + * Added AccumT and SelectT monad transformers + * Deprecated ListT + * Added Monad (and related) instances for Reverse + * Added elimLift and eitherToErrors + * Added specialized definitions of several methods for efficiency + * Removed specialized definition of sequenceA for Reverse + * Backported Eq1/Ord1/Read1/Show1 instances for Proxy + +0.5.2.0 Ross Paterson <R.Paterson@city.ac.uk> Feb 2016 + * Re-added orphan instances for Either to deprecated module + * Added lots of INLINE pragmas + +0.5.1.0 Ross Paterson <R.Paterson@city.ac.uk> Jan 2016 + * Bump minor version number, required by added instances + +0.5.0.2 Ross Paterson <R.Paterson@city.ac.uk> Jan 2016 + * Backported extra instances for Identity + +0.5.0.1 Ross Paterson <R.Paterson@city.ac.uk> Jan 2016 + * Tightened GHC bounds for PolyKinds and DeriveDataTypeable + +0.5.0.0 Ross Paterson <R.Paterson@city.ac.uk> Dec 2015 + * Control.Monad.IO.Class in base for GHC >= 8.0 + * Data.Functor.{Classes,Compose,Product,Sum} in base for GHC >= 8.0 + * Added PolyKinds for GHC >= 7.4 + * Added instances of base classes MonadZip and MonadFail + * Changed liftings of Prelude classes to use explicit dictionaries + +0.4.3.0 Ross Paterson <R.Paterson@city.ac.uk> Mar 2015 + * Added Eq1, Ord1, Show1 and Read1 instances for Const + +0.4.2.0 Ross Paterson <ross@soi.city.ac.uk> Nov 2014 + * Dropped compatibility with base-1.x + * Data.Functor.Identity in base for GHC >= 7.10 + * Added mapLift and runErrors to Control.Applicative.Lift + * Added AutoDeriveTypeable for GHC >= 7.10 + * Expanded messages from mfix on ExceptT and MaybeT + +0.4.1.0 Ross Paterson <ross@soi.city.ac.uk> May 2014 + * Reverted to record syntax for newtypes until next major release + +0.4.0.0 Ross Paterson <ross@soi.city.ac.uk> May 2014 + * Added Sum type + * Added modify', a strict version of modify, to the state monads + * Added ExceptT and deprecated ErrorT + * Added infixr 9 `Compose` to match (.) + * Added Eq, Ord, Read and Show instances where possible + * Replaced record syntax for newtypes with separate inverse functions + * Added delimited continuation functions to ContT + * Added instance Alternative IO to ErrorT + * Handled disappearance of Control.Monad.Instances + +0.3.0.0 Ross Paterson <ross@soi.city.ac.uk> Mar 2012 + * Added type synonyms for signatures of complex operations + * Generalized state, reader and writer constructor functions + * Added Lift, Backwards/Reverse + * Added MonadFix instances for IdentityT and MaybeT + * Added Foldable and Traversable instances + * Added Monad instances for Product + +0.2.2.1 Ross Paterson <ross@soi.city.ac.uk> Oct 2013 + * Backport of fix for disappearance of Control.Monad.Instances + +0.2.2.0 Ross Paterson <ross@soi.city.ac.uk> Sep 2010 + * Handled move of Either instances to base package + +0.2.1.0 Ross Paterson <ross@soi.city.ac.uk> Apr 2010 + * Added Alternative instance for Compose + * Added Data.Functor.Product + +0.2.0.0 Ross Paterson <ross@soi.city.ac.uk> Mar 2010 + * Added Constant and Compose + * Renamed modules to avoid clash with mtl + * Removed Monad constraint from Monad instance for ContT + +0.1.4.0 Ross Paterson <ross@soi.city.ac.uk> Mar 2009 + * Adjusted lifting of Identity and Maybe transformers + +0.1.3.0 Ross Paterson <ross@soi.city.ac.uk> Mar 2009 + * Added IdentityT transformer + * Added Applicative and Alternative instances for (Either e) + +0.1.1.0 Ross Paterson <ross@soi.city.ac.uk> Jan 2009 + * Made all Functor instances assume Functor + +0.1.0.1 Ross Paterson <ross@soi.city.ac.uk> Jan 2009 + * Adjusted dependencies + +0.1.0.0 Ross Paterson <ross@soi.city.ac.uk> Jan 2009 + * Two versions of lifting of callcc through StateT + * Added Applicative instances + +0.0.1.0 Ross Paterson <ross@soi.city.ac.uk> Jan 2009 + * Added constructors state, etc for simple monads + +0.0.0.0 Ross Paterson <ross@soi.city.ac.uk> Jan 2009 + * Split Haskell 98 transformers from the mtl diff --git a/third_party/bazel/rules_haskell/examples/transformers/legacy/pre709/Data/Functor/Identity.hs b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre709/Data/Functor/Identity.hs new file mode 100644 index 000000000000..940e4e470f47 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre709/Data/Functor/Identity.hs @@ -0,0 +1,259 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 700 +{-# LANGUAGE DeriveDataTypeable #-} +#endif +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE Trustworthy #-} +#endif +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE PolyKinds #-} +#endif +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE DataKinds #-} +#endif +#if MIN_VERSION_base(4,7,0) +-- We need to implement bitSize for the Bits instance, but it's deprecated. +{-# OPTIONS_GHC -fno-warn-deprecations #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Data.Functor.Identity +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : ross@soi.city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- The identity functor and monad. +-- +-- This trivial type constructor serves two purposes: +-- +-- * It can be used with functions parameterized by functor or monad classes. +-- +-- * It can be used as a base monad to which a series of monad +-- transformers may be applied to construct a composite monad. +-- Most monad transformer modules include the special case of +-- applying the transformer to 'Identity'. For example, @State s@ +-- is an abbreviation for @StateT s 'Identity'@. +----------------------------------------------------------------------------- + +module Data.Functor.Identity ( + Identity(..), + ) where + +import Data.Bits +import Control.Applicative +import Control.Arrow (Arrow((***))) +import Control.Monad.Fix +#if MIN_VERSION_base(4,4,0) +import Control.Monad.Zip (MonadZip(mzipWith, munzip)) +#endif +import Data.Foldable (Foldable(foldMap)) +import Data.Monoid (Monoid(mempty, mappend)) +import Data.String (IsString(fromString)) +import Data.Traversable (Traversable(traverse)) +#if __GLASGOW_HASKELL__ >= 700 +import Data.Data +#endif +import Data.Ix (Ix(..)) +import Foreign (Storable(..), castPtr) +#if __GLASGOW_HASKELL__ >= 702 +import GHC.Generics +#endif + +-- | Identity functor and monad. (a non-strict monad) +newtype Identity a = Identity { runIdentity :: a } + deriving ( Eq, Ord +#if __GLASGOW_HASKELL__ >= 700 + , Data, Typeable +#endif +#if __GLASGOW_HASKELL__ >= 702 + , Generic +#endif +#if __GLASGOW_HASKELL__ >= 706 + , Generic1 +#endif + ) + +instance (Bits a) => Bits (Identity a) where + Identity x .&. Identity y = Identity (x .&. y) + Identity x .|. Identity y = Identity (x .|. y) + xor (Identity x) (Identity y) = Identity (xor x y) + complement (Identity x) = Identity (complement x) + shift (Identity x) i = Identity (shift x i) + rotate (Identity x) i = Identity (rotate x i) + setBit (Identity x) i = Identity (setBit x i) + clearBit (Identity x) i = Identity (clearBit x i) + shiftL (Identity x) i = Identity (shiftL x i) + shiftR (Identity x) i = Identity (shiftR x i) + rotateL (Identity x) i = Identity (rotateL x i) + rotateR (Identity x) i = Identity (rotateR x i) + testBit (Identity x) i = testBit x i + bitSize (Identity x) = bitSize x + isSigned (Identity x) = isSigned x + bit i = Identity (bit i) +#if MIN_VERSION_base(4,5,0) + unsafeShiftL (Identity x) i = Identity (unsafeShiftL x i) + unsafeShiftR (Identity x) i = Identity (unsafeShiftR x i) + popCount (Identity x) = popCount x +#endif +#if MIN_VERSION_base(4,7,0) + zeroBits = Identity zeroBits + bitSizeMaybe (Identity x) = bitSizeMaybe x +#endif + +instance (Bounded a) => Bounded (Identity a) where + minBound = Identity minBound + maxBound = Identity maxBound + +instance (Enum a) => Enum (Identity a) where + succ (Identity x) = Identity (succ x) + pred (Identity x) = Identity (pred x) + toEnum i = Identity (toEnum i) + fromEnum (Identity x) = fromEnum x + enumFrom (Identity x) = map Identity (enumFrom x) + enumFromThen (Identity x) (Identity y) = map Identity (enumFromThen x y) + enumFromTo (Identity x) (Identity y) = map Identity (enumFromTo x y) + enumFromThenTo (Identity x) (Identity y) (Identity z) = + map Identity (enumFromThenTo x y z) + +#if MIN_VERSION_base(4,7,0) +instance (FiniteBits a) => FiniteBits (Identity a) where + finiteBitSize (Identity x) = finiteBitSize x +#endif + +instance (Floating a) => Floating (Identity a) where + pi = Identity pi + exp (Identity x) = Identity (exp x) + log (Identity x) = Identity (log x) + sqrt (Identity x) = Identity (sqrt x) + sin (Identity x) = Identity (sin x) + cos (Identity x) = Identity (cos x) + tan (Identity x) = Identity (tan x) + asin (Identity x) = Identity (asin x) + acos (Identity x) = Identity (acos x) + atan (Identity x) = Identity (atan x) + sinh (Identity x) = Identity (sinh x) + cosh (Identity x) = Identity (cosh x) + tanh (Identity x) = Identity (tanh x) + asinh (Identity x) = Identity (asinh x) + acosh (Identity x) = Identity (acosh x) + atanh (Identity x) = Identity (atanh x) + Identity x ** Identity y = Identity (x ** y) + logBase (Identity x) (Identity y) = Identity (logBase x y) + +instance (Fractional a) => Fractional (Identity a) where + Identity x / Identity y = Identity (x / y) + recip (Identity x) = Identity (recip x) + fromRational r = Identity (fromRational r) + +instance (IsString a) => IsString (Identity a) where + fromString s = Identity (fromString s) + +instance (Ix a) => Ix (Identity a) where + range (Identity x, Identity y) = map Identity (range (x, y)) + index (Identity x, Identity y) (Identity i) = index (x, y) i + inRange (Identity x, Identity y) (Identity e) = inRange (x, y) e + rangeSize (Identity x, Identity y) = rangeSize (x, y) + +instance (Integral a) => Integral (Identity a) where + quot (Identity x) (Identity y) = Identity (quot x y) + rem (Identity x) (Identity y) = Identity (rem x y) + div (Identity x) (Identity y) = Identity (div x y) + mod (Identity x) (Identity y) = Identity (mod x y) + quotRem (Identity x) (Identity y) = (Identity *** Identity) (quotRem x y) + divMod (Identity x) (Identity y) = (Identity *** Identity) (divMod x y) + toInteger (Identity x) = toInteger x + +instance (Monoid a) => Monoid (Identity a) where + mempty = Identity mempty + mappend (Identity x) (Identity y) = Identity (mappend x y) + +instance (Num a) => Num (Identity a) where + Identity x + Identity y = Identity (x + y) + Identity x - Identity y = Identity (x - y) + Identity x * Identity y = Identity (x * y) + negate (Identity x) = Identity (negate x) + abs (Identity x) = Identity (abs x) + signum (Identity x) = Identity (signum x) + fromInteger n = Identity (fromInteger n) + +instance (Real a) => Real (Identity a) where + toRational (Identity x) = toRational x + +instance (RealFloat a) => RealFloat (Identity a) where + floatRadix (Identity x) = floatRadix x + floatDigits (Identity x) = floatDigits x + floatRange (Identity x) = floatRange x + decodeFloat (Identity x) = decodeFloat x + exponent (Identity x) = exponent x + isNaN (Identity x) = isNaN x + isInfinite (Identity x) = isInfinite x + isDenormalized (Identity x) = isDenormalized x + isNegativeZero (Identity x) = isNegativeZero x + isIEEE (Identity x) = isIEEE x + significand (Identity x) = significand (Identity x) + scaleFloat s (Identity x) = Identity (scaleFloat s x) + encodeFloat m n = Identity (encodeFloat m n) + atan2 (Identity x) (Identity y) = Identity (atan2 x y) + +instance (RealFrac a) => RealFrac (Identity a) where + properFraction (Identity x) = (id *** Identity) (properFraction x) + truncate (Identity x) = truncate x + round (Identity x) = round x + ceiling (Identity x) = ceiling x + floor (Identity x) = floor x + +instance (Storable a) => Storable (Identity a) where + sizeOf (Identity x) = sizeOf x + alignment (Identity x) = alignment x + peekElemOff p i = fmap Identity (peekElemOff (castPtr p) i) + pokeElemOff p i (Identity x) = pokeElemOff (castPtr p) i x + peekByteOff p i = fmap Identity (peekByteOff p i) + pokeByteOff p i (Identity x) = pokeByteOff p i x + peek p = fmap runIdentity (peek (castPtr p)) + poke p (Identity x) = poke (castPtr p) x + +-- These instances would be equivalent to the derived instances of the +-- newtype if the field were removed. + +instance (Read a) => Read (Identity a) where + readsPrec d = readParen (d > 10) $ \ r -> + [(Identity x,t) | ("Identity",s) <- lex r, (x,t) <- readsPrec 11 s] + +instance (Show a) => Show (Identity a) where + showsPrec d (Identity x) = showParen (d > 10) $ + showString "Identity " . showsPrec 11 x + +-- --------------------------------------------------------------------------- +-- Identity instances for Functor and Monad + +instance Functor Identity where + fmap f m = Identity (f (runIdentity m)) + +instance Foldable Identity where + foldMap f (Identity x) = f x + +instance Traversable Identity where + traverse f (Identity x) = Identity <$> f x + +instance Applicative Identity where + pure a = Identity a + Identity f <*> Identity x = Identity (f x) + +instance Monad Identity where + return a = Identity a + m >>= k = k (runIdentity m) + +instance MonadFix Identity where + mfix f = Identity (fix (runIdentity . f)) + +#if MIN_VERSION_base(4,4,0) +instance MonadZip Identity where + mzipWith f (Identity x) (Identity y) = Identity (f x y) + munzip (Identity (a, b)) = (Identity a, Identity b) +#endif diff --git a/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Control/Monad/IO/Class.hs b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Control/Monad/IO/Class.hs new file mode 100644 index 000000000000..7c74d4ef0d71 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Control/Monad/IO/Class.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.IO.Class +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- Class of monads based on @IO@. +----------------------------------------------------------------------------- + +module Control.Monad.IO.Class ( + MonadIO(..) + ) where + +#if __GLASGOW_HASKELL__ >= 708 +import Data.Typeable +#endif + +-- | Monads in which 'IO' computations may be embedded. +-- Any monad built by applying a sequence of monad transformers to the +-- 'IO' monad will be an instance of this class. +-- +-- Instances should satisfy the following laws, which state that 'liftIO' +-- is a transformer of monads: +-- +-- * @'liftIO' . 'return' = 'return'@ +-- +-- * @'liftIO' (m >>= f) = 'liftIO' m >>= ('liftIO' . f)@ + +class (Monad m) => MonadIO m where + -- | Lift a computation from the 'IO' monad. + liftIO :: IO a -> m a + +#if __GLASGOW_HASKELL__ >= 708 +deriving instance Typeable MonadIO +#endif + +instance MonadIO IO where + liftIO = id diff --git a/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Classes.hs b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Classes.hs new file mode 100644 index 000000000000..bda1749643d1 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Classes.hs @@ -0,0 +1,529 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} +#endif +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Data.Functor.Classes +-- Copyright : (c) Ross Paterson 2013 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- Liftings of the Prelude classes 'Eq', 'Ord', 'Read' and 'Show' to +-- unary and binary type constructors. +-- +-- These classes are needed to express the constraints on arguments of +-- transformers in portable Haskell. Thus for a new transformer @T@, +-- one might write instances like +-- +-- > instance (Eq1 f) => Eq1 (T f) where ... +-- > instance (Ord1 f) => Ord1 (T f) where ... +-- > instance (Read1 f) => Read1 (T f) where ... +-- > instance (Show1 f) => Show1 (T f) where ... +-- +-- If these instances can be defined, defining instances of the base +-- classes is mechanical: +-- +-- > instance (Eq1 f, Eq a) => Eq (T f a) where (==) = eq1 +-- > instance (Ord1 f, Ord a) => Ord (T f a) where compare = compare1 +-- > instance (Read1 f, Read a) => Read (T f a) where readsPrec = readsPrec1 +-- > instance (Show1 f, Show a) => Show (T f a) where showsPrec = showsPrec1 +-- +----------------------------------------------------------------------------- + +module Data.Functor.Classes ( + -- * Liftings of Prelude classes + -- ** For unary constructors + Eq1(..), eq1, + Ord1(..), compare1, + Read1(..), readsPrec1, + Show1(..), showsPrec1, + -- ** For binary constructors + Eq2(..), eq2, + Ord2(..), compare2, + Read2(..), readsPrec2, + Show2(..), showsPrec2, + -- * Helper functions + -- $example + readsData, + readsUnaryWith, + readsBinaryWith, + showsUnaryWith, + showsBinaryWith, + -- ** Obsolete helpers + readsUnary, + readsUnary1, + readsBinary1, + showsUnary, + showsUnary1, + showsBinary1, + ) where + +import Control.Applicative (Const(Const)) +import Data.Functor.Identity (Identity(Identity)) +import Data.Monoid (mappend) +#if MIN_VERSION_base(4,7,0) +import Data.Proxy (Proxy(Proxy)) +#endif +#if __GLASGOW_HASKELL__ >= 708 +import Data.Typeable +#endif +import Text.Show (showListWith) + +-- | Lifting of the 'Eq' class to unary type constructors. +class Eq1 f where + -- | Lift an equality test through the type constructor. + -- + -- The function will usually be applied to an equality function, + -- but the more general type ensures that the implementation uses + -- it to compare elements of the first container with elements of + -- the second. + liftEq :: (a -> b -> Bool) -> f a -> f b -> Bool + +#if __GLASGOW_HASKELL__ >= 708 +deriving instance Typeable Eq1 +#endif + +-- | Lift the standard @('==')@ function through the type constructor. +eq1 :: (Eq1 f, Eq a) => f a -> f a -> Bool +eq1 = liftEq (==) + +-- | Lifting of the 'Ord' class to unary type constructors. +class (Eq1 f) => Ord1 f where + -- | Lift a 'compare' function through the type constructor. + -- + -- The function will usually be applied to a comparison function, + -- but the more general type ensures that the implementation uses + -- it to compare elements of the first container with elements of + -- the second. + liftCompare :: (a -> b -> Ordering) -> f a -> f b -> Ordering + +#if __GLASGOW_HASKELL__ >= 708 +deriving instance Typeable Ord1 +#endif + +-- | Lift the standard 'compare' function through the type constructor. +compare1 :: (Ord1 f, Ord a) => f a -> f a -> Ordering +compare1 = liftCompare compare + +-- | Lifting of the 'Read' class to unary type constructors. +class Read1 f where + -- | 'readsPrec' function for an application of the type constructor + -- based on 'readsPrec' and 'readList' functions for the argument type. + liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a) + + -- | 'readList' function for an application of the type constructor + -- based on 'readsPrec' and 'readList' functions for the argument type. + -- The default implementation using standard list syntax is correct + -- for most types. + liftReadList :: (Int -> ReadS a) -> ReadS [a] -> ReadS [f a] + liftReadList rp rl = readListWith (liftReadsPrec rp rl 0) + +#if __GLASGOW_HASKELL__ >= 708 +deriving instance Typeable Read1 +#endif + +-- | Read a list (using square brackets and commas), given a function +-- for reading elements. +readListWith :: ReadS a -> ReadS [a] +readListWith rp = + readParen False (\r -> [pr | ("[",s) <- lex r, pr <- readl s]) + where + readl s = [([],t) | ("]",t) <- lex s] ++ + [(x:xs,u) | (x,t) <- rp s, (xs,u) <- readl' t] + readl' s = [([],t) | ("]",t) <- lex s] ++ + [(x:xs,v) | (",",t) <- lex s, (x,u) <- rp t, (xs,v) <- readl' u] + +-- | Lift the standard 'readsPrec' and 'readList' functions through the +-- type constructor. +readsPrec1 :: (Read1 f, Read a) => Int -> ReadS (f a) +readsPrec1 = liftReadsPrec readsPrec readList + +-- | Lifting of the 'Show' class to unary type constructors. +class Show1 f where + -- | 'showsPrec' function for an application of the type constructor + -- based on 'showsPrec' and 'showList' functions for the argument type. + liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> + Int -> f a -> ShowS + + -- | 'showList' function for an application of the type constructor + -- based on 'showsPrec' and 'showList' functions for the argument type. + -- The default implementation using standard list syntax is correct + -- for most types. + liftShowList :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> + [f a] -> ShowS + liftShowList sp sl = showListWith (liftShowsPrec sp sl 0) + +#if __GLASGOW_HASKELL__ >= 708 +deriving instance Typeable Show1 +#endif + +-- | Lift the standard 'showsPrec' and 'showList' functions through the +-- type constructor. +showsPrec1 :: (Show1 f, Show a) => Int -> f a -> ShowS +showsPrec1 = liftShowsPrec showsPrec showList + +-- | Lifting of the 'Eq' class to binary type constructors. +class Eq2 f where + -- | Lift equality tests through the type constructor. + -- + -- The function will usually be applied to equality functions, + -- but the more general type ensures that the implementation uses + -- them to compare elements of the first container with elements of + -- the second. + liftEq2 :: (a -> b -> Bool) -> (c -> d -> Bool) -> f a c -> f b d -> Bool + +#if __GLASGOW_HASKELL__ >= 708 +deriving instance Typeable Eq2 +#endif + +-- | Lift the standard @('==')@ function through the type constructor. +eq2 :: (Eq2 f, Eq a, Eq b) => f a b -> f a b -> Bool +eq2 = liftEq2 (==) (==) + +-- | Lifting of the 'Ord' class to binary type constructors. +class (Eq2 f) => Ord2 f where + -- | Lift 'compare' functions through the type constructor. + -- + -- The function will usually be applied to comparison functions, + -- but the more general type ensures that the implementation uses + -- them to compare elements of the first container with elements of + -- the second. + liftCompare2 :: (a -> b -> Ordering) -> (c -> d -> Ordering) -> + f a c -> f b d -> Ordering + +#if __GLASGOW_HASKELL__ >= 708 +deriving instance Typeable Ord2 +#endif + +-- | Lift the standard 'compare' function through the type constructor. +compare2 :: (Ord2 f, Ord a, Ord b) => f a b -> f a b -> Ordering +compare2 = liftCompare2 compare compare + +-- | Lifting of the 'Read' class to binary type constructors. +class Read2 f where + -- | 'readsPrec' function for an application of the type constructor + -- based on 'readsPrec' and 'readList' functions for the argument types. + liftReadsPrec2 :: (Int -> ReadS a) -> ReadS [a] -> + (Int -> ReadS b) -> ReadS [b] -> Int -> ReadS (f a b) + + -- | 'readList' function for an application of the type constructor + -- based on 'readsPrec' and 'readList' functions for the argument types. + -- The default implementation using standard list syntax is correct + -- for most types. + liftReadList2 :: (Int -> ReadS a) -> ReadS [a] -> + (Int -> ReadS b) -> ReadS [b] -> ReadS [f a b] + liftReadList2 rp1 rl1 rp2 rl2 = + readListWith (liftReadsPrec2 rp1 rl1 rp2 rl2 0) + +#if __GLASGOW_HASKELL__ >= 708 +deriving instance Typeable Read2 +#endif + +-- | Lift the standard 'readsPrec' function through the type constructor. +readsPrec2 :: (Read2 f, Read a, Read b) => Int -> ReadS (f a b) +readsPrec2 = liftReadsPrec2 readsPrec readList readsPrec readList + +-- | Lifting of the 'Show' class to binary type constructors. +class Show2 f where + -- | 'showsPrec' function for an application of the type constructor + -- based on 'showsPrec' and 'showList' functions for the argument types. + liftShowsPrec2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> + (Int -> b -> ShowS) -> ([b] -> ShowS) -> Int -> f a b -> ShowS + + -- | 'showList' function for an application of the type constructor + -- based on 'showsPrec' and 'showList' functions for the argument types. + -- The default implementation using standard list syntax is correct + -- for most types. + liftShowList2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> + (Int -> b -> ShowS) -> ([b] -> ShowS) -> [f a b] -> ShowS + liftShowList2 sp1 sl1 sp2 sl2 = + showListWith (liftShowsPrec2 sp1 sl1 sp2 sl2 0) + +#if __GLASGOW_HASKELL__ >= 708 +deriving instance Typeable Show2 +#endif + +-- | Lift the standard 'showsPrec' function through the type constructor. +showsPrec2 :: (Show2 f, Show a, Show b) => Int -> f a b -> ShowS +showsPrec2 = liftShowsPrec2 showsPrec showList showsPrec showList + +-- Instances for Prelude type constructors + +instance Eq1 Maybe where + liftEq _ Nothing Nothing = True + liftEq _ Nothing (Just _) = False + liftEq _ (Just _) Nothing = False + liftEq eq (Just x) (Just y) = eq x y + +instance Ord1 Maybe where + liftCompare _ Nothing Nothing = EQ + liftCompare _ Nothing (Just _) = LT + liftCompare _ (Just _) Nothing = GT + liftCompare comp (Just x) (Just y) = comp x y + +instance Read1 Maybe where + liftReadsPrec rp _ d = + readParen False (\ r -> [(Nothing,s) | ("Nothing",s) <- lex r]) + `mappend` + readsData (readsUnaryWith rp "Just" Just) d + +instance Show1 Maybe where + liftShowsPrec _ _ _ Nothing = showString "Nothing" + liftShowsPrec sp _ d (Just x) = showsUnaryWith sp "Just" d x + +instance Eq1 [] where + liftEq _ [] [] = True + liftEq _ [] (_:_) = False + liftEq _ (_:_) [] = False + liftEq eq (x:xs) (y:ys) = eq x y && liftEq eq xs ys + +instance Ord1 [] where + liftCompare _ [] [] = EQ + liftCompare _ [] (_:_) = LT + liftCompare _ (_:_) [] = GT + liftCompare comp (x:xs) (y:ys) = comp x y `mappend` liftCompare comp xs ys + +instance Read1 [] where + liftReadsPrec _ rl _ = rl + +instance Show1 [] where + liftShowsPrec _ sl _ = sl + +instance Eq2 (,) where + liftEq2 e1 e2 (x1, y1) (x2, y2) = e1 x1 x2 && e2 y1 y2 + +instance Ord2 (,) where + liftCompare2 comp1 comp2 (x1, y1) (x2, y2) = + comp1 x1 x2 `mappend` comp2 y1 y2 + +instance Read2 (,) where + liftReadsPrec2 rp1 _ rp2 _ _ = readParen False $ \ r -> + [((x,y), w) | ("(",s) <- lex r, + (x,t) <- rp1 0 s, + (",",u) <- lex t, + (y,v) <- rp2 0 u, + (")",w) <- lex v] + +instance Show2 (,) where + liftShowsPrec2 sp1 _ sp2 _ _ (x, y) = + showChar '(' . sp1 0 x . showChar ',' . sp2 0 y . showChar ')' + +instance (Eq a) => Eq1 ((,) a) where + liftEq = liftEq2 (==) + +instance (Ord a) => Ord1 ((,) a) where + liftCompare = liftCompare2 compare + +instance (Read a) => Read1 ((,) a) where + liftReadsPrec = liftReadsPrec2 readsPrec readList + +instance (Show a) => Show1 ((,) a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + +instance Eq2 Either where + liftEq2 e1 _ (Left x) (Left y) = e1 x y + liftEq2 _ _ (Left _) (Right _) = False + liftEq2 _ _ (Right _) (Left _) = False + liftEq2 _ e2 (Right x) (Right y) = e2 x y + +instance Ord2 Either where + liftCompare2 comp1 _ (Left x) (Left y) = comp1 x y + liftCompare2 _ _ (Left _) (Right _) = LT + liftCompare2 _ _ (Right _) (Left _) = GT + liftCompare2 _ comp2 (Right x) (Right y) = comp2 x y + +instance Read2 Either where + liftReadsPrec2 rp1 _ rp2 _ = readsData $ + readsUnaryWith rp1 "Left" Left `mappend` + readsUnaryWith rp2 "Right" Right + +instance Show2 Either where + liftShowsPrec2 sp1 _ _ _ d (Left x) = showsUnaryWith sp1 "Left" d x + liftShowsPrec2 _ _ sp2 _ d (Right x) = showsUnaryWith sp2 "Right" d x + +instance (Eq a) => Eq1 (Either a) where + liftEq = liftEq2 (==) + +instance (Ord a) => Ord1 (Either a) where + liftCompare = liftCompare2 compare + +instance (Read a) => Read1 (Either a) where + liftReadsPrec = liftReadsPrec2 readsPrec readList + +instance (Show a) => Show1 (Either a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + +#if MIN_VERSION_base(4,7,0) +instance Eq1 Proxy where + liftEq _ _ _ = True + +instance Ord1 Proxy where + liftCompare _ _ _ = EQ + +instance Show1 Proxy where + liftShowsPrec _ _ _ _ = showString "Proxy" + +instance Read1 Proxy where + liftReadsPrec _ _ d = + readParen (d > 10) (\r -> [(Proxy, s) | ("Proxy",s) <- lex r ]) +#endif + +-- Instances for other functors defined in the base package + +instance Eq1 Identity where + liftEq eq (Identity x) (Identity y) = eq x y + +instance Ord1 Identity where + liftCompare comp (Identity x) (Identity y) = comp x y + +instance Read1 Identity where + liftReadsPrec rp _ = readsData $ + readsUnaryWith rp "Identity" Identity + +instance Show1 Identity where + liftShowsPrec sp _ d (Identity x) = showsUnaryWith sp "Identity" d x + +instance Eq2 Const where + liftEq2 eq _ (Const x) (Const y) = eq x y + +instance Ord2 Const where + liftCompare2 comp _ (Const x) (Const y) = comp x y + +instance Read2 Const where + liftReadsPrec2 rp _ _ _ = readsData $ + readsUnaryWith rp "Const" Const + +instance Show2 Const where + liftShowsPrec2 sp _ _ _ d (Const x) = showsUnaryWith sp "Const" d x + +instance (Eq a) => Eq1 (Const a) where + liftEq = liftEq2 (==) +instance (Ord a) => Ord1 (Const a) where + liftCompare = liftCompare2 compare +instance (Read a) => Read1 (Const a) where + liftReadsPrec = liftReadsPrec2 readsPrec readList +instance (Show a) => Show1 (Const a) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + +-- Building blocks + +-- | @'readsData' p d@ is a parser for datatypes where each alternative +-- begins with a data constructor. It parses the constructor and +-- passes it to @p@. Parsers for various constructors can be constructed +-- with 'readsUnary', 'readsUnary1' and 'readsBinary1', and combined with +-- @mappend@ from the @Monoid@ class. +readsData :: (String -> ReadS a) -> Int -> ReadS a +readsData reader d = + readParen (d > 10) $ \ r -> [res | (kw,s) <- lex r, res <- reader kw s] + +-- | @'readsUnaryWith' rp n c n'@ matches the name of a unary data constructor +-- and then parses its argument using @rp@. +readsUnaryWith :: (Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t +readsUnaryWith rp name cons kw s = + [(cons x,t) | kw == name, (x,t) <- rp 11 s] + +-- | @'readsBinaryWith' rp1 rp2 n c n'@ matches the name of a binary +-- data constructor and then parses its arguments using @rp1@ and @rp2@ +-- respectively. +readsBinaryWith :: (Int -> ReadS a) -> (Int -> ReadS b) -> + String -> (a -> b -> t) -> String -> ReadS t +readsBinaryWith rp1 rp2 name cons kw s = + [(cons x y,u) | kw == name, (x,t) <- rp1 11 s, (y,u) <- rp2 11 t] + +-- | @'showsUnaryWith' sp n d x@ produces the string representation of a +-- unary data constructor with name @n@ and argument @x@, in precedence +-- context @d@. +showsUnaryWith :: (Int -> a -> ShowS) -> String -> Int -> a -> ShowS +showsUnaryWith sp name d x = showParen (d > 10) $ + showString name . showChar ' ' . sp 11 x + +-- | @'showsBinaryWith' sp1 sp2 n d x y@ produces the string +-- representation of a binary data constructor with name @n@ and arguments +-- @x@ and @y@, in precedence context @d@. +showsBinaryWith :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) -> + String -> Int -> a -> b -> ShowS +showsBinaryWith sp1 sp2 name d x y = showParen (d > 10) $ + showString name . showChar ' ' . sp1 11 x . showChar ' ' . sp2 11 y + +-- Obsolete building blocks + +-- | @'readsUnary' n c n'@ matches the name of a unary data constructor +-- and then parses its argument using 'readsPrec'. +{-# DEPRECATED readsUnary "Use readsUnaryWith to define liftReadsPrec" #-} +readsUnary :: (Read a) => String -> (a -> t) -> String -> ReadS t +readsUnary name cons kw s = + [(cons x,t) | kw == name, (x,t) <- readsPrec 11 s] + +-- | @'readsUnary1' n c n'@ matches the name of a unary data constructor +-- and then parses its argument using 'readsPrec1'. +{-# DEPRECATED readsUnary1 "Use readsUnaryWith to define liftReadsPrec" #-} +readsUnary1 :: (Read1 f, Read a) => String -> (f a -> t) -> String -> ReadS t +readsUnary1 name cons kw s = + [(cons x,t) | kw == name, (x,t) <- readsPrec1 11 s] + +-- | @'readsBinary1' n c n'@ matches the name of a binary data constructor +-- and then parses its arguments using 'readsPrec1'. +{-# DEPRECATED readsBinary1 "Use readsBinaryWith to define liftReadsPrec" #-} +readsBinary1 :: (Read1 f, Read1 g, Read a) => + String -> (f a -> g a -> t) -> String -> ReadS t +readsBinary1 name cons kw s = + [(cons x y,u) | kw == name, + (x,t) <- readsPrec1 11 s, (y,u) <- readsPrec1 11 t] + +-- | @'showsUnary' n d x@ produces the string representation of a unary data +-- constructor with name @n@ and argument @x@, in precedence context @d@. +{-# DEPRECATED showsUnary "Use showsUnaryWith to define liftShowsPrec" #-} +showsUnary :: (Show a) => String -> Int -> a -> ShowS +showsUnary name d x = showParen (d > 10) $ + showString name . showChar ' ' . showsPrec 11 x + +-- | @'showsUnary1' n d x@ produces the string representation of a unary data +-- constructor with name @n@ and argument @x@, in precedence context @d@. +{-# DEPRECATED showsUnary1 "Use showsUnaryWith to define liftShowsPrec" #-} +showsUnary1 :: (Show1 f, Show a) => String -> Int -> f a -> ShowS +showsUnary1 name d x = showParen (d > 10) $ + showString name . showChar ' ' . showsPrec1 11 x + +-- | @'showsBinary1' n d x y@ produces the string representation of a binary +-- data constructor with name @n@ and arguments @x@ and @y@, in precedence +-- context @d@. +{-# DEPRECATED showsBinary1 "Use showsBinaryWith to define liftShowsPrec" #-} +showsBinary1 :: (Show1 f, Show1 g, Show a) => + String -> Int -> f a -> g a -> ShowS +showsBinary1 name d x y = showParen (d > 10) $ + showString name . showChar ' ' . showsPrec1 11 x . + showChar ' ' . showsPrec1 11 y + +{- $example +These functions can be used to assemble 'Read' and 'Show' instances for +new algebraic types. For example, given the definition + +> data T f a = Zero a | One (f a) | Two a (f a) + +a standard 'Read1' instance may be defined as + +> instance (Read1 f) => Read1 (T f) where +> liftReadsPrec rp rl = readsData $ +> readsUnaryWith rp "Zero" Zero `mappend` +> readsUnaryWith (liftReadsPrec rp rl) "One" One `mappend` +> readsBinaryWith rp (liftReadsPrec rp rl) "Two" Two + +and the corresponding 'Show1' instance as + +> instance (Show1 f) => Show1 (T f) where +> liftShowsPrec sp _ d (Zero x) = +> showsUnaryWith sp "Zero" d x +> liftShowsPrec sp sl d (One x) = +> showsUnaryWith (liftShowsPrec sp sl) "One" d x +> liftShowsPrec sp sl d (Two x y) = +> showsBinaryWith sp (liftShowsPrec sp sl) "Two" d x y + +-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Compose.hs b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Compose.hs new file mode 100644 index 000000000000..ed781309aff8 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Compose.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +#endif +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE PolyKinds #-} +#endif +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Data.Functor.Compose +-- Copyright : (c) Ross Paterson 2010 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- Composition of functors. +----------------------------------------------------------------------------- + +module Data.Functor.Compose ( + Compose(..), + ) where + +import Data.Functor.Classes +#if MIN_VERSION_base(4,12,0) +import Data.Functor.Contravariant +#endif + +import Control.Applicative +#if __GLASGOW_HASKELL__ >= 708 +import Data.Data +#endif +import Data.Foldable (Foldable(foldMap)) +import Data.Traversable (Traversable(traverse)) +#if __GLASGOW_HASKELL__ >= 702 +import GHC.Generics +#endif + +infixr 9 `Compose` + +-- | Right-to-left composition of functors. +-- The composition of applicative functors is always applicative, +-- but the composition of monads is not always a monad. +newtype Compose f g a = Compose { getCompose :: f (g a) } + +#if __GLASGOW_HASKELL__ >= 702 +deriving instance Generic (Compose f g a) + +instance Functor f => Generic1 (Compose f g) where + type Rep1 (Compose f g) = + D1 MDCompose + (C1 MCCompose + (S1 MSCompose (f :.: Rec1 g))) + from1 (Compose x) = M1 (M1 (M1 (Comp1 (fmap Rec1 x)))) + to1 (M1 (M1 (M1 x))) = Compose (fmap unRec1 (unComp1 x)) + +data MDCompose +data MCCompose +data MSCompose + +instance Datatype MDCompose where + datatypeName _ = "Compose" + moduleName _ = "Data.Functor.Compose" +# if __GLASGOW_HASKELL__ >= 708 + isNewtype _ = True +# endif + +instance Constructor MCCompose where + conName _ = "Compose" + conIsRecord _ = True + +instance Selector MSCompose where + selName _ = "getCompose" +#endif + +#if __GLASGOW_HASKELL__ >= 708 +deriving instance Typeable Compose +deriving instance (Data (f (g a)), Typeable f, Typeable g, Typeable a) + => Data (Compose (f :: * -> *) (g :: * -> *) (a :: *)) +#endif + +-- Instances of lifted Prelude classes + +instance (Eq1 f, Eq1 g) => Eq1 (Compose f g) where + liftEq eq (Compose x) (Compose y) = liftEq (liftEq eq) x y + +instance (Ord1 f, Ord1 g) => Ord1 (Compose f g) where + liftCompare comp (Compose x) (Compose y) = + liftCompare (liftCompare comp) x y + +instance (Read1 f, Read1 g) => Read1 (Compose f g) where + liftReadsPrec rp rl = readsData $ + readsUnaryWith (liftReadsPrec rp' rl') "Compose" Compose + where + rp' = liftReadsPrec rp rl + rl' = liftReadList rp rl + +instance (Show1 f, Show1 g) => Show1 (Compose f g) where + liftShowsPrec sp sl d (Compose x) = + showsUnaryWith (liftShowsPrec sp' sl') "Compose" d x + where + sp' = liftShowsPrec sp sl + sl' = liftShowList sp sl + +-- Instances of Prelude classes + +instance (Eq1 f, Eq1 g, Eq a) => Eq (Compose f g a) where + (==) = eq1 + +instance (Ord1 f, Ord1 g, Ord a) => Ord (Compose f g a) where + compare = compare1 + +instance (Read1 f, Read1 g, Read a) => Read (Compose f g a) where + readsPrec = readsPrec1 + +instance (Show1 f, Show1 g, Show a) => Show (Compose f g a) where + showsPrec = showsPrec1 + +-- Functor instances + +instance (Functor f, Functor g) => Functor (Compose f g) where + fmap f (Compose x) = Compose (fmap (fmap f) x) + +instance (Foldable f, Foldable g) => Foldable (Compose f g) where + foldMap f (Compose t) = foldMap (foldMap f) t + +instance (Traversable f, Traversable g) => Traversable (Compose f g) where + traverse f (Compose t) = Compose <$> traverse (traverse f) t + +instance (Applicative f, Applicative g) => Applicative (Compose f g) where + pure x = Compose (pure (pure x)) + Compose f <*> Compose x = Compose ((<*>) <$> f <*> x) + +instance (Alternative f, Applicative g) => Alternative (Compose f g) where + empty = Compose empty + Compose x <|> Compose y = Compose (x <|> y) + +#if MIN_VERSION_base(4,12,0) +instance (Functor f, Contravariant g) => Contravariant (Compose f g) where + contramap f (Compose fga) = Compose (fmap (contramap f) fga) +#endif diff --git a/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Product.hs b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Product.hs new file mode 100644 index 000000000000..ba0dc0407e00 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Product.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +#endif +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE PolyKinds #-} +#endif +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Data.Functor.Product +-- Copyright : (c) Ross Paterson 2010 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- Products, lifted to functors. +----------------------------------------------------------------------------- + +module Data.Functor.Product ( + Product(..), + ) where + +import Control.Applicative +import Control.Monad (MonadPlus(..)) +import Control.Monad.Fix (MonadFix(..)) +#if MIN_VERSION_base(4,4,0) +import Control.Monad.Zip (MonadZip(mzipWith)) +#endif +#if __GLASGOW_HASKELL__ >= 708 +import Data.Data +#endif +import Data.Foldable (Foldable(foldMap)) +import Data.Functor.Classes +#if MIN_VERSION_base(4,12,0) +import Data.Functor.Contravariant +#endif +import Data.Monoid (mappend) +import Data.Traversable (Traversable(traverse)) +#if __GLASGOW_HASKELL__ >= 702 +import GHC.Generics +#endif + +-- | Lifted product of functors. +data Product f g a = Pair (f a) (g a) + +#if __GLASGOW_HASKELL__ >= 702 +deriving instance Generic (Product f g a) + +instance Generic1 (Product f g) where + type Rep1 (Product f g) = + D1 MDProduct + (C1 MCPair + (S1 NoSelector (Rec1 f) :*: S1 NoSelector (Rec1 g))) + from1 (Pair f g) = M1 (M1 (M1 (Rec1 f) :*: M1 (Rec1 g))) + to1 (M1 (M1 (M1 f :*: M1 g))) = Pair (unRec1 f) (unRec1 g) + +data MDProduct +data MCPair + +instance Datatype MDProduct where + datatypeName _ = "Product" + moduleName _ = "Data.Functor.Product" + +instance Constructor MCPair where + conName _ = "Pair" +#endif + +#if __GLASGOW_HASKELL__ >= 708 +deriving instance Typeable Product +deriving instance (Data (f a), Data (g a), Typeable f, Typeable g, Typeable a) + => Data (Product (f :: * -> *) (g :: * -> *) (a :: *)) +#endif + +instance (Eq1 f, Eq1 g) => Eq1 (Product f g) where + liftEq eq (Pair x1 y1) (Pair x2 y2) = liftEq eq x1 x2 && liftEq eq y1 y2 + +instance (Ord1 f, Ord1 g) => Ord1 (Product f g) where + liftCompare comp (Pair x1 y1) (Pair x2 y2) = + liftCompare comp x1 x2 `mappend` liftCompare comp y1 y2 + +instance (Read1 f, Read1 g) => Read1 (Product f g) where + liftReadsPrec rp rl = readsData $ + readsBinaryWith (liftReadsPrec rp rl) (liftReadsPrec rp rl) "Pair" Pair + +instance (Show1 f, Show1 g) => Show1 (Product f g) where + liftShowsPrec sp sl d (Pair x y) = + showsBinaryWith (liftShowsPrec sp sl) (liftShowsPrec sp sl) "Pair" d x y + +instance (Eq1 f, Eq1 g, Eq a) => Eq (Product f g a) + where (==) = eq1 +instance (Ord1 f, Ord1 g, Ord a) => Ord (Product f g a) where + compare = compare1 +instance (Read1 f, Read1 g, Read a) => Read (Product f g a) where + readsPrec = readsPrec1 +instance (Show1 f, Show1 g, Show a) => Show (Product f g a) where + showsPrec = showsPrec1 + +instance (Functor f, Functor g) => Functor (Product f g) where + fmap f (Pair x y) = Pair (fmap f x) (fmap f y) + +instance (Foldable f, Foldable g) => Foldable (Product f g) where + foldMap f (Pair x y) = foldMap f x `mappend` foldMap f y + +instance (Traversable f, Traversable g) => Traversable (Product f g) where + traverse f (Pair x y) = Pair <$> traverse f x <*> traverse f y + +instance (Applicative f, Applicative g) => Applicative (Product f g) where + pure x = Pair (pure x) (pure x) + Pair f g <*> Pair x y = Pair (f <*> x) (g <*> y) + +instance (Alternative f, Alternative g) => Alternative (Product f g) where + empty = Pair empty empty + Pair x1 y1 <|> Pair x2 y2 = Pair (x1 <|> x2) (y1 <|> y2) + +instance (Monad f, Monad g) => Monad (Product f g) where +#if !(MIN_VERSION_base(4,8,0)) + return x = Pair (return x) (return x) +#endif + Pair m n >>= f = Pair (m >>= fstP . f) (n >>= sndP . f) + where + fstP (Pair a _) = a + sndP (Pair _ b) = b + +instance (MonadPlus f, MonadPlus g) => MonadPlus (Product f g) where + mzero = Pair mzero mzero + Pair x1 y1 `mplus` Pair x2 y2 = Pair (x1 `mplus` x2) (y1 `mplus` y2) + +instance (MonadFix f, MonadFix g) => MonadFix (Product f g) where + mfix f = Pair (mfix (fstP . f)) (mfix (sndP . f)) + where + fstP (Pair a _) = a + sndP (Pair _ b) = b + +#if MIN_VERSION_base(4,4,0) +instance (MonadZip f, MonadZip g) => MonadZip (Product f g) where + mzipWith f (Pair x1 y1) (Pair x2 y2) = Pair (mzipWith f x1 x2) (mzipWith f y1 y2) +#endif + +#if MIN_VERSION_base(4,12,0) +instance (Contravariant f, Contravariant g) => Contravariant (Product f g) where + contramap f (Pair a b) = Pair (contramap f a) (contramap f b) +#endif diff --git a/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Sum.hs b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Sum.hs new file mode 100644 index 000000000000..e6d1428b30e3 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Sum.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +#endif +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE PolyKinds #-} +#endif +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Data.Functor.Sum +-- Copyright : (c) Ross Paterson 2014 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : R.Paterson@city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- Sums, lifted to functors. +----------------------------------------------------------------------------- + +module Data.Functor.Sum ( + Sum(..), + ) where + +import Control.Applicative +#if __GLASGOW_HASKELL__ >= 708 +import Data.Data +#endif +import Data.Foldable (Foldable(foldMap)) +import Data.Functor.Classes +#if MIN_VERSION_base(4,12,0) +import Data.Functor.Contravariant +#endif +import Data.Monoid (mappend) +import Data.Traversable (Traversable(traverse)) +#if __GLASGOW_HASKELL__ >= 702 +import GHC.Generics +#endif + +-- | Lifted sum of functors. +data Sum f g a = InL (f a) | InR (g a) + +#if __GLASGOW_HASKELL__ >= 702 +deriving instance Generic (Sum f g a) + +instance Generic1 (Sum f g) where + type Rep1 (Sum f g) = + D1 MDSum (C1 MCInL (S1 NoSelector (Rec1 f)) + :+: C1 MCInR (S1 NoSelector (Rec1 g))) + from1 (InL f) = M1 (L1 (M1 (M1 (Rec1 f)))) + from1 (InR g) = M1 (R1 (M1 (M1 (Rec1 g)))) + to1 (M1 (L1 (M1 (M1 f)))) = InL (unRec1 f) + to1 (M1 (R1 (M1 (M1 g)))) = InR (unRec1 g) + +data MDSum +data MCInL +data MCInR + +instance Datatype MDSum where + datatypeName _ = "Sum" + moduleName _ = "Data.Functor.Sum" + +instance Constructor MCInL where + conName _ = "InL" + +instance Constructor MCInR where + conName _ = "InR" +#endif + +#if __GLASGOW_HASKELL__ >= 708 +deriving instance Typeable Sum +deriving instance (Data (f a), Data (g a), Typeable f, Typeable g, Typeable a) + => Data (Sum (f :: * -> *) (g :: * -> *) (a :: *)) +#endif + +instance (Eq1 f, Eq1 g) => Eq1 (Sum f g) where + liftEq eq (InL x1) (InL x2) = liftEq eq x1 x2 + liftEq _ (InL _) (InR _) = False + liftEq _ (InR _) (InL _) = False + liftEq eq (InR y1) (InR y2) = liftEq eq y1 y2 + +instance (Ord1 f, Ord1 g) => Ord1 (Sum f g) where + liftCompare comp (InL x1) (InL x2) = liftCompare comp x1 x2 + liftCompare _ (InL _) (InR _) = LT + liftCompare _ (InR _) (InL _) = GT + liftCompare comp (InR y1) (InR y2) = liftCompare comp y1 y2 + +instance (Read1 f, Read1 g) => Read1 (Sum f g) where + liftReadsPrec rp rl = readsData $ + readsUnaryWith (liftReadsPrec rp rl) "InL" InL `mappend` + readsUnaryWith (liftReadsPrec rp rl) "InR" InR + +instance (Show1 f, Show1 g) => Show1 (Sum f g) where + liftShowsPrec sp sl d (InL x) = + showsUnaryWith (liftShowsPrec sp sl) "InL" d x + liftShowsPrec sp sl d (InR y) = + showsUnaryWith (liftShowsPrec sp sl) "InR" d y + +instance (Eq1 f, Eq1 g, Eq a) => Eq (Sum f g a) where + (==) = eq1 +instance (Ord1 f, Ord1 g, Ord a) => Ord (Sum f g a) where + compare = compare1 +instance (Read1 f, Read1 g, Read a) => Read (Sum f g a) where + readsPrec = readsPrec1 +instance (Show1 f, Show1 g, Show a) => Show (Sum f g a) where + showsPrec = showsPrec1 + +instance (Functor f, Functor g) => Functor (Sum f g) where + fmap f (InL x) = InL (fmap f x) + fmap f (InR y) = InR (fmap f y) + +instance (Foldable f, Foldable g) => Foldable (Sum f g) where + foldMap f (InL x) = foldMap f x + foldMap f (InR y) = foldMap f y + +instance (Traversable f, Traversable g) => Traversable (Sum f g) where + traverse f (InL x) = InL <$> traverse f x + traverse f (InR y) = InR <$> traverse f y + +#if MIN_VERSION_base(4,12,0) +instance (Contravariant f, Contravariant g) => Contravariant (Sum f g) where + contramap f (InL xs) = InL (contramap f xs) + contramap f (InR ys) = InR (contramap f ys) +#endif diff --git a/third_party/bazel/rules_haskell/examples/transformers/transformers.cabal b/third_party/bazel/rules_haskell/examples/transformers/transformers.cabal new file mode 100644 index 000000000000..945adda910fd --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/transformers.cabal @@ -0,0 +1,91 @@ +name: transformers +version: 0.5.6.2 +license: BSD3 +license-file: LICENSE +author: Andy Gill, Ross Paterson +maintainer: Ross Paterson <R.Paterson@city.ac.uk> +bug-reports: http://hub.darcs.net/ross/transformers/issues +category: Control +synopsis: Concrete functor and monad transformers +description: + A portable library of functor and monad transformers, inspired by + the paper + . + * \"Functional Programming with Overloading and Higher-Order + Polymorphism\", by Mark P Jones, + in /Advanced School of Functional Programming/, 1995 + (<http://web.cecs.pdx.edu/~mpj/pubs/springschool.html>). + . + This package contains: + . + * the monad transformer class (in "Control.Monad.Trans.Class") + . + * concrete functor and monad transformers, each with associated + operations and functions to lift operations associated with other + transformers. + . + The package can be used on its own in portable Haskell code, in + which case operations need to be manually lifted through transformer + stacks (see "Control.Monad.Trans.Class" for some examples). + Alternatively, it can be used with the non-portable monad classes in + the @mtl@ or @monads-tf@ packages, which automatically lift operations + introduced by monad transformers through other transformers. +build-type: Simple +extra-source-files: + changelog +cabal-version: >= 1.6 + +source-repository head + type: darcs + location: http://hub.darcs.net/ross/transformers + +library + build-depends: base >= 2 && < 6 + hs-source-dirs: . + if !impl(ghc>=7.9) + -- Data.Functor.Identity was moved into base-4.8.0.0 (GHC 7.10) + -- see also https://ghc.haskell.org/trac/ghc/ticket/9664 + -- NB: using impl(ghc>=7.9) instead of fragile Cabal flags + hs-source-dirs: legacy/pre709 + exposed-modules: Data.Functor.Identity + if !impl(ghc>=7.11) + -- modules moved into base-4.9.0 (GHC 8.0) + -- see https://ghc.haskell.org/trac/ghc/ticket/10773 + -- see https://ghc.haskell.org/trac/ghc/ticket/11135 + hs-source-dirs: legacy/pre711 + exposed-modules: + Control.Monad.IO.Class + Data.Functor.Classes + Data.Functor.Compose + Data.Functor.Product + Data.Functor.Sum + if impl(ghc>=7.2 && <7.5) + -- Prior to GHC 7.5, GHC.Generics lived in ghc-prim + build-depends: ghc-prim + exposed-modules: + Control.Applicative.Backwards + Control.Applicative.Lift + Control.Monad.Signatures + Control.Monad.Trans.Accum + Control.Monad.Trans.Class + Control.Monad.Trans.Cont + Control.Monad.Trans.Except + Control.Monad.Trans.Error + Control.Monad.Trans.Identity + Control.Monad.Trans.List + Control.Monad.Trans.Maybe + Control.Monad.Trans.Reader + Control.Monad.Trans.RWS + Control.Monad.Trans.RWS.CPS + Control.Monad.Trans.RWS.Lazy + Control.Monad.Trans.RWS.Strict + Control.Monad.Trans.Select + Control.Monad.Trans.State + Control.Monad.Trans.State.Lazy + Control.Monad.Trans.State.Strict + Control.Monad.Trans.Writer + Control.Monad.Trans.Writer.CPS + Control.Monad.Trans.Writer.Lazy + Control.Monad.Trans.Writer.Strict + Data.Functor.Constant + Data.Functor.Reverse diff --git a/third_party/bazel/rules_haskell/examples/vector/BUILD.bazel b/third_party/bazel/rules_haskell/examples/vector/BUILD.bazel new file mode 100644 index 000000000000..7c00806efe5f --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/BUILD.bazel @@ -0,0 +1,38 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_cc_import", + "haskell_library", + "haskell_toolchain_library", +) + +haskell_toolchain_library(name = "base") + +haskell_toolchain_library(name = "deepseq") + +haskell_toolchain_library(name = "ghc-prim") + +haskell_toolchain_library(name = "primitive") + +haskell_toolchain_library(name = "semigroups") + +haskell_library( + name = "vector", + testonly = 1, + srcs = glob(["Data/**/*.*hs"]), + compiler_flags = [ + "-Iexternal/io_tweag_rules_haskell_examples/vector/include", + "-Iexternal/io_tweag_rules_haskell_examples/vector/internal", + ], + extra_srcs = [ + "include/vector.h", + "internal/unbox-tuple-instances", + ], + version = "0", + visibility = ["//visibility:public"], + deps = [ + ":base", + ":deepseq", + ":ghc-prim", + "//primitive", + ], +) diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector.hs new file mode 100644 index 000000000000..21b61960ca40 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector.hs @@ -0,0 +1,1719 @@ +{-# LANGUAGE CPP + , DeriveDataTypeable + , FlexibleInstances + , MultiParamTypeClasses + , TypeFamilies + , Rank2Types + , BangPatterns + #-} + +-- | +-- Module : Data.Vector +-- Copyright : (c) Roman Leshchinskiy 2008-2010 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> +-- Stability : experimental +-- Portability : non-portable +-- +-- A library for boxed vectors (that is, polymorphic arrays capable of +-- holding any Haskell value). The vectors come in two flavours: +-- +-- * mutable +-- +-- * immutable +-- +-- and support a rich interface of both list-like operations, and bulk +-- array operations. +-- +-- For unboxed arrays, use "Data.Vector.Unboxed" +-- + +module Data.Vector ( + -- * Boxed vectors + Vector, MVector, + + -- * Accessors + + -- ** Length information + length, null, + + -- ** Indexing + (!), (!?), head, last, + unsafeIndex, unsafeHead, unsafeLast, + + -- ** Monadic indexing + indexM, headM, lastM, + unsafeIndexM, unsafeHeadM, unsafeLastM, + + -- ** Extracting subvectors (slicing) + slice, init, tail, take, drop, splitAt, + unsafeSlice, unsafeInit, unsafeTail, unsafeTake, unsafeDrop, + + -- * Construction + + -- ** Initialisation + empty, singleton, replicate, generate, iterateN, + + -- ** Monadic initialisation + replicateM, generateM, iterateNM, create, createT, + + -- ** Unfolding + unfoldr, unfoldrN, + unfoldrM, unfoldrNM, + constructN, constructrN, + + -- ** Enumeration + enumFromN, enumFromStepN, enumFromTo, enumFromThenTo, + + -- ** Concatenation + cons, snoc, (++), concat, + + -- ** Restricting memory usage + force, + + -- * Modifying vectors + + -- ** Bulk updates + (//), update, update_, + unsafeUpd, unsafeUpdate, unsafeUpdate_, + + -- ** Accumulations + accum, accumulate, accumulate_, + unsafeAccum, unsafeAccumulate, unsafeAccumulate_, + + -- ** Permutations + reverse, backpermute, unsafeBackpermute, + + -- ** Safe destructive updates + modify, + + -- * Elementwise operations + + -- ** Indexing + indexed, + + -- ** Mapping + map, imap, concatMap, + + -- ** Monadic mapping + mapM, imapM, mapM_, imapM_, forM, forM_, + + -- ** Zipping + zipWith, zipWith3, zipWith4, zipWith5, zipWith6, + izipWith, izipWith3, izipWith4, izipWith5, izipWith6, + zip, zip3, zip4, zip5, zip6, + + -- ** Monadic zipping + zipWithM, izipWithM, zipWithM_, izipWithM_, + + -- ** Unzipping + unzip, unzip3, unzip4, unzip5, unzip6, + + -- * Working with predicates + + -- ** Filtering + filter, ifilter, uniq, + mapMaybe, imapMaybe, + filterM, + takeWhile, dropWhile, + + -- ** Partitioning + partition, unstablePartition, span, break, + + -- ** Searching + elem, notElem, find, findIndex, findIndices, elemIndex, elemIndices, + + -- * Folding + foldl, foldl1, foldl', foldl1', foldr, foldr1, foldr', foldr1', + ifoldl, ifoldl', ifoldr, ifoldr', + + -- ** Specialised folds + all, any, and, or, + sum, product, + maximum, maximumBy, minimum, minimumBy, + minIndex, minIndexBy, maxIndex, maxIndexBy, + + -- ** Monadic folds + foldM, ifoldM, foldM', ifoldM', + fold1M, fold1M',foldM_, ifoldM_, + foldM'_, ifoldM'_, fold1M_, fold1M'_, + + -- ** Monadic sequencing + sequence, sequence_, + + -- * Prefix sums (scans) + prescanl, prescanl', + postscanl, postscanl', + scanl, scanl', scanl1, scanl1', + iscanl, iscanl', + prescanr, prescanr', + postscanr, postscanr', + scanr, scanr', scanr1, scanr1', + iscanr, iscanr', + + -- * Conversions + + -- ** Lists + toList, Data.Vector.fromList, Data.Vector.fromListN, + + -- ** Other vector types + G.convert, + + -- ** Mutable vectors + freeze, thaw, copy, unsafeFreeze, unsafeThaw, unsafeCopy +) where + +import qualified Data.Vector.Generic as G +import Data.Vector.Mutable ( MVector(..) ) +import Data.Primitive.Array +import qualified Data.Vector.Fusion.Bundle as Bundle + +import Control.DeepSeq ( NFData, rnf ) +import Control.Monad ( MonadPlus(..), liftM, ap ) +import Control.Monad.ST ( ST ) +import Control.Monad.Primitive + + +import Control.Monad.Zip + +import Prelude hiding ( length, null, + replicate, (++), concat, + head, last, + init, tail, take, drop, splitAt, reverse, + map, concatMap, + zipWith, zipWith3, zip, zip3, unzip, unzip3, + filter, takeWhile, dropWhile, span, break, + elem, notElem, + foldl, foldl1, foldr, foldr1, + all, any, and, or, sum, product, minimum, maximum, + scanl, scanl1, scanr, scanr1, + enumFromTo, enumFromThenTo, + mapM, mapM_, sequence, sequence_ ) + +#if MIN_VERSION_base(4,9,0) +import Data.Functor.Classes (Eq1 (..), Ord1 (..), Read1 (..), Show1 (..)) +#endif + +import Data.Typeable ( Typeable ) +import Data.Data ( Data(..) ) +import Text.Read ( Read(..), readListPrecDefault ) +import Data.Semigroup ( Semigroup(..) ) + +import qualified Control.Applicative as Applicative +import qualified Data.Foldable as Foldable +import qualified Data.Traversable as Traversable + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid ( Monoid(..) ) +#endif + +#if __GLASGOW_HASKELL__ >= 708 +import qualified GHC.Exts as Exts (IsList(..)) +#endif + + +-- | Boxed vectors, supporting efficient slicing. +data Vector a = Vector {-# UNPACK #-} !Int + {-# UNPACK #-} !Int + {-# UNPACK #-} !(Array a) + deriving ( Typeable ) + +instance NFData a => NFData (Vector a) where + rnf (Vector i n arr) = rnfAll i + where + rnfAll ix | ix < n = rnf (indexArray arr ix) `seq` rnfAll (ix+1) + | otherwise = () + +instance Show a => Show (Vector a) where + showsPrec = G.showsPrec + +instance Read a => Read (Vector a) where + readPrec = G.readPrec + readListPrec = readListPrecDefault + +#if MIN_VERSION_base(4,9,0) +instance Show1 Vector where + liftShowsPrec = G.liftShowsPrec + +instance Read1 Vector where + liftReadsPrec = G.liftReadsPrec +#endif + +#if __GLASGOW_HASKELL__ >= 708 + +instance Exts.IsList (Vector a) where + type Item (Vector a) = a + fromList = Data.Vector.fromList + fromListN = Data.Vector.fromListN + toList = toList +#endif + +instance Data a => Data (Vector a) where + gfoldl = G.gfoldl + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = G.mkType "Data.Vector.Vector" + dataCast1 = G.dataCast + +type instance G.Mutable Vector = MVector + +instance G.Vector Vector a where + {-# INLINE basicUnsafeFreeze #-} + basicUnsafeFreeze (MVector i n marr) + = Vector i n `liftM` unsafeFreezeArray marr + + {-# INLINE basicUnsafeThaw #-} + basicUnsafeThaw (Vector i n arr) + = MVector i n `liftM` unsafeThawArray arr + + {-# INLINE basicLength #-} + basicLength (Vector _ n _) = n + + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice j n (Vector i _ arr) = Vector (i+j) n arr + + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeIndexM (Vector i _ arr) j = indexArrayM arr (i+j) + + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy (MVector i n dst) (Vector j _ src) + = copyArray dst i src j n + +-- See http://trac.haskell.org/vector/ticket/12 +instance Eq a => Eq (Vector a) where + {-# INLINE (==) #-} + xs == ys = Bundle.eq (G.stream xs) (G.stream ys) + + {-# INLINE (/=) #-} + xs /= ys = not (Bundle.eq (G.stream xs) (G.stream ys)) + +-- See http://trac.haskell.org/vector/ticket/12 +instance Ord a => Ord (Vector a) where + {-# INLINE compare #-} + compare xs ys = Bundle.cmp (G.stream xs) (G.stream ys) + + {-# INLINE (<) #-} + xs < ys = Bundle.cmp (G.stream xs) (G.stream ys) == LT + + {-# INLINE (<=) #-} + xs <= ys = Bundle.cmp (G.stream xs) (G.stream ys) /= GT + + {-# INLINE (>) #-} + xs > ys = Bundle.cmp (G.stream xs) (G.stream ys) == GT + + {-# INLINE (>=) #-} + xs >= ys = Bundle.cmp (G.stream xs) (G.stream ys) /= LT + +#if MIN_VERSION_base(4,9,0) +instance Eq1 Vector where + liftEq eq xs ys = Bundle.eqBy eq (G.stream xs) (G.stream ys) + +instance Ord1 Vector where + liftCompare cmp xs ys = Bundle.cmpBy cmp (G.stream xs) (G.stream ys) +#endif + +instance Semigroup (Vector a) where + {-# INLINE (<>) #-} + (<>) = (++) + + {-# INLINE sconcat #-} + sconcat = G.concatNE + +instance Monoid (Vector a) where + {-# INLINE mempty #-} + mempty = empty + + {-# INLINE mappend #-} + mappend = (++) + + {-# INLINE mconcat #-} + mconcat = concat + +instance Functor Vector where + {-# INLINE fmap #-} + fmap = map + +instance Monad Vector where + {-# INLINE return #-} + return = Applicative.pure + + {-# INLINE (>>=) #-} + (>>=) = flip concatMap + + {-# INLINE fail #-} + fail _ = empty + +instance MonadPlus Vector where + {-# INLINE mzero #-} + mzero = empty + + {-# INLINE mplus #-} + mplus = (++) + +instance MonadZip Vector where + {-# INLINE mzip #-} + mzip = zip + + {-# INLINE mzipWith #-} + mzipWith = zipWith + + {-# INLINE munzip #-} + munzip = unzip + + +instance Applicative.Applicative Vector where + {-# INLINE pure #-} + pure = singleton + + {-# INLINE (<*>) #-} + (<*>) = ap + +instance Applicative.Alternative Vector where + {-# INLINE empty #-} + empty = empty + + {-# INLINE (<|>) #-} + (<|>) = (++) + +instance Foldable.Foldable Vector where + {-# INLINE foldr #-} + foldr = foldr + + {-# INLINE foldl #-} + foldl = foldl + + {-# INLINE foldr1 #-} + foldr1 = foldr1 + + {-# INLINE foldl1 #-} + foldl1 = foldl1 + +#if MIN_VERSION_base(4,6,0) + {-# INLINE foldr' #-} + foldr' = foldr' + + {-# INLINE foldl' #-} + foldl' = foldl' +#endif + +#if MIN_VERSION_base(4,8,0) + {-# INLINE toList #-} + toList = toList + + {-# INLINE length #-} + length = length + + {-# INLINE null #-} + null = null + + {-# INLINE elem #-} + elem = elem + + {-# INLINE maximum #-} + maximum = maximum + + {-# INLINE minimum #-} + minimum = minimum + + {-# INLINE sum #-} + sum = sum + + {-# INLINE product #-} + product = product +#endif + +instance Traversable.Traversable Vector where + {-# INLINE traverse #-} + traverse f xs = Data.Vector.fromList Applicative.<$> Traversable.traverse f (toList xs) + + {-# INLINE mapM #-} + mapM = mapM + + {-# INLINE sequence #-} + sequence = sequence + +-- Length information +-- ------------------ + +-- | /O(1)/ Yield the length of the vector +length :: Vector a -> Int +{-# INLINE length #-} +length = G.length + +-- | /O(1)/ Test whether a vector is empty +null :: Vector a -> Bool +{-# INLINE null #-} +null = G.null + +-- Indexing +-- -------- + +-- | O(1) Indexing +(!) :: Vector a -> Int -> a +{-# INLINE (!) #-} +(!) = (G.!) + +-- | O(1) Safe indexing +(!?) :: Vector a -> Int -> Maybe a +{-# INLINE (!?) #-} +(!?) = (G.!?) + +-- | /O(1)/ First element +head :: Vector a -> a +{-# INLINE head #-} +head = G.head + +-- | /O(1)/ Last element +last :: Vector a -> a +{-# INLINE last #-} +last = G.last + +-- | /O(1)/ Unsafe indexing without bounds checking +unsafeIndex :: Vector a -> Int -> a +{-# INLINE unsafeIndex #-} +unsafeIndex = G.unsafeIndex + +-- | /O(1)/ First element without checking if the vector is empty +unsafeHead :: Vector a -> a +{-# INLINE unsafeHead #-} +unsafeHead = G.unsafeHead + +-- | /O(1)/ Last element without checking if the vector is empty +unsafeLast :: Vector a -> a +{-# INLINE unsafeLast #-} +unsafeLast = G.unsafeLast + +-- Monadic indexing +-- ---------------- + +-- | /O(1)/ Indexing in a monad. +-- +-- The monad allows operations to be strict in the vector when necessary. +-- Suppose vector copying is implemented like this: +-- +-- > copy mv v = ... write mv i (v ! i) ... +-- +-- For lazy vectors, @v ! i@ would not be evaluated which means that @mv@ +-- would unnecessarily retain a reference to @v@ in each element written. +-- +-- With 'indexM', copying can be implemented like this instead: +-- +-- > copy mv v = ... do +-- > x <- indexM v i +-- > write mv i x +-- +-- Here, no references to @v@ are retained because indexing (but /not/ the +-- elements) is evaluated eagerly. +-- +indexM :: Monad m => Vector a -> Int -> m a +{-# INLINE indexM #-} +indexM = G.indexM + +-- | /O(1)/ First element of a vector in a monad. See 'indexM' for an +-- explanation of why this is useful. +headM :: Monad m => Vector a -> m a +{-# INLINE headM #-} +headM = G.headM + +-- | /O(1)/ Last element of a vector in a monad. See 'indexM' for an +-- explanation of why this is useful. +lastM :: Monad m => Vector a -> m a +{-# INLINE lastM #-} +lastM = G.lastM + +-- | /O(1)/ Indexing in a monad without bounds checks. See 'indexM' for an +-- explanation of why this is useful. +unsafeIndexM :: Monad m => Vector a -> Int -> m a +{-# INLINE unsafeIndexM #-} +unsafeIndexM = G.unsafeIndexM + +-- | /O(1)/ First element in a monad without checking for empty vectors. +-- See 'indexM' for an explanation of why this is useful. +unsafeHeadM :: Monad m => Vector a -> m a +{-# INLINE unsafeHeadM #-} +unsafeHeadM = G.unsafeHeadM + +-- | /O(1)/ Last element in a monad without checking for empty vectors. +-- See 'indexM' for an explanation of why this is useful. +unsafeLastM :: Monad m => Vector a -> m a +{-# INLINE unsafeLastM #-} +unsafeLastM = G.unsafeLastM + +-- Extracting subvectors (slicing) +-- ------------------------------- + +-- | /O(1)/ Yield a slice of the vector without copying it. The vector must +-- contain at least @i+n@ elements. +slice :: Int -- ^ @i@ starting index + -> Int -- ^ @n@ length + -> Vector a + -> Vector a +{-# INLINE slice #-} +slice = G.slice + +-- | /O(1)/ Yield all but the last element without copying. The vector may not +-- be empty. +init :: Vector a -> Vector a +{-# INLINE init #-} +init = G.init + +-- | /O(1)/ Yield all but the first element without copying. The vector may not +-- be empty. +tail :: Vector a -> Vector a +{-# INLINE tail #-} +tail = G.tail + +-- | /O(1)/ Yield at the first @n@ elements without copying. The vector may +-- contain less than @n@ elements in which case it is returned unchanged. +take :: Int -> Vector a -> Vector a +{-# INLINE take #-} +take = G.take + +-- | /O(1)/ Yield all but the first @n@ elements without copying. The vector may +-- contain less than @n@ elements in which case an empty vector is returned. +drop :: Int -> Vector a -> Vector a +{-# INLINE drop #-} +drop = G.drop + +-- | /O(1)/ Yield the first @n@ elements paired with the remainder without copying. +-- +-- Note that @'splitAt' n v@ is equivalent to @('take' n v, 'drop' n v)@ +-- but slightly more efficient. +{-# INLINE splitAt #-} +splitAt :: Int -> Vector a -> (Vector a, Vector a) +splitAt = G.splitAt + +-- | /O(1)/ Yield a slice of the vector without copying. The vector must +-- contain at least @i+n@ elements but this is not checked. +unsafeSlice :: Int -- ^ @i@ starting index + -> Int -- ^ @n@ length + -> Vector a + -> Vector a +{-# INLINE unsafeSlice #-} +unsafeSlice = G.unsafeSlice + +-- | /O(1)/ Yield all but the last element without copying. The vector may not +-- be empty but this is not checked. +unsafeInit :: Vector a -> Vector a +{-# INLINE unsafeInit #-} +unsafeInit = G.unsafeInit + +-- | /O(1)/ Yield all but the first element without copying. The vector may not +-- be empty but this is not checked. +unsafeTail :: Vector a -> Vector a +{-# INLINE unsafeTail #-} +unsafeTail = G.unsafeTail + +-- | /O(1)/ Yield the first @n@ elements without copying. The vector must +-- contain at least @n@ elements but this is not checked. +unsafeTake :: Int -> Vector a -> Vector a +{-# INLINE unsafeTake #-} +unsafeTake = G.unsafeTake + +-- | /O(1)/ Yield all but the first @n@ elements without copying. The vector +-- must contain at least @n@ elements but this is not checked. +unsafeDrop :: Int -> Vector a -> Vector a +{-# INLINE unsafeDrop #-} +unsafeDrop = G.unsafeDrop + +-- Initialisation +-- -------------- + +-- | /O(1)/ Empty vector +empty :: Vector a +{-# INLINE empty #-} +empty = G.empty + +-- | /O(1)/ Vector with exactly one element +singleton :: a -> Vector a +{-# INLINE singleton #-} +singleton = G.singleton + +-- | /O(n)/ Vector of the given length with the same value in each position +replicate :: Int -> a -> Vector a +{-# INLINE replicate #-} +replicate = G.replicate + +-- | /O(n)/ Construct a vector of the given length by applying the function to +-- each index +generate :: Int -> (Int -> a) -> Vector a +{-# INLINE generate #-} +generate = G.generate + +-- | /O(n)/ Apply function n times to value. Zeroth element is original value. +iterateN :: Int -> (a -> a) -> a -> Vector a +{-# INLINE iterateN #-} +iterateN = G.iterateN + +-- Unfolding +-- --------- + +-- | /O(n)/ Construct a vector by repeatedly applying the generator function +-- to a seed. The generator function yields 'Just' the next element and the +-- new seed or 'Nothing' if there are no more elements. +-- +-- > unfoldr (\n -> if n == 0 then Nothing else Just (n,n-1)) 10 +-- > = <10,9,8,7,6,5,4,3,2,1> +unfoldr :: (b -> Maybe (a, b)) -> b -> Vector a +{-# INLINE unfoldr #-} +unfoldr = G.unfoldr + +-- | /O(n)/ Construct a vector with at most @n@ elements by repeatedly applying +-- the generator function to a seed. The generator function yields 'Just' the +-- next element and the new seed or 'Nothing' if there are no more elements. +-- +-- > unfoldrN 3 (\n -> Just (n,n-1)) 10 = <10,9,8> +unfoldrN :: Int -> (b -> Maybe (a, b)) -> b -> Vector a +{-# INLINE unfoldrN #-} +unfoldrN = G.unfoldrN + +-- | /O(n)/ Construct a vector by repeatedly applying the monadic +-- generator function to a seed. The generator function yields 'Just' +-- the next element and the new seed or 'Nothing' if there are no more +-- elements. +unfoldrM :: (Monad m) => (b -> m (Maybe (a, b))) -> b -> m (Vector a) +{-# INLINE unfoldrM #-} +unfoldrM = G.unfoldrM + +-- | /O(n)/ Construct a vector by repeatedly applying the monadic +-- generator function to a seed. The generator function yields 'Just' +-- the next element and the new seed or 'Nothing' if there are no more +-- elements. +unfoldrNM :: (Monad m) => Int -> (b -> m (Maybe (a, b))) -> b -> m (Vector a) +{-# INLINE unfoldrNM #-} +unfoldrNM = G.unfoldrNM + +-- | /O(n)/ Construct a vector with @n@ elements by repeatedly applying the +-- generator function to the already constructed part of the vector. +-- +-- > constructN 3 f = let a = f <> ; b = f <a> ; c = f <a,b> in f <a,b,c> +-- +constructN :: Int -> (Vector a -> a) -> Vector a +{-# INLINE constructN #-} +constructN = G.constructN + +-- | /O(n)/ Construct a vector with @n@ elements from right to left by +-- repeatedly applying the generator function to the already constructed part +-- of the vector. +-- +-- > constructrN 3 f = let a = f <> ; b = f<a> ; c = f <b,a> in f <c,b,a> +-- +constructrN :: Int -> (Vector a -> a) -> Vector a +{-# INLINE constructrN #-} +constructrN = G.constructrN + +-- Enumeration +-- ----------- + +-- | /O(n)/ Yield a vector of the given length containing the values @x@, @x+1@ +-- etc. This operation is usually more efficient than 'enumFromTo'. +-- +-- > enumFromN 5 3 = <5,6,7> +enumFromN :: Num a => a -> Int -> Vector a +{-# INLINE enumFromN #-} +enumFromN = G.enumFromN + +-- | /O(n)/ Yield a vector of the given length containing the values @x@, @x+y@, +-- @x+y+y@ etc. This operations is usually more efficient than 'enumFromThenTo'. +-- +-- > enumFromStepN 1 0.1 5 = <1,1.1,1.2,1.3,1.4> +enumFromStepN :: Num a => a -> a -> Int -> Vector a +{-# INLINE enumFromStepN #-} +enumFromStepN = G.enumFromStepN + +-- | /O(n)/ Enumerate values from @x@ to @y@. +-- +-- /WARNING:/ This operation can be very inefficient. If at all possible, use +-- 'enumFromN' instead. +enumFromTo :: Enum a => a -> a -> Vector a +{-# INLINE enumFromTo #-} +enumFromTo = G.enumFromTo + +-- | /O(n)/ Enumerate values from @x@ to @y@ with a specific step @z@. +-- +-- /WARNING:/ This operation can be very inefficient. If at all possible, use +-- 'enumFromStepN' instead. +enumFromThenTo :: Enum a => a -> a -> a -> Vector a +{-# INLINE enumFromThenTo #-} +enumFromThenTo = G.enumFromThenTo + +-- Concatenation +-- ------------- + +-- | /O(n)/ Prepend an element +cons :: a -> Vector a -> Vector a +{-# INLINE cons #-} +cons = G.cons + +-- | /O(n)/ Append an element +snoc :: Vector a -> a -> Vector a +{-# INLINE snoc #-} +snoc = G.snoc + +infixr 5 ++ +-- | /O(m+n)/ Concatenate two vectors +(++) :: Vector a -> Vector a -> Vector a +{-# INLINE (++) #-} +(++) = (G.++) + +-- | /O(n)/ Concatenate all vectors in the list +concat :: [Vector a] -> Vector a +{-# INLINE concat #-} +concat = G.concat + +-- Monadic initialisation +-- ---------------------- + +-- | /O(n)/ Execute the monadic action the given number of times and store the +-- results in a vector. +replicateM :: Monad m => Int -> m a -> m (Vector a) +{-# INLINE replicateM #-} +replicateM = G.replicateM + +-- | /O(n)/ Construct a vector of the given length by applying the monadic +-- action to each index +generateM :: Monad m => Int -> (Int -> m a) -> m (Vector a) +{-# INLINE generateM #-} +generateM = G.generateM + +-- | /O(n)/ Apply monadic function n times to value. Zeroth element is original value. +iterateNM :: Monad m => Int -> (a -> m a) -> a -> m (Vector a) +{-# INLINE iterateNM #-} +iterateNM = G.iterateNM + +-- | Execute the monadic action and freeze the resulting vector. +-- +-- @ +-- create (do { v \<- new 2; write v 0 \'a\'; write v 1 \'b\'; return v }) = \<'a','b'\> +-- @ +create :: (forall s. ST s (MVector s a)) -> Vector a +{-# INLINE create #-} +-- NOTE: eta-expanded due to http://hackage.haskell.org/trac/ghc/ticket/4120 +create p = G.create p + +-- | Execute the monadic action and freeze the resulting vectors. +createT :: Traversable.Traversable f => (forall s. ST s (f (MVector s a))) -> f (Vector a) +{-# INLINE createT #-} +createT p = G.createT p + + + +-- Restricting memory usage +-- ------------------------ + +-- | /O(n)/ Yield the argument but force it not to retain any extra memory, +-- possibly by copying it. +-- +-- This is especially useful when dealing with slices. For example: +-- +-- > force (slice 0 2 <huge vector>) +-- +-- Here, the slice retains a reference to the huge vector. Forcing it creates +-- a copy of just the elements that belong to the slice and allows the huge +-- vector to be garbage collected. +force :: Vector a -> Vector a +{-# INLINE force #-} +force = G.force + +-- Bulk updates +-- ------------ + +-- | /O(m+n)/ For each pair @(i,a)@ from the list, replace the vector +-- element at position @i@ by @a@. +-- +-- > <5,9,2,7> // [(2,1),(0,3),(2,8)] = <3,9,8,7> +-- +(//) :: Vector a -- ^ initial vector (of length @m@) + -> [(Int, a)] -- ^ list of index/value pairs (of length @n@) + -> Vector a +{-# INLINE (//) #-} +(//) = (G.//) + +-- | /O(m+n)/ For each pair @(i,a)@ from the vector of index/value pairs, +-- replace the vector element at position @i@ by @a@. +-- +-- > update <5,9,2,7> <(2,1),(0,3),(2,8)> = <3,9,8,7> +-- +update :: Vector a -- ^ initial vector (of length @m@) + -> Vector (Int, a) -- ^ vector of index/value pairs (of length @n@) + -> Vector a +{-# INLINE update #-} +update = G.update + +-- | /O(m+min(n1,n2))/ For each index @i@ from the index vector and the +-- corresponding value @a@ from the value vector, replace the element of the +-- initial vector at position @i@ by @a@. +-- +-- > update_ <5,9,2,7> <2,0,2> <1,3,8> = <3,9,8,7> +-- +-- The function 'update' provides the same functionality and is usually more +-- convenient. +-- +-- @ +-- update_ xs is ys = 'update' xs ('zip' is ys) +-- @ +update_ :: Vector a -- ^ initial vector (of length @m@) + -> Vector Int -- ^ index vector (of length @n1@) + -> Vector a -- ^ value vector (of length @n2@) + -> Vector a +{-# INLINE update_ #-} +update_ = G.update_ + +-- | Same as ('//') but without bounds checking. +unsafeUpd :: Vector a -> [(Int, a)] -> Vector a +{-# INLINE unsafeUpd #-} +unsafeUpd = G.unsafeUpd + +-- | Same as 'update' but without bounds checking. +unsafeUpdate :: Vector a -> Vector (Int, a) -> Vector a +{-# INLINE unsafeUpdate #-} +unsafeUpdate = G.unsafeUpdate + +-- | Same as 'update_' but without bounds checking. +unsafeUpdate_ :: Vector a -> Vector Int -> Vector a -> Vector a +{-# INLINE unsafeUpdate_ #-} +unsafeUpdate_ = G.unsafeUpdate_ + +-- Accumulations +-- ------------- + +-- | /O(m+n)/ For each pair @(i,b)@ from the list, replace the vector element +-- @a@ at position @i@ by @f a b@. +-- +-- > accum (+) <5,9,2> [(2,4),(1,6),(0,3),(1,7)] = <5+3, 9+6+7, 2+4> +accum :: (a -> b -> a) -- ^ accumulating function @f@ + -> Vector a -- ^ initial vector (of length @m@) + -> [(Int,b)] -- ^ list of index/value pairs (of length @n@) + -> Vector a +{-# INLINE accum #-} +accum = G.accum + +-- | /O(m+n)/ For each pair @(i,b)@ from the vector of pairs, replace the vector +-- element @a@ at position @i@ by @f a b@. +-- +-- > accumulate (+) <5,9,2> <(2,4),(1,6),(0,3),(1,7)> = <5+3, 9+6+7, 2+4> +accumulate :: (a -> b -> a) -- ^ accumulating function @f@ + -> Vector a -- ^ initial vector (of length @m@) + -> Vector (Int,b) -- ^ vector of index/value pairs (of length @n@) + -> Vector a +{-# INLINE accumulate #-} +accumulate = G.accumulate + +-- | /O(m+min(n1,n2))/ For each index @i@ from the index vector and the +-- corresponding value @b@ from the the value vector, +-- replace the element of the initial vector at +-- position @i@ by @f a b@. +-- +-- > accumulate_ (+) <5,9,2> <2,1,0,1> <4,6,3,7> = <5+3, 9+6+7, 2+4> +-- +-- The function 'accumulate' provides the same functionality and is usually more +-- convenient. +-- +-- @ +-- accumulate_ f as is bs = 'accumulate' f as ('zip' is bs) +-- @ +accumulate_ :: (a -> b -> a) -- ^ accumulating function @f@ + -> Vector a -- ^ initial vector (of length @m@) + -> Vector Int -- ^ index vector (of length @n1@) + -> Vector b -- ^ value vector (of length @n2@) + -> Vector a +{-# INLINE accumulate_ #-} +accumulate_ = G.accumulate_ + +-- | Same as 'accum' but without bounds checking. +unsafeAccum :: (a -> b -> a) -> Vector a -> [(Int,b)] -> Vector a +{-# INLINE unsafeAccum #-} +unsafeAccum = G.unsafeAccum + +-- | Same as 'accumulate' but without bounds checking. +unsafeAccumulate :: (a -> b -> a) -> Vector a -> Vector (Int,b) -> Vector a +{-# INLINE unsafeAccumulate #-} +unsafeAccumulate = G.unsafeAccumulate + +-- | Same as 'accumulate_' but without bounds checking. +unsafeAccumulate_ + :: (a -> b -> a) -> Vector a -> Vector Int -> Vector b -> Vector a +{-# INLINE unsafeAccumulate_ #-} +unsafeAccumulate_ = G.unsafeAccumulate_ + +-- Permutations +-- ------------ + +-- | /O(n)/ Reverse a vector +reverse :: Vector a -> Vector a +{-# INLINE reverse #-} +reverse = G.reverse + +-- | /O(n)/ Yield the vector obtained by replacing each element @i@ of the +-- index vector by @xs'!'i@. This is equivalent to @'map' (xs'!') is@ but is +-- often much more efficient. +-- +-- > backpermute <a,b,c,d> <0,3,2,3,1,0> = <a,d,c,d,b,a> +backpermute :: Vector a -> Vector Int -> Vector a +{-# INLINE backpermute #-} +backpermute = G.backpermute + +-- | Same as 'backpermute' but without bounds checking. +unsafeBackpermute :: Vector a -> Vector Int -> Vector a +{-# INLINE unsafeBackpermute #-} +unsafeBackpermute = G.unsafeBackpermute + +-- Safe destructive updates +-- ------------------------ + +-- | Apply a destructive operation to a vector. The operation will be +-- performed in place if it is safe to do so and will modify a copy of the +-- vector otherwise. +-- +-- @ +-- modify (\\v -> write v 0 \'x\') ('replicate' 3 \'a\') = \<\'x\',\'a\',\'a\'\> +-- @ +modify :: (forall s. MVector s a -> ST s ()) -> Vector a -> Vector a +{-# INLINE modify #-} +modify p = G.modify p + +-- Indexing +-- -------- + +-- | /O(n)/ Pair each element in a vector with its index +indexed :: Vector a -> Vector (Int,a) +{-# INLINE indexed #-} +indexed = G.indexed + +-- Mapping +-- ------- + +-- | /O(n)/ Map a function over a vector +map :: (a -> b) -> Vector a -> Vector b +{-# INLINE map #-} +map = G.map + +-- | /O(n)/ Apply a function to every element of a vector and its index +imap :: (Int -> a -> b) -> Vector a -> Vector b +{-# INLINE imap #-} +imap = G.imap + +-- | Map a function over a vector and concatenate the results. +concatMap :: (a -> Vector b) -> Vector a -> Vector b +{-# INLINE concatMap #-} +concatMap = G.concatMap + +-- Monadic mapping +-- --------------- + +-- | /O(n)/ Apply the monadic action to all elements of the vector, yielding a +-- vector of results +mapM :: Monad m => (a -> m b) -> Vector a -> m (Vector b) +{-# INLINE mapM #-} +mapM = G.mapM + +-- | /O(n)/ Apply the monadic action to every element of a vector and its +-- index, yielding a vector of results +imapM :: Monad m => (Int -> a -> m b) -> Vector a -> m (Vector b) +{-# INLINE imapM #-} +imapM = G.imapM + +-- | /O(n)/ Apply the monadic action to all elements of a vector and ignore the +-- results +mapM_ :: Monad m => (a -> m b) -> Vector a -> m () +{-# INLINE mapM_ #-} +mapM_ = G.mapM_ + +-- | /O(n)/ Apply the monadic action to every element of a vector and its +-- index, ignoring the results +imapM_ :: Monad m => (Int -> a -> m b) -> Vector a -> m () +{-# INLINE imapM_ #-} +imapM_ = G.imapM_ + +-- | /O(n)/ Apply the monadic action to all elements of the vector, yielding a +-- vector of results. Equivalent to @flip 'mapM'@. +forM :: Monad m => Vector a -> (a -> m b) -> m (Vector b) +{-# INLINE forM #-} +forM = G.forM + +-- | /O(n)/ Apply the monadic action to all elements of a vector and ignore the +-- results. Equivalent to @flip 'mapM_'@. +forM_ :: Monad m => Vector a -> (a -> m b) -> m () +{-# INLINE forM_ #-} +forM_ = G.forM_ + +-- Zipping +-- ------- + +-- | /O(min(m,n))/ Zip two vectors with the given function. +zipWith :: (a -> b -> c) -> Vector a -> Vector b -> Vector c +{-# INLINE zipWith #-} +zipWith = G.zipWith + +-- | Zip three vectors with the given function. +zipWith3 :: (a -> b -> c -> d) -> Vector a -> Vector b -> Vector c -> Vector d +{-# INLINE zipWith3 #-} +zipWith3 = G.zipWith3 + +zipWith4 :: (a -> b -> c -> d -> e) + -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e +{-# INLINE zipWith4 #-} +zipWith4 = G.zipWith4 + +zipWith5 :: (a -> b -> c -> d -> e -> f) + -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e + -> Vector f +{-# INLINE zipWith5 #-} +zipWith5 = G.zipWith5 + +zipWith6 :: (a -> b -> c -> d -> e -> f -> g) + -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e + -> Vector f -> Vector g +{-# INLINE zipWith6 #-} +zipWith6 = G.zipWith6 + +-- | /O(min(m,n))/ Zip two vectors with a function that also takes the +-- elements' indices. +izipWith :: (Int -> a -> b -> c) -> Vector a -> Vector b -> Vector c +{-# INLINE izipWith #-} +izipWith = G.izipWith + +-- | Zip three vectors and their indices with the given function. +izipWith3 :: (Int -> a -> b -> c -> d) + -> Vector a -> Vector b -> Vector c -> Vector d +{-# INLINE izipWith3 #-} +izipWith3 = G.izipWith3 + +izipWith4 :: (Int -> a -> b -> c -> d -> e) + -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e +{-# INLINE izipWith4 #-} +izipWith4 = G.izipWith4 + +izipWith5 :: (Int -> a -> b -> c -> d -> e -> f) + -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e + -> Vector f +{-# INLINE izipWith5 #-} +izipWith5 = G.izipWith5 + +izipWith6 :: (Int -> a -> b -> c -> d -> e -> f -> g) + -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e + -> Vector f -> Vector g +{-# INLINE izipWith6 #-} +izipWith6 = G.izipWith6 + +-- | Elementwise pairing of array elements. +zip :: Vector a -> Vector b -> Vector (a, b) +{-# INLINE zip #-} +zip = G.zip + +-- | zip together three vectors into a vector of triples +zip3 :: Vector a -> Vector b -> Vector c -> Vector (a, b, c) +{-# INLINE zip3 #-} +zip3 = G.zip3 + +zip4 :: Vector a -> Vector b -> Vector c -> Vector d + -> Vector (a, b, c, d) +{-# INLINE zip4 #-} +zip4 = G.zip4 + +zip5 :: Vector a -> Vector b -> Vector c -> Vector d -> Vector e + -> Vector (a, b, c, d, e) +{-# INLINE zip5 #-} +zip5 = G.zip5 + +zip6 :: Vector a -> Vector b -> Vector c -> Vector d -> Vector e -> Vector f + -> Vector (a, b, c, d, e, f) +{-# INLINE zip6 #-} +zip6 = G.zip6 + +-- Unzipping +-- --------- + +-- | /O(min(m,n))/ Unzip a vector of pairs. +unzip :: Vector (a, b) -> (Vector a, Vector b) +{-# INLINE unzip #-} +unzip = G.unzip + +unzip3 :: Vector (a, b, c) -> (Vector a, Vector b, Vector c) +{-# INLINE unzip3 #-} +unzip3 = G.unzip3 + +unzip4 :: Vector (a, b, c, d) -> (Vector a, Vector b, Vector c, Vector d) +{-# INLINE unzip4 #-} +unzip4 = G.unzip4 + +unzip5 :: Vector (a, b, c, d, e) + -> (Vector a, Vector b, Vector c, Vector d, Vector e) +{-# INLINE unzip5 #-} +unzip5 = G.unzip5 + +unzip6 :: Vector (a, b, c, d, e, f) + -> (Vector a, Vector b, Vector c, Vector d, Vector e, Vector f) +{-# INLINE unzip6 #-} +unzip6 = G.unzip6 + +-- Monadic zipping +-- --------------- + +-- | /O(min(m,n))/ Zip the two vectors with the monadic action and yield a +-- vector of results +zipWithM :: Monad m => (a -> b -> m c) -> Vector a -> Vector b -> m (Vector c) +{-# INLINE zipWithM #-} +zipWithM = G.zipWithM + +-- | /O(min(m,n))/ Zip the two vectors with a monadic action that also takes +-- the element index and yield a vector of results +izipWithM :: Monad m => (Int -> a -> b -> m c) -> Vector a -> Vector b -> m (Vector c) +{-# INLINE izipWithM #-} +izipWithM = G.izipWithM + +-- | /O(min(m,n))/ Zip the two vectors with the monadic action and ignore the +-- results +zipWithM_ :: Monad m => (a -> b -> m c) -> Vector a -> Vector b -> m () +{-# INLINE zipWithM_ #-} +zipWithM_ = G.zipWithM_ + +-- | /O(min(m,n))/ Zip the two vectors with a monadic action that also takes +-- the element index and ignore the results +izipWithM_ :: Monad m => (Int -> a -> b -> m c) -> Vector a -> Vector b -> m () +{-# INLINE izipWithM_ #-} +izipWithM_ = G.izipWithM_ + +-- Filtering +-- --------- + +-- | /O(n)/ Drop elements that do not satisfy the predicate +filter :: (a -> Bool) -> Vector a -> Vector a +{-# INLINE filter #-} +filter = G.filter + +-- | /O(n)/ Drop elements that do not satisfy the predicate which is applied to +-- values and their indices +ifilter :: (Int -> a -> Bool) -> Vector a -> Vector a +{-# INLINE ifilter #-} +ifilter = G.ifilter + +-- | /O(n)/ Drop repeated adjacent elements. +uniq :: (Eq a) => Vector a -> Vector a +{-# INLINE uniq #-} +uniq = G.uniq + +-- | /O(n)/ Drop elements when predicate returns Nothing +mapMaybe :: (a -> Maybe b) -> Vector a -> Vector b +{-# INLINE mapMaybe #-} +mapMaybe = G.mapMaybe + +-- | /O(n)/ Drop elements when predicate, applied to index and value, returns Nothing +imapMaybe :: (Int -> a -> Maybe b) -> Vector a -> Vector b +{-# INLINE imapMaybe #-} +imapMaybe = G.imapMaybe + +-- | /O(n)/ Drop elements that do not satisfy the monadic predicate +filterM :: Monad m => (a -> m Bool) -> Vector a -> m (Vector a) +{-# INLINE filterM #-} +filterM = G.filterM + +-- | /O(n)/ Yield the longest prefix of elements satisfying the predicate +-- without copying. +takeWhile :: (a -> Bool) -> Vector a -> Vector a +{-# INLINE takeWhile #-} +takeWhile = G.takeWhile + +-- | /O(n)/ Drop the longest prefix of elements that satisfy the predicate +-- without copying. +dropWhile :: (a -> Bool) -> Vector a -> Vector a +{-# INLINE dropWhile #-} +dropWhile = G.dropWhile + +-- Parititioning +-- ------------- + +-- | /O(n)/ Split the vector in two parts, the first one containing those +-- elements that satisfy the predicate and the second one those that don't. The +-- relative order of the elements is preserved at the cost of a sometimes +-- reduced performance compared to 'unstablePartition'. +partition :: (a -> Bool) -> Vector a -> (Vector a, Vector a) +{-# INLINE partition #-} +partition = G.partition + +-- | /O(n)/ Split the vector in two parts, the first one containing those +-- elements that satisfy the predicate and the second one those that don't. +-- The order of the elements is not preserved but the operation is often +-- faster than 'partition'. +unstablePartition :: (a -> Bool) -> Vector a -> (Vector a, Vector a) +{-# INLINE unstablePartition #-} +unstablePartition = G.unstablePartition + +-- | /O(n)/ Split the vector into the longest prefix of elements that satisfy +-- the predicate and the rest without copying. +span :: (a -> Bool) -> Vector a -> (Vector a, Vector a) +{-# INLINE span #-} +span = G.span + +-- | /O(n)/ Split the vector into the longest prefix of elements that do not +-- satisfy the predicate and the rest without copying. +break :: (a -> Bool) -> Vector a -> (Vector a, Vector a) +{-# INLINE break #-} +break = G.break + +-- Searching +-- --------- + +infix 4 `elem` +-- | /O(n)/ Check if the vector contains an element +elem :: Eq a => a -> Vector a -> Bool +{-# INLINE elem #-} +elem = G.elem + +infix 4 `notElem` +-- | /O(n)/ Check if the vector does not contain an element (inverse of 'elem') +notElem :: Eq a => a -> Vector a -> Bool +{-# INLINE notElem #-} +notElem = G.notElem + +-- | /O(n)/ Yield 'Just' the first element matching the predicate or 'Nothing' +-- if no such element exists. +find :: (a -> Bool) -> Vector a -> Maybe a +{-# INLINE find #-} +find = G.find + +-- | /O(n)/ Yield 'Just' the index of the first element matching the predicate +-- or 'Nothing' if no such element exists. +findIndex :: (a -> Bool) -> Vector a -> Maybe Int +{-# INLINE findIndex #-} +findIndex = G.findIndex + +-- | /O(n)/ Yield the indices of elements satisfying the predicate in ascending +-- order. +findIndices :: (a -> Bool) -> Vector a -> Vector Int +{-# INLINE findIndices #-} +findIndices = G.findIndices + +-- | /O(n)/ Yield 'Just' the index of the first occurence of the given element or +-- 'Nothing' if the vector does not contain the element. This is a specialised +-- version of 'findIndex'. +elemIndex :: Eq a => a -> Vector a -> Maybe Int +{-# INLINE elemIndex #-} +elemIndex = G.elemIndex + +-- | /O(n)/ Yield the indices of all occurences of the given element in +-- ascending order. This is a specialised version of 'findIndices'. +elemIndices :: Eq a => a -> Vector a -> Vector Int +{-# INLINE elemIndices #-} +elemIndices = G.elemIndices + +-- Folding +-- ------- + +-- | /O(n)/ Left fold +foldl :: (a -> b -> a) -> a -> Vector b -> a +{-# INLINE foldl #-} +foldl = G.foldl + +-- | /O(n)/ Left fold on non-empty vectors +foldl1 :: (a -> a -> a) -> Vector a -> a +{-# INLINE foldl1 #-} +foldl1 = G.foldl1 + +-- | /O(n)/ Left fold with strict accumulator +foldl' :: (a -> b -> a) -> a -> Vector b -> a +{-# INLINE foldl' #-} +foldl' = G.foldl' + +-- | /O(n)/ Left fold on non-empty vectors with strict accumulator +foldl1' :: (a -> a -> a) -> Vector a -> a +{-# INLINE foldl1' #-} +foldl1' = G.foldl1' + +-- | /O(n)/ Right fold +foldr :: (a -> b -> b) -> b -> Vector a -> b +{-# INLINE foldr #-} +foldr = G.foldr + +-- | /O(n)/ Right fold on non-empty vectors +foldr1 :: (a -> a -> a) -> Vector a -> a +{-# INLINE foldr1 #-} +foldr1 = G.foldr1 + +-- | /O(n)/ Right fold with a strict accumulator +foldr' :: (a -> b -> b) -> b -> Vector a -> b +{-# INLINE foldr' #-} +foldr' = G.foldr' + +-- | /O(n)/ Right fold on non-empty vectors with strict accumulator +foldr1' :: (a -> a -> a) -> Vector a -> a +{-# INLINE foldr1' #-} +foldr1' = G.foldr1' + +-- | /O(n)/ Left fold (function applied to each element and its index) +ifoldl :: (a -> Int -> b -> a) -> a -> Vector b -> a +{-# INLINE ifoldl #-} +ifoldl = G.ifoldl + +-- | /O(n)/ Left fold with strict accumulator (function applied to each element +-- and its index) +ifoldl' :: (a -> Int -> b -> a) -> a -> Vector b -> a +{-# INLINE ifoldl' #-} +ifoldl' = G.ifoldl' + +-- | /O(n)/ Right fold (function applied to each element and its index) +ifoldr :: (Int -> a -> b -> b) -> b -> Vector a -> b +{-# INLINE ifoldr #-} +ifoldr = G.ifoldr + +-- | /O(n)/ Right fold with strict accumulator (function applied to each +-- element and its index) +ifoldr' :: (Int -> a -> b -> b) -> b -> Vector a -> b +{-# INLINE ifoldr' #-} +ifoldr' = G.ifoldr' + +-- Specialised folds +-- ----------------- + +-- | /O(n)/ Check if all elements satisfy the predicate. +all :: (a -> Bool) -> Vector a -> Bool +{-# INLINE all #-} +all = G.all + +-- | /O(n)/ Check if any element satisfies the predicate. +any :: (a -> Bool) -> Vector a -> Bool +{-# INLINE any #-} +any = G.any + +-- | /O(n)/ Check if all elements are 'True' +and :: Vector Bool -> Bool +{-# INLINE and #-} +and = G.and + +-- | /O(n)/ Check if any element is 'True' +or :: Vector Bool -> Bool +{-# INLINE or #-} +or = G.or + +-- | /O(n)/ Compute the sum of the elements +sum :: Num a => Vector a -> a +{-# INLINE sum #-} +sum = G.sum + +-- | /O(n)/ Compute the produce of the elements +product :: Num a => Vector a -> a +{-# INLINE product #-} +product = G.product + +-- | /O(n)/ Yield the maximum element of the vector. The vector may not be +-- empty. +maximum :: Ord a => Vector a -> a +{-# INLINE maximum #-} +maximum = G.maximum + +-- | /O(n)/ Yield the maximum element of the vector according to the given +-- comparison function. The vector may not be empty. +maximumBy :: (a -> a -> Ordering) -> Vector a -> a +{-# INLINE maximumBy #-} +maximumBy = G.maximumBy + +-- | /O(n)/ Yield the minimum element of the vector. The vector may not be +-- empty. +minimum :: Ord a => Vector a -> a +{-# INLINE minimum #-} +minimum = G.minimum + +-- | /O(n)/ Yield the minimum element of the vector according to the given +-- comparison function. The vector may not be empty. +minimumBy :: (a -> a -> Ordering) -> Vector a -> a +{-# INLINE minimumBy #-} +minimumBy = G.minimumBy + +-- | /O(n)/ Yield the index of the maximum element of the vector. The vector +-- may not be empty. +maxIndex :: Ord a => Vector a -> Int +{-# INLINE maxIndex #-} +maxIndex = G.maxIndex + +-- | /O(n)/ Yield the index of the maximum element of the vector according to +-- the given comparison function. The vector may not be empty. +maxIndexBy :: (a -> a -> Ordering) -> Vector a -> Int +{-# INLINE maxIndexBy #-} +maxIndexBy = G.maxIndexBy + +-- | /O(n)/ Yield the index of the minimum element of the vector. The vector +-- may not be empty. +minIndex :: Ord a => Vector a -> Int +{-# INLINE minIndex #-} +minIndex = G.minIndex + +-- | /O(n)/ Yield the index of the minimum element of the vector according to +-- the given comparison function. The vector may not be empty. +minIndexBy :: (a -> a -> Ordering) -> Vector a -> Int +{-# INLINE minIndexBy #-} +minIndexBy = G.minIndexBy + +-- Monadic folds +-- ------------- + +-- | /O(n)/ Monadic fold +foldM :: Monad m => (a -> b -> m a) -> a -> Vector b -> m a +{-# INLINE foldM #-} +foldM = G.foldM + +-- | /O(n)/ Monadic fold (action applied to each element and its index) +ifoldM :: Monad m => (a -> Int -> b -> m a) -> a -> Vector b -> m a +{-# INLINE ifoldM #-} +ifoldM = G.ifoldM + +-- | /O(n)/ Monadic fold over non-empty vectors +fold1M :: Monad m => (a -> a -> m a) -> Vector a -> m a +{-# INLINE fold1M #-} +fold1M = G.fold1M + +-- | /O(n)/ Monadic fold with strict accumulator +foldM' :: Monad m => (a -> b -> m a) -> a -> Vector b -> m a +{-# INLINE foldM' #-} +foldM' = G.foldM' + +-- | /O(n)/ Monadic fold with strict accumulator (action applied to each +-- element and its index) +ifoldM' :: Monad m => (a -> Int -> b -> m a) -> a -> Vector b -> m a +{-# INLINE ifoldM' #-} +ifoldM' = G.ifoldM' + +-- | /O(n)/ Monadic fold over non-empty vectors with strict accumulator +fold1M' :: Monad m => (a -> a -> m a) -> Vector a -> m a +{-# INLINE fold1M' #-} +fold1M' = G.fold1M' + +-- | /O(n)/ Monadic fold that discards the result +foldM_ :: Monad m => (a -> b -> m a) -> a -> Vector b -> m () +{-# INLINE foldM_ #-} +foldM_ = G.foldM_ + +-- | /O(n)/ Monadic fold that discards the result (action applied to each +-- element and its index) +ifoldM_ :: Monad m => (a -> Int -> b -> m a) -> a -> Vector b -> m () +{-# INLINE ifoldM_ #-} +ifoldM_ = G.ifoldM_ + +-- | /O(n)/ Monadic fold over non-empty vectors that discards the result +fold1M_ :: Monad m => (a -> a -> m a) -> Vector a -> m () +{-# INLINE fold1M_ #-} +fold1M_ = G.fold1M_ + +-- | /O(n)/ Monadic fold with strict accumulator that discards the result +foldM'_ :: Monad m => (a -> b -> m a) -> a -> Vector b -> m () +{-# INLINE foldM'_ #-} +foldM'_ = G.foldM'_ + +-- | /O(n)/ Monadic fold with strict accumulator that discards the result +-- (action applied to each element and its index) +ifoldM'_ :: Monad m => (a -> Int -> b -> m a) -> a -> Vector b -> m () +{-# INLINE ifoldM'_ #-} +ifoldM'_ = G.ifoldM'_ + +-- | /O(n)/ Monadic fold over non-empty vectors with strict accumulator +-- that discards the result +fold1M'_ :: Monad m => (a -> a -> m a) -> Vector a -> m () +{-# INLINE fold1M'_ #-} +fold1M'_ = G.fold1M'_ + +-- Monadic sequencing +-- ------------------ + +-- | Evaluate each action and collect the results +sequence :: Monad m => Vector (m a) -> m (Vector a) +{-# INLINE sequence #-} +sequence = G.sequence + +-- | Evaluate each action and discard the results +sequence_ :: Monad m => Vector (m a) -> m () +{-# INLINE sequence_ #-} +sequence_ = G.sequence_ + +-- Prefix sums (scans) +-- ------------------- + +-- | /O(n)/ Prescan +-- +-- @ +-- prescanl f z = 'init' . 'scanl' f z +-- @ +-- +-- Example: @prescanl (+) 0 \<1,2,3,4\> = \<0,1,3,6\>@ +-- +prescanl :: (a -> b -> a) -> a -> Vector b -> Vector a +{-# INLINE prescanl #-} +prescanl = G.prescanl + +-- | /O(n)/ Prescan with strict accumulator +prescanl' :: (a -> b -> a) -> a -> Vector b -> Vector a +{-# INLINE prescanl' #-} +prescanl' = G.prescanl' + +-- | /O(n)/ Scan +-- +-- @ +-- postscanl f z = 'tail' . 'scanl' f z +-- @ +-- +-- Example: @postscanl (+) 0 \<1,2,3,4\> = \<1,3,6,10\>@ +-- +postscanl :: (a -> b -> a) -> a -> Vector b -> Vector a +{-# INLINE postscanl #-} +postscanl = G.postscanl + +-- | /O(n)/ Scan with strict accumulator +postscanl' :: (a -> b -> a) -> a -> Vector b -> Vector a +{-# INLINE postscanl' #-} +postscanl' = G.postscanl' + +-- | /O(n)/ Haskell-style scan +-- +-- > scanl f z <x1,...,xn> = <y1,...,y(n+1)> +-- > where y1 = z +-- > yi = f y(i-1) x(i-1) +-- +-- Example: @scanl (+) 0 \<1,2,3,4\> = \<0,1,3,6,10\>@ +-- +scanl :: (a -> b -> a) -> a -> Vector b -> Vector a +{-# INLINE scanl #-} +scanl = G.scanl + +-- | /O(n)/ Haskell-style scan with strict accumulator +scanl' :: (a -> b -> a) -> a -> Vector b -> Vector a +{-# INLINE scanl' #-} +scanl' = G.scanl' + +-- | /O(n)/ Scan over a vector with its index +iscanl :: (Int -> a -> b -> a) -> a -> Vector b -> Vector a +{-# INLINE iscanl #-} +iscanl = G.iscanl + +-- | /O(n)/ Scan over a vector (strictly) with its index +iscanl' :: (Int -> a -> b -> a) -> a -> Vector b -> Vector a +{-# INLINE iscanl' #-} +iscanl' = G.iscanl' + +-- | /O(n)/ Scan over a non-empty vector +-- +-- > scanl f <x1,...,xn> = <y1,...,yn> +-- > where y1 = x1 +-- > yi = f y(i-1) xi +-- +scanl1 :: (a -> a -> a) -> Vector a -> Vector a +{-# INLINE scanl1 #-} +scanl1 = G.scanl1 + +-- | /O(n)/ Scan over a non-empty vector with a strict accumulator +scanl1' :: (a -> a -> a) -> Vector a -> Vector a +{-# INLINE scanl1' #-} +scanl1' = G.scanl1' + +-- | /O(n)/ Right-to-left prescan +-- +-- @ +-- prescanr f z = 'reverse' . 'prescanl' (flip f) z . 'reverse' +-- @ +-- +prescanr :: (a -> b -> b) -> b -> Vector a -> Vector b +{-# INLINE prescanr #-} +prescanr = G.prescanr + +-- | /O(n)/ Right-to-left prescan with strict accumulator +prescanr' :: (a -> b -> b) -> b -> Vector a -> Vector b +{-# INLINE prescanr' #-} +prescanr' = G.prescanr' + +-- | /O(n)/ Right-to-left scan +postscanr :: (a -> b -> b) -> b -> Vector a -> Vector b +{-# INLINE postscanr #-} +postscanr = G.postscanr + +-- | /O(n)/ Right-to-left scan with strict accumulator +postscanr' :: (a -> b -> b) -> b -> Vector a -> Vector b +{-# INLINE postscanr' #-} +postscanr' = G.postscanr' + +-- | /O(n)/ Right-to-left Haskell-style scan +scanr :: (a -> b -> b) -> b -> Vector a -> Vector b +{-# INLINE scanr #-} +scanr = G.scanr + +-- | /O(n)/ Right-to-left Haskell-style scan with strict accumulator +scanr' :: (a -> b -> b) -> b -> Vector a -> Vector b +{-# INLINE scanr' #-} +scanr' = G.scanr' + +-- | /O(n)/ Right-to-left scan over a vector with its index +iscanr :: (Int -> a -> b -> b) -> b -> Vector a -> Vector b +{-# INLINE iscanr #-} +iscanr = G.iscanr + +-- | /O(n)/ Right-to-left scan over a vector (strictly) with its index +iscanr' :: (Int -> a -> b -> b) -> b -> Vector a -> Vector b +{-# INLINE iscanr' #-} +iscanr' = G.iscanr' + +-- | /O(n)/ Right-to-left scan over a non-empty vector +scanr1 :: (a -> a -> a) -> Vector a -> Vector a +{-# INLINE scanr1 #-} +scanr1 = G.scanr1 + +-- | /O(n)/ Right-to-left scan over a non-empty vector with a strict +-- accumulator +scanr1' :: (a -> a -> a) -> Vector a -> Vector a +{-# INLINE scanr1' #-} +scanr1' = G.scanr1' + +-- Conversions - Lists +-- ------------------------ + +-- | /O(n)/ Convert a vector to a list +toList :: Vector a -> [a] +{-# INLINE toList #-} +toList = G.toList + +-- | /O(n)/ Convert a list to a vector +fromList :: [a] -> Vector a +{-# INLINE fromList #-} +fromList = G.fromList + +-- | /O(n)/ Convert the first @n@ elements of a list to a vector +-- +-- @ +-- fromListN n xs = 'fromList' ('take' n xs) +-- @ +fromListN :: Int -> [a] -> Vector a +{-# INLINE fromListN #-} +fromListN = G.fromListN + +-- Conversions - Mutable vectors +-- ----------------------------- + +-- | /O(1)/ Unsafe convert a mutable vector to an immutable one without +-- copying. The mutable vector may not be used after this operation. +unsafeFreeze :: PrimMonad m => MVector (PrimState m) a -> m (Vector a) +{-# INLINE unsafeFreeze #-} +unsafeFreeze = G.unsafeFreeze + +-- | /O(1)/ Unsafely convert an immutable vector to a mutable one without +-- copying. The immutable vector may not be used after this operation. +unsafeThaw :: PrimMonad m => Vector a -> m (MVector (PrimState m) a) +{-# INLINE unsafeThaw #-} +unsafeThaw = G.unsafeThaw + +-- | /O(n)/ Yield a mutable copy of the immutable vector. +thaw :: PrimMonad m => Vector a -> m (MVector (PrimState m) a) +{-# INLINE thaw #-} +thaw = G.thaw + +-- | /O(n)/ Yield an immutable copy of the mutable vector. +freeze :: PrimMonad m => MVector (PrimState m) a -> m (Vector a) +{-# INLINE freeze #-} +freeze = G.freeze + +-- | /O(n)/ Copy an immutable vector into a mutable one. The two vectors must +-- have the same length. This is not checked. +unsafeCopy :: PrimMonad m => MVector (PrimState m) a -> Vector a -> m () +{-# INLINE unsafeCopy #-} +unsafeCopy = G.unsafeCopy + +-- | /O(n)/ Copy an immutable vector into a mutable one. The two vectors must +-- have the same length. +copy :: PrimMonad m => MVector (PrimState m) a -> Vector a -> m () +{-# INLINE copy #-} +copy = G.copy diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Bundle.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Bundle.hs new file mode 100644 index 000000000000..6b6b6236d7cb --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Bundle.hs @@ -0,0 +1,655 @@ +{-# LANGUAGE CPP, FlexibleInstances, Rank2Types, BangPatterns #-} + +-- | +-- Module : Data.Vector.Fusion.Bundle +-- Copyright : (c) Roman Leshchinskiy 2008-2010 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> +-- Stability : experimental +-- Portability : non-portable +-- +-- Bundles for stream fusion +-- + +module Data.Vector.Fusion.Bundle ( + -- * Types + Step(..), Chunk(..), Bundle, MBundle, + + -- * In-place markers + inplace, + + -- * Size hints + size, sized, + + -- * Length information + length, null, + + -- * Construction + empty, singleton, cons, snoc, replicate, generate, (++), + + -- * Accessing individual elements + head, last, (!!), (!?), + + -- * Substreams + slice, init, tail, take, drop, + + -- * Mapping + map, concatMap, flatten, unbox, + + -- * Zipping + indexed, indexedR, + zipWith, zipWith3, zipWith4, zipWith5, zipWith6, + zip, zip3, zip4, zip5, zip6, + + -- * Filtering + filter, takeWhile, dropWhile, + + -- * Searching + elem, notElem, find, findIndex, + + -- * Folding + foldl, foldl1, foldl', foldl1', foldr, foldr1, + + -- * Specialised folds + and, or, + + -- * Unfolding + unfoldr, unfoldrN, iterateN, + + -- * Scans + prescanl, prescanl', + postscanl, postscanl', + scanl, scanl', + scanl1, scanl1', + + -- * Enumerations + enumFromStepN, enumFromTo, enumFromThenTo, + + -- * Conversions + toList, fromList, fromListN, unsafeFromList, lift, + fromVector, reVector, fromVectors, concatVectors, + + -- * Monadic combinators + mapM, mapM_, zipWithM, zipWithM_, filterM, foldM, fold1M, foldM', fold1M', + + eq, cmp, eqBy, cmpBy +) where + +import Data.Vector.Generic.Base ( Vector ) +import Data.Vector.Fusion.Bundle.Size +import Data.Vector.Fusion.Util +import Data.Vector.Fusion.Stream.Monadic ( Stream(..), Step(..) ) +import Data.Vector.Fusion.Bundle.Monadic ( Chunk(..) ) +import qualified Data.Vector.Fusion.Bundle.Monadic as M +import qualified Data.Vector.Fusion.Stream.Monadic as S + +import Prelude hiding ( length, null, + replicate, (++), + head, last, (!!), + init, tail, take, drop, + map, concatMap, + zipWith, zipWith3, zip, zip3, + filter, takeWhile, dropWhile, + elem, notElem, + foldl, foldl1, foldr, foldr1, + and, or, + scanl, scanl1, + enumFromTo, enumFromThenTo, + mapM, mapM_ ) + +#if MIN_VERSION_base(4,9,0) +import Data.Functor.Classes (Eq1 (..), Ord1 (..)) +#endif + +import GHC.Base ( build ) + +-- Data.Vector.Internal.Check is unused +#define NOT_VECTOR_MODULE +#include "vector.h" + +-- | The type of pure streams +type Bundle = M.Bundle Id + +-- | Alternative name for monadic streams +type MBundle = M.Bundle + +inplace :: (forall m. Monad m => S.Stream m a -> S.Stream m b) + -> (Size -> Size) -> Bundle v a -> Bundle v b +{-# INLINE_FUSED inplace #-} +inplace f g b = b `seq` M.fromStream (f (M.elements b)) (g (M.size b)) + +{-# RULES + +"inplace/inplace [Vector]" + forall (f1 :: forall m. Monad m => S.Stream m a -> S.Stream m a) + (f2 :: forall m. Monad m => S.Stream m a -> S.Stream m a) + g1 g2 s. + inplace f1 g1 (inplace f2 g2 s) = inplace (f1 . f2) (g1 . g2) s #-} + + + +-- | Convert a pure stream to a monadic stream +lift :: Monad m => Bundle v a -> M.Bundle m v a +{-# INLINE_FUSED lift #-} +lift (M.Bundle (Stream step s) (Stream vstep t) v sz) + = M.Bundle (Stream (return . unId . step) s) + (Stream (return . unId . vstep) t) v sz + +-- | 'Size' hint of a 'Bundle' +size :: Bundle v a -> Size +{-# INLINE size #-} +size = M.size + +-- | Attach a 'Size' hint to a 'Bundle' +sized :: Bundle v a -> Size -> Bundle v a +{-# INLINE sized #-} +sized = M.sized + +-- Length +-- ------ + +-- | Length of a 'Bundle' +length :: Bundle v a -> Int +{-# INLINE length #-} +length = unId . M.length + +-- | Check if a 'Bundle' is empty +null :: Bundle v a -> Bool +{-# INLINE null #-} +null = unId . M.null + +-- Construction +-- ------------ + +-- | Empty 'Bundle' +empty :: Bundle v a +{-# INLINE empty #-} +empty = M.empty + +-- | Singleton 'Bundle' +singleton :: a -> Bundle v a +{-# INLINE singleton #-} +singleton = M.singleton + +-- | Replicate a value to a given length +replicate :: Int -> a -> Bundle v a +{-# INLINE replicate #-} +replicate = M.replicate + +-- | Generate a stream from its indices +generate :: Int -> (Int -> a) -> Bundle v a +{-# INLINE generate #-} +generate = M.generate + +-- | Prepend an element +cons :: a -> Bundle v a -> Bundle v a +{-# INLINE cons #-} +cons = M.cons + +-- | Append an element +snoc :: Bundle v a -> a -> Bundle v a +{-# INLINE snoc #-} +snoc = M.snoc + +infixr 5 ++ +-- | Concatenate two 'Bundle's +(++) :: Bundle v a -> Bundle v a -> Bundle v a +{-# INLINE (++) #-} +(++) = (M.++) + +-- Accessing elements +-- ------------------ + +-- | First element of the 'Bundle' or error if empty +head :: Bundle v a -> a +{-# INLINE head #-} +head = unId . M.head + +-- | Last element of the 'Bundle' or error if empty +last :: Bundle v a -> a +{-# INLINE last #-} +last = unId . M.last + +infixl 9 !! +-- | Element at the given position +(!!) :: Bundle v a -> Int -> a +{-# INLINE (!!) #-} +s !! i = unId (s M.!! i) + +infixl 9 !? +-- | Element at the given position or 'Nothing' if out of bounds +(!?) :: Bundle v a -> Int -> Maybe a +{-# INLINE (!?) #-} +s !? i = unId (s M.!? i) + +-- Substreams +-- ---------- + +-- | Extract a substream of the given length starting at the given position. +slice :: Int -- ^ starting index + -> Int -- ^ length + -> Bundle v a + -> Bundle v a +{-# INLINE slice #-} +slice = M.slice + +-- | All but the last element +init :: Bundle v a -> Bundle v a +{-# INLINE init #-} +init = M.init + +-- | All but the first element +tail :: Bundle v a -> Bundle v a +{-# INLINE tail #-} +tail = M.tail + +-- | The first @n@ elements +take :: Int -> Bundle v a -> Bundle v a +{-# INLINE take #-} +take = M.take + +-- | All but the first @n@ elements +drop :: Int -> Bundle v a -> Bundle v a +{-# INLINE drop #-} +drop = M.drop + +-- Mapping +-- --------------- + +-- | Map a function over a 'Bundle' +map :: (a -> b) -> Bundle v a -> Bundle v b +{-# INLINE map #-} +map = M.map + +unbox :: Bundle v (Box a) -> Bundle v a +{-# INLINE unbox #-} +unbox = M.unbox + +concatMap :: (a -> Bundle v b) -> Bundle v a -> Bundle v b +{-# INLINE concatMap #-} +concatMap = M.concatMap + +-- Zipping +-- ------- + +-- | Pair each element in a 'Bundle' with its index +indexed :: Bundle v a -> Bundle v (Int,a) +{-# INLINE indexed #-} +indexed = M.indexed + +-- | Pair each element in a 'Bundle' with its index, starting from the right +-- and counting down +indexedR :: Int -> Bundle v a -> Bundle v (Int,a) +{-# INLINE_FUSED indexedR #-} +indexedR = M.indexedR + +-- | Zip two 'Bundle's with the given function +zipWith :: (a -> b -> c) -> Bundle v a -> Bundle v b -> Bundle v c +{-# INLINE zipWith #-} +zipWith = M.zipWith + +-- | Zip three 'Bundle's with the given function +zipWith3 :: (a -> b -> c -> d) -> Bundle v a -> Bundle v b -> Bundle v c -> Bundle v d +{-# INLINE zipWith3 #-} +zipWith3 = M.zipWith3 + +zipWith4 :: (a -> b -> c -> d -> e) + -> Bundle v a -> Bundle v b -> Bundle v c -> Bundle v d + -> Bundle v e +{-# INLINE zipWith4 #-} +zipWith4 = M.zipWith4 + +zipWith5 :: (a -> b -> c -> d -> e -> f) + -> Bundle v a -> Bundle v b -> Bundle v c -> Bundle v d + -> Bundle v e -> Bundle v f +{-# INLINE zipWith5 #-} +zipWith5 = M.zipWith5 + +zipWith6 :: (a -> b -> c -> d -> e -> f -> g) + -> Bundle v a -> Bundle v b -> Bundle v c -> Bundle v d + -> Bundle v e -> Bundle v f -> Bundle v g +{-# INLINE zipWith6 #-} +zipWith6 = M.zipWith6 + +zip :: Bundle v a -> Bundle v b -> Bundle v (a,b) +{-# INLINE zip #-} +zip = M.zip + +zip3 :: Bundle v a -> Bundle v b -> Bundle v c -> Bundle v (a,b,c) +{-# INLINE zip3 #-} +zip3 = M.zip3 + +zip4 :: Bundle v a -> Bundle v b -> Bundle v c -> Bundle v d + -> Bundle v (a,b,c,d) +{-# INLINE zip4 #-} +zip4 = M.zip4 + +zip5 :: Bundle v a -> Bundle v b -> Bundle v c -> Bundle v d + -> Bundle v e -> Bundle v (a,b,c,d,e) +{-# INLINE zip5 #-} +zip5 = M.zip5 + +zip6 :: Bundle v a -> Bundle v b -> Bundle v c -> Bundle v d + -> Bundle v e -> Bundle v f -> Bundle v (a,b,c,d,e,f) +{-# INLINE zip6 #-} +zip6 = M.zip6 + +-- Filtering +-- --------- + +-- | Drop elements which do not satisfy the predicate +filter :: (a -> Bool) -> Bundle v a -> Bundle v a +{-# INLINE filter #-} +filter = M.filter + +-- | Longest prefix of elements that satisfy the predicate +takeWhile :: (a -> Bool) -> Bundle v a -> Bundle v a +{-# INLINE takeWhile #-} +takeWhile = M.takeWhile + +-- | Drop the longest prefix of elements that satisfy the predicate +dropWhile :: (a -> Bool) -> Bundle v a -> Bundle v a +{-# INLINE dropWhile #-} +dropWhile = M.dropWhile + +-- Searching +-- --------- + +infix 4 `elem` +-- | Check whether the 'Bundle' contains an element +elem :: Eq a => a -> Bundle v a -> Bool +{-# INLINE elem #-} +elem x = unId . M.elem x + +infix 4 `notElem` +-- | Inverse of `elem` +notElem :: Eq a => a -> Bundle v a -> Bool +{-# INLINE notElem #-} +notElem x = unId . M.notElem x + +-- | Yield 'Just' the first element matching the predicate or 'Nothing' if no +-- such element exists. +find :: (a -> Bool) -> Bundle v a -> Maybe a +{-# INLINE find #-} +find f = unId . M.find f + +-- | Yield 'Just' the index of the first element matching the predicate or +-- 'Nothing' if no such element exists. +findIndex :: (a -> Bool) -> Bundle v a -> Maybe Int +{-# INLINE findIndex #-} +findIndex f = unId . M.findIndex f + +-- Folding +-- ------- + +-- | Left fold +foldl :: (a -> b -> a) -> a -> Bundle v b -> a +{-# INLINE foldl #-} +foldl f z = unId . M.foldl f z + +-- | Left fold on non-empty 'Bundle's +foldl1 :: (a -> a -> a) -> Bundle v a -> a +{-# INLINE foldl1 #-} +foldl1 f = unId . M.foldl1 f + +-- | Left fold with strict accumulator +foldl' :: (a -> b -> a) -> a -> Bundle v b -> a +{-# INLINE foldl' #-} +foldl' f z = unId . M.foldl' f z + +-- | Left fold on non-empty 'Bundle's with strict accumulator +foldl1' :: (a -> a -> a) -> Bundle v a -> a +{-# INLINE foldl1' #-} +foldl1' f = unId . M.foldl1' f + +-- | Right fold +foldr :: (a -> b -> b) -> b -> Bundle v a -> b +{-# INLINE foldr #-} +foldr f z = unId . M.foldr f z + +-- | Right fold on non-empty 'Bundle's +foldr1 :: (a -> a -> a) -> Bundle v a -> a +{-# INLINE foldr1 #-} +foldr1 f = unId . M.foldr1 f + +-- Specialised folds +-- ----------------- + +and :: Bundle v Bool -> Bool +{-# INLINE and #-} +and = unId . M.and + +or :: Bundle v Bool -> Bool +{-# INLINE or #-} +or = unId . M.or + +-- Unfolding +-- --------- + +-- | Unfold +unfoldr :: (s -> Maybe (a, s)) -> s -> Bundle v a +{-# INLINE unfoldr #-} +unfoldr = M.unfoldr + +-- | Unfold at most @n@ elements +unfoldrN :: Int -> (s -> Maybe (a, s)) -> s -> Bundle v a +{-# INLINE unfoldrN #-} +unfoldrN = M.unfoldrN + +-- | Apply function n-1 times to value. Zeroth element is original value. +iterateN :: Int -> (a -> a) -> a -> Bundle v a +{-# INLINE iterateN #-} +iterateN = M.iterateN + +-- Scans +-- ----- + +-- | Prefix scan +prescanl :: (a -> b -> a) -> a -> Bundle v b -> Bundle v a +{-# INLINE prescanl #-} +prescanl = M.prescanl + +-- | Prefix scan with strict accumulator +prescanl' :: (a -> b -> a) -> a -> Bundle v b -> Bundle v a +{-# INLINE prescanl' #-} +prescanl' = M.prescanl' + +-- | Suffix scan +postscanl :: (a -> b -> a) -> a -> Bundle v b -> Bundle v a +{-# INLINE postscanl #-} +postscanl = M.postscanl + +-- | Suffix scan with strict accumulator +postscanl' :: (a -> b -> a) -> a -> Bundle v b -> Bundle v a +{-# INLINE postscanl' #-} +postscanl' = M.postscanl' + +-- | Haskell-style scan +scanl :: (a -> b -> a) -> a -> Bundle v b -> Bundle v a +{-# INLINE scanl #-} +scanl = M.scanl + +-- | Haskell-style scan with strict accumulator +scanl' :: (a -> b -> a) -> a -> Bundle v b -> Bundle v a +{-# INLINE scanl' #-} +scanl' = M.scanl' + +-- | Scan over a non-empty 'Bundle' +scanl1 :: (a -> a -> a) -> Bundle v a -> Bundle v a +{-# INLINE scanl1 #-} +scanl1 = M.scanl1 + +-- | Scan over a non-empty 'Bundle' with a strict accumulator +scanl1' :: (a -> a -> a) -> Bundle v a -> Bundle v a +{-# INLINE scanl1' #-} +scanl1' = M.scanl1' + + +-- Comparisons +-- ----------- + +-- | Check if two 'Bundle's are equal +eq :: (Eq a) => Bundle v a -> Bundle v a -> Bool +{-# INLINE eq #-} +eq = eqBy (==) + +eqBy :: (a -> b -> Bool) -> Bundle v a -> Bundle v b -> Bool +{-# INLINE eqBy #-} +eqBy e x y = unId (M.eqBy e x y) + +-- | Lexicographically compare two 'Bundle's +cmp :: (Ord a) => Bundle v a -> Bundle v a -> Ordering +{-# INLINE cmp #-} +cmp = cmpBy compare + +cmpBy :: (a -> b -> Ordering) -> Bundle v a -> Bundle v b -> Ordering +{-# INLINE cmpBy #-} +cmpBy c x y = unId (M.cmpBy c x y) + +instance Eq a => Eq (M.Bundle Id v a) where + {-# INLINE (==) #-} + (==) = eq + +instance Ord a => Ord (M.Bundle Id v a) where + {-# INLINE compare #-} + compare = cmp + +#if MIN_VERSION_base(4,9,0) +instance Eq1 (M.Bundle Id v) where + {-# INLINE liftEq #-} + liftEq = eqBy + +instance Ord1 (M.Bundle Id v) where + {-# INLINE liftCompare #-} + liftCompare = cmpBy +#endif + +-- Monadic combinators +-- ------------------- + +-- | Apply a monadic action to each element of the stream, producing a monadic +-- stream of results +mapM :: Monad m => (a -> m b) -> Bundle v a -> M.Bundle m v b +{-# INLINE mapM #-} +mapM f = M.mapM f . lift + +-- | Apply a monadic action to each element of the stream +mapM_ :: Monad m => (a -> m b) -> Bundle v a -> m () +{-# INLINE mapM_ #-} +mapM_ f = M.mapM_ f . lift + +zipWithM :: Monad m => (a -> b -> m c) -> Bundle v a -> Bundle v b -> M.Bundle m v c +{-# INLINE zipWithM #-} +zipWithM f as bs = M.zipWithM f (lift as) (lift bs) + +zipWithM_ :: Monad m => (a -> b -> m c) -> Bundle v a -> Bundle v b -> m () +{-# INLINE zipWithM_ #-} +zipWithM_ f as bs = M.zipWithM_ f (lift as) (lift bs) + +-- | Yield a monadic stream of elements that satisfy the monadic predicate +filterM :: Monad m => (a -> m Bool) -> Bundle v a -> M.Bundle m v a +{-# INLINE filterM #-} +filterM f = M.filterM f . lift + +-- | Monadic fold +foldM :: Monad m => (a -> b -> m a) -> a -> Bundle v b -> m a +{-# INLINE foldM #-} +foldM m z = M.foldM m z . lift + +-- | Monadic fold over non-empty stream +fold1M :: Monad m => (a -> a -> m a) -> Bundle v a -> m a +{-# INLINE fold1M #-} +fold1M m = M.fold1M m . lift + +-- | Monadic fold with strict accumulator +foldM' :: Monad m => (a -> b -> m a) -> a -> Bundle v b -> m a +{-# INLINE foldM' #-} +foldM' m z = M.foldM' m z . lift + +-- | Monad fold over non-empty stream with strict accumulator +fold1M' :: Monad m => (a -> a -> m a) -> Bundle v a -> m a +{-# INLINE fold1M' #-} +fold1M' m = M.fold1M' m . lift + +-- Enumerations +-- ------------ + +-- | Yield a 'Bundle' of the given length containing the values @x@, @x+y@, +-- @x+y+y@ etc. +enumFromStepN :: Num a => a -> a -> Int -> Bundle v a +{-# INLINE enumFromStepN #-} +enumFromStepN = M.enumFromStepN + +-- | Enumerate values +-- +-- /WARNING:/ This operations can be very inefficient. If at all possible, use +-- 'enumFromStepN' instead. +enumFromTo :: Enum a => a -> a -> Bundle v a +{-# INLINE enumFromTo #-} +enumFromTo = M.enumFromTo + +-- | Enumerate values with a given step. +-- +-- /WARNING:/ This operations is very inefficient. If at all possible, use +-- 'enumFromStepN' instead. +enumFromThenTo :: Enum a => a -> a -> a -> Bundle v a +{-# INLINE enumFromThenTo #-} +enumFromThenTo = M.enumFromThenTo + +-- Conversions +-- ----------- + +-- | Convert a 'Bundle' to a list +toList :: Bundle v a -> [a] +{-# INLINE toList #-} +-- toList s = unId (M.toList s) +toList s = build (\c n -> toListFB c n s) + +-- This supports foldr/build list fusion that GHC implements +toListFB :: (a -> b -> b) -> b -> Bundle v a -> b +{-# INLINE [0] toListFB #-} +toListFB c n M.Bundle{M.sElems = Stream step t} = go t + where + go s = case unId (step s) of + Yield x s' -> x `c` go s' + Skip s' -> go s' + Done -> n + +-- | Create a 'Bundle' from a list +fromList :: [a] -> Bundle v a +{-# INLINE fromList #-} +fromList = M.fromList + +-- | Create a 'Bundle' from the first @n@ elements of a list +-- +-- > fromListN n xs = fromList (take n xs) +fromListN :: Int -> [a] -> Bundle v a +{-# INLINE fromListN #-} +fromListN = M.fromListN + +unsafeFromList :: Size -> [a] -> Bundle v a +{-# INLINE unsafeFromList #-} +unsafeFromList = M.unsafeFromList + +fromVector :: Vector v a => v a -> Bundle v a +{-# INLINE fromVector #-} +fromVector = M.fromVector + +reVector :: Bundle u a -> Bundle v a +{-# INLINE reVector #-} +reVector = M.reVector + +fromVectors :: Vector v a => [v a] -> Bundle v a +{-# INLINE fromVectors #-} +fromVectors = M.fromVectors + +concatVectors :: Vector v a => Bundle u (v a) -> Bundle v a +{-# INLINE concatVectors #-} +concatVectors = M.concatVectors + +-- | Create a 'Bundle' of values from a 'Bundle' of streamable things +flatten :: (a -> s) -> (s -> Step s b) -> Size -> Bundle v a -> Bundle v b +{-# INLINE_FUSED flatten #-} +flatten mk istep sz = M.flatten (return . mk) (return . istep) sz . lift + diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Bundle/Monadic.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Bundle/Monadic.hs new file mode 100644 index 000000000000..46f4a165f88d --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Bundle/Monadic.hs @@ -0,0 +1,1106 @@ +{-# LANGUAGE CPP, ExistentialQuantification, MultiParamTypeClasses, FlexibleInstances, Rank2Types, BangPatterns, KindSignatures, GADTs, ScopedTypeVariables #-} + +-- | +-- Module : Data.Vector.Fusion.Bundle.Monadic +-- Copyright : (c) Roman Leshchinskiy 2008-2010 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> +-- Stability : experimental +-- Portability : non-portable +-- +-- Monadic bundles. +-- + +module Data.Vector.Fusion.Bundle.Monadic ( + Bundle(..), Chunk(..), + + -- * Size hints + size, sized, + + -- * Length + length, null, + + -- * Construction + empty, singleton, cons, snoc, replicate, replicateM, generate, generateM, (++), + + -- * Accessing elements + head, last, (!!), (!?), + + -- * Substreams + slice, init, tail, take, drop, + + -- * Mapping + map, mapM, mapM_, trans, unbox, concatMap, flatten, + + -- * Zipping + indexed, indexedR, zipWithM_, + zipWithM, zipWith3M, zipWith4M, zipWith5M, zipWith6M, + zipWith, zipWith3, zipWith4, zipWith5, zipWith6, + zip, zip3, zip4, zip5, zip6, + + -- * Comparisons + eqBy, cmpBy, + + -- * Filtering + filter, filterM, takeWhile, takeWhileM, dropWhile, dropWhileM, + + -- * Searching + elem, notElem, find, findM, findIndex, findIndexM, + + -- * Folding + foldl, foldlM, foldl1, foldl1M, foldM, fold1M, + foldl', foldlM', foldl1', foldl1M', foldM', fold1M', + foldr, foldrM, foldr1, foldr1M, + + -- * Specialised folds + and, or, concatMapM, + + -- * Unfolding + unfoldr, unfoldrM, + unfoldrN, unfoldrNM, + iterateN, iterateNM, + + -- * Scans + prescanl, prescanlM, prescanl', prescanlM', + postscanl, postscanlM, postscanl', postscanlM', + scanl, scanlM, scanl', scanlM', + scanl1, scanl1M, scanl1', scanl1M', + + -- * Enumerations + enumFromStepN, enumFromTo, enumFromThenTo, + + -- * Conversions + toList, fromList, fromListN, unsafeFromList, + fromVector, reVector, fromVectors, concatVectors, + fromStream, chunks, elements +) where + +import Data.Vector.Generic.Base +import qualified Data.Vector.Generic.Mutable.Base as M +import Data.Vector.Fusion.Bundle.Size +import Data.Vector.Fusion.Util ( Box(..), delay_inline ) +import Data.Vector.Fusion.Stream.Monadic ( Stream(..), Step(..) ) +import qualified Data.Vector.Fusion.Stream.Monadic as S +import Control.Monad.Primitive + +import qualified Data.List as List +import Data.Char ( ord ) +import GHC.Base ( unsafeChr ) +import Control.Monad ( liftM ) +import Prelude hiding ( length, null, + replicate, (++), + head, last, (!!), + init, tail, take, drop, + map, mapM, mapM_, concatMap, + zipWith, zipWith3, zip, zip3, + filter, takeWhile, dropWhile, + elem, notElem, + foldl, foldl1, foldr, foldr1, + and, or, + scanl, scanl1, + enumFromTo, enumFromThenTo ) + +import Data.Int ( Int8, Int16, Int32 ) +import Data.Word ( Word8, Word16, Word32, Word64 ) + +#if !MIN_VERSION_base(4,8,0) +import Data.Word ( Word ) +#endif + +#include "vector.h" +#include "MachDeps.h" + +#if WORD_SIZE_IN_BITS > 32 +import Data.Int ( Int64 ) +#endif + +data Chunk v a = Chunk Int (forall m. (PrimMonad m, Vector v a) => Mutable v (PrimState m) a -> m ()) + +-- | Monadic streams +data Bundle m v a = Bundle { sElems :: Stream m a + , sChunks :: Stream m (Chunk v a) + , sVector :: Maybe (v a) + , sSize :: Size + } + +fromStream :: Monad m => Stream m a -> Size -> Bundle m v a +{-# INLINE fromStream #-} +fromStream (Stream step t) sz = Bundle (Stream step t) (Stream step' t) Nothing sz + where + step' s = do r <- step s + return $ fmap (\x -> Chunk 1 (\v -> M.basicUnsafeWrite v 0 x)) r + +chunks :: Bundle m v a -> Stream m (Chunk v a) +{-# INLINE chunks #-} +chunks = sChunks + +elements :: Bundle m v a -> Stream m a +{-# INLINE elements #-} +elements = sElems + +-- | 'Size' hint of a 'Bundle' +size :: Bundle m v a -> Size +{-# INLINE size #-} +size = sSize + +-- | Attach a 'Size' hint to a 'Bundle' +sized :: Bundle m v a -> Size -> Bundle m v a +{-# INLINE_FUSED sized #-} +sized s sz = s { sSize = sz } + +-- Length +-- ------ + +-- | Length of a 'Bundle' +length :: Monad m => Bundle m v a -> m Int +{-# INLINE_FUSED length #-} +length Bundle{sSize = Exact n} = return n +length Bundle{sChunks = s} = S.foldl' (\n (Chunk k _) -> n+k) 0 s + +-- | Check if a 'Bundle' is empty +null :: Monad m => Bundle m v a -> m Bool +{-# INLINE_FUSED null #-} +null Bundle{sSize = Exact n} = return (n == 0) +null Bundle{sChunks = s} = S.foldr (\(Chunk n _) z -> n == 0 && z) True s + +-- Construction +-- ------------ + +-- | Empty 'Bundle' +empty :: Monad m => Bundle m v a +{-# INLINE_FUSED empty #-} +empty = fromStream S.empty (Exact 0) + +-- | Singleton 'Bundle' +singleton :: Monad m => a -> Bundle m v a +{-# INLINE_FUSED singleton #-} +singleton x = fromStream (S.singleton x) (Exact 1) + +-- | Replicate a value to a given length +replicate :: Monad m => Int -> a -> Bundle m v a +{-# INLINE_FUSED replicate #-} +replicate n x = Bundle (S.replicate n x) + (S.singleton $ Chunk len (\v -> M.basicSet v x)) + Nothing + (Exact len) + where + len = delay_inline max n 0 + +-- | Yield a 'Bundle' of values obtained by performing the monadic action the +-- given number of times +replicateM :: Monad m => Int -> m a -> Bundle m v a +{-# INLINE_FUSED replicateM #-} +-- NOTE: We delay inlining max here because GHC will create a join point for +-- the call to newArray# otherwise which is not really nice. +replicateM n p = fromStream (S.replicateM n p) (Exact (delay_inline max n 0)) + +generate :: Monad m => Int -> (Int -> a) -> Bundle m v a +{-# INLINE generate #-} +generate n f = generateM n (return . f) + +-- | Generate a stream from its indices +generateM :: Monad m => Int -> (Int -> m a) -> Bundle m v a +{-# INLINE_FUSED generateM #-} +generateM n f = fromStream (S.generateM n f) (Exact (delay_inline max n 0)) + +-- | Prepend an element +cons :: Monad m => a -> Bundle m v a -> Bundle m v a +{-# INLINE cons #-} +cons x s = singleton x ++ s + +-- | Append an element +snoc :: Monad m => Bundle m v a -> a -> Bundle m v a +{-# INLINE snoc #-} +snoc s x = s ++ singleton x + +infixr 5 ++ +-- | Concatenate two 'Bundle's +(++) :: Monad m => Bundle m v a -> Bundle m v a -> Bundle m v a +{-# INLINE_FUSED (++) #-} +Bundle sa ta _ na ++ Bundle sb tb _ nb = Bundle (sa S.++ sb) (ta S.++ tb) Nothing (na + nb) + +-- Accessing elements +-- ------------------ + +-- | First element of the 'Bundle' or error if empty +head :: Monad m => Bundle m v a -> m a +{-# INLINE_FUSED head #-} +head = S.head . sElems + +-- | Last element of the 'Bundle' or error if empty +last :: Monad m => Bundle m v a -> m a +{-# INLINE_FUSED last #-} +last = S.last . sElems + +infixl 9 !! +-- | Element at the given position +(!!) :: Monad m => Bundle m v a -> Int -> m a +{-# INLINE (!!) #-} +b !! i = sElems b S.!! i + +infixl 9 !? +-- | Element at the given position or 'Nothing' if out of bounds +(!?) :: Monad m => Bundle m v a -> Int -> m (Maybe a) +{-# INLINE (!?) #-} +b !? i = sElems b S.!? i + +-- Substreams +-- ---------- + +-- | Extract a substream of the given length starting at the given position. +slice :: Monad m => Int -- ^ starting index + -> Int -- ^ length + -> Bundle m v a + -> Bundle m v a +{-# INLINE slice #-} +slice i n s = take n (drop i s) + +-- | All but the last element +init :: Monad m => Bundle m v a -> Bundle m v a +{-# INLINE_FUSED init #-} +init Bundle{sElems = s, sSize = sz} = fromStream (S.init s) (sz-1) + +-- | All but the first element +tail :: Monad m => Bundle m v a -> Bundle m v a +{-# INLINE_FUSED tail #-} +tail Bundle{sElems = s, sSize = sz} = fromStream (S.tail s) (sz-1) + +-- | The first @n@ elements +take :: Monad m => Int -> Bundle m v a -> Bundle m v a +{-# INLINE_FUSED take #-} +take n Bundle{sElems = s, sSize = sz} = fromStream (S.take n s) (smaller (Exact n) sz) + +-- | All but the first @n@ elements +drop :: Monad m => Int -> Bundle m v a -> Bundle m v a +{-# INLINE_FUSED drop #-} +drop n Bundle{sElems = s, sSize = sz} = + fromStream (S.drop n s) (clampedSubtract sz (Exact n)) + +-- Mapping +-- ------- + +instance Monad m => Functor (Bundle m v) where + {-# INLINE fmap #-} + fmap = map + +-- | Map a function over a 'Bundle' +map :: Monad m => (a -> b) -> Bundle m v a -> Bundle m v b +{-# INLINE map #-} +map f = mapM (return . f) + +-- | Map a monadic function over a 'Bundle' +mapM :: Monad m => (a -> m b) -> Bundle m v a -> Bundle m v b +{-# INLINE_FUSED mapM #-} +mapM f Bundle{sElems = s, sSize = n} = fromStream (S.mapM f s) n + +-- | Execute a monadic action for each element of the 'Bundle' +mapM_ :: Monad m => (a -> m b) -> Bundle m v a -> m () +{-# INLINE_FUSED mapM_ #-} +mapM_ m = S.mapM_ m . sElems + +-- | Transform a 'Bundle' to use a different monad +trans :: (Monad m, Monad m') => (forall z. m z -> m' z) + -> Bundle m v a -> Bundle m' v a +{-# INLINE_FUSED trans #-} +trans f Bundle{sElems = s, sChunks = cs, sVector = v, sSize = n} + = Bundle { sElems = S.trans f s, sChunks = S.trans f cs, sVector = v, sSize = n } + +unbox :: Monad m => Bundle m v (Box a) -> Bundle m v a +{-# INLINE_FUSED unbox #-} +unbox Bundle{sElems = s, sSize = n} = fromStream (S.unbox s) n + +-- Zipping +-- ------- + +-- | Pair each element in a 'Bundle' with its index +indexed :: Monad m => Bundle m v a -> Bundle m v (Int,a) +{-# INLINE_FUSED indexed #-} +indexed Bundle{sElems = s, sSize = n} = fromStream (S.indexed s) n + +-- | Pair each element in a 'Bundle' with its index, starting from the right +-- and counting down +indexedR :: Monad m => Int -> Bundle m v a -> Bundle m v (Int,a) +{-# INLINE_FUSED indexedR #-} +indexedR m Bundle{sElems = s, sSize = n} = fromStream (S.indexedR m s) n + +-- | Zip two 'Bundle's with the given monadic function +zipWithM :: Monad m => (a -> b -> m c) -> Bundle m v a -> Bundle m v b -> Bundle m v c +{-# INLINE_FUSED zipWithM #-} +zipWithM f Bundle{sElems = sa, sSize = na} + Bundle{sElems = sb, sSize = nb} = fromStream (S.zipWithM f sa sb) (smaller na nb) + +-- FIXME: This might expose an opportunity for inplace execution. +{-# RULES + +"zipWithM xs xs [Vector.Bundle]" forall f xs. + zipWithM f xs xs = mapM (\x -> f x x) xs #-} + + +zipWithM_ :: Monad m => (a -> b -> m c) -> Bundle m v a -> Bundle m v b -> m () +{-# INLINE zipWithM_ #-} +zipWithM_ f sa sb = S.zipWithM_ f (sElems sa) (sElems sb) + +zipWith3M :: Monad m => (a -> b -> c -> m d) -> Bundle m v a -> Bundle m v b -> Bundle m v c -> Bundle m v d +{-# INLINE_FUSED zipWith3M #-} +zipWith3M f Bundle{sElems = sa, sSize = na} + Bundle{sElems = sb, sSize = nb} + Bundle{sElems = sc, sSize = nc} + = fromStream (S.zipWith3M f sa sb sc) (smaller na (smaller nb nc)) + +zipWith4M :: Monad m => (a -> b -> c -> d -> m e) + -> Bundle m v a -> Bundle m v b -> Bundle m v c -> Bundle m v d + -> Bundle m v e +{-# INLINE zipWith4M #-} +zipWith4M f sa sb sc sd + = zipWithM (\(a,b) (c,d) -> f a b c d) (zip sa sb) (zip sc sd) + +zipWith5M :: Monad m => (a -> b -> c -> d -> e -> m f) + -> Bundle m v a -> Bundle m v b -> Bundle m v c -> Bundle m v d + -> Bundle m v e -> Bundle m v f +{-# INLINE zipWith5M #-} +zipWith5M f sa sb sc sd se + = zipWithM (\(a,b,c) (d,e) -> f a b c d e) (zip3 sa sb sc) (zip sd se) + +zipWith6M :: Monad m => (a -> b -> c -> d -> e -> f -> m g) + -> Bundle m v a -> Bundle m v b -> Bundle m v c -> Bundle m v d + -> Bundle m v e -> Bundle m v f -> Bundle m v g +{-# INLINE zipWith6M #-} +zipWith6M fn sa sb sc sd se sf + = zipWithM (\(a,b,c) (d,e,f) -> fn a b c d e f) (zip3 sa sb sc) + (zip3 sd se sf) + +zipWith :: Monad m => (a -> b -> c) -> Bundle m v a -> Bundle m v b -> Bundle m v c +{-# INLINE zipWith #-} +zipWith f = zipWithM (\a b -> return (f a b)) + +zipWith3 :: Monad m => (a -> b -> c -> d) + -> Bundle m v a -> Bundle m v b -> Bundle m v c -> Bundle m v d +{-# INLINE zipWith3 #-} +zipWith3 f = zipWith3M (\a b c -> return (f a b c)) + +zipWith4 :: Monad m => (a -> b -> c -> d -> e) + -> Bundle m v a -> Bundle m v b -> Bundle m v c -> Bundle m v d + -> Bundle m v e +{-# INLINE zipWith4 #-} +zipWith4 f = zipWith4M (\a b c d -> return (f a b c d)) + +zipWith5 :: Monad m => (a -> b -> c -> d -> e -> f) + -> Bundle m v a -> Bundle m v b -> Bundle m v c -> Bundle m v d + -> Bundle m v e -> Bundle m v f +{-# INLINE zipWith5 #-} +zipWith5 f = zipWith5M (\a b c d e -> return (f a b c d e)) + +zipWith6 :: Monad m => (a -> b -> c -> d -> e -> f -> g) + -> Bundle m v a -> Bundle m v b -> Bundle m v c -> Bundle m v d + -> Bundle m v e -> Bundle m v f -> Bundle m v g +{-# INLINE zipWith6 #-} +zipWith6 fn = zipWith6M (\a b c d e f -> return (fn a b c d e f)) + +zip :: Monad m => Bundle m v a -> Bundle m v b -> Bundle m v (a,b) +{-# INLINE zip #-} +zip = zipWith (,) + +zip3 :: Monad m => Bundle m v a -> Bundle m v b -> Bundle m v c -> Bundle m v (a,b,c) +{-# INLINE zip3 #-} +zip3 = zipWith3 (,,) + +zip4 :: Monad m => Bundle m v a -> Bundle m v b -> Bundle m v c -> Bundle m v d + -> Bundle m v (a,b,c,d) +{-# INLINE zip4 #-} +zip4 = zipWith4 (,,,) + +zip5 :: Monad m => Bundle m v a -> Bundle m v b -> Bundle m v c -> Bundle m v d + -> Bundle m v e -> Bundle m v (a,b,c,d,e) +{-# INLINE zip5 #-} +zip5 = zipWith5 (,,,,) + +zip6 :: Monad m => Bundle m v a -> Bundle m v b -> Bundle m v c -> Bundle m v d + -> Bundle m v e -> Bundle m v f -> Bundle m v (a,b,c,d,e,f) +{-# INLINE zip6 #-} +zip6 = zipWith6 (,,,,,) + +-- Comparisons +-- ----------- + +-- | Check if two 'Bundle's are equal +eqBy :: (Monad m) => (a -> b -> Bool) -> Bundle m v a -> Bundle m v b -> m Bool +{-# INLINE_FUSED eqBy #-} +eqBy eq x y = S.eqBy eq (sElems x) (sElems y) + +-- | Lexicographically compare two 'Bundle's +cmpBy :: (Monad m) => (a -> b -> Ordering) -> Bundle m v a -> Bundle m v b -> m Ordering +{-# INLINE_FUSED cmpBy #-} +cmpBy cmp x y = S.cmpBy cmp (sElems x) (sElems y) + +-- Filtering +-- --------- + +-- | Drop elements which do not satisfy the predicate +filter :: Monad m => (a -> Bool) -> Bundle m v a -> Bundle m v a +{-# INLINE filter #-} +filter f = filterM (return . f) + +-- | Drop elements which do not satisfy the monadic predicate +filterM :: Monad m => (a -> m Bool) -> Bundle m v a -> Bundle m v a +{-# INLINE_FUSED filterM #-} +filterM f Bundle{sElems = s, sSize = n} = fromStream (S.filterM f s) (toMax n) + +-- | Longest prefix of elements that satisfy the predicate +takeWhile :: Monad m => (a -> Bool) -> Bundle m v a -> Bundle m v a +{-# INLINE takeWhile #-} +takeWhile f = takeWhileM (return . f) + +-- | Longest prefix of elements that satisfy the monadic predicate +takeWhileM :: Monad m => (a -> m Bool) -> Bundle m v a -> Bundle m v a +{-# INLINE_FUSED takeWhileM #-} +takeWhileM f Bundle{sElems = s, sSize = n} = fromStream (S.takeWhileM f s) (toMax n) + +-- | Drop the longest prefix of elements that satisfy the predicate +dropWhile :: Monad m => (a -> Bool) -> Bundle m v a -> Bundle m v a +{-# INLINE dropWhile #-} +dropWhile f = dropWhileM (return . f) + +-- | Drop the longest prefix of elements that satisfy the monadic predicate +dropWhileM :: Monad m => (a -> m Bool) -> Bundle m v a -> Bundle m v a +{-# INLINE_FUSED dropWhileM #-} +dropWhileM f Bundle{sElems = s, sSize = n} = fromStream (S.dropWhileM f s) (toMax n) + +-- Searching +-- --------- + +infix 4 `elem` +-- | Check whether the 'Bundle' contains an element +elem :: (Monad m, Eq a) => a -> Bundle m v a -> m Bool +{-# INLINE_FUSED elem #-} +elem x = S.elem x . sElems + +infix 4 `notElem` +-- | Inverse of `elem` +notElem :: (Monad m, Eq a) => a -> Bundle m v a -> m Bool +{-# INLINE notElem #-} +notElem x = S.notElem x . sElems + +-- | Yield 'Just' the first element that satisfies the predicate or 'Nothing' +-- if no such element exists. +find :: Monad m => (a -> Bool) -> Bundle m v a -> m (Maybe a) +{-# INLINE find #-} +find f = findM (return . f) + +-- | Yield 'Just' the first element that satisfies the monadic predicate or +-- 'Nothing' if no such element exists. +findM :: Monad m => (a -> m Bool) -> Bundle m v a -> m (Maybe a) +{-# INLINE_FUSED findM #-} +findM f = S.findM f . sElems + +-- | Yield 'Just' the index of the first element that satisfies the predicate +-- or 'Nothing' if no such element exists. +findIndex :: Monad m => (a -> Bool) -> Bundle m v a -> m (Maybe Int) +{-# INLINE_FUSED findIndex #-} +findIndex f = findIndexM (return . f) + +-- | Yield 'Just' the index of the first element that satisfies the monadic +-- predicate or 'Nothing' if no such element exists. +findIndexM :: Monad m => (a -> m Bool) -> Bundle m v a -> m (Maybe Int) +{-# INLINE_FUSED findIndexM #-} +findIndexM f = S.findIndexM f . sElems + +-- Folding +-- ------- + +-- | Left fold +foldl :: Monad m => (a -> b -> a) -> a -> Bundle m v b -> m a +{-# INLINE foldl #-} +foldl f = foldlM (\a b -> return (f a b)) + +-- | Left fold with a monadic operator +foldlM :: Monad m => (a -> b -> m a) -> a -> Bundle m v b -> m a +{-# INLINE_FUSED foldlM #-} +foldlM m z = S.foldlM m z . sElems + +-- | Same as 'foldlM' +foldM :: Monad m => (a -> b -> m a) -> a -> Bundle m v b -> m a +{-# INLINE foldM #-} +foldM = foldlM + +-- | Left fold over a non-empty 'Bundle' +foldl1 :: Monad m => (a -> a -> a) -> Bundle m v a -> m a +{-# INLINE foldl1 #-} +foldl1 f = foldl1M (\a b -> return (f a b)) + +-- | Left fold over a non-empty 'Bundle' with a monadic operator +foldl1M :: Monad m => (a -> a -> m a) -> Bundle m v a -> m a +{-# INLINE_FUSED foldl1M #-} +foldl1M f = S.foldl1M f . sElems + +-- | Same as 'foldl1M' +fold1M :: Monad m => (a -> a -> m a) -> Bundle m v a -> m a +{-# INLINE fold1M #-} +fold1M = foldl1M + +-- | Left fold with a strict accumulator +foldl' :: Monad m => (a -> b -> a) -> a -> Bundle m v b -> m a +{-# INLINE foldl' #-} +foldl' f = foldlM' (\a b -> return (f a b)) + +-- | Left fold with a strict accumulator and a monadic operator +foldlM' :: Monad m => (a -> b -> m a) -> a -> Bundle m v b -> m a +{-# INLINE_FUSED foldlM' #-} +foldlM' m z = S.foldlM' m z . sElems + +-- | Same as 'foldlM'' +foldM' :: Monad m => (a -> b -> m a) -> a -> Bundle m v b -> m a +{-# INLINE foldM' #-} +foldM' = foldlM' + +-- | Left fold over a non-empty 'Bundle' with a strict accumulator +foldl1' :: Monad m => (a -> a -> a) -> Bundle m v a -> m a +{-# INLINE foldl1' #-} +foldl1' f = foldl1M' (\a b -> return (f a b)) + +-- | Left fold over a non-empty 'Bundle' with a strict accumulator and a +-- monadic operator +foldl1M' :: Monad m => (a -> a -> m a) -> Bundle m v a -> m a +{-# INLINE_FUSED foldl1M' #-} +foldl1M' f = S.foldl1M' f . sElems + +-- | Same as 'foldl1M'' +fold1M' :: Monad m => (a -> a -> m a) -> Bundle m v a -> m a +{-# INLINE fold1M' #-} +fold1M' = foldl1M' + +-- | Right fold +foldr :: Monad m => (a -> b -> b) -> b -> Bundle m v a -> m b +{-# INLINE foldr #-} +foldr f = foldrM (\a b -> return (f a b)) + +-- | Right fold with a monadic operator +foldrM :: Monad m => (a -> b -> m b) -> b -> Bundle m v a -> m b +{-# INLINE_FUSED foldrM #-} +foldrM f z = S.foldrM f z . sElems + +-- | Right fold over a non-empty stream +foldr1 :: Monad m => (a -> a -> a) -> Bundle m v a -> m a +{-# INLINE foldr1 #-} +foldr1 f = foldr1M (\a b -> return (f a b)) + +-- | Right fold over a non-empty stream with a monadic operator +foldr1M :: Monad m => (a -> a -> m a) -> Bundle m v a -> m a +{-# INLINE_FUSED foldr1M #-} +foldr1M f = S.foldr1M f . sElems + +-- Specialised folds +-- ----------------- + +and :: Monad m => Bundle m v Bool -> m Bool +{-# INLINE_FUSED and #-} +and = S.and . sElems + +or :: Monad m => Bundle m v Bool -> m Bool +{-# INLINE_FUSED or #-} +or = S.or . sElems + +concatMap :: Monad m => (a -> Bundle m v b) -> Bundle m v a -> Bundle m v b +{-# INLINE concatMap #-} +concatMap f = concatMapM (return . f) + +concatMapM :: Monad m => (a -> m (Bundle m v b)) -> Bundle m v a -> Bundle m v b +{-# INLINE_FUSED concatMapM #-} +concatMapM f Bundle{sElems = s} = fromStream (S.concatMapM (liftM sElems . f) s) Unknown + +-- | Create a 'Bundle' of values from a 'Bundle' of streamable things +flatten :: Monad m => (a -> m s) -> (s -> m (Step s b)) -> Size + -> Bundle m v a -> Bundle m v b +{-# INLINE_FUSED flatten #-} +flatten mk istep sz Bundle{sElems = s} = fromStream (S.flatten mk istep s) sz + +-- Unfolding +-- --------- + +-- | Unfold +unfoldr :: Monad m => (s -> Maybe (a, s)) -> s -> Bundle m u a +{-# INLINE_FUSED unfoldr #-} +unfoldr f = unfoldrM (return . f) + +-- | Unfold with a monadic function +unfoldrM :: Monad m => (s -> m (Maybe (a, s))) -> s -> Bundle m u a +{-# INLINE_FUSED unfoldrM #-} +unfoldrM f s = fromStream (S.unfoldrM f s) Unknown + +-- | Unfold at most @n@ elements +unfoldrN :: Monad m => Int -> (s -> Maybe (a, s)) -> s -> Bundle m u a +{-# INLINE_FUSED unfoldrN #-} +unfoldrN n f = unfoldrNM n (return . f) + +-- | Unfold at most @n@ elements with a monadic functions +unfoldrNM :: Monad m => Int -> (s -> m (Maybe (a, s))) -> s -> Bundle m u a +{-# INLINE_FUSED unfoldrNM #-} +unfoldrNM n f s = fromStream (S.unfoldrNM n f s) (Max (delay_inline max n 0)) + +-- | Apply monadic function n times to value. Zeroth element is original value. +iterateNM :: Monad m => Int -> (a -> m a) -> a -> Bundle m u a +{-# INLINE_FUSED iterateNM #-} +iterateNM n f x0 = fromStream (S.iterateNM n f x0) (Exact (delay_inline max n 0)) + +-- | Apply function n times to value. Zeroth element is original value. +iterateN :: Monad m => Int -> (a -> a) -> a -> Bundle m u a +{-# INLINE_FUSED iterateN #-} +iterateN n f x0 = iterateNM n (return . f) x0 + +-- Scans +-- ----- + +-- | Prefix scan +prescanl :: Monad m => (a -> b -> a) -> a -> Bundle m v b -> Bundle m v a +{-# INLINE prescanl #-} +prescanl f = prescanlM (\a b -> return (f a b)) + +-- | Prefix scan with a monadic operator +prescanlM :: Monad m => (a -> b -> m a) -> a -> Bundle m v b -> Bundle m v a +{-# INLINE_FUSED prescanlM #-} +prescanlM f z Bundle{sElems = s, sSize = sz} = fromStream (S.prescanlM f z s) sz + +-- | Prefix scan with strict accumulator +prescanl' :: Monad m => (a -> b -> a) -> a -> Bundle m v b -> Bundle m v a +{-# INLINE prescanl' #-} +prescanl' f = prescanlM' (\a b -> return (f a b)) + +-- | Prefix scan with strict accumulator and a monadic operator +prescanlM' :: Monad m => (a -> b -> m a) -> a -> Bundle m v b -> Bundle m v a +{-# INLINE_FUSED prescanlM' #-} +prescanlM' f z Bundle{sElems = s, sSize = sz} = fromStream (S.prescanlM' f z s) sz + +-- | Suffix scan +postscanl :: Monad m => (a -> b -> a) -> a -> Bundle m v b -> Bundle m v a +{-# INLINE postscanl #-} +postscanl f = postscanlM (\a b -> return (f a b)) + +-- | Suffix scan with a monadic operator +postscanlM :: Monad m => (a -> b -> m a) -> a -> Bundle m v b -> Bundle m v a +{-# INLINE_FUSED postscanlM #-} +postscanlM f z Bundle{sElems = s, sSize = sz} = fromStream (S.postscanlM f z s) sz + +-- | Suffix scan with strict accumulator +postscanl' :: Monad m => (a -> b -> a) -> a -> Bundle m v b -> Bundle m v a +{-# INLINE postscanl' #-} +postscanl' f = postscanlM' (\a b -> return (f a b)) + +-- | Suffix scan with strict acccumulator and a monadic operator +postscanlM' :: Monad m => (a -> b -> m a) -> a -> Bundle m v b -> Bundle m v a +{-# INLINE_FUSED postscanlM' #-} +postscanlM' f z Bundle{sElems = s, sSize = sz} = fromStream (S.postscanlM' f z s) sz + +-- | Haskell-style scan +scanl :: Monad m => (a -> b -> a) -> a -> Bundle m v b -> Bundle m v a +{-# INLINE scanl #-} +scanl f = scanlM (\a b -> return (f a b)) + +-- | Haskell-style scan with a monadic operator +scanlM :: Monad m => (a -> b -> m a) -> a -> Bundle m v b -> Bundle m v a +{-# INLINE scanlM #-} +scanlM f z s = z `cons` postscanlM f z s + +-- | Haskell-style scan with strict accumulator +scanl' :: Monad m => (a -> b -> a) -> a -> Bundle m v b -> Bundle m v a +{-# INLINE scanl' #-} +scanl' f = scanlM' (\a b -> return (f a b)) + +-- | Haskell-style scan with strict accumulator and a monadic operator +scanlM' :: Monad m => (a -> b -> m a) -> a -> Bundle m v b -> Bundle m v a +{-# INLINE scanlM' #-} +scanlM' f z s = z `seq` (z `cons` postscanlM f z s) + +-- | Scan over a non-empty 'Bundle' +scanl1 :: Monad m => (a -> a -> a) -> Bundle m v a -> Bundle m v a +{-# INLINE scanl1 #-} +scanl1 f = scanl1M (\x y -> return (f x y)) + +-- | Scan over a non-empty 'Bundle' with a monadic operator +scanl1M :: Monad m => (a -> a -> m a) -> Bundle m v a -> Bundle m v a +{-# INLINE_FUSED scanl1M #-} +scanl1M f Bundle{sElems = s, sSize = sz} = fromStream (S.scanl1M f s) sz + +-- | Scan over a non-empty 'Bundle' with a strict accumulator +scanl1' :: Monad m => (a -> a -> a) -> Bundle m v a -> Bundle m v a +{-# INLINE scanl1' #-} +scanl1' f = scanl1M' (\x y -> return (f x y)) + +-- | Scan over a non-empty 'Bundle' with a strict accumulator and a monadic +-- operator +scanl1M' :: Monad m => (a -> a -> m a) -> Bundle m v a -> Bundle m v a +{-# INLINE_FUSED scanl1M' #-} +scanl1M' f Bundle{sElems = s, sSize = sz} = fromStream (S.scanl1M' f s) sz + +-- Enumerations +-- ------------ + +-- The Enum class is broken for this, there just doesn't seem to be a +-- way to implement this generically. We have to specialise for as many types +-- as we can but this doesn't help in polymorphic loops. + +-- | Yield a 'Bundle' of the given length containing the values @x@, @x+y@, +-- @x+y+y@ etc. +enumFromStepN :: (Num a, Monad m) => a -> a -> Int -> Bundle m v a +{-# INLINE_FUSED enumFromStepN #-} +enumFromStepN x y n = fromStream (S.enumFromStepN x y n) (Exact (delay_inline max n 0)) + +-- | Enumerate values +-- +-- /WARNING:/ This operation can be very inefficient. If at all possible, use +-- 'enumFromStepN' instead. +enumFromTo :: (Enum a, Monad m) => a -> a -> Bundle m v a +{-# INLINE_FUSED enumFromTo #-} +enumFromTo x y = fromList [x .. y] + +-- NOTE: We use (x+1) instead of (succ x) below because the latter checks for +-- overflow which can't happen here. + +-- FIXME: add "too large" test for Int +enumFromTo_small :: (Integral a, Monad m) => a -> a -> Bundle m v a +{-# INLINE_FUSED enumFromTo_small #-} +enumFromTo_small x y = x `seq` y `seq` fromStream (Stream step x) (Exact n) + where + n = delay_inline max (fromIntegral y - fromIntegral x + 1) 0 + + {-# INLINE_INNER step #-} + step z | z <= y = return $ Yield z (z+1) + | otherwise = return $ Done + +{-# RULES + +"enumFromTo<Int8> [Bundle]" + enumFromTo = enumFromTo_small :: Monad m => Int8 -> Int8 -> Bundle m v Int8 + +"enumFromTo<Int16> [Bundle]" + enumFromTo = enumFromTo_small :: Monad m => Int16 -> Int16 -> Bundle m v Int16 + +"enumFromTo<Word8> [Bundle]" + enumFromTo = enumFromTo_small :: Monad m => Word8 -> Word8 -> Bundle m v Word8 + +"enumFromTo<Word16> [Bundle]" + enumFromTo = enumFromTo_small :: Monad m => Word16 -> Word16 -> Bundle m v Word16 #-} + + + +#if WORD_SIZE_IN_BITS > 32 + +{-# RULES + +"enumFromTo<Int32> [Bundle]" + enumFromTo = enumFromTo_small :: Monad m => Int32 -> Int32 -> Bundle m v Int32 + +"enumFromTo<Word32> [Bundle]" + enumFromTo = enumFromTo_small :: Monad m => Word32 -> Word32 -> Bundle m v Word32 #-} + +#endif + +-- NOTE: We could implement a generic "too large" test: +-- +-- len x y | x > y = 0 +-- | n > 0 && n <= fromIntegral (maxBound :: Int) = fromIntegral n +-- | otherwise = error +-- where +-- n = y-x+1 +-- +-- Alas, GHC won't eliminate unnecessary comparisons (such as n >= 0 for +-- unsigned types). See http://hackage.haskell.org/trac/ghc/ticket/3744 +-- + +enumFromTo_int :: forall m v. Monad m => Int -> Int -> Bundle m v Int +{-# INLINE_FUSED enumFromTo_int #-} +enumFromTo_int x y = x `seq` y `seq` fromStream (Stream step x) (Exact (len x y)) + where + {-# INLINE [0] len #-} + len :: Int -> Int -> Int + len u v | u > v = 0 + | otherwise = BOUNDS_CHECK(check) "enumFromTo" "vector too large" + (n > 0) + $ n + where + n = v-u+1 + + {-# INLINE_INNER step #-} + step z | z <= y = return $ Yield z (z+1) + | otherwise = return $ Done + +enumFromTo_intlike :: (Integral a, Monad m) => a -> a -> Bundle m v a +{-# INLINE_FUSED enumFromTo_intlike #-} +enumFromTo_intlike x y = x `seq` y `seq` fromStream (Stream step x) (Exact (len x y)) + where + {-# INLINE [0] len #-} + len u v | u > v = 0 + | otherwise = BOUNDS_CHECK(check) "enumFromTo" "vector too large" + (n > 0) + $ fromIntegral n + where + n = v-u+1 + + {-# INLINE_INNER step #-} + step z | z <= y = return $ Yield z (z+1) + | otherwise = return $ Done + +{-# RULES + +"enumFromTo<Int> [Bundle]" + enumFromTo = enumFromTo_int :: Monad m => Int -> Int -> Bundle m v Int + +#if WORD_SIZE_IN_BITS > 32 + +"enumFromTo<Int64> [Bundle]" + enumFromTo = enumFromTo_intlike :: Monad m => Int64 -> Int64 -> Bundle m v Int64 #-} + +#else + +"enumFromTo<Int32> [Bundle]" + enumFromTo = enumFromTo_intlike :: Monad m => Int32 -> Int32 -> Bundle m v Int32 #-} + +#endif + + + +enumFromTo_big_word :: (Integral a, Monad m) => a -> a -> Bundle m v a +{-# INLINE_FUSED enumFromTo_big_word #-} +enumFromTo_big_word x y = x `seq` y `seq` fromStream (Stream step x) (Exact (len x y)) + where + {-# INLINE [0] len #-} + len u v | u > v = 0 + | otherwise = BOUNDS_CHECK(check) "enumFromTo" "vector too large" + (n < fromIntegral (maxBound :: Int)) + $ fromIntegral (n+1) + where + n = v-u + + {-# INLINE_INNER step #-} + step z | z <= y = return $ Yield z (z+1) + | otherwise = return $ Done + +{-# RULES + +"enumFromTo<Word> [Bundle]" + enumFromTo = enumFromTo_big_word :: Monad m => Word -> Word -> Bundle m v Word + +"enumFromTo<Word64> [Bundle]" + enumFromTo = enumFromTo_big_word + :: Monad m => Word64 -> Word64 -> Bundle m v Word64 + +#if WORD_SIZE_IN_BITS == 32 + +"enumFromTo<Word32> [Bundle]" + enumFromTo = enumFromTo_big_word + :: Monad m => Word32 -> Word32 -> Bundle m v Word32 + +#endif + +"enumFromTo<Integer> [Bundle]" + enumFromTo = enumFromTo_big_word + :: Monad m => Integer -> Integer -> Bundle m v Integer #-} + + +#if WORD_SIZE_IN_BITS > 32 + +-- FIXME: the "too large" test is totally wrong +enumFromTo_big_int :: (Integral a, Monad m) => a -> a -> Bundle m v a +{-# INLINE_FUSED enumFromTo_big_int #-} +enumFromTo_big_int x y = x `seq` y `seq` fromStream (Stream step x) (Exact (len x y)) + where + {-# INLINE [0] len #-} + len u v | u > v = 0 + | otherwise = BOUNDS_CHECK(check) "enumFromTo" "vector too large" + (n > 0 && n <= fromIntegral (maxBound :: Int)) + $ fromIntegral n + where + n = v-u+1 + + {-# INLINE_INNER step #-} + step z | z <= y = return $ Yield z (z+1) + | otherwise = return $ Done + + +{-# RULES + +"enumFromTo<Int64> [Bundle]" + enumFromTo = enumFromTo_big_int :: Monad m => Int64 -> Int64 -> Bundle m v Int64 #-} + + + +#endif + +enumFromTo_char :: Monad m => Char -> Char -> Bundle m v Char +{-# INLINE_FUSED enumFromTo_char #-} +enumFromTo_char x y = x `seq` y `seq` fromStream (Stream step xn) (Exact n) + where + xn = ord x + yn = ord y + + n = delay_inline max 0 (yn - xn + 1) + + {-# INLINE_INNER step #-} + step zn | zn <= yn = return $ Yield (unsafeChr zn) (zn+1) + | otherwise = return $ Done + +{-# RULES + +"enumFromTo<Char> [Bundle]" + enumFromTo = enumFromTo_char #-} + + + +------------------------------------------------------------------------ + +-- Specialise enumFromTo for Float and Double. +-- Also, try to do something about pairs? + +enumFromTo_double :: (Monad m, Ord a, RealFrac a) => a -> a -> Bundle m v a +{-# INLINE_FUSED enumFromTo_double #-} +enumFromTo_double n m = n `seq` m `seq` fromStream (Stream step n) (Max (len n lim)) + where + lim = m + 1/2 -- important to float out + + {-# INLINE [0] len #-} + len x y | x > y = 0 + | otherwise = BOUNDS_CHECK(check) "enumFromTo" "vector too large" + (l > 0) + $ fromIntegral l + where + l :: Integer + l = truncate (y-x)+2 + + {-# INLINE_INNER step #-} + step x | x <= lim = return $ Yield x (x+1) + | otherwise = return $ Done + +{-# RULES + +"enumFromTo<Double> [Bundle]" + enumFromTo = enumFromTo_double :: Monad m => Double -> Double -> Bundle m v Double + +"enumFromTo<Float> [Bundle]" + enumFromTo = enumFromTo_double :: Monad m => Float -> Float -> Bundle m v Float #-} + + + +------------------------------------------------------------------------ + +-- | Enumerate values with a given step. +-- +-- /WARNING:/ This operation is very inefficient. If at all possible, use +-- 'enumFromStepN' instead. +enumFromThenTo :: (Enum a, Monad m) => a -> a -> a -> Bundle m v a +{-# INLINE_FUSED enumFromThenTo #-} +enumFromThenTo x y z = fromList [x, y .. z] + +-- FIXME: Specialise enumFromThenTo. + +-- Conversions +-- ----------- + +-- | Convert a 'Bundle' to a list +toList :: Monad m => Bundle m v a -> m [a] +{-# INLINE toList #-} +toList = foldr (:) [] + +-- | Convert a list to a 'Bundle' +fromList :: Monad m => [a] -> Bundle m v a +{-# INLINE fromList #-} +fromList xs = unsafeFromList Unknown xs + +-- | Convert the first @n@ elements of a list to a 'Bundle' +fromListN :: Monad m => Int -> [a] -> Bundle m v a +{-# INLINE_FUSED fromListN #-} +fromListN n xs = fromStream (S.fromListN n xs) (Max (delay_inline max n 0)) + +-- | Convert a list to a 'Bundle' with the given 'Size' hint. +unsafeFromList :: Monad m => Size -> [a] -> Bundle m v a +{-# INLINE_FUSED unsafeFromList #-} +unsafeFromList sz xs = fromStream (S.fromList xs) sz + +fromVector :: (Monad m, Vector v a) => v a -> Bundle m v a +{-# INLINE_FUSED fromVector #-} +fromVector v = v `seq` n `seq` Bundle (Stream step 0) + (Stream vstep True) + (Just v) + (Exact n) + where + n = basicLength v + + {-# INLINE step #-} + step i | i >= n = return Done + | otherwise = case basicUnsafeIndexM v i of + Box x -> return $ Yield x (i+1) + + + {-# INLINE vstep #-} + vstep True = return (Yield (Chunk (basicLength v) (\mv -> basicUnsafeCopy mv v)) False) + vstep False = return Done + +fromVectors :: forall m v a. (Monad m, Vector v a) => [v a] -> Bundle m v a +{-# INLINE_FUSED fromVectors #-} +fromVectors us = Bundle (Stream pstep (Left us)) + (Stream vstep us) + Nothing + (Exact n) + where + n = List.foldl' (\k v -> k + basicLength v) 0 us + + pstep (Left []) = return Done + pstep (Left (v:vs)) = basicLength v `seq` return (Skip (Right (v,0,vs))) + + pstep (Right (v,i,vs)) + | i >= basicLength v = return $ Skip (Left vs) + | otherwise = case basicUnsafeIndexM v i of + Box x -> return $ Yield x (Right (v,i+1,vs)) + + -- FIXME: work around bug in GHC 7.6.1 + vstep :: [v a] -> m (Step [v a] (Chunk v a)) + vstep [] = return Done + vstep (v:vs) = return $ Yield (Chunk (basicLength v) + (\mv -> INTERNAL_CHECK(check) "concatVectors" "length mismatch" + (M.basicLength mv == basicLength v) + $ basicUnsafeCopy mv v)) vs + + +concatVectors :: (Monad m, Vector v a) => Bundle m u (v a) -> Bundle m v a +{-# INLINE_FUSED concatVectors #-} +concatVectors Bundle{sElems = Stream step t} + = Bundle (Stream pstep (Left t)) + (Stream vstep t) + Nothing + Unknown + where + pstep (Left s) = do + r <- step s + case r of + Yield v s' -> basicLength v `seq` return (Skip (Right (v,0,s'))) + Skip s' -> return (Skip (Left s')) + Done -> return Done + + pstep (Right (v,i,s)) + | i >= basicLength v = return (Skip (Left s)) + | otherwise = case basicUnsafeIndexM v i of + Box x -> return (Yield x (Right (v,i+1,s))) + + + vstep s = do + r <- step s + case r of + Yield v s' -> return (Yield (Chunk (basicLength v) + (\mv -> INTERNAL_CHECK(check) "concatVectors" "length mismatch" + (M.basicLength mv == basicLength v) + $ basicUnsafeCopy mv v)) s') + Skip s' -> return (Skip s') + Done -> return Done + +reVector :: Monad m => Bundle m u a -> Bundle m v a +{-# INLINE_FUSED reVector #-} +reVector Bundle{sElems = s, sSize = n} = fromStream s n + +{-# RULES + +"reVector [Vector]" + reVector = id + +"reVector/reVector [Vector]" forall s. + reVector (reVector s) = s #-} + + + diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Bundle/Size.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Bundle/Size.hs new file mode 100644 index 000000000000..e90cf373202d --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Bundle/Size.hs @@ -0,0 +1,121 @@ +-- | +-- Module : Data.Vector.Fusion.Bundle.Size +-- Copyright : (c) Roman Leshchinskiy 2008-2010 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> +-- Stability : experimental +-- Portability : portable +-- +-- Size hints for streams. +-- + +module Data.Vector.Fusion.Bundle.Size ( + Size(..), clampedSubtract, smaller, larger, toMax, upperBound, lowerBound +) where + +import Data.Vector.Fusion.Util ( delay_inline ) + +-- | Size hint +data Size = Exact Int -- ^ Exact size + | Max Int -- ^ Upper bound on the size + | Unknown -- ^ Unknown size + deriving( Eq, Show ) + +instance Num Size where + Exact m + Exact n = checkedAdd Exact m n + Exact m + Max n = checkedAdd Max m n + + Max m + Exact n = checkedAdd Max m n + Max m + Max n = checkedAdd Max m n + + _ + _ = Unknown + + + Exact m - Exact n = checkedSubtract Exact m n + Exact m - Max _ = Max m + + Max m - Exact n = checkedSubtract Max m n + Max m - Max _ = Max m + Max m - Unknown = Max m + + _ - _ = Unknown + + + fromInteger n = Exact (fromInteger n) + + (*) = error "vector: internal error * for Bundle.size isn't defined" + abs = error "vector: internal error abs for Bundle.size isn't defined" + signum = error "vector: internal error signum for Bundle.size isn't defined" + +{-# INLINE checkedAdd #-} +checkedAdd :: (Int -> Size) -> Int -> Int -> Size +checkedAdd con m n + -- Note: we assume m and n are >= 0. + | r < m || r < n = + error $ "Data.Vector.Fusion.Bundle.Size.checkedAdd: overflow: " ++ show r + | otherwise = con r + where + r = m + n + +{-# INLINE checkedSubtract #-} +checkedSubtract :: (Int -> Size) -> Int -> Int -> Size +checkedSubtract con m n + | r < 0 = + error $ "Data.Vector.Fusion.Bundle.Size.checkedSubtract: underflow: " ++ show r + | otherwise = con r + where + r = m - n + +-- | Subtract two sizes with clamping to 0, for drop-like things +{-# INLINE clampedSubtract #-} +clampedSubtract :: Size -> Size -> Size +clampedSubtract (Exact m) (Exact n) = Exact (max 0 (m - n)) +clampedSubtract (Max m) (Exact n) + | m <= n = Exact 0 + | otherwise = Max (m - n) +clampedSubtract (Exact m) (Max _) = Max m +clampedSubtract (Max m) (Max _) = Max m +clampedSubtract _ _ = Unknown + +-- | Minimum of two size hints +smaller :: Size -> Size -> Size +{-# INLINE smaller #-} +smaller (Exact m) (Exact n) = Exact (delay_inline min m n) +smaller (Exact m) (Max n) = Max (delay_inline min m n) +smaller (Exact m) Unknown = Max m +smaller (Max m) (Exact n) = Max (delay_inline min m n) +smaller (Max m) (Max n) = Max (delay_inline min m n) +smaller (Max m) Unknown = Max m +smaller Unknown (Exact n) = Max n +smaller Unknown (Max n) = Max n +smaller Unknown Unknown = Unknown + +-- | Maximum of two size hints +larger :: Size -> Size -> Size +{-# INLINE larger #-} +larger (Exact m) (Exact n) = Exact (delay_inline max m n) +larger (Exact m) (Max n) | m >= n = Exact m + | otherwise = Max n +larger (Max m) (Exact n) | n >= m = Exact n + | otherwise = Max m +larger (Max m) (Max n) = Max (delay_inline max m n) +larger _ _ = Unknown + +-- | Convert a size hint to an upper bound +toMax :: Size -> Size +toMax (Exact n) = Max n +toMax (Max n) = Max n +toMax Unknown = Unknown + +-- | Compute the minimum size from a size hint +lowerBound :: Size -> Int +lowerBound (Exact n) = n +lowerBound _ = 0 + +-- | Compute the maximum size from a size hint if possible +upperBound :: Size -> Maybe Int +upperBound (Exact n) = Just n +upperBound (Max n) = Just n +upperBound Unknown = Nothing + diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Stream/Monadic.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Stream/Monadic.hs new file mode 100644 index 000000000000..cca002ca6f74 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Stream/Monadic.hs @@ -0,0 +1,1639 @@ +{-# LANGUAGE CPP, ExistentialQuantification, MultiParamTypeClasses, FlexibleInstances, Rank2Types, BangPatterns, KindSignatures, GADTs, ScopedTypeVariables #-} + +-- | +-- Module : Data.Vector.Fusion.Stream.Monadic +-- Copyright : (c) Roman Leshchinskiy 2008-2010 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> +-- Stability : experimental +-- Portability : non-portable +-- +-- Monadic stream combinators. +-- + +module Data.Vector.Fusion.Stream.Monadic ( + Stream(..), Step(..), SPEC(..), + + -- * Length + length, null, + + -- * Construction + empty, singleton, cons, snoc, replicate, replicateM, generate, generateM, (++), + + -- * Accessing elements + head, last, (!!), (!?), + + -- * Substreams + slice, init, tail, take, drop, + + -- * Mapping + map, mapM, mapM_, trans, unbox, concatMap, flatten, + + -- * Zipping + indexed, indexedR, zipWithM_, + zipWithM, zipWith3M, zipWith4M, zipWith5M, zipWith6M, + zipWith, zipWith3, zipWith4, zipWith5, zipWith6, + zip, zip3, zip4, zip5, zip6, + + -- * Comparisons + eqBy, cmpBy, + + -- * Filtering + filter, filterM, uniq, mapMaybe, takeWhile, takeWhileM, dropWhile, dropWhileM, + + -- * Searching + elem, notElem, find, findM, findIndex, findIndexM, + + -- * Folding + foldl, foldlM, foldl1, foldl1M, foldM, fold1M, + foldl', foldlM', foldl1', foldl1M', foldM', fold1M', + foldr, foldrM, foldr1, foldr1M, + + -- * Specialised folds + and, or, concatMapM, + + -- * Unfolding + unfoldr, unfoldrM, + unfoldrN, unfoldrNM, + iterateN, iterateNM, + + -- * Scans + prescanl, prescanlM, prescanl', prescanlM', + postscanl, postscanlM, postscanl', postscanlM', + scanl, scanlM, scanl', scanlM', + scanl1, scanl1M, scanl1', scanl1M', + + -- * Enumerations + enumFromStepN, enumFromTo, enumFromThenTo, + + -- * Conversions + toList, fromList, fromListN +) where + +import Data.Vector.Fusion.Util ( Box(..) ) + +import Data.Char ( ord ) +import GHC.Base ( unsafeChr ) +import Control.Monad ( liftM ) +import Prelude hiding ( length, null, + replicate, (++), + head, last, (!!), + init, tail, take, drop, + map, mapM, mapM_, concatMap, + zipWith, zipWith3, zip, zip3, + filter, takeWhile, dropWhile, + elem, notElem, + foldl, foldl1, foldr, foldr1, + and, or, + scanl, scanl1, + enumFromTo, enumFromThenTo ) + +import Data.Int ( Int8, Int16, Int32 ) +import Data.Word ( Word8, Word16, Word32, Word64 ) + +#if !MIN_VERSION_base(4,8,0) +import Data.Word ( Word8, Word16, Word32, Word, Word64 ) +#endif + +#if __GLASGOW_HASKELL__ >= 708 +import GHC.Types ( SPEC(..) ) +#elif __GLASGOW_HASKELL__ >= 700 +import GHC.Exts ( SpecConstrAnnotation(..) ) +#endif + +#include "vector.h" +#include "MachDeps.h" + +#if WORD_SIZE_IN_BITS > 32 +import Data.Int ( Int64 ) +#endif + +#if __GLASGOW_HASKELL__ < 708 +data SPEC = SPEC | SPEC2 +#if __GLASGOW_HASKELL__ >= 700 +{-# ANN type SPEC ForceSpecConstr #-} +#endif +#endif + +emptyStream :: String +{-# NOINLINE emptyStream #-} +emptyStream = "empty stream" + +#define EMPTY_STREAM (\state -> ERROR state emptyStream) + +-- | Result of taking a single step in a stream +data Step s a where + Yield :: a -> s -> Step s a + Skip :: s -> Step s a + Done :: Step s a + +instance Functor (Step s) where + {-# INLINE fmap #-} + fmap f (Yield x s) = Yield (f x) s + fmap _ (Skip s) = Skip s + fmap _ Done = Done + +-- | Monadic streams +data Stream m a = forall s. Stream (s -> m (Step s a)) s + +-- Length +-- ------ + +-- | Length of a 'Stream' +length :: Monad m => Stream m a -> m Int +{-# INLINE_FUSED length #-} +length = foldl' (\n _ -> n+1) 0 + +-- | Check if a 'Stream' is empty +null :: Monad m => Stream m a -> m Bool +{-# INLINE_FUSED null #-} +null (Stream step t) = null_loop t + where + null_loop s = do + r <- step s + case r of + Yield _ _ -> return False + Skip s' -> null_loop s' + Done -> return True + +-- Construction +-- ------------ + +-- | Empty 'Stream' +empty :: Monad m => Stream m a +{-# INLINE_FUSED empty #-} +empty = Stream (const (return Done)) () + +-- | Singleton 'Stream' +singleton :: Monad m => a -> Stream m a +{-# INLINE_FUSED singleton #-} +singleton x = Stream (return . step) True + where + {-# INLINE_INNER step #-} + step True = Yield x False + step False = Done + +-- | Replicate a value to a given length +replicate :: Monad m => Int -> a -> Stream m a +{-# INLINE_FUSED replicate #-} +replicate n x = replicateM n (return x) + +-- | Yield a 'Stream' of values obtained by performing the monadic action the +-- given number of times +replicateM :: Monad m => Int -> m a -> Stream m a +{-# INLINE_FUSED replicateM #-} +replicateM n p = Stream step n + where + {-# INLINE_INNER step #-} + step i | i <= 0 = return Done + | otherwise = do { x <- p; return $ Yield x (i-1) } + +generate :: Monad m => Int -> (Int -> a) -> Stream m a +{-# INLINE generate #-} +generate n f = generateM n (return . f) + +-- | Generate a stream from its indices +generateM :: Monad m => Int -> (Int -> m a) -> Stream m a +{-# INLINE_FUSED generateM #-} +generateM n f = n `seq` Stream step 0 + where + {-# INLINE_INNER step #-} + step i | i < n = do + x <- f i + return $ Yield x (i+1) + | otherwise = return Done + +-- | Prepend an element +cons :: Monad m => a -> Stream m a -> Stream m a +{-# INLINE cons #-} +cons x s = singleton x ++ s + +-- | Append an element +snoc :: Monad m => Stream m a -> a -> Stream m a +{-# INLINE snoc #-} +snoc s x = s ++ singleton x + +infixr 5 ++ +-- | Concatenate two 'Stream's +(++) :: Monad m => Stream m a -> Stream m a -> Stream m a +{-# INLINE_FUSED (++) #-} +Stream stepa ta ++ Stream stepb tb = Stream step (Left ta) + where + {-# INLINE_INNER step #-} + step (Left sa) = do + r <- stepa sa + case r of + Yield x sa' -> return $ Yield x (Left sa') + Skip sa' -> return $ Skip (Left sa') + Done -> return $ Skip (Right tb) + step (Right sb) = do + r <- stepb sb + case r of + Yield x sb' -> return $ Yield x (Right sb') + Skip sb' -> return $ Skip (Right sb') + Done -> return $ Done + +-- Accessing elements +-- ------------------ + +-- | First element of the 'Stream' or error if empty +head :: Monad m => Stream m a -> m a +{-# INLINE_FUSED head #-} +head (Stream step t) = head_loop SPEC t + where + head_loop !_ s + = do + r <- step s + case r of + Yield x _ -> return x + Skip s' -> head_loop SPEC s' + Done -> EMPTY_STREAM "head" + + + +-- | Last element of the 'Stream' or error if empty +last :: Monad m => Stream m a -> m a +{-# INLINE_FUSED last #-} +last (Stream step t) = last_loop0 SPEC t + where + last_loop0 !_ s + = do + r <- step s + case r of + Yield x s' -> last_loop1 SPEC x s' + Skip s' -> last_loop0 SPEC s' + Done -> EMPTY_STREAM "last" + + last_loop1 !_ x s + = do + r <- step s + case r of + Yield y s' -> last_loop1 SPEC y s' + Skip s' -> last_loop1 SPEC x s' + Done -> return x + +infixl 9 !! +-- | Element at the given position +(!!) :: Monad m => Stream m a -> Int -> m a +{-# INLINE (!!) #-} +Stream step t !! j | j < 0 = ERROR "!!" "negative index" + | otherwise = index_loop SPEC t j + where + index_loop !_ s i + = i `seq` + do + r <- step s + case r of + Yield x s' | i == 0 -> return x + | otherwise -> index_loop SPEC s' (i-1) + Skip s' -> index_loop SPEC s' i + Done -> EMPTY_STREAM "!!" + +infixl 9 !? +-- | Element at the given position or 'Nothing' if out of bounds +(!?) :: Monad m => Stream m a -> Int -> m (Maybe a) +{-# INLINE (!?) #-} +Stream step t !? j = index_loop SPEC t j + where + index_loop !_ s i + = i `seq` + do + r <- step s + case r of + Yield x s' | i == 0 -> return (Just x) + | otherwise -> index_loop SPEC s' (i-1) + Skip s' -> index_loop SPEC s' i + Done -> return Nothing + +-- Substreams +-- ---------- + +-- | Extract a substream of the given length starting at the given position. +slice :: Monad m => Int -- ^ starting index + -> Int -- ^ length + -> Stream m a + -> Stream m a +{-# INLINE slice #-} +slice i n s = take n (drop i s) + +-- | All but the last element +init :: Monad m => Stream m a -> Stream m a +{-# INLINE_FUSED init #-} +init (Stream step t) = Stream step' (Nothing, t) + where + {-# INLINE_INNER step' #-} + step' (Nothing, s) = liftM (\r -> + case r of + Yield x s' -> Skip (Just x, s') + Skip s' -> Skip (Nothing, s') + Done -> EMPTY_STREAM "init" + ) (step s) + + step' (Just x, s) = liftM (\r -> + case r of + Yield y s' -> Yield x (Just y, s') + Skip s' -> Skip (Just x, s') + Done -> Done + ) (step s) + +-- | All but the first element +tail :: Monad m => Stream m a -> Stream m a +{-# INLINE_FUSED tail #-} +tail (Stream step t) = Stream step' (Left t) + where + {-# INLINE_INNER step' #-} + step' (Left s) = liftM (\r -> + case r of + Yield _ s' -> Skip (Right s') + Skip s' -> Skip (Left s') + Done -> EMPTY_STREAM "tail" + ) (step s) + + step' (Right s) = liftM (\r -> + case r of + Yield x s' -> Yield x (Right s') + Skip s' -> Skip (Right s') + Done -> Done + ) (step s) + +-- | The first @n@ elements +take :: Monad m => Int -> Stream m a -> Stream m a +{-# INLINE_FUSED take #-} +take n (Stream step t) = n `seq` Stream step' (t, 0) + where + {-# INLINE_INNER step' #-} + step' (s, i) | i < n = liftM (\r -> + case r of + Yield x s' -> Yield x (s', i+1) + Skip s' -> Skip (s', i) + Done -> Done + ) (step s) + step' (_, _) = return Done + +-- | All but the first @n@ elements +drop :: Monad m => Int -> Stream m a -> Stream m a +{-# INLINE_FUSED drop #-} +drop n (Stream step t) = Stream step' (t, Just n) + where + {-# INLINE_INNER step' #-} + step' (s, Just i) | i > 0 = liftM (\r -> + case r of + Yield _ s' -> Skip (s', Just (i-1)) + Skip s' -> Skip (s', Just i) + Done -> Done + ) (step s) + | otherwise = return $ Skip (s, Nothing) + + step' (s, Nothing) = liftM (\r -> + case r of + Yield x s' -> Yield x (s', Nothing) + Skip s' -> Skip (s', Nothing) + Done -> Done + ) (step s) + +-- Mapping +-- ------- + +instance Monad m => Functor (Stream m) where + {-# INLINE fmap #-} + fmap = map + +-- | Map a function over a 'Stream' +map :: Monad m => (a -> b) -> Stream m a -> Stream m b +{-# INLINE map #-} +map f = mapM (return . f) + + +-- | Map a monadic function over a 'Stream' +mapM :: Monad m => (a -> m b) -> Stream m a -> Stream m b +{-# INLINE_FUSED mapM #-} +mapM f (Stream step t) = Stream step' t + where + {-# INLINE_INNER step' #-} + step' s = do + r <- step s + case r of + Yield x s' -> liftM (`Yield` s') (f x) + Skip s' -> return (Skip s') + Done -> return Done + +consume :: Monad m => Stream m a -> m () +{-# INLINE_FUSED consume #-} +consume (Stream step t) = consume_loop SPEC t + where + consume_loop !_ s + = do + r <- step s + case r of + Yield _ s' -> consume_loop SPEC s' + Skip s' -> consume_loop SPEC s' + Done -> return () + +-- | Execute a monadic action for each element of the 'Stream' +mapM_ :: Monad m => (a -> m b) -> Stream m a -> m () +{-# INLINE_FUSED mapM_ #-} +mapM_ m = consume . mapM m + +-- | Transform a 'Stream' to use a different monad +trans :: (Monad m, Monad m') + => (forall z. m z -> m' z) -> Stream m a -> Stream m' a +{-# INLINE_FUSED trans #-} +trans f (Stream step s) = Stream (f . step) s + +unbox :: Monad m => Stream m (Box a) -> Stream m a +{-# INLINE_FUSED unbox #-} +unbox (Stream step t) = Stream step' t + where + {-# INLINE_INNER step' #-} + step' s = do + r <- step s + case r of + Yield (Box x) s' -> return $ Yield x s' + Skip s' -> return $ Skip s' + Done -> return $ Done + +-- Zipping +-- ------- + +-- | Pair each element in a 'Stream' with its index +indexed :: Monad m => Stream m a -> Stream m (Int,a) +{-# INLINE_FUSED indexed #-} +indexed (Stream step t) = Stream step' (t,0) + where + {-# INLINE_INNER step' #-} + step' (s,i) = i `seq` + do + r <- step s + case r of + Yield x s' -> return $ Yield (i,x) (s', i+1) + Skip s' -> return $ Skip (s', i) + Done -> return Done + +-- | Pair each element in a 'Stream' with its index, starting from the right +-- and counting down +indexedR :: Monad m => Int -> Stream m a -> Stream m (Int,a) +{-# INLINE_FUSED indexedR #-} +indexedR m (Stream step t) = Stream step' (t,m) + where + {-# INLINE_INNER step' #-} + step' (s,i) = i `seq` + do + r <- step s + case r of + Yield x s' -> let i' = i-1 + in + return $ Yield (i',x) (s', i') + Skip s' -> return $ Skip (s', i) + Done -> return Done + +-- | Zip two 'Stream's with the given monadic function +zipWithM :: Monad m => (a -> b -> m c) -> Stream m a -> Stream m b -> Stream m c +{-# INLINE_FUSED zipWithM #-} +zipWithM f (Stream stepa ta) (Stream stepb tb) = Stream step (ta, tb, Nothing) + where + {-# INLINE_INNER step #-} + step (sa, sb, Nothing) = liftM (\r -> + case r of + Yield x sa' -> Skip (sa', sb, Just x) + Skip sa' -> Skip (sa', sb, Nothing) + Done -> Done + ) (stepa sa) + + step (sa, sb, Just x) = do + r <- stepb sb + case r of + Yield y sb' -> + do + z <- f x y + return $ Yield z (sa, sb', Nothing) + Skip sb' -> return $ Skip (sa, sb', Just x) + Done -> return $ Done + +-- FIXME: This might expose an opportunity for inplace execution. +{-# RULES + +"zipWithM xs xs [Vector.Stream]" forall f xs. + zipWithM f xs xs = mapM (\x -> f x x) xs #-} + + +zipWithM_ :: Monad m => (a -> b -> m c) -> Stream m a -> Stream m b -> m () +{-# INLINE zipWithM_ #-} +zipWithM_ f sa sb = consume (zipWithM f sa sb) + +zipWith3M :: Monad m => (a -> b -> c -> m d) -> Stream m a -> Stream m b -> Stream m c -> Stream m d +{-# INLINE_FUSED zipWith3M #-} +zipWith3M f (Stream stepa ta) + (Stream stepb tb) + (Stream stepc tc) = Stream step (ta, tb, tc, Nothing) + where + {-# INLINE_INNER step #-} + step (sa, sb, sc, Nothing) = do + r <- stepa sa + return $ case r of + Yield x sa' -> Skip (sa', sb, sc, Just (x, Nothing)) + Skip sa' -> Skip (sa', sb, sc, Nothing) + Done -> Done + + step (sa, sb, sc, Just (x, Nothing)) = do + r <- stepb sb + return $ case r of + Yield y sb' -> Skip (sa, sb', sc, Just (x, Just y)) + Skip sb' -> Skip (sa, sb', sc, Just (x, Nothing)) + Done -> Done + + step (sa, sb, sc, Just (x, Just y)) = do + r <- stepc sc + case r of + Yield z sc' -> f x y z >>= (\res -> return $ Yield res (sa, sb, sc', Nothing)) + Skip sc' -> return $ Skip (sa, sb, sc', Just (x, Just y)) + Done -> return $ Done + +zipWith4M :: Monad m => (a -> b -> c -> d -> m e) + -> Stream m a -> Stream m b -> Stream m c -> Stream m d + -> Stream m e +{-# INLINE zipWith4M #-} +zipWith4M f sa sb sc sd + = zipWithM (\(a,b) (c,d) -> f a b c d) (zip sa sb) (zip sc sd) + +zipWith5M :: Monad m => (a -> b -> c -> d -> e -> m f) + -> Stream m a -> Stream m b -> Stream m c -> Stream m d + -> Stream m e -> Stream m f +{-# INLINE zipWith5M #-} +zipWith5M f sa sb sc sd se + = zipWithM (\(a,b,c) (d,e) -> f a b c d e) (zip3 sa sb sc) (zip sd se) + +zipWith6M :: Monad m => (a -> b -> c -> d -> e -> f -> m g) + -> Stream m a -> Stream m b -> Stream m c -> Stream m d + -> Stream m e -> Stream m f -> Stream m g +{-# INLINE zipWith6M #-} +zipWith6M fn sa sb sc sd se sf + = zipWithM (\(a,b,c) (d,e,f) -> fn a b c d e f) (zip3 sa sb sc) + (zip3 sd se sf) + +zipWith :: Monad m => (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c +{-# INLINE zipWith #-} +zipWith f = zipWithM (\a b -> return (f a b)) + +zipWith3 :: Monad m => (a -> b -> c -> d) + -> Stream m a -> Stream m b -> Stream m c -> Stream m d +{-# INLINE zipWith3 #-} +zipWith3 f = zipWith3M (\a b c -> return (f a b c)) + +zipWith4 :: Monad m => (a -> b -> c -> d -> e) + -> Stream m a -> Stream m b -> Stream m c -> Stream m d + -> Stream m e +{-# INLINE zipWith4 #-} +zipWith4 f = zipWith4M (\a b c d -> return (f a b c d)) + +zipWith5 :: Monad m => (a -> b -> c -> d -> e -> f) + -> Stream m a -> Stream m b -> Stream m c -> Stream m d + -> Stream m e -> Stream m f +{-# INLINE zipWith5 #-} +zipWith5 f = zipWith5M (\a b c d e -> return (f a b c d e)) + +zipWith6 :: Monad m => (a -> b -> c -> d -> e -> f -> g) + -> Stream m a -> Stream m b -> Stream m c -> Stream m d + -> Stream m e -> Stream m f -> Stream m g +{-# INLINE zipWith6 #-} +zipWith6 fn = zipWith6M (\a b c d e f -> return (fn a b c d e f)) + +zip :: Monad m => Stream m a -> Stream m b -> Stream m (a,b) +{-# INLINE zip #-} +zip = zipWith (,) + +zip3 :: Monad m => Stream m a -> Stream m b -> Stream m c -> Stream m (a,b,c) +{-# INLINE zip3 #-} +zip3 = zipWith3 (,,) + +zip4 :: Monad m => Stream m a -> Stream m b -> Stream m c -> Stream m d + -> Stream m (a,b,c,d) +{-# INLINE zip4 #-} +zip4 = zipWith4 (,,,) + +zip5 :: Monad m => Stream m a -> Stream m b -> Stream m c -> Stream m d + -> Stream m e -> Stream m (a,b,c,d,e) +{-# INLINE zip5 #-} +zip5 = zipWith5 (,,,,) + +zip6 :: Monad m => Stream m a -> Stream m b -> Stream m c -> Stream m d + -> Stream m e -> Stream m f -> Stream m (a,b,c,d,e,f) +{-# INLINE zip6 #-} +zip6 = zipWith6 (,,,,,) + +-- Comparisons +-- ----------- + +-- | Check if two 'Stream's are equal +eqBy :: (Monad m) => (a -> b -> Bool) -> Stream m a -> Stream m b -> m Bool +{-# INLINE_FUSED eqBy #-} +eqBy eq (Stream step1 t1) (Stream step2 t2) = eq_loop0 SPEC t1 t2 + where + eq_loop0 !_ s1 s2 = do + r <- step1 s1 + case r of + Yield x s1' -> eq_loop1 SPEC x s1' s2 + Skip s1' -> eq_loop0 SPEC s1' s2 + Done -> eq_null s2 + + eq_loop1 !_ x s1 s2 = do + r <- step2 s2 + case r of + Yield y s2' + | eq x y -> eq_loop0 SPEC s1 s2' + | otherwise -> return False + Skip s2' -> eq_loop1 SPEC x s1 s2' + Done -> return False + + eq_null s2 = do + r <- step2 s2 + case r of + Yield _ _ -> return False + Skip s2' -> eq_null s2' + Done -> return True + +-- | Lexicographically compare two 'Stream's +cmpBy :: (Monad m) => (a -> b -> Ordering) -> Stream m a -> Stream m b -> m Ordering +{-# INLINE_FUSED cmpBy #-} +cmpBy cmp (Stream step1 t1) (Stream step2 t2) = cmp_loop0 SPEC t1 t2 + where + cmp_loop0 !_ s1 s2 = do + r <- step1 s1 + case r of + Yield x s1' -> cmp_loop1 SPEC x s1' s2 + Skip s1' -> cmp_loop0 SPEC s1' s2 + Done -> cmp_null s2 + + cmp_loop1 !_ x s1 s2 = do + r <- step2 s2 + case r of + Yield y s2' -> case x `cmp` y of + EQ -> cmp_loop0 SPEC s1 s2' + c -> return c + Skip s2' -> cmp_loop1 SPEC x s1 s2' + Done -> return GT + + cmp_null s2 = do + r <- step2 s2 + case r of + Yield _ _ -> return LT + Skip s2' -> cmp_null s2' + Done -> return EQ + +-- Filtering +-- --------- + +-- | Drop elements which do not satisfy the predicate +filter :: Monad m => (a -> Bool) -> Stream m a -> Stream m a +{-# INLINE filter #-} +filter f = filterM (return . f) + +mapMaybe :: Monad m => (a -> Maybe b) -> Stream m a -> Stream m b +{-# INLINE_FUSED mapMaybe #-} +mapMaybe f (Stream step t) = Stream step' t + where + {-# INLINE_INNER step' #-} + step' s = do + r <- step s + case r of + Yield x s' -> do + return $ case f x of + Nothing -> Skip s' + Just b' -> Yield b' s' + Skip s' -> return $ Skip s' + Done -> return $ Done + +-- | Drop elements which do not satisfy the monadic predicate +filterM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a +{-# INLINE_FUSED filterM #-} +filterM f (Stream step t) = Stream step' t + where + {-# INLINE_INNER step' #-} + step' s = do + r <- step s + case r of + Yield x s' -> do + b <- f x + return $ if b then Yield x s' + else Skip s' + Skip s' -> return $ Skip s' + Done -> return $ Done + +-- | Drop repeated adjacent elements. +uniq :: (Eq a, Monad m) => Stream m a -> Stream m a +{-# INLINE_FUSED uniq #-} +uniq (Stream step st) = Stream step' (Nothing,st) + where + {-# INLINE_INNER step' #-} + step' (Nothing, s) = do r <- step s + case r of + Yield x s' -> return $ Yield x (Just x , s') + Skip s' -> return $ Skip (Nothing, s') + Done -> return Done + step' (Just x0, s) = do r <- step s + case r of + Yield x s' | x == x0 -> return $ Skip (Just x0, s') + | otherwise -> return $ Yield x (Just x , s') + Skip s' -> return $ Skip (Just x0, s') + Done -> return Done + +-- | Longest prefix of elements that satisfy the predicate +takeWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a +{-# INLINE takeWhile #-} +takeWhile f = takeWhileM (return . f) + +-- | Longest prefix of elements that satisfy the monadic predicate +takeWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a +{-# INLINE_FUSED takeWhileM #-} +takeWhileM f (Stream step t) = Stream step' t + where + {-# INLINE_INNER step' #-} + step' s = do + r <- step s + case r of + Yield x s' -> do + b <- f x + return $ if b then Yield x s' else Done + Skip s' -> return $ Skip s' + Done -> return $ Done + +-- | Drop the longest prefix of elements that satisfy the predicate +dropWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a +{-# INLINE dropWhile #-} +dropWhile f = dropWhileM (return . f) + +data DropWhile s a = DropWhile_Drop s | DropWhile_Yield a s | DropWhile_Next s + +-- | Drop the longest prefix of elements that satisfy the monadic predicate +dropWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a +{-# INLINE_FUSED dropWhileM #-} +dropWhileM f (Stream step t) = Stream step' (DropWhile_Drop t) + where + -- NOTE: we jump through hoops here to have only one Yield; local data + -- declarations would be nice! + + {-# INLINE_INNER step' #-} + step' (DropWhile_Drop s) + = do + r <- step s + case r of + Yield x s' -> do + b <- f x + return $ if b then Skip (DropWhile_Drop s') + else Skip (DropWhile_Yield x s') + Skip s' -> return $ Skip (DropWhile_Drop s') + Done -> return $ Done + + step' (DropWhile_Yield x s) = return $ Yield x (DropWhile_Next s) + + step' (DropWhile_Next s) + = liftM (\r -> + case r of + Yield x s' -> Skip (DropWhile_Yield x s') + Skip s' -> Skip (DropWhile_Next s') + Done -> Done + ) (step s) + +-- Searching +-- --------- + +infix 4 `elem` +-- | Check whether the 'Stream' contains an element +elem :: (Monad m, Eq a) => a -> Stream m a -> m Bool +{-# INLINE_FUSED elem #-} +elem x (Stream step t) = elem_loop SPEC t + where + elem_loop !_ s + = do + r <- step s + case r of + Yield y s' | x == y -> return True + | otherwise -> elem_loop SPEC s' + Skip s' -> elem_loop SPEC s' + Done -> return False + +infix 4 `notElem` +-- | Inverse of `elem` +notElem :: (Monad m, Eq a) => a -> Stream m a -> m Bool +{-# INLINE notElem #-} +notElem x s = liftM not (elem x s) + +-- | Yield 'Just' the first element that satisfies the predicate or 'Nothing' +-- if no such element exists. +find :: Monad m => (a -> Bool) -> Stream m a -> m (Maybe a) +{-# INLINE find #-} +find f = findM (return . f) + +-- | Yield 'Just' the first element that satisfies the monadic predicate or +-- 'Nothing' if no such element exists. +findM :: Monad m => (a -> m Bool) -> Stream m a -> m (Maybe a) +{-# INLINE_FUSED findM #-} +findM f (Stream step t) = find_loop SPEC t + where + find_loop !_ s + = do + r <- step s + case r of + Yield x s' -> do + b <- f x + if b then return $ Just x + else find_loop SPEC s' + Skip s' -> find_loop SPEC s' + Done -> return Nothing + +-- | Yield 'Just' the index of the first element that satisfies the predicate +-- or 'Nothing' if no such element exists. +findIndex :: Monad m => (a -> Bool) -> Stream m a -> m (Maybe Int) +{-# INLINE_FUSED findIndex #-} +findIndex f = findIndexM (return . f) + +-- | Yield 'Just' the index of the first element that satisfies the monadic +-- predicate or 'Nothing' if no such element exists. +findIndexM :: Monad m => (a -> m Bool) -> Stream m a -> m (Maybe Int) +{-# INLINE_FUSED findIndexM #-} +findIndexM f (Stream step t) = findIndex_loop SPEC t 0 + where + findIndex_loop !_ s i + = do + r <- step s + case r of + Yield x s' -> do + b <- f x + if b then return $ Just i + else findIndex_loop SPEC s' (i+1) + Skip s' -> findIndex_loop SPEC s' i + Done -> return Nothing + +-- Folding +-- ------- + +-- | Left fold +foldl :: Monad m => (a -> b -> a) -> a -> Stream m b -> m a +{-# INLINE foldl #-} +foldl f = foldlM (\a b -> return (f a b)) + +-- | Left fold with a monadic operator +foldlM :: Monad m => (a -> b -> m a) -> a -> Stream m b -> m a +{-# INLINE_FUSED foldlM #-} +foldlM m w (Stream step t) = foldlM_loop SPEC w t + where + foldlM_loop !_ z s + = do + r <- step s + case r of + Yield x s' -> do { z' <- m z x; foldlM_loop SPEC z' s' } + Skip s' -> foldlM_loop SPEC z s' + Done -> return z + +-- | Same as 'foldlM' +foldM :: Monad m => (a -> b -> m a) -> a -> Stream m b -> m a +{-# INLINE foldM #-} +foldM = foldlM + +-- | Left fold over a non-empty 'Stream' +foldl1 :: Monad m => (a -> a -> a) -> Stream m a -> m a +{-# INLINE foldl1 #-} +foldl1 f = foldl1M (\a b -> return (f a b)) + +-- | Left fold over a non-empty 'Stream' with a monadic operator +foldl1M :: Monad m => (a -> a -> m a) -> Stream m a -> m a +{-# INLINE_FUSED foldl1M #-} +foldl1M f (Stream step t) = foldl1M_loop SPEC t + where + foldl1M_loop !_ s + = do + r <- step s + case r of + Yield x s' -> foldlM f x (Stream step s') + Skip s' -> foldl1M_loop SPEC s' + Done -> EMPTY_STREAM "foldl1M" + +-- | Same as 'foldl1M' +fold1M :: Monad m => (a -> a -> m a) -> Stream m a -> m a +{-# INLINE fold1M #-} +fold1M = foldl1M + +-- | Left fold with a strict accumulator +foldl' :: Monad m => (a -> b -> a) -> a -> Stream m b -> m a +{-# INLINE foldl' #-} +foldl' f = foldlM' (\a b -> return (f a b)) + +-- | Left fold with a strict accumulator and a monadic operator +foldlM' :: Monad m => (a -> b -> m a) -> a -> Stream m b -> m a +{-# INLINE_FUSED foldlM' #-} +foldlM' m w (Stream step t) = foldlM'_loop SPEC w t + where + foldlM'_loop !_ z s + = z `seq` + do + r <- step s + case r of + Yield x s' -> do { z' <- m z x; foldlM'_loop SPEC z' s' } + Skip s' -> foldlM'_loop SPEC z s' + Done -> return z + +-- | Same as 'foldlM'' +foldM' :: Monad m => (a -> b -> m a) -> a -> Stream m b -> m a +{-# INLINE foldM' #-} +foldM' = foldlM' + +-- | Left fold over a non-empty 'Stream' with a strict accumulator +foldl1' :: Monad m => (a -> a -> a) -> Stream m a -> m a +{-# INLINE foldl1' #-} +foldl1' f = foldl1M' (\a b -> return (f a b)) + +-- | Left fold over a non-empty 'Stream' with a strict accumulator and a +-- monadic operator +foldl1M' :: Monad m => (a -> a -> m a) -> Stream m a -> m a +{-# INLINE_FUSED foldl1M' #-} +foldl1M' f (Stream step t) = foldl1M'_loop SPEC t + where + foldl1M'_loop !_ s + = do + r <- step s + case r of + Yield x s' -> foldlM' f x (Stream step s') + Skip s' -> foldl1M'_loop SPEC s' + Done -> EMPTY_STREAM "foldl1M'" + +-- | Same as 'foldl1M'' +fold1M' :: Monad m => (a -> a -> m a) -> Stream m a -> m a +{-# INLINE fold1M' #-} +fold1M' = foldl1M' + +-- | Right fold +foldr :: Monad m => (a -> b -> b) -> b -> Stream m a -> m b +{-# INLINE foldr #-} +foldr f = foldrM (\a b -> return (f a b)) + +-- | Right fold with a monadic operator +foldrM :: Monad m => (a -> b -> m b) -> b -> Stream m a -> m b +{-# INLINE_FUSED foldrM #-} +foldrM f z (Stream step t) = foldrM_loop SPEC t + where + foldrM_loop !_ s + = do + r <- step s + case r of + Yield x s' -> f x =<< foldrM_loop SPEC s' + Skip s' -> foldrM_loop SPEC s' + Done -> return z + +-- | Right fold over a non-empty stream +foldr1 :: Monad m => (a -> a -> a) -> Stream m a -> m a +{-# INLINE foldr1 #-} +foldr1 f = foldr1M (\a b -> return (f a b)) + +-- | Right fold over a non-empty stream with a monadic operator +foldr1M :: Monad m => (a -> a -> m a) -> Stream m a -> m a +{-# INLINE_FUSED foldr1M #-} +foldr1M f (Stream step t) = foldr1M_loop0 SPEC t + where + foldr1M_loop0 !_ s + = do + r <- step s + case r of + Yield x s' -> foldr1M_loop1 SPEC x s' + Skip s' -> foldr1M_loop0 SPEC s' + Done -> EMPTY_STREAM "foldr1M" + + foldr1M_loop1 !_ x s + = do + r <- step s + case r of + Yield y s' -> f x =<< foldr1M_loop1 SPEC y s' + Skip s' -> foldr1M_loop1 SPEC x s' + Done -> return x + +-- Specialised folds +-- ----------------- + +and :: Monad m => Stream m Bool -> m Bool +{-# INLINE_FUSED and #-} +and (Stream step t) = and_loop SPEC t + where + and_loop !_ s + = do + r <- step s + case r of + Yield False _ -> return False + Yield True s' -> and_loop SPEC s' + Skip s' -> and_loop SPEC s' + Done -> return True + +or :: Monad m => Stream m Bool -> m Bool +{-# INLINE_FUSED or #-} +or (Stream step t) = or_loop SPEC t + where + or_loop !_ s + = do + r <- step s + case r of + Yield False s' -> or_loop SPEC s' + Yield True _ -> return True + Skip s' -> or_loop SPEC s' + Done -> return False + +concatMap :: Monad m => (a -> Stream m b) -> Stream m a -> Stream m b +{-# INLINE concatMap #-} +concatMap f = concatMapM (return . f) + +concatMapM :: Monad m => (a -> m (Stream m b)) -> Stream m a -> Stream m b +{-# INLINE_FUSED concatMapM #-} +concatMapM f (Stream step t) = Stream concatMap_go (Left t) + where + concatMap_go (Left s) = do + r <- step s + case r of + Yield a s' -> do + b_stream <- f a + return $ Skip (Right (b_stream, s')) + Skip s' -> return $ Skip (Left s') + Done -> return Done + concatMap_go (Right (Stream inner_step inner_s, s)) = do + r <- inner_step inner_s + case r of + Yield b inner_s' -> return $ Yield b (Right (Stream inner_step inner_s', s)) + Skip inner_s' -> return $ Skip (Right (Stream inner_step inner_s', s)) + Done -> return $ Skip (Left s) + +-- | Create a 'Stream' of values from a 'Stream' of streamable things +flatten :: Monad m => (a -> m s) -> (s -> m (Step s b)) -> Stream m a -> Stream m b +{-# INLINE_FUSED flatten #-} +flatten mk istep (Stream ostep u) = Stream step (Left u) + where + {-# INLINE_INNER step #-} + step (Left t) = do + r <- ostep t + case r of + Yield a t' -> do + s <- mk a + s `seq` return (Skip (Right (s,t'))) + Skip t' -> return $ Skip (Left t') + Done -> return $ Done + + + step (Right (s,t)) = do + r <- istep s + case r of + Yield x s' -> return $ Yield x (Right (s',t)) + Skip s' -> return $ Skip (Right (s',t)) + Done -> return $ Skip (Left t) + +-- Unfolding +-- --------- + +-- | Unfold +unfoldr :: Monad m => (s -> Maybe (a, s)) -> s -> Stream m a +{-# INLINE_FUSED unfoldr #-} +unfoldr f = unfoldrM (return . f) + +-- | Unfold with a monadic function +unfoldrM :: Monad m => (s -> m (Maybe (a, s))) -> s -> Stream m a +{-# INLINE_FUSED unfoldrM #-} +unfoldrM f t = Stream step t + where + {-# INLINE_INNER step #-} + step s = liftM (\r -> + case r of + Just (x, s') -> Yield x s' + Nothing -> Done + ) (f s) + +unfoldrN :: Monad m => Int -> (s -> Maybe (a, s)) -> s -> Stream m a +{-# INLINE_FUSED unfoldrN #-} +unfoldrN n f = unfoldrNM n (return . f) + +-- | Unfold at most @n@ elements with a monadic functions +unfoldrNM :: Monad m => Int -> (s -> m (Maybe (a, s))) -> s -> Stream m a +{-# INLINE_FUSED unfoldrNM #-} +unfoldrNM m f t = Stream step (t,m) + where + {-# INLINE_INNER step #-} + step (s,n) | n <= 0 = return Done + | otherwise = liftM (\r -> + case r of + Just (x,s') -> Yield x (s',n-1) + Nothing -> Done + ) (f s) + +-- | Apply monadic function n times to value. Zeroth element is original value. +iterateNM :: Monad m => Int -> (a -> m a) -> a -> Stream m a +{-# INLINE_FUSED iterateNM #-} +iterateNM n f x0 = Stream step (x0,n) + where + {-# INLINE_INNER step #-} + step (x,i) | i <= 0 = return Done + | i == n = return $ Yield x (x,i-1) + | otherwise = do a <- f x + return $ Yield a (a,i-1) + +-- | Apply function n times to value. Zeroth element is original value. +iterateN :: Monad m => Int -> (a -> a) -> a -> Stream m a +{-# INLINE_FUSED iterateN #-} +iterateN n f x0 = iterateNM n (return . f) x0 + +-- Scans +-- ----- + +-- | Prefix scan +prescanl :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a +{-# INLINE prescanl #-} +prescanl f = prescanlM (\a b -> return (f a b)) + +-- | Prefix scan with a monadic operator +prescanlM :: Monad m => (a -> b -> m a) -> a -> Stream m b -> Stream m a +{-# INLINE_FUSED prescanlM #-} +prescanlM f w (Stream step t) = Stream step' (t,w) + where + {-# INLINE_INNER step' #-} + step' (s,x) = do + r <- step s + case r of + Yield y s' -> do + z <- f x y + return $ Yield x (s', z) + Skip s' -> return $ Skip (s', x) + Done -> return Done + +-- | Prefix scan with strict accumulator +prescanl' :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a +{-# INLINE prescanl' #-} +prescanl' f = prescanlM' (\a b -> return (f a b)) + +-- | Prefix scan with strict accumulator and a monadic operator +prescanlM' :: Monad m => (a -> b -> m a) -> a -> Stream m b -> Stream m a +{-# INLINE_FUSED prescanlM' #-} +prescanlM' f w (Stream step t) = Stream step' (t,w) + where + {-# INLINE_INNER step' #-} + step' (s,x) = x `seq` + do + r <- step s + case r of + Yield y s' -> do + z <- f x y + return $ Yield x (s', z) + Skip s' -> return $ Skip (s', x) + Done -> return Done + +-- | Suffix scan +postscanl :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a +{-# INLINE postscanl #-} +postscanl f = postscanlM (\a b -> return (f a b)) + +-- | Suffix scan with a monadic operator +postscanlM :: Monad m => (a -> b -> m a) -> a -> Stream m b -> Stream m a +{-# INLINE_FUSED postscanlM #-} +postscanlM f w (Stream step t) = Stream step' (t,w) + where + {-# INLINE_INNER step' #-} + step' (s,x) = do + r <- step s + case r of + Yield y s' -> do + z <- f x y + return $ Yield z (s',z) + Skip s' -> return $ Skip (s',x) + Done -> return Done + +-- | Suffix scan with strict accumulator +postscanl' :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a +{-# INLINE postscanl' #-} +postscanl' f = postscanlM' (\a b -> return (f a b)) + +-- | Suffix scan with strict acccumulator and a monadic operator +postscanlM' :: Monad m => (a -> b -> m a) -> a -> Stream m b -> Stream m a +{-# INLINE_FUSED postscanlM' #-} +postscanlM' f w (Stream step t) = w `seq` Stream step' (t,w) + where + {-# INLINE_INNER step' #-} + step' (s,x) = x `seq` + do + r <- step s + case r of + Yield y s' -> do + z <- f x y + z `seq` return (Yield z (s',z)) + Skip s' -> return $ Skip (s',x) + Done -> return Done + +-- | Haskell-style scan +scanl :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a +{-# INLINE scanl #-} +scanl f = scanlM (\a b -> return (f a b)) + +-- | Haskell-style scan with a monadic operator +scanlM :: Monad m => (a -> b -> m a) -> a -> Stream m b -> Stream m a +{-# INLINE scanlM #-} +scanlM f z s = z `cons` postscanlM f z s + +-- | Haskell-style scan with strict accumulator +scanl' :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a +{-# INLINE scanl' #-} +scanl' f = scanlM' (\a b -> return (f a b)) + +-- | Haskell-style scan with strict accumulator and a monadic operator +scanlM' :: Monad m => (a -> b -> m a) -> a -> Stream m b -> Stream m a +{-# INLINE scanlM' #-} +scanlM' f z s = z `seq` (z `cons` postscanlM f z s) + +-- | Scan over a non-empty 'Stream' +scanl1 :: Monad m => (a -> a -> a) -> Stream m a -> Stream m a +{-# INLINE scanl1 #-} +scanl1 f = scanl1M (\x y -> return (f x y)) + +-- | Scan over a non-empty 'Stream' with a monadic operator +scanl1M :: Monad m => (a -> a -> m a) -> Stream m a -> Stream m a +{-# INLINE_FUSED scanl1M #-} +scanl1M f (Stream step t) = Stream step' (t, Nothing) + where + {-# INLINE_INNER step' #-} + step' (s, Nothing) = do + r <- step s + case r of + Yield x s' -> return $ Yield x (s', Just x) + Skip s' -> return $ Skip (s', Nothing) + Done -> EMPTY_STREAM "scanl1M" + + step' (s, Just x) = do + r <- step s + case r of + Yield y s' -> do + z <- f x y + return $ Yield z (s', Just z) + Skip s' -> return $ Skip (s', Just x) + Done -> return Done + +-- | Scan over a non-empty 'Stream' with a strict accumulator +scanl1' :: Monad m => (a -> a -> a) -> Stream m a -> Stream m a +{-# INLINE scanl1' #-} +scanl1' f = scanl1M' (\x y -> return (f x y)) + +-- | Scan over a non-empty 'Stream' with a strict accumulator and a monadic +-- operator +scanl1M' :: Monad m => (a -> a -> m a) -> Stream m a -> Stream m a +{-# INLINE_FUSED scanl1M' #-} +scanl1M' f (Stream step t) = Stream step' (t, Nothing) + where + {-# INLINE_INNER step' #-} + step' (s, Nothing) = do + r <- step s + case r of + Yield x s' -> x `seq` return (Yield x (s', Just x)) + Skip s' -> return $ Skip (s', Nothing) + Done -> EMPTY_STREAM "scanl1M" + + step' (s, Just x) = x `seq` + do + r <- step s + case r of + Yield y s' -> do + z <- f x y + z `seq` return (Yield z (s', Just z)) + Skip s' -> return $ Skip (s', Just x) + Done -> return Done + +-- Enumerations +-- ------------ + +-- The Enum class is broken for this, there just doesn't seem to be a +-- way to implement this generically. We have to specialise for as many types +-- as we can but this doesn't help in polymorphic loops. + +-- | Yield a 'Stream' of the given length containing the values @x@, @x+y@, +-- @x+y+y@ etc. +enumFromStepN :: (Num a, Monad m) => a -> a -> Int -> Stream m a +{-# INLINE_FUSED enumFromStepN #-} +enumFromStepN x y n = x `seq` y `seq` n `seq` Stream step (x,n) + where + {-# INLINE_INNER step #-} + step (w,m) | m > 0 = return $ Yield w (w+y,m-1) + | otherwise = return $ Done + +-- | Enumerate values +-- +-- /WARNING:/ This operation can be very inefficient. If at all possible, use +-- 'enumFromStepN' instead. +enumFromTo :: (Enum a, Monad m) => a -> a -> Stream m a +{-# INLINE_FUSED enumFromTo #-} +enumFromTo x y = fromList [x .. y] + +-- NOTE: We use (x+1) instead of (succ x) below because the latter checks for +-- overflow which can't happen here. + +-- FIXME: add "too large" test for Int +enumFromTo_small :: (Integral a, Monad m) => a -> a -> Stream m a +{-# INLINE_FUSED enumFromTo_small #-} +enumFromTo_small x y = x `seq` y `seq` Stream step x + where + {-# INLINE_INNER step #-} + step w | w <= y = return $ Yield w (w+1) + | otherwise = return $ Done + +{-# RULES + +"enumFromTo<Int8> [Stream]" + enumFromTo = enumFromTo_small :: Monad m => Int8 -> Int8 -> Stream m Int8 + +"enumFromTo<Int16> [Stream]" + enumFromTo = enumFromTo_small :: Monad m => Int16 -> Int16 -> Stream m Int16 + +"enumFromTo<Word8> [Stream]" + enumFromTo = enumFromTo_small :: Monad m => Word8 -> Word8 -> Stream m Word8 + +"enumFromTo<Word16> [Stream]" + enumFromTo = enumFromTo_small :: Monad m => Word16 -> Word16 -> Stream m Word16 #-} + + +#if WORD_SIZE_IN_BITS > 32 + +{-# RULES + +"enumFromTo<Int32> [Stream]" + enumFromTo = enumFromTo_small :: Monad m => Int32 -> Int32 -> Stream m Int32 + +"enumFromTo<Word32> [Stream]" + enumFromTo = enumFromTo_small :: Monad m => Word32 -> Word32 -> Stream m Word32 #-} + + +#endif + +-- NOTE: We could implement a generic "too large" test: +-- +-- len x y | x > y = 0 +-- | n > 0 && n <= fromIntegral (maxBound :: Int) = fromIntegral n +-- | otherwise = error +-- where +-- n = y-x+1 +-- +-- Alas, GHC won't eliminate unnecessary comparisons (such as n >= 0 for +-- unsigned types). See http://hackage.haskell.org/trac/ghc/ticket/3744 +-- + +enumFromTo_int :: forall m. Monad m => Int -> Int -> Stream m Int +{-# INLINE_FUSED enumFromTo_int #-} +enumFromTo_int x y = x `seq` y `seq` Stream step x + where + -- {-# INLINE [0] len #-} + -- len :: Int -> Int -> Int + -- len u v | u > v = 0 + -- | otherwise = BOUNDS_CHECK(check) "enumFromTo" "vector too large" + -- (n > 0) + -- $ n + -- where + -- n = v-u+1 + + {-# INLINE_INNER step #-} + step z | z <= y = return $ Yield z (z+1) + | otherwise = return $ Done + +enumFromTo_intlike :: (Integral a, Monad m) => a -> a -> Stream m a +{-# INLINE_FUSED enumFromTo_intlike #-} +enumFromTo_intlike x y = x `seq` y `seq` Stream step x + where + {-# INLINE_INNER step #-} + step z | z <= y = return $ Yield z (z+1) + | otherwise = return $ Done + +{-# RULES + +"enumFromTo<Int> [Stream]" + enumFromTo = enumFromTo_int :: Monad m => Int -> Int -> Stream m Int + +#if WORD_SIZE_IN_BITS > 32 + +"enumFromTo<Int64> [Stream]" + enumFromTo = enumFromTo_intlike :: Monad m => Int64 -> Int64 -> Stream m Int64 #-} + +#else + +"enumFromTo<Int32> [Stream]" + enumFromTo = enumFromTo_intlike :: Monad m => Int32 -> Int32 -> Stream m Int32 #-} + +#endif + +enumFromTo_big_word :: (Integral a, Monad m) => a -> a -> Stream m a +{-# INLINE_FUSED enumFromTo_big_word #-} +enumFromTo_big_word x y = x `seq` y `seq` Stream step x + where + {-# INLINE_INNER step #-} + step z | z <= y = return $ Yield z (z+1) + | otherwise = return $ Done + +{-# RULES + +"enumFromTo<Word> [Stream]" + enumFromTo = enumFromTo_big_word :: Monad m => Word -> Word -> Stream m Word + +"enumFromTo<Word64> [Stream]" + enumFromTo = enumFromTo_big_word + :: Monad m => Word64 -> Word64 -> Stream m Word64 + +#if WORD_SIZE_IN_BITS == 32 + +"enumFromTo<Word32> [Stream]" + enumFromTo = enumFromTo_big_word + :: Monad m => Word32 -> Word32 -> Stream m Word32 + +#endif + +"enumFromTo<Integer> [Stream]" + enumFromTo = enumFromTo_big_word + :: Monad m => Integer -> Integer -> Stream m Integer #-} + + + +#if WORD_SIZE_IN_BITS > 32 + +-- FIXME: the "too large" test is totally wrong +enumFromTo_big_int :: (Integral a, Monad m) => a -> a -> Stream m a +{-# INLINE_FUSED enumFromTo_big_int #-} +enumFromTo_big_int x y = x `seq` y `seq` Stream step x + where + {-# INLINE_INNER step #-} + step z | z <= y = return $ Yield z (z+1) + | otherwise = return $ Done + +{-# RULES + +"enumFromTo<Int64> [Stream]" + enumFromTo = enumFromTo_big_int :: Monad m => Int64 -> Int64 -> Stream m Int64 #-} + + + +#endif + +enumFromTo_char :: Monad m => Char -> Char -> Stream m Char +{-# INLINE_FUSED enumFromTo_char #-} +enumFromTo_char x y = x `seq` y `seq` Stream step xn + where + xn = ord x + yn = ord y + + {-# INLINE_INNER step #-} + step zn | zn <= yn = return $ Yield (unsafeChr zn) (zn+1) + | otherwise = return $ Done + +{-# RULES + +"enumFromTo<Char> [Stream]" + enumFromTo = enumFromTo_char #-} + + + +------------------------------------------------------------------------ + +-- Specialise enumFromTo for Float and Double. +-- Also, try to do something about pairs? + +enumFromTo_double :: (Monad m, Ord a, RealFrac a) => a -> a -> Stream m a +{-# INLINE_FUSED enumFromTo_double #-} +enumFromTo_double n m = n `seq` m `seq` Stream step n + where + lim = m + 1/2 -- important to float out + + {-# INLINE_INNER step #-} + step x | x <= lim = return $ Yield x (x+1) + | otherwise = return $ Done + +{-# RULES + +"enumFromTo<Double> [Stream]" + enumFromTo = enumFromTo_double :: Monad m => Double -> Double -> Stream m Double + +"enumFromTo<Float> [Stream]" + enumFromTo = enumFromTo_double :: Monad m => Float -> Float -> Stream m Float #-} + + + +------------------------------------------------------------------------ + +-- | Enumerate values with a given step. +-- +-- /WARNING:/ This operation is very inefficient. If at all possible, use +-- 'enumFromStepN' instead. +enumFromThenTo :: (Enum a, Monad m) => a -> a -> a -> Stream m a +{-# INLINE_FUSED enumFromThenTo #-} +enumFromThenTo x y z = fromList [x, y .. z] + +-- FIXME: Specialise enumFromThenTo. + +-- Conversions +-- ----------- + +-- | Convert a 'Stream' to a list +toList :: Monad m => Stream m a -> m [a] +{-# INLINE toList #-} +toList = foldr (:) [] + +-- | Convert a list to a 'Stream' +fromList :: Monad m => [a] -> Stream m a +{-# INLINE fromList #-} +fromList zs = Stream step zs + where + step (x:xs) = return (Yield x xs) + step [] = return Done + +-- | Convert the first @n@ elements of a list to a 'Bundle' +fromListN :: Monad m => Int -> [a] -> Stream m a +{-# INLINE_FUSED fromListN #-} +fromListN m zs = Stream step (zs,m) + where + {-# INLINE_INNER step #-} + step (_, n) | n <= 0 = return Done + step (x:xs,n) = return (Yield x (xs,n-1)) + step ([],_) = return Done + +{- +fromVector :: (Monad m, Vector v a) => v a -> Stream m a +{-# INLINE_FUSED fromVector #-} +fromVector v = v `seq` n `seq` Stream (Unf step 0) + (Unf vstep True) + (Just v) + (Exact n) + where + n = basicLength v + + {-# INLINE step #-} + step i | i >= n = return Done + | otherwise = case basicUnsafeIndexM v i of + Box x -> return $ Yield x (i+1) + + + {-# INLINE vstep #-} + vstep True = return (Yield (Chunk (basicLength v) (\mv -> basicUnsafeCopy mv v)) False) + vstep False = return Done + +fromVectors :: forall m a. (Monad m, Vector v a) => [v a] -> Stream m a +{-# INLINE_FUSED fromVectors #-} +fromVectors vs = Stream (Unf pstep (Left vs)) + (Unf vstep vs) + Nothing + (Exact n) + where + n = List.foldl' (\k v -> k + basicLength v) 0 vs + + pstep (Left []) = return Done + pstep (Left (v:vs)) = basicLength v `seq` return (Skip (Right (v,0,vs))) + + pstep (Right (v,i,vs)) + | i >= basicLength v = return $ Skip (Left vs) + | otherwise = case basicUnsafeIndexM v i of + Box x -> return $ Yield x (Right (v,i+1,vs)) + + -- FIXME: work around bug in GHC 7.6.1 + vstep :: [v a] -> m (Step [v a] (Chunk v a)) + vstep [] = return Done + vstep (v:vs) = return $ Yield (Chunk (basicLength v) + (\mv -> INTERNAL_CHECK(check) "concatVectors" "length mismatch" + (M.basicLength mv == basicLength v) + $ basicUnsafeCopy mv v)) vs + + +concatVectors :: (Monad m, Vector v a) => Stream m (v a) -> Stream m a +{-# INLINE_FUSED concatVectors #-} +concatVectors (Stream step s} + = Stream (Unf pstep (Left s)) + (Unf vstep s) + Nothing + Unknown + where + pstep (Left s) = do + r <- step s + case r of + Yield v s' -> basicLength v `seq` return (Skip (Right (v,0,s'))) + Skip s' -> return (Skip (Left s')) + Done -> return Done + + pstep (Right (v,i,s)) + | i >= basicLength v = return (Skip (Left s)) + | otherwise = case basicUnsafeIndexM v i of + Box x -> return (Yield x (Right (v,i+1,s))) + + + vstep s = do + r <- step s + case r of + Yield v s' -> return (Yield (Chunk (basicLength v) + (\mv -> INTERNAL_CHECK(check) "concatVectors" "length mismatch" + (M.basicLength mv == basicLength v) + $ basicUnsafeCopy mv v)) s') + Skip s' -> return (Skip s') + Done -> return Done + +reVector :: Monad m => Stream m a -> Stream m a +{-# INLINE_FUSED reVector #-} +reVector (Stream step s, sSize = n} = Stream step s n + +{-# RULES + +"reVector [Vector]" + reVector = id + +"reVector/reVector [Vector]" forall s. + reVector (reVector s) = s #-} + + +-} + diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Util.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Util.hs new file mode 100644 index 000000000000..855bf5ddd40d --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Util.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Data.Vector.Fusion.Util +-- Copyright : (c) Roman Leshchinskiy 2009 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> +-- Stability : experimental +-- Portability : portable +-- +-- Fusion-related utility types +-- + +module Data.Vector.Fusion.Util ( + Id(..), Box(..), + + delay_inline, delayed_min +) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative (Applicative(..)) +#endif + +-- | Identity monad +newtype Id a = Id { unId :: a } + +instance Functor Id where + fmap f (Id x) = Id (f x) + +instance Applicative Id where + pure = Id + Id f <*> Id x = Id (f x) + +instance Monad Id where + return = pure + Id x >>= f = f x + +-- | Box monad +data Box a = Box { unBox :: a } + +instance Functor Box where + fmap f (Box x) = Box (f x) + +instance Applicative Box where + pure = Box + Box f <*> Box x = Box (f x) + +instance Monad Box where + return = pure + Box x >>= f = f x + +-- | Delay inlining a function until late in the game (simplifier phase 0). +delay_inline :: (a -> b) -> a -> b +{-# INLINE [0] delay_inline #-} +delay_inline f = f + +-- | `min` inlined in phase 0 +delayed_min :: Int -> Int -> Int +{-# INLINE [0] delayed_min #-} +delayed_min m n = min m n diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic.hs new file mode 100644 index 000000000000..066c07fd3d1d --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic.hs @@ -0,0 +1,2206 @@ +{-# LANGUAGE CPP, Rank2Types, MultiParamTypeClasses, FlexibleContexts, + TypeFamilies, ScopedTypeVariables, BangPatterns #-} +-- | +-- Module : Data.Vector.Generic +-- Copyright : (c) Roman Leshchinskiy 2008-2010 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> +-- Stability : experimental +-- Portability : non-portable +-- +-- Generic interface to pure vectors. +-- + +module Data.Vector.Generic ( + -- * Immutable vectors + Vector(..), Mutable, + + -- * Accessors + + -- ** Length information + length, null, + + -- ** Indexing + (!), (!?), head, last, + unsafeIndex, unsafeHead, unsafeLast, + + -- ** Monadic indexing + indexM, headM, lastM, + unsafeIndexM, unsafeHeadM, unsafeLastM, + + -- ** Extracting subvectors (slicing) + slice, init, tail, take, drop, splitAt, + unsafeSlice, unsafeInit, unsafeTail, unsafeTake, unsafeDrop, + + -- * Construction + + -- ** Initialisation + empty, singleton, replicate, generate, iterateN, + + -- ** Monadic initialisation + replicateM, generateM, iterateNM, create, createT, + + -- ** Unfolding + unfoldr, unfoldrN, + unfoldrM, unfoldrNM, + constructN, constructrN, + + -- ** Enumeration + enumFromN, enumFromStepN, enumFromTo, enumFromThenTo, + + -- ** Concatenation + cons, snoc, (++), concat, concatNE, + + -- ** Restricting memory usage + force, + + -- * Modifying vectors + + -- ** Bulk updates + (//), update, update_, + unsafeUpd, unsafeUpdate, unsafeUpdate_, + + -- ** Accumulations + accum, accumulate, accumulate_, + unsafeAccum, unsafeAccumulate, unsafeAccumulate_, + + -- ** Permutations + reverse, backpermute, unsafeBackpermute, + + -- ** Safe destructive updates + modify, + + -- * Elementwise operations + + -- ** Indexing + indexed, + + -- ** Mapping + map, imap, concatMap, + + -- ** Monadic mapping + mapM, imapM, mapM_, imapM_, forM, forM_, + + -- ** Zipping + zipWith, zipWith3, zipWith4, zipWith5, zipWith6, + izipWith, izipWith3, izipWith4, izipWith5, izipWith6, + zip, zip3, zip4, zip5, zip6, + + -- ** Monadic zipping + zipWithM, izipWithM, zipWithM_, izipWithM_, + + -- ** Unzipping + unzip, unzip3, unzip4, unzip5, unzip6, + + -- * Working with predicates + + -- ** Filtering + filter, ifilter, uniq, + mapMaybe, imapMaybe, + filterM, + takeWhile, dropWhile, + + -- ** Partitioning + partition, unstablePartition, span, break, + + -- ** Searching + elem, notElem, find, findIndex, findIndices, elemIndex, elemIndices, + + -- * Folding + foldl, foldl1, foldl', foldl1', foldr, foldr1, foldr', foldr1', + ifoldl, ifoldl', ifoldr, ifoldr', + + -- ** Specialised folds + all, any, and, or, + sum, product, + maximum, maximumBy, minimum, minimumBy, + minIndex, minIndexBy, maxIndex, maxIndexBy, + + -- ** Monadic folds + foldM, ifoldM, foldM', ifoldM', + fold1M, fold1M', foldM_, ifoldM_, + foldM'_, ifoldM'_, fold1M_, fold1M'_, + + -- ** Monadic sequencing + sequence, sequence_, + + -- * Prefix sums (scans) + prescanl, prescanl', + postscanl, postscanl', + scanl, scanl', scanl1, scanl1', + iscanl, iscanl', + prescanr, prescanr', + postscanr, postscanr', + scanr, scanr', scanr1, scanr1', + iscanr, iscanr', + + -- * Conversions + + -- ** Lists + toList, fromList, fromListN, + + -- ** Different vector types + convert, + + -- ** Mutable vectors + freeze, thaw, copy, unsafeFreeze, unsafeThaw, unsafeCopy, + + -- * Fusion support + + -- ** Conversion to/from Bundles + stream, unstream, streamR, unstreamR, + + -- ** Recycling support + new, clone, + + -- * Utilities + + -- ** Comparisons + eq, cmp, + eqBy, cmpBy, + + -- ** Show and Read + showsPrec, readPrec, + liftShowsPrec, liftReadsPrec, + + -- ** @Data@ and @Typeable@ + gfoldl, dataCast, mkType +) where + +import Data.Vector.Generic.Base + +import qualified Data.Vector.Generic.Mutable as M + +import qualified Data.Vector.Generic.New as New +import Data.Vector.Generic.New ( New ) + +import qualified Data.Vector.Fusion.Bundle as Bundle +import Data.Vector.Fusion.Bundle ( Bundle, MBundle, lift, inplace ) +import qualified Data.Vector.Fusion.Bundle.Monadic as MBundle +import Data.Vector.Fusion.Stream.Monadic ( Stream ) +import qualified Data.Vector.Fusion.Stream.Monadic as S +import Data.Vector.Fusion.Bundle.Size +import Data.Vector.Fusion.Util + +import Control.Monad.ST ( ST, runST ) +import Control.Monad.Primitive +import Prelude hiding ( length, null, + replicate, (++), concat, + head, last, + init, tail, take, drop, splitAt, reverse, + map, concat, concatMap, + zipWith, zipWith3, zip, zip3, unzip, unzip3, + filter, takeWhile, dropWhile, span, break, + elem, notElem, + foldl, foldl1, foldr, foldr1, + all, any, and, or, sum, product, maximum, minimum, + scanl, scanl1, scanr, scanr1, + enumFromTo, enumFromThenTo, + mapM, mapM_, sequence, sequence_, + showsPrec ) + +import qualified Text.Read as Read +import qualified Data.List.NonEmpty as NonEmpty + +#if __GLASGOW_HASKELL__ >= 707 +import Data.Typeable ( Typeable, gcast1 ) +#else +import Data.Typeable ( Typeable1, gcast1 ) +#endif + +#include "vector.h" + +import Data.Data ( Data, DataType ) +#if MIN_VERSION_base(4,2,0) +import Data.Data ( mkNoRepType ) +#else +import Data.Data ( mkNorepType ) +mkNoRepType :: String -> DataType +mkNoRepType = mkNorepType +#endif + +import qualified Data.Traversable as T (Traversable(mapM)) + +-- Length information +-- ------------------ + +-- | /O(1)/ Yield the length of the vector +length :: Vector v a => v a -> Int +{-# INLINE length #-} +length = Bundle.length . stream' + +-- | /O(1)/ Test whether a vector is empty +null :: Vector v a => v a -> Bool +{-# INLINE null #-} +null = Bundle.null . stream + +-- Indexing +-- -------- + +infixl 9 ! +-- | O(1) Indexing +(!) :: Vector v a => v a -> Int -> a +{-# INLINE_FUSED (!) #-} +(!) v i = BOUNDS_CHECK(checkIndex) "(!)" i (length v) + $ unId (basicUnsafeIndexM v i) + +infixl 9 !? +-- | O(1) Safe indexing +(!?) :: Vector v a => v a -> Int -> Maybe a +{-# INLINE_FUSED (!?) #-} +v !? i | i < 0 || i >= length v = Nothing + | otherwise = Just $ unsafeIndex v i + +-- | /O(1)/ First element +head :: Vector v a => v a -> a +{-# INLINE_FUSED head #-} +head v = v ! 0 + +-- | /O(1)/ Last element +last :: Vector v a => v a -> a +{-# INLINE_FUSED last #-} +last v = v ! (length v - 1) + +-- | /O(1)/ Unsafe indexing without bounds checking +unsafeIndex :: Vector v a => v a -> Int -> a +{-# INLINE_FUSED unsafeIndex #-} +unsafeIndex v i = UNSAFE_CHECK(checkIndex) "unsafeIndex" i (length v) + $ unId (basicUnsafeIndexM v i) + +-- | /O(1)/ First element without checking if the vector is empty +unsafeHead :: Vector v a => v a -> a +{-# INLINE_FUSED unsafeHead #-} +unsafeHead v = unsafeIndex v 0 + +-- | /O(1)/ Last element without checking if the vector is empty +unsafeLast :: Vector v a => v a -> a +{-# INLINE_FUSED unsafeLast #-} +unsafeLast v = unsafeIndex v (length v - 1) + +{-# RULES + +"(!)/unstream [Vector]" forall i s. + new (New.unstream s) ! i = s Bundle.!! i + +"(!?)/unstream [Vector]" forall i s. + new (New.unstream s) !? i = s Bundle.!? i + +"head/unstream [Vector]" forall s. + head (new (New.unstream s)) = Bundle.head s + +"last/unstream [Vector]" forall s. + last (new (New.unstream s)) = Bundle.last s + +"unsafeIndex/unstream [Vector]" forall i s. + unsafeIndex (new (New.unstream s)) i = s Bundle.!! i + +"unsafeHead/unstream [Vector]" forall s. + unsafeHead (new (New.unstream s)) = Bundle.head s + +"unsafeLast/unstream [Vector]" forall s. + unsafeLast (new (New.unstream s)) = Bundle.last s #-} + + + +-- Monadic indexing +-- ---------------- + +-- | /O(1)/ Indexing in a monad. +-- +-- The monad allows operations to be strict in the vector when necessary. +-- Suppose vector copying is implemented like this: +-- +-- > copy mv v = ... write mv i (v ! i) ... +-- +-- For lazy vectors, @v ! i@ would not be evaluated which means that @mv@ +-- would unnecessarily retain a reference to @v@ in each element written. +-- +-- With 'indexM', copying can be implemented like this instead: +-- +-- > copy mv v = ... do +-- > x <- indexM v i +-- > write mv i x +-- +-- Here, no references to @v@ are retained because indexing (but /not/ the +-- elements) is evaluated eagerly. +-- +indexM :: (Vector v a, Monad m) => v a -> Int -> m a +{-# INLINE_FUSED indexM #-} +indexM v i = BOUNDS_CHECK(checkIndex) "indexM" i (length v) + $ basicUnsafeIndexM v i + +-- | /O(1)/ First element of a vector in a monad. See 'indexM' for an +-- explanation of why this is useful. +headM :: (Vector v a, Monad m) => v a -> m a +{-# INLINE_FUSED headM #-} +headM v = indexM v 0 + +-- | /O(1)/ Last element of a vector in a monad. See 'indexM' for an +-- explanation of why this is useful. +lastM :: (Vector v a, Monad m) => v a -> m a +{-# INLINE_FUSED lastM #-} +lastM v = indexM v (length v - 1) + +-- | /O(1)/ Indexing in a monad without bounds checks. See 'indexM' for an +-- explanation of why this is useful. +unsafeIndexM :: (Vector v a, Monad m) => v a -> Int -> m a +{-# INLINE_FUSED unsafeIndexM #-} +unsafeIndexM v i = UNSAFE_CHECK(checkIndex) "unsafeIndexM" i (length v) + $ basicUnsafeIndexM v i + +-- | /O(1)/ First element in a monad without checking for empty vectors. +-- See 'indexM' for an explanation of why this is useful. +unsafeHeadM :: (Vector v a, Monad m) => v a -> m a +{-# INLINE_FUSED unsafeHeadM #-} +unsafeHeadM v = unsafeIndexM v 0 + +-- | /O(1)/ Last element in a monad without checking for empty vectors. +-- See 'indexM' for an explanation of why this is useful. +unsafeLastM :: (Vector v a, Monad m) => v a -> m a +{-# INLINE_FUSED unsafeLastM #-} +unsafeLastM v = unsafeIndexM v (length v - 1) + +{-# RULES + +"indexM/unstream [Vector]" forall s i. + indexM (new (New.unstream s)) i = lift s MBundle.!! i + +"headM/unstream [Vector]" forall s. + headM (new (New.unstream s)) = MBundle.head (lift s) + +"lastM/unstream [Vector]" forall s. + lastM (new (New.unstream s)) = MBundle.last (lift s) + +"unsafeIndexM/unstream [Vector]" forall s i. + unsafeIndexM (new (New.unstream s)) i = lift s MBundle.!! i + +"unsafeHeadM/unstream [Vector]" forall s. + unsafeHeadM (new (New.unstream s)) = MBundle.head (lift s) + +"unsafeLastM/unstream [Vector]" forall s. + unsafeLastM (new (New.unstream s)) = MBundle.last (lift s) #-} + + + +-- Extracting subvectors (slicing) +-- ------------------------------- + +-- | /O(1)/ Yield a slice of the vector without copying it. The vector must +-- contain at least @i+n@ elements. +slice :: Vector v a => Int -- ^ @i@ starting index + -> Int -- ^ @n@ length + -> v a + -> v a +{-# INLINE_FUSED slice #-} +slice i n v = BOUNDS_CHECK(checkSlice) "slice" i n (length v) + $ basicUnsafeSlice i n v + +-- | /O(1)/ Yield all but the last element without copying. The vector may not +-- be empty. +init :: Vector v a => v a -> v a +{-# INLINE_FUSED init #-} +init v = slice 0 (length v - 1) v + +-- | /O(1)/ Yield all but the first element without copying. The vector may not +-- be empty. +tail :: Vector v a => v a -> v a +{-# INLINE_FUSED tail #-} +tail v = slice 1 (length v - 1) v + +-- | /O(1)/ Yield the first @n@ elements without copying. The vector may +-- contain less than @n@ elements in which case it is returned unchanged. +take :: Vector v a => Int -> v a -> v a +{-# INLINE_FUSED take #-} +take n v = unsafeSlice 0 (delay_inline min n' (length v)) v + where n' = max n 0 + +-- | /O(1)/ Yield all but the first @n@ elements without copying. The vector may +-- contain less than @n@ elements in which case an empty vector is returned. +drop :: Vector v a => Int -> v a -> v a +{-# INLINE_FUSED drop #-} +drop n v = unsafeSlice (delay_inline min n' len) + (delay_inline max 0 (len - n')) v + where n' = max n 0 + len = length v + +-- | /O(1)/ Yield the first @n@ elements paired with the remainder without copying. +-- +-- Note that @'splitAt' n v@ is equivalent to @('take' n v, 'drop' n v)@ +-- but slightly more efficient. +{-# INLINE_FUSED splitAt #-} +splitAt :: Vector v a => Int -> v a -> (v a, v a) +splitAt n v = ( unsafeSlice 0 m v + , unsafeSlice m (delay_inline max 0 (len - n')) v + ) + where + m = delay_inline min n' len + n' = max n 0 + len = length v + +-- | /O(1)/ Yield a slice of the vector without copying. The vector must +-- contain at least @i+n@ elements but this is not checked. +unsafeSlice :: Vector v a => Int -- ^ @i@ starting index + -> Int -- ^ @n@ length + -> v a + -> v a +{-# INLINE_FUSED unsafeSlice #-} +unsafeSlice i n v = UNSAFE_CHECK(checkSlice) "unsafeSlice" i n (length v) + $ basicUnsafeSlice i n v + +-- | /O(1)/ Yield all but the last element without copying. The vector may not +-- be empty but this is not checked. +unsafeInit :: Vector v a => v a -> v a +{-# INLINE_FUSED unsafeInit #-} +unsafeInit v = unsafeSlice 0 (length v - 1) v + +-- | /O(1)/ Yield all but the first element without copying. The vector may not +-- be empty but this is not checked. +unsafeTail :: Vector v a => v a -> v a +{-# INLINE_FUSED unsafeTail #-} +unsafeTail v = unsafeSlice 1 (length v - 1) v + +-- | /O(1)/ Yield the first @n@ elements without copying. The vector must +-- contain at least @n@ elements but this is not checked. +unsafeTake :: Vector v a => Int -> v a -> v a +{-# INLINE unsafeTake #-} +unsafeTake n v = unsafeSlice 0 n v + +-- | /O(1)/ Yield all but the first @n@ elements without copying. The vector +-- must contain at least @n@ elements but this is not checked. +unsafeDrop :: Vector v a => Int -> v a -> v a +{-# INLINE unsafeDrop #-} +unsafeDrop n v = unsafeSlice n (length v - n) v + +{-# RULES + +"slice/new [Vector]" forall i n p. + slice i n (new p) = new (New.slice i n p) + +"init/new [Vector]" forall p. + init (new p) = new (New.init p) + +"tail/new [Vector]" forall p. + tail (new p) = new (New.tail p) + +"take/new [Vector]" forall n p. + take n (new p) = new (New.take n p) + +"drop/new [Vector]" forall n p. + drop n (new p) = new (New.drop n p) + +"unsafeSlice/new [Vector]" forall i n p. + unsafeSlice i n (new p) = new (New.unsafeSlice i n p) + +"unsafeInit/new [Vector]" forall p. + unsafeInit (new p) = new (New.unsafeInit p) + +"unsafeTail/new [Vector]" forall p. + unsafeTail (new p) = new (New.unsafeTail p) #-} + + + +-- Initialisation +-- -------------- + +-- | /O(1)/ Empty vector +empty :: Vector v a => v a +{-# INLINE empty #-} +empty = unstream Bundle.empty + +-- | /O(1)/ Vector with exactly one element +singleton :: forall v a. Vector v a => a -> v a +{-# INLINE singleton #-} +singleton x = elemseq (undefined :: v a) x + $ unstream (Bundle.singleton x) + +-- | /O(n)/ Vector of the given length with the same value in each position +replicate :: forall v a. Vector v a => Int -> a -> v a +{-# INLINE replicate #-} +replicate n x = elemseq (undefined :: v a) x + $ unstream + $ Bundle.replicate n x + +-- | /O(n)/ Construct a vector of the given length by applying the function to +-- each index +generate :: Vector v a => Int -> (Int -> a) -> v a +{-# INLINE generate #-} +generate n f = unstream (Bundle.generate n f) + +-- | /O(n)/ Apply function n times to value. Zeroth element is original value. +iterateN :: Vector v a => Int -> (a -> a) -> a -> v a +{-# INLINE iterateN #-} +iterateN n f x = unstream (Bundle.iterateN n f x) + +-- Unfolding +-- --------- + +-- | /O(n)/ Construct a vector by repeatedly applying the generator function +-- to a seed. The generator function yields 'Just' the next element and the +-- new seed or 'Nothing' if there are no more elements. +-- +-- > unfoldr (\n -> if n == 0 then Nothing else Just (n,n-1)) 10 +-- > = <10,9,8,7,6,5,4,3,2,1> +unfoldr :: Vector v a => (b -> Maybe (a, b)) -> b -> v a +{-# INLINE unfoldr #-} +unfoldr f = unstream . Bundle.unfoldr f + +-- | /O(n)/ Construct a vector with at most @n@ elements by repeatedly applying +-- the generator function to a seed. The generator function yields 'Just' the +-- next element and the new seed or 'Nothing' if there are no more elements. +-- +-- > unfoldrN 3 (\n -> Just (n,n-1)) 10 = <10,9,8> +unfoldrN :: Vector v a => Int -> (b -> Maybe (a, b)) -> b -> v a +{-# INLINE unfoldrN #-} +unfoldrN n f = unstream . Bundle.unfoldrN n f + +-- | /O(n)/ Construct a vector by repeatedly applying the monadic +-- generator function to a seed. The generator function yields 'Just' +-- the next element and the new seed or 'Nothing' if there are no more +-- elements. +unfoldrM :: (Monad m, Vector v a) => (b -> m (Maybe (a, b))) -> b -> m (v a) +{-# INLINE unfoldrM #-} +unfoldrM f = unstreamM . MBundle.unfoldrM f + +-- | /O(n)/ Construct a vector by repeatedly applying the monadic +-- generator function to a seed. The generator function yields 'Just' +-- the next element and the new seed or 'Nothing' if there are no more +-- elements. +unfoldrNM :: (Monad m, Vector v a) => Int -> (b -> m (Maybe (a, b))) -> b -> m (v a) +{-# INLINE unfoldrNM #-} +unfoldrNM n f = unstreamM . MBundle.unfoldrNM n f + +-- | /O(n)/ Construct a vector with @n@ elements by repeatedly applying the +-- generator function to the already constructed part of the vector. +-- +-- > constructN 3 f = let a = f <> ; b = f <a> ; c = f <a,b> in f <a,b,c> +-- +constructN :: forall v a. Vector v a => Int -> (v a -> a) -> v a +{-# INLINE constructN #-} +-- NOTE: We *CANNOT* wrap this in New and then fuse because the elements +-- might contain references to the immutable vector! +constructN !n f = runST ( + do + v <- M.new n + v' <- unsafeFreeze v + fill v' 0 + ) + where + fill :: forall s. v a -> Int -> ST s (v a) + fill !v i | i < n = let x = f (unsafeTake i v) + in + elemseq v x $ + do + v' <- unsafeThaw v + M.unsafeWrite v' i x + v'' <- unsafeFreeze v' + fill v'' (i+1) + + fill v _ = return v + +-- | /O(n)/ Construct a vector with @n@ elements from right to left by +-- repeatedly applying the generator function to the already constructed part +-- of the vector. +-- +-- > constructrN 3 f = let a = f <> ; b = f<a> ; c = f <b,a> in f <c,b,a> +-- +constructrN :: forall v a. Vector v a => Int -> (v a -> a) -> v a +{-# INLINE constructrN #-} +-- NOTE: We *CANNOT* wrap this in New and then fuse because the elements +-- might contain references to the immutable vector! +constructrN !n f = runST ( + do + v <- n `seq` M.new n + v' <- unsafeFreeze v + fill v' 0 + ) + where + fill :: forall s. v a -> Int -> ST s (v a) + fill !v i | i < n = let x = f (unsafeSlice (n-i) i v) + in + elemseq v x $ + do + v' <- unsafeThaw v + M.unsafeWrite v' (n-i-1) x + v'' <- unsafeFreeze v' + fill v'' (i+1) + + fill v _ = return v + + +-- Enumeration +-- ----------- + +-- | /O(n)/ Yield a vector of the given length containing the values @x@, @x+1@ +-- etc. This operation is usually more efficient than 'enumFromTo'. +-- +-- > enumFromN 5 3 = <5,6,7> +enumFromN :: (Vector v a, Num a) => a -> Int -> v a +{-# INLINE enumFromN #-} +enumFromN x n = enumFromStepN x 1 n + +-- | /O(n)/ Yield a vector of the given length containing the values @x@, @x+y@, +-- @x+y+y@ etc. This operations is usually more efficient than 'enumFromThenTo'. +-- +-- > enumFromStepN 1 0.1 5 = <1,1.1,1.2,1.3,1.4> +enumFromStepN :: forall v a. (Vector v a, Num a) => a -> a -> Int -> v a +{-# INLINE enumFromStepN #-} +enumFromStepN x y n = elemseq (undefined :: v a) x + $ elemseq (undefined :: v a) y + $ unstream + $ Bundle.enumFromStepN x y n + +-- | /O(n)/ Enumerate values from @x@ to @y@. +-- +-- /WARNING:/ This operation can be very inefficient. If at all possible, use +-- 'enumFromN' instead. +enumFromTo :: (Vector v a, Enum a) => a -> a -> v a +{-# INLINE enumFromTo #-} +enumFromTo x y = unstream (Bundle.enumFromTo x y) + +-- | /O(n)/ Enumerate values from @x@ to @y@ with a specific step @z@. +-- +-- /WARNING:/ This operation can be very inefficient. If at all possible, use +-- 'enumFromStepN' instead. +enumFromThenTo :: (Vector v a, Enum a) => a -> a -> a -> v a +{-# INLINE enumFromThenTo #-} +enumFromThenTo x y z = unstream (Bundle.enumFromThenTo x y z) + +-- Concatenation +-- ------------- + +-- | /O(n)/ Prepend an element +cons :: forall v a. Vector v a => a -> v a -> v a +{-# INLINE cons #-} +cons x v = elemseq (undefined :: v a) x + $ unstream + $ Bundle.cons x + $ stream v + +-- | /O(n)/ Append an element +snoc :: forall v a. Vector v a => v a -> a -> v a +{-# INLINE snoc #-} +snoc v x = elemseq (undefined :: v a) x + $ unstream + $ Bundle.snoc (stream v) x + +infixr 5 ++ +-- | /O(m+n)/ Concatenate two vectors +(++) :: Vector v a => v a -> v a -> v a +{-# INLINE (++) #-} +v ++ w = unstream (stream v Bundle.++ stream w) + +-- | /O(n)/ Concatenate all vectors in the list +concat :: Vector v a => [v a] -> v a +{-# INLINE concat #-} +concat = unstream . Bundle.fromVectors +{- +concat vs = unstream (Bundle.flatten mk step (Exact n) (Bundle.fromList vs)) + where + n = List.foldl' (\k v -> k + length v) 0 vs + + {-# INLINE_INNER step #-} + step (v,i,k) + | i < k = case unsafeIndexM v i of + Box x -> Bundle.Yield x (v,i+1,k) + | otherwise = Bundle.Done + + {-# INLINE mk #-} + mk v = let k = length v + in + k `seq` (v,0,k) +-} + +-- | /O(n)/ Concatenate all vectors in the non-empty list +concatNE :: Vector v a => NonEmpty.NonEmpty (v a) -> v a +concatNE = concat . NonEmpty.toList + +-- Monadic initialisation +-- ---------------------- + +-- | /O(n)/ Execute the monadic action the given number of times and store the +-- results in a vector. +replicateM :: (Monad m, Vector v a) => Int -> m a -> m (v a) +{-# INLINE replicateM #-} +replicateM n m = unstreamM (MBundle.replicateM n m) + +-- | /O(n)/ Construct a vector of the given length by applying the monadic +-- action to each index +generateM :: (Monad m, Vector v a) => Int -> (Int -> m a) -> m (v a) +{-# INLINE generateM #-} +generateM n f = unstreamM (MBundle.generateM n f) + +-- | /O(n)/ Apply monadic function n times to value. Zeroth element is original value. +iterateNM :: (Monad m, Vector v a) => Int -> (a -> m a) -> a -> m (v a) +{-# INLINE iterateNM #-} +iterateNM n f x = unstreamM (MBundle.iterateNM n f x) + +-- | Execute the monadic action and freeze the resulting vector. +-- +-- @ +-- create (do { v \<- 'M.new' 2; 'M.write' v 0 \'a\'; 'M.write' v 1 \'b\'; return v }) = \<'a','b'\> +-- @ +create :: Vector v a => (forall s. ST s (Mutable v s a)) -> v a +{-# INLINE create #-} +create p = new (New.create p) + +-- | Execute the monadic action and freeze the resulting vectors. +createT + :: (T.Traversable f, Vector v a) + => (forall s. ST s (f (Mutable v s a))) -> f (v a) +{-# INLINE createT #-} +createT p = runST (p >>= T.mapM unsafeFreeze) + +-- Restricting memory usage +-- ------------------------ + +-- | /O(n)/ Yield the argument but force it not to retain any extra memory, +-- possibly by copying it. +-- +-- This is especially useful when dealing with slices. For example: +-- +-- > force (slice 0 2 <huge vector>) +-- +-- Here, the slice retains a reference to the huge vector. Forcing it creates +-- a copy of just the elements that belong to the slice and allows the huge +-- vector to be garbage collected. +force :: Vector v a => v a -> v a +-- FIXME: we probably ought to inline this later as the rules still might fire +-- otherwise +{-# INLINE_FUSED force #-} +force v = new (clone v) + +-- Bulk updates +-- ------------ + +-- | /O(m+n)/ For each pair @(i,a)@ from the list, replace the vector +-- element at position @i@ by @a@. +-- +-- > <5,9,2,7> // [(2,1),(0,3),(2,8)] = <3,9,8,7> +-- +(//) :: Vector v a => v a -- ^ initial vector (of length @m@) + -> [(Int, a)] -- ^ list of index/value pairs (of length @n@) + -> v a +{-# INLINE (//) #-} +v // us = update_stream v (Bundle.fromList us) + +-- | /O(m+n)/ For each pair @(i,a)@ from the vector of index/value pairs, +-- replace the vector element at position @i@ by @a@. +-- +-- > update <5,9,2,7> <(2,1),(0,3),(2,8)> = <3,9,8,7> +-- +update :: (Vector v a, Vector v (Int, a)) + => v a -- ^ initial vector (of length @m@) + -> v (Int, a) -- ^ vector of index/value pairs (of length @n@) + -> v a +{-# INLINE update #-} +update v w = update_stream v (stream w) + +-- | /O(m+min(n1,n2))/ For each index @i@ from the index vector and the +-- corresponding value @a@ from the value vector, replace the element of the +-- initial vector at position @i@ by @a@. +-- +-- > update_ <5,9,2,7> <2,0,2> <1,3,8> = <3,9,8,7> +-- +-- This function is useful for instances of 'Vector' that cannot store pairs. +-- Otherwise, 'update' is probably more convenient. +-- +-- @ +-- update_ xs is ys = 'update' xs ('zip' is ys) +-- @ +update_ :: (Vector v a, Vector v Int) + => v a -- ^ initial vector (of length @m@) + -> v Int -- ^ index vector (of length @n1@) + -> v a -- ^ value vector (of length @n2@) + -> v a +{-# INLINE update_ #-} +update_ v is w = update_stream v (Bundle.zipWith (,) (stream is) (stream w)) + +update_stream :: Vector v a => v a -> Bundle u (Int,a) -> v a +{-# INLINE update_stream #-} +update_stream = modifyWithBundle M.update + +-- | Same as ('//') but without bounds checking. +unsafeUpd :: Vector v a => v a -> [(Int, a)] -> v a +{-# INLINE unsafeUpd #-} +unsafeUpd v us = unsafeUpdate_stream v (Bundle.fromList us) + +-- | Same as 'update' but without bounds checking. +unsafeUpdate :: (Vector v a, Vector v (Int, a)) => v a -> v (Int, a) -> v a +{-# INLINE unsafeUpdate #-} +unsafeUpdate v w = unsafeUpdate_stream v (stream w) + +-- | Same as 'update_' but without bounds checking. +unsafeUpdate_ :: (Vector v a, Vector v Int) => v a -> v Int -> v a -> v a +{-# INLINE unsafeUpdate_ #-} +unsafeUpdate_ v is w + = unsafeUpdate_stream v (Bundle.zipWith (,) (stream is) (stream w)) + +unsafeUpdate_stream :: Vector v a => v a -> Bundle u (Int,a) -> v a +{-# INLINE unsafeUpdate_stream #-} +unsafeUpdate_stream = modifyWithBundle M.unsafeUpdate + +-- Accumulations +-- ------------- + +-- | /O(m+n)/ For each pair @(i,b)@ from the list, replace the vector element +-- @a@ at position @i@ by @f a b@. +-- +-- > accum (+) <5,9,2> [(2,4),(1,6),(0,3),(1,7)] = <5+3, 9+6+7, 2+4> +accum :: Vector v a + => (a -> b -> a) -- ^ accumulating function @f@ + -> v a -- ^ initial vector (of length @m@) + -> [(Int,b)] -- ^ list of index/value pairs (of length @n@) + -> v a +{-# INLINE accum #-} +accum f v us = accum_stream f v (Bundle.fromList us) + +-- | /O(m+n)/ For each pair @(i,b)@ from the vector of pairs, replace the vector +-- element @a@ at position @i@ by @f a b@. +-- +-- > accumulate (+) <5,9,2> <(2,4),(1,6),(0,3),(1,7)> = <5+3, 9+6+7, 2+4> +accumulate :: (Vector v a, Vector v (Int, b)) + => (a -> b -> a) -- ^ accumulating function @f@ + -> v a -- ^ initial vector (of length @m@) + -> v (Int,b) -- ^ vector of index/value pairs (of length @n@) + -> v a +{-# INLINE accumulate #-} +accumulate f v us = accum_stream f v (stream us) + +-- | /O(m+min(n1,n2))/ For each index @i@ from the index vector and the +-- corresponding value @b@ from the the value vector, +-- replace the element of the initial vector at +-- position @i@ by @f a b@. +-- +-- > accumulate_ (+) <5,9,2> <2,1,0,1> <4,6,3,7> = <5+3, 9+6+7, 2+4> +-- +-- This function is useful for instances of 'Vector' that cannot store pairs. +-- Otherwise, 'accumulate' is probably more convenient: +-- +-- @ +-- accumulate_ f as is bs = 'accumulate' f as ('zip' is bs) +-- @ +accumulate_ :: (Vector v a, Vector v Int, Vector v b) + => (a -> b -> a) -- ^ accumulating function @f@ + -> v a -- ^ initial vector (of length @m@) + -> v Int -- ^ index vector (of length @n1@) + -> v b -- ^ value vector (of length @n2@) + -> v a +{-# INLINE accumulate_ #-} +accumulate_ f v is xs = accum_stream f v (Bundle.zipWith (,) (stream is) + (stream xs)) + + +accum_stream :: Vector v a => (a -> b -> a) -> v a -> Bundle u (Int,b) -> v a +{-# INLINE accum_stream #-} +accum_stream f = modifyWithBundle (M.accum f) + +-- | Same as 'accum' but without bounds checking. +unsafeAccum :: Vector v a => (a -> b -> a) -> v a -> [(Int,b)] -> v a +{-# INLINE unsafeAccum #-} +unsafeAccum f v us = unsafeAccum_stream f v (Bundle.fromList us) + +-- | Same as 'accumulate' but without bounds checking. +unsafeAccumulate :: (Vector v a, Vector v (Int, b)) + => (a -> b -> a) -> v a -> v (Int,b) -> v a +{-# INLINE unsafeAccumulate #-} +unsafeAccumulate f v us = unsafeAccum_stream f v (stream us) + +-- | Same as 'accumulate_' but without bounds checking. +unsafeAccumulate_ :: (Vector v a, Vector v Int, Vector v b) + => (a -> b -> a) -> v a -> v Int -> v b -> v a +{-# INLINE unsafeAccumulate_ #-} +unsafeAccumulate_ f v is xs + = unsafeAccum_stream f v (Bundle.zipWith (,) (stream is) (stream xs)) + +unsafeAccum_stream + :: Vector v a => (a -> b -> a) -> v a -> Bundle u (Int,b) -> v a +{-# INLINE unsafeAccum_stream #-} +unsafeAccum_stream f = modifyWithBundle (M.unsafeAccum f) + +-- Permutations +-- ------------ + +-- | /O(n)/ Reverse a vector +reverse :: (Vector v a) => v a -> v a +{-# INLINE reverse #-} +-- FIXME: make this fuse better, add support for recycling +reverse = unstream . streamR + +-- | /O(n)/ Yield the vector obtained by replacing each element @i@ of the +-- index vector by @xs'!'i@. This is equivalent to @'map' (xs'!') is@ but is +-- often much more efficient. +-- +-- > backpermute <a,b,c,d> <0,3,2,3,1,0> = <a,d,c,d,b,a> +backpermute :: (Vector v a, Vector v Int) + => v a -- ^ @xs@ value vector + -> v Int -- ^ @is@ index vector (of length @n@) + -> v a +{-# INLINE backpermute #-} +-- This somewhat non-intuitive definition ensures that the resulting vector +-- does not retain references to the original one even if it is lazy in its +-- elements. This would not be the case if we simply used map (v!) +backpermute v is = seq v + $ seq n + $ unstream + $ Bundle.unbox + $ Bundle.map index + $ stream is + where + n = length v + + {-# INLINE index #-} + -- NOTE: we do it this way to avoid triggering LiberateCase on n in + -- polymorphic code + index i = BOUNDS_CHECK(checkIndex) "backpermute" i n + $ basicUnsafeIndexM v i + +-- | Same as 'backpermute' but without bounds checking. +unsafeBackpermute :: (Vector v a, Vector v Int) => v a -> v Int -> v a +{-# INLINE unsafeBackpermute #-} +unsafeBackpermute v is = seq v + $ seq n + $ unstream + $ Bundle.unbox + $ Bundle.map index + $ stream is + where + n = length v + + {-# INLINE index #-} + -- NOTE: we do it this way to avoid triggering LiberateCase on n in + -- polymorphic code + index i = UNSAFE_CHECK(checkIndex) "unsafeBackpermute" i n + $ basicUnsafeIndexM v i + +-- Safe destructive updates +-- ------------------------ + +-- | Apply a destructive operation to a vector. The operation will be +-- performed in place if it is safe to do so and will modify a copy of the +-- vector otherwise. +-- +-- @ +-- modify (\\v -> 'M.write' v 0 \'x\') ('replicate' 3 \'a\') = \<\'x\',\'a\',\'a\'\> +-- @ +modify :: Vector v a => (forall s. Mutable v s a -> ST s ()) -> v a -> v a +{-# INLINE modify #-} +modify p = new . New.modify p . clone + +-- We have to make sure that this is strict in the stream but we can't seq on +-- it while fusion is happening. Hence this ugliness. +modifyWithBundle :: Vector v a + => (forall s. Mutable v s a -> Bundle u b -> ST s ()) + -> v a -> Bundle u b -> v a +{-# INLINE modifyWithBundle #-} +modifyWithBundle p v s = new (New.modifyWithBundle p (clone v) s) + +-- Indexing +-- -------- + +-- | /O(n)/ Pair each element in a vector with its index +indexed :: (Vector v a, Vector v (Int,a)) => v a -> v (Int,a) +{-# INLINE indexed #-} +indexed = unstream . Bundle.indexed . stream + +-- Mapping +-- ------- + +-- | /O(n)/ Map a function over a vector +map :: (Vector v a, Vector v b) => (a -> b) -> v a -> v b +{-# INLINE map #-} +map f = unstream . inplace (S.map f) id . stream + +-- | /O(n)/ Apply a function to every element of a vector and its index +imap :: (Vector v a, Vector v b) => (Int -> a -> b) -> v a -> v b +{-# INLINE imap #-} +imap f = unstream . inplace (S.map (uncurry f) . S.indexed) id + . stream + +-- | Map a function over a vector and concatenate the results. +concatMap :: (Vector v a, Vector v b) => (a -> v b) -> v a -> v b +{-# INLINE concatMap #-} +-- NOTE: We can't fuse concatMap anyway so don't pretend we do. +-- This seems to be slightly slower +-- concatMap f = concat . Bundle.toList . Bundle.map f . stream + +-- Slowest +-- concatMap f = unstream . Bundle.concatMap (stream . f) . stream + +-- Used to be fastest +{- +concatMap f = unstream + . Bundle.flatten mk step Unknown + . stream + where + {-# INLINE_INNER step #-} + step (v,i,k) + | i < k = case unsafeIndexM v i of + Box x -> Bundle.Yield x (v,i+1,k) + | otherwise = Bundle.Done + + {-# INLINE mk #-} + mk x = let v = f x + k = length v + in + k `seq` (v,0,k) +-} + +-- This seems to be fastest now +concatMap f = unstream + . Bundle.concatVectors + . Bundle.map f + . stream + +-- Monadic mapping +-- --------------- + +-- | /O(n)/ Apply the monadic action to all elements of the vector, yielding a +-- vector of results +mapM :: (Monad m, Vector v a, Vector v b) => (a -> m b) -> v a -> m (v b) +{-# INLINE mapM #-} +mapM f = unstreamM . Bundle.mapM f . stream + +-- | /O(n)/ Apply the monadic action to every element of a vector and its +-- index, yielding a vector of results +imapM :: (Monad m, Vector v a, Vector v b) + => (Int -> a -> m b) -> v a -> m (v b) +imapM f = unstreamM . Bundle.mapM (uncurry f) . Bundle.indexed . stream + +-- | /O(n)/ Apply the monadic action to all elements of a vector and ignore the +-- results +mapM_ :: (Monad m, Vector v a) => (a -> m b) -> v a -> m () +{-# INLINE mapM_ #-} +mapM_ f = Bundle.mapM_ f . stream + +-- | /O(n)/ Apply the monadic action to every element of a vector and its +-- index, ignoring the results +imapM_ :: (Monad m, Vector v a) => (Int -> a -> m b) -> v a -> m () +{-# INLINE imapM_ #-} +imapM_ f = Bundle.mapM_ (uncurry f) . Bundle.indexed . stream + +-- | /O(n)/ Apply the monadic action to all elements of the vector, yielding a +-- vector of results. Equivalent to @flip 'mapM'@. +forM :: (Monad m, Vector v a, Vector v b) => v a -> (a -> m b) -> m (v b) +{-# INLINE forM #-} +forM as f = mapM f as + +-- | /O(n)/ Apply the monadic action to all elements of a vector and ignore the +-- results. Equivalent to @flip 'mapM_'@. +forM_ :: (Monad m, Vector v a) => v a -> (a -> m b) -> m () +{-# INLINE forM_ #-} +forM_ as f = mapM_ f as + +-- Zipping +-- ------- + +-- | /O(min(m,n))/ Zip two vectors with the given function. +zipWith :: (Vector v a, Vector v b, Vector v c) + => (a -> b -> c) -> v a -> v b -> v c +{-# INLINE zipWith #-} +zipWith f = \xs ys -> unstream (Bundle.zipWith f (stream xs) (stream ys)) + +-- | Zip three vectors with the given function. +zipWith3 :: (Vector v a, Vector v b, Vector v c, Vector v d) + => (a -> b -> c -> d) -> v a -> v b -> v c -> v d +{-# INLINE zipWith3 #-} +zipWith3 f = \as bs cs -> unstream (Bundle.zipWith3 f (stream as) + (stream bs) + (stream cs)) + +zipWith4 :: (Vector v a, Vector v b, Vector v c, Vector v d, Vector v e) + => (a -> b -> c -> d -> e) -> v a -> v b -> v c -> v d -> v e +{-# INLINE zipWith4 #-} +zipWith4 f = \as bs cs ds -> + unstream (Bundle.zipWith4 f (stream as) + (stream bs) + (stream cs) + (stream ds)) + +zipWith5 :: (Vector v a, Vector v b, Vector v c, Vector v d, Vector v e, + Vector v f) + => (a -> b -> c -> d -> e -> f) -> v a -> v b -> v c -> v d -> v e + -> v f +{-# INLINE zipWith5 #-} +zipWith5 f = \as bs cs ds es -> + unstream (Bundle.zipWith5 f (stream as) + (stream bs) + (stream cs) + (stream ds) + (stream es)) + +zipWith6 :: (Vector v a, Vector v b, Vector v c, Vector v d, Vector v e, + Vector v f, Vector v g) + => (a -> b -> c -> d -> e -> f -> g) + -> v a -> v b -> v c -> v d -> v e -> v f -> v g +{-# INLINE zipWith6 #-} +zipWith6 f = \as bs cs ds es fs -> + unstream (Bundle.zipWith6 f (stream as) + (stream bs) + (stream cs) + (stream ds) + (stream es) + (stream fs)) + +-- | /O(min(m,n))/ Zip two vectors with a function that also takes the +-- elements' indices. +izipWith :: (Vector v a, Vector v b, Vector v c) + => (Int -> a -> b -> c) -> v a -> v b -> v c +{-# INLINE izipWith #-} +izipWith f = \xs ys -> + unstream (Bundle.zipWith (uncurry f) (Bundle.indexed (stream xs)) + (stream ys)) + +izipWith3 :: (Vector v a, Vector v b, Vector v c, Vector v d) + => (Int -> a -> b -> c -> d) -> v a -> v b -> v c -> v d +{-# INLINE izipWith3 #-} +izipWith3 f = \as bs cs -> + unstream (Bundle.zipWith3 (uncurry f) (Bundle.indexed (stream as)) + (stream bs) + (stream cs)) + +izipWith4 :: (Vector v a, Vector v b, Vector v c, Vector v d, Vector v e) + => (Int -> a -> b -> c -> d -> e) -> v a -> v b -> v c -> v d -> v e +{-# INLINE izipWith4 #-} +izipWith4 f = \as bs cs ds -> + unstream (Bundle.zipWith4 (uncurry f) (Bundle.indexed (stream as)) + (stream bs) + (stream cs) + (stream ds)) + +izipWith5 :: (Vector v a, Vector v b, Vector v c, Vector v d, Vector v e, + Vector v f) + => (Int -> a -> b -> c -> d -> e -> f) -> v a -> v b -> v c -> v d + -> v e -> v f +{-# INLINE izipWith5 #-} +izipWith5 f = \as bs cs ds es -> + unstream (Bundle.zipWith5 (uncurry f) (Bundle.indexed (stream as)) + (stream bs) + (stream cs) + (stream ds) + (stream es)) + +izipWith6 :: (Vector v a, Vector v b, Vector v c, Vector v d, Vector v e, + Vector v f, Vector v g) + => (Int -> a -> b -> c -> d -> e -> f -> g) + -> v a -> v b -> v c -> v d -> v e -> v f -> v g +{-# INLINE izipWith6 #-} +izipWith6 f = \as bs cs ds es fs -> + unstream (Bundle.zipWith6 (uncurry f) (Bundle.indexed (stream as)) + (stream bs) + (stream cs) + (stream ds) + (stream es) + (stream fs)) + +-- | /O(min(m,n))/ Zip two vectors +zip :: (Vector v a, Vector v b, Vector v (a,b)) => v a -> v b -> v (a, b) +{-# INLINE zip #-} +zip = zipWith (,) + +zip3 :: (Vector v a, Vector v b, Vector v c, Vector v (a, b, c)) + => v a -> v b -> v c -> v (a, b, c) +{-# INLINE zip3 #-} +zip3 = zipWith3 (,,) + +zip4 :: (Vector v a, Vector v b, Vector v c, Vector v d, Vector v (a, b, c, d)) + => v a -> v b -> v c -> v d -> v (a, b, c, d) +{-# INLINE zip4 #-} +zip4 = zipWith4 (,,,) + +zip5 :: (Vector v a, Vector v b, Vector v c, Vector v d, Vector v e, + Vector v (a, b, c, d, e)) + => v a -> v b -> v c -> v d -> v e -> v (a, b, c, d, e) +{-# INLINE zip5 #-} +zip5 = zipWith5 (,,,,) + +zip6 :: (Vector v a, Vector v b, Vector v c, Vector v d, Vector v e, + Vector v f, Vector v (a, b, c, d, e, f)) + => v a -> v b -> v c -> v d -> v e -> v f -> v (a, b, c, d, e, f) +{-# INLINE zip6 #-} +zip6 = zipWith6 (,,,,,) + +-- Monadic zipping +-- --------------- + +-- | /O(min(m,n))/ Zip the two vectors with the monadic action and yield a +-- vector of results +zipWithM :: (Monad m, Vector v a, Vector v b, Vector v c) + => (a -> b -> m c) -> v a -> v b -> m (v c) +-- FIXME: specialise for ST and IO? +{-# INLINE zipWithM #-} +zipWithM f = \as bs -> unstreamM $ Bundle.zipWithM f (stream as) (stream bs) + +-- | /O(min(m,n))/ Zip the two vectors with a monadic action that also takes +-- the element index and yield a vector of results +izipWithM :: (Monad m, Vector v a, Vector v b, Vector v c) + => (Int -> a -> b -> m c) -> v a -> v b -> m (v c) +{-# INLINE izipWithM #-} +izipWithM m as bs = unstreamM . Bundle.zipWithM (uncurry m) + (Bundle.indexed (stream as)) + $ stream bs + +-- | /O(min(m,n))/ Zip the two vectors with the monadic action and ignore the +-- results +zipWithM_ :: (Monad m, Vector v a, Vector v b) + => (a -> b -> m c) -> v a -> v b -> m () +{-# INLINE zipWithM_ #-} +zipWithM_ f = \as bs -> Bundle.zipWithM_ f (stream as) (stream bs) + +-- | /O(min(m,n))/ Zip the two vectors with a monadic action that also takes +-- the element index and ignore the results +izipWithM_ :: (Monad m, Vector v a, Vector v b) + => (Int -> a -> b -> m c) -> v a -> v b -> m () +{-# INLINE izipWithM_ #-} +izipWithM_ m as bs = Bundle.zipWithM_ (uncurry m) + (Bundle.indexed (stream as)) + $ stream bs + +-- Unzipping +-- --------- + +-- | /O(min(m,n))/ Unzip a vector of pairs. +unzip :: (Vector v a, Vector v b, Vector v (a,b)) => v (a, b) -> (v a, v b) +{-# INLINE unzip #-} +unzip xs = (map fst xs, map snd xs) + +unzip3 :: (Vector v a, Vector v b, Vector v c, Vector v (a, b, c)) + => v (a, b, c) -> (v a, v b, v c) +{-# INLINE unzip3 #-} +unzip3 xs = (map (\(a, _, _) -> a) xs, + map (\(_, b, _) -> b) xs, + map (\(_, _, c) -> c) xs) + +unzip4 :: (Vector v a, Vector v b, Vector v c, Vector v d, + Vector v (a, b, c, d)) + => v (a, b, c, d) -> (v a, v b, v c, v d) +{-# INLINE unzip4 #-} +unzip4 xs = (map (\(a, _, _, _) -> a) xs, + map (\(_, b, _, _) -> b) xs, + map (\(_, _, c, _) -> c) xs, + map (\(_, _, _, d) -> d) xs) + +unzip5 :: (Vector v a, Vector v b, Vector v c, Vector v d, Vector v e, + Vector v (a, b, c, d, e)) + => v (a, b, c, d, e) -> (v a, v b, v c, v d, v e) +{-# INLINE unzip5 #-} +unzip5 xs = (map (\(a, _, _, _, _) -> a) xs, + map (\(_, b, _, _, _) -> b) xs, + map (\(_, _, c, _, _) -> c) xs, + map (\(_, _, _, d, _) -> d) xs, + map (\(_, _, _, _, e) -> e) xs) + +unzip6 :: (Vector v a, Vector v b, Vector v c, Vector v d, Vector v e, + Vector v f, Vector v (a, b, c, d, e, f)) + => v (a, b, c, d, e, f) -> (v a, v b, v c, v d, v e, v f) +{-# INLINE unzip6 #-} +unzip6 xs = (map (\(a, _, _, _, _, _) -> a) xs, + map (\(_, b, _, _, _, _) -> b) xs, + map (\(_, _, c, _, _, _) -> c) xs, + map (\(_, _, _, d, _, _) -> d) xs, + map (\(_, _, _, _, e, _) -> e) xs, + map (\(_, _, _, _, _, f) -> f) xs) + +-- Filtering +-- --------- + +-- | /O(n)/ Drop elements that do not satisfy the predicate +filter :: Vector v a => (a -> Bool) -> v a -> v a +{-# INLINE filter #-} +filter f = unstream . inplace (S.filter f) toMax . stream + +-- | /O(n)/ Drop elements that do not satisfy the predicate which is applied to +-- values and their indices +ifilter :: Vector v a => (Int -> a -> Bool) -> v a -> v a +{-# INLINE ifilter #-} +ifilter f = unstream + . inplace (S.map snd . S.filter (uncurry f) . S.indexed) toMax + . stream + +-- | /O(n)/ Drop repeated adjacent elements. +uniq :: (Vector v a, Eq a) => v a -> v a +{-# INLINE uniq #-} +uniq = unstream . inplace S.uniq toMax . stream + +-- | /O(n)/ Drop elements when predicate returns Nothing +mapMaybe :: (Vector v a, Vector v b) => (a -> Maybe b) -> v a -> v b +{-# INLINE mapMaybe #-} +mapMaybe f = unstream . inplace (S.mapMaybe f) toMax . stream + +-- | /O(n)/ Drop elements when predicate, applied to index and value, returns Nothing +imapMaybe :: (Vector v a, Vector v b) => (Int -> a -> Maybe b) -> v a -> v b +{-# INLINE imapMaybe #-} +imapMaybe f = unstream + . inplace (S.mapMaybe (uncurry f) . S.indexed) toMax + . stream + + +-- | /O(n)/ Drop elements that do not satisfy the monadic predicate +filterM :: (Monad m, Vector v a) => (a -> m Bool) -> v a -> m (v a) +{-# INLINE filterM #-} +filterM f = unstreamM . Bundle.filterM f . stream + +-- | /O(n)/ Yield the longest prefix of elements satisfying the predicate +-- without copying. +takeWhile :: Vector v a => (a -> Bool) -> v a -> v a +{-# INLINE takeWhile #-} +takeWhile f = unstream . Bundle.takeWhile f . stream + +-- | /O(n)/ Drop the longest prefix of elements that satisfy the predicate +-- without copying. +dropWhile :: Vector v a => (a -> Bool) -> v a -> v a +{-# INLINE dropWhile #-} +dropWhile f = unstream . Bundle.dropWhile f . stream + +-- Parititioning +-- ------------- + +-- | /O(n)/ Split the vector in two parts, the first one containing those +-- elements that satisfy the predicate and the second one those that don't. The +-- relative order of the elements is preserved at the cost of a sometimes +-- reduced performance compared to 'unstablePartition'. +partition :: Vector v a => (a -> Bool) -> v a -> (v a, v a) +{-# INLINE partition #-} +partition f = partition_stream f . stream + +-- FIXME: Make this inplace-fusible (look at how stable_partition is +-- implemented in C++) + +partition_stream :: Vector v a => (a -> Bool) -> Bundle u a -> (v a, v a) +{-# INLINE_FUSED partition_stream #-} +partition_stream f s = s `seq` runST ( + do + (mv1,mv2) <- M.partitionBundle f s + v1 <- unsafeFreeze mv1 + v2 <- unsafeFreeze mv2 + return (v1,v2)) + +-- | /O(n)/ Split the vector in two parts, the first one containing those +-- elements that satisfy the predicate and the second one those that don't. +-- The order of the elements is not preserved but the operation is often +-- faster than 'partition'. +unstablePartition :: Vector v a => (a -> Bool) -> v a -> (v a, v a) +{-# INLINE unstablePartition #-} +unstablePartition f = unstablePartition_stream f . stream + +unstablePartition_stream + :: Vector v a => (a -> Bool) -> Bundle u a -> (v a, v a) +{-# INLINE_FUSED unstablePartition_stream #-} +unstablePartition_stream f s = s `seq` runST ( + do + (mv1,mv2) <- M.unstablePartitionBundle f s + v1 <- unsafeFreeze mv1 + v2 <- unsafeFreeze mv2 + return (v1,v2)) + +unstablePartition_new :: Vector v a => (a -> Bool) -> New v a -> (v a, v a) +{-# INLINE_FUSED unstablePartition_new #-} +unstablePartition_new f (New.New p) = runST ( + do + mv <- p + i <- M.unstablePartition f mv + v <- unsafeFreeze mv + return (unsafeTake i v, unsafeDrop i v)) + +{-# RULES + +"unstablePartition" forall f p. + unstablePartition_stream f (stream (new p)) + = unstablePartition_new f p #-} + + + + +-- FIXME: make span and break fusible + +-- | /O(n)/ Split the vector into the longest prefix of elements that satisfy +-- the predicate and the rest without copying. +span :: Vector v a => (a -> Bool) -> v a -> (v a, v a) +{-# INLINE span #-} +span f = break (not . f) + +-- | /O(n)/ Split the vector into the longest prefix of elements that do not +-- satisfy the predicate and the rest without copying. +break :: Vector v a => (a -> Bool) -> v a -> (v a, v a) +{-# INLINE break #-} +break f xs = case findIndex f xs of + Just i -> (unsafeSlice 0 i xs, unsafeSlice i (length xs - i) xs) + Nothing -> (xs, empty) + + +-- Searching +-- --------- + +infix 4 `elem` +-- | /O(n)/ Check if the vector contains an element +elem :: (Vector v a, Eq a) => a -> v a -> Bool +{-# INLINE elem #-} +elem x = Bundle.elem x . stream + +infix 4 `notElem` +-- | /O(n)/ Check if the vector does not contain an element (inverse of 'elem') +notElem :: (Vector v a, Eq a) => a -> v a -> Bool +{-# INLINE notElem #-} +notElem x = Bundle.notElem x . stream + +-- | /O(n)/ Yield 'Just' the first element matching the predicate or 'Nothing' +-- if no such element exists. +find :: Vector v a => (a -> Bool) -> v a -> Maybe a +{-# INLINE find #-} +find f = Bundle.find f . stream + +-- | /O(n)/ Yield 'Just' the index of the first element matching the predicate +-- or 'Nothing' if no such element exists. +findIndex :: Vector v a => (a -> Bool) -> v a -> Maybe Int +{-# INLINE findIndex #-} +findIndex f = Bundle.findIndex f . stream + +-- | /O(n)/ Yield the indices of elements satisfying the predicate in ascending +-- order. +findIndices :: (Vector v a, Vector v Int) => (a -> Bool) -> v a -> v Int +{-# INLINE findIndices #-} +findIndices f = unstream + . inplace (S.map fst . S.filter (f . snd) . S.indexed) toMax + . stream + +-- | /O(n)/ Yield 'Just' the index of the first occurence of the given element or +-- 'Nothing' if the vector does not contain the element. This is a specialised +-- version of 'findIndex'. +elemIndex :: (Vector v a, Eq a) => a -> v a -> Maybe Int +{-# INLINE elemIndex #-} +elemIndex x = findIndex (x==) + +-- | /O(n)/ Yield the indices of all occurences of the given element in +-- ascending order. This is a specialised version of 'findIndices'. +elemIndices :: (Vector v a, Vector v Int, Eq a) => a -> v a -> v Int +{-# INLINE elemIndices #-} +elemIndices x = findIndices (x==) + +-- Folding +-- ------- + +-- | /O(n)/ Left fold +foldl :: Vector v b => (a -> b -> a) -> a -> v b -> a +{-# INLINE foldl #-} +foldl f z = Bundle.foldl f z . stream + +-- | /O(n)/ Left fold on non-empty vectors +foldl1 :: Vector v a => (a -> a -> a) -> v a -> a +{-# INLINE foldl1 #-} +foldl1 f = Bundle.foldl1 f . stream + +-- | /O(n)/ Left fold with strict accumulator +foldl' :: Vector v b => (a -> b -> a) -> a -> v b -> a +{-# INLINE foldl' #-} +foldl' f z = Bundle.foldl' f z . stream + +-- | /O(n)/ Left fold on non-empty vectors with strict accumulator +foldl1' :: Vector v a => (a -> a -> a) -> v a -> a +{-# INLINE foldl1' #-} +foldl1' f = Bundle.foldl1' f . stream + +-- | /O(n)/ Right fold +foldr :: Vector v a => (a -> b -> b) -> b -> v a -> b +{-# INLINE foldr #-} +foldr f z = Bundle.foldr f z . stream + +-- | /O(n)/ Right fold on non-empty vectors +foldr1 :: Vector v a => (a -> a -> a) -> v a -> a +{-# INLINE foldr1 #-} +foldr1 f = Bundle.foldr1 f . stream + +-- | /O(n)/ Right fold with a strict accumulator +foldr' :: Vector v a => (a -> b -> b) -> b -> v a -> b +{-# INLINE foldr' #-} +foldr' f z = Bundle.foldl' (flip f) z . streamR + +-- | /O(n)/ Right fold on non-empty vectors with strict accumulator +foldr1' :: Vector v a => (a -> a -> a) -> v a -> a +{-# INLINE foldr1' #-} +foldr1' f = Bundle.foldl1' (flip f) . streamR + +-- | /O(n)/ Left fold (function applied to each element and its index) +ifoldl :: Vector v b => (a -> Int -> b -> a) -> a -> v b -> a +{-# INLINE ifoldl #-} +ifoldl f z = Bundle.foldl (uncurry . f) z . Bundle.indexed . stream + +-- | /O(n)/ Left fold with strict accumulator (function applied to each element +-- and its index) +ifoldl' :: Vector v b => (a -> Int -> b -> a) -> a -> v b -> a +{-# INLINE ifoldl' #-} +ifoldl' f z = Bundle.foldl' (uncurry . f) z . Bundle.indexed . stream + +-- | /O(n)/ Right fold (function applied to each element and its index) +ifoldr :: Vector v a => (Int -> a -> b -> b) -> b -> v a -> b +{-# INLINE ifoldr #-} +ifoldr f z = Bundle.foldr (uncurry f) z . Bundle.indexed . stream + +-- | /O(n)/ Right fold with strict accumulator (function applied to each +-- element and its index) +ifoldr' :: Vector v a => (Int -> a -> b -> b) -> b -> v a -> b +{-# INLINE ifoldr' #-} +ifoldr' f z xs = Bundle.foldl' (flip (uncurry f)) z + $ Bundle.indexedR (length xs) $ streamR xs + +-- Specialised folds +-- ----------------- + +-- | /O(n)/ Check if all elements satisfy the predicate. +all :: Vector v a => (a -> Bool) -> v a -> Bool +{-# INLINE all #-} +all f = Bundle.and . Bundle.map f . stream + +-- | /O(n)/ Check if any element satisfies the predicate. +any :: Vector v a => (a -> Bool) -> v a -> Bool +{-# INLINE any #-} +any f = Bundle.or . Bundle.map f . stream + +-- | /O(n)/ Check if all elements are 'True' +and :: Vector v Bool => v Bool -> Bool +{-# INLINE and #-} +and = Bundle.and . stream + +-- | /O(n)/ Check if any element is 'True' +or :: Vector v Bool => v Bool -> Bool +{-# INLINE or #-} +or = Bundle.or . stream + +-- | /O(n)/ Compute the sum of the elements +sum :: (Vector v a, Num a) => v a -> a +{-# INLINE sum #-} +sum = Bundle.foldl' (+) 0 . stream + +-- | /O(n)/ Compute the produce of the elements +product :: (Vector v a, Num a) => v a -> a +{-# INLINE product #-} +product = Bundle.foldl' (*) 1 . stream + +-- | /O(n)/ Yield the maximum element of the vector. The vector may not be +-- empty. +maximum :: (Vector v a, Ord a) => v a -> a +{-# INLINE maximum #-} +maximum = Bundle.foldl1' max . stream + +-- | /O(n)/ Yield the maximum element of the vector according to the given +-- comparison function. The vector may not be empty. +maximumBy :: Vector v a => (a -> a -> Ordering) -> v a -> a +{-# INLINE maximumBy #-} +maximumBy cmpr = Bundle.foldl1' maxBy . stream + where + {-# INLINE maxBy #-} + maxBy x y = case cmpr x y of + LT -> y + _ -> x + +-- | /O(n)/ Yield the minimum element of the vector. The vector may not be +-- empty. +minimum :: (Vector v a, Ord a) => v a -> a +{-# INLINE minimum #-} +minimum = Bundle.foldl1' min . stream + +-- | /O(n)/ Yield the minimum element of the vector according to the given +-- comparison function. The vector may not be empty. +minimumBy :: Vector v a => (a -> a -> Ordering) -> v a -> a +{-# INLINE minimumBy #-} +minimumBy cmpr = Bundle.foldl1' minBy . stream + where + {-# INLINE minBy #-} + minBy x y = case cmpr x y of + GT -> y + _ -> x + +-- | /O(n)/ Yield the index of the maximum element of the vector. The vector +-- may not be empty. +maxIndex :: (Vector v a, Ord a) => v a -> Int +{-# INLINE maxIndex #-} +maxIndex = maxIndexBy compare + +-- | /O(n)/ Yield the index of the maximum element of the vector according to +-- the given comparison function. The vector may not be empty. +maxIndexBy :: Vector v a => (a -> a -> Ordering) -> v a -> Int +{-# INLINE maxIndexBy #-} +maxIndexBy cmpr = fst . Bundle.foldl1' imax . Bundle.indexed . stream + where + imax (i,x) (j,y) = i `seq` j `seq` + case cmpr x y of + LT -> (j,y) + _ -> (i,x) + +-- | /O(n)/ Yield the index of the minimum element of the vector. The vector +-- may not be empty. +minIndex :: (Vector v a, Ord a) => v a -> Int +{-# INLINE minIndex #-} +minIndex = minIndexBy compare + +-- | /O(n)/ Yield the index of the minimum element of the vector according to +-- the given comparison function. The vector may not be empty. +minIndexBy :: Vector v a => (a -> a -> Ordering) -> v a -> Int +{-# INLINE minIndexBy #-} +minIndexBy cmpr = fst . Bundle.foldl1' imin . Bundle.indexed . stream + where + imin (i,x) (j,y) = i `seq` j `seq` + case cmpr x y of + GT -> (j,y) + _ -> (i,x) + +-- Monadic folds +-- ------------- + +-- | /O(n)/ Monadic fold +foldM :: (Monad m, Vector v b) => (a -> b -> m a) -> a -> v b -> m a +{-# INLINE foldM #-} +foldM m z = Bundle.foldM m z . stream + +-- | /O(n)/ Monadic fold (action applied to each element and its index) +ifoldM :: (Monad m, Vector v b) => (a -> Int -> b -> m a) -> a -> v b -> m a +{-# INLINE ifoldM #-} +ifoldM m z = Bundle.foldM (uncurry . m) z . Bundle.indexed . stream + +-- | /O(n)/ Monadic fold over non-empty vectors +fold1M :: (Monad m, Vector v a) => (a -> a -> m a) -> v a -> m a +{-# INLINE fold1M #-} +fold1M m = Bundle.fold1M m . stream + +-- | /O(n)/ Monadic fold with strict accumulator +foldM' :: (Monad m, Vector v b) => (a -> b -> m a) -> a -> v b -> m a +{-# INLINE foldM' #-} +foldM' m z = Bundle.foldM' m z . stream + +-- | /O(n)/ Monadic fold with strict accumulator (action applied to each +-- element and its index) +ifoldM' :: (Monad m, Vector v b) => (a -> Int -> b -> m a) -> a -> v b -> m a +{-# INLINE ifoldM' #-} +ifoldM' m z = Bundle.foldM' (uncurry . m) z . Bundle.indexed . stream + +-- | /O(n)/ Monadic fold over non-empty vectors with strict accumulator +fold1M' :: (Monad m, Vector v a) => (a -> a -> m a) -> v a -> m a +{-# INLINE fold1M' #-} +fold1M' m = Bundle.fold1M' m . stream + +discard :: Monad m => m a -> m () +{-# INLINE discard #-} +discard m = m >> return () + +-- | /O(n)/ Monadic fold that discards the result +foldM_ :: (Monad m, Vector v b) => (a -> b -> m a) -> a -> v b -> m () +{-# INLINE foldM_ #-} +foldM_ m z = discard . Bundle.foldM m z . stream + +-- | /O(n)/ Monadic fold that discards the result (action applied to +-- each element and its index) +ifoldM_ :: (Monad m, Vector v b) => (a -> Int -> b -> m a) -> a -> v b -> m () +{-# INLINE ifoldM_ #-} +ifoldM_ m z = discard . Bundle.foldM (uncurry . m) z . Bundle.indexed . stream + +-- | /O(n)/ Monadic fold over non-empty vectors that discards the result +fold1M_ :: (Monad m, Vector v a) => (a -> a -> m a) -> v a -> m () +{-# INLINE fold1M_ #-} +fold1M_ m = discard . Bundle.fold1M m . stream + +-- | /O(n)/ Monadic fold with strict accumulator that discards the result +foldM'_ :: (Monad m, Vector v b) => (a -> b -> m a) -> a -> v b -> m () +{-# INLINE foldM'_ #-} +foldM'_ m z = discard . Bundle.foldM' m z . stream + +-- | /O(n)/ Monadic fold with strict accumulator that discards the result +-- (action applied to each element and its index) +ifoldM'_ :: (Monad m, Vector v b) => (a -> Int -> b -> m a) -> a -> v b -> m () +{-# INLINE ifoldM'_ #-} +ifoldM'_ m z = discard . Bundle.foldM' (uncurry . m) z . Bundle.indexed . stream + +-- | /O(n)/ Monad fold over non-empty vectors with strict accumulator +-- that discards the result +fold1M'_ :: (Monad m, Vector v a) => (a -> a -> m a) -> v a -> m () +{-# INLINE fold1M'_ #-} +fold1M'_ m = discard . Bundle.fold1M' m . stream + +-- Monadic sequencing +-- ------------------ + +-- | Evaluate each action and collect the results +sequence :: (Monad m, Vector v a, Vector v (m a)) => v (m a) -> m (v a) +{-# INLINE sequence #-} +sequence = mapM id + +-- | Evaluate each action and discard the results +sequence_ :: (Monad m, Vector v (m a)) => v (m a) -> m () +{-# INLINE sequence_ #-} +sequence_ = mapM_ id + +-- Prefix sums (scans) +-- ------------------- + +-- | /O(n)/ Prescan +-- +-- @ +-- prescanl f z = 'init' . 'scanl' f z +-- @ +-- +-- Example: @prescanl (+) 0 \<1,2,3,4\> = \<0,1,3,6\>@ +-- +prescanl :: (Vector v a, Vector v b) => (a -> b -> a) -> a -> v b -> v a +{-# INLINE prescanl #-} +prescanl f z = unstream . inplace (S.prescanl f z) id . stream + +-- | /O(n)/ Prescan with strict accumulator +prescanl' :: (Vector v a, Vector v b) => (a -> b -> a) -> a -> v b -> v a +{-# INLINE prescanl' #-} +prescanl' f z = unstream . inplace (S.prescanl' f z) id . stream + +-- | /O(n)/ Scan +-- +-- @ +-- postscanl f z = 'tail' . 'scanl' f z +-- @ +-- +-- Example: @postscanl (+) 0 \<1,2,3,4\> = \<1,3,6,10\>@ +-- +postscanl :: (Vector v a, Vector v b) => (a -> b -> a) -> a -> v b -> v a +{-# INLINE postscanl #-} +postscanl f z = unstream . inplace (S.postscanl f z) id . stream + +-- | /O(n)/ Scan with strict accumulator +postscanl' :: (Vector v a, Vector v b) => (a -> b -> a) -> a -> v b -> v a +{-# INLINE postscanl' #-} +postscanl' f z = unstream . inplace (S.postscanl' f z) id . stream + +-- | /O(n)/ Haskell-style scan +-- +-- > scanl f z <x1,...,xn> = <y1,...,y(n+1)> +-- > where y1 = z +-- > yi = f y(i-1) x(i-1) +-- +-- Example: @scanl (+) 0 \<1,2,3,4\> = \<0,1,3,6,10\>@ +-- +scanl :: (Vector v a, Vector v b) => (a -> b -> a) -> a -> v b -> v a +{-# INLINE scanl #-} +scanl f z = unstream . Bundle.scanl f z . stream + +-- | /O(n)/ Haskell-style scan with strict accumulator +scanl' :: (Vector v a, Vector v b) => (a -> b -> a) -> a -> v b -> v a +{-# INLINE scanl' #-} +scanl' f z = unstream . Bundle.scanl' f z . stream + +-- | /O(n)/ Scan over a vector with its index +iscanl :: (Vector v a, Vector v b) => (Int -> a -> b -> a) -> a -> v b -> v a +{-# INLINE iscanl #-} +iscanl f z = + unstream + . inplace (S.scanl (\a (i, b) -> f i a b) z . S.indexed) (+1) + . stream + +-- | /O(n)/ Scan over a vector (strictly) with its index +iscanl' :: (Vector v a, Vector v b) => (Int -> a -> b -> a) -> a -> v b -> v a +{-# INLINE iscanl' #-} +iscanl' f z = + unstream + . inplace (S.scanl' (\a (i, b) -> f i a b) z . S.indexed) (+1) + . stream + + +-- | /O(n)/ Scan over a non-empty vector +-- +-- > scanl f <x1,...,xn> = <y1,...,yn> +-- > where y1 = x1 +-- > yi = f y(i-1) xi +-- +scanl1 :: Vector v a => (a -> a -> a) -> v a -> v a +{-# INLINE scanl1 #-} +scanl1 f = unstream . inplace (S.scanl1 f) id . stream + +-- | /O(n)/ Scan over a non-empty vector with a strict accumulator +scanl1' :: Vector v a => (a -> a -> a) -> v a -> v a +{-# INLINE scanl1' #-} +scanl1' f = unstream . inplace (S.scanl1' f) id . stream + +-- | /O(n)/ Right-to-left prescan +-- +-- @ +-- prescanr f z = 'reverse' . 'prescanl' (flip f) z . 'reverse' +-- @ +-- +prescanr :: (Vector v a, Vector v b) => (a -> b -> b) -> b -> v a -> v b +{-# INLINE prescanr #-} +prescanr f z = unstreamR . inplace (S.prescanl (flip f) z) id . streamR + +-- | /O(n)/ Right-to-left prescan with strict accumulator +prescanr' :: (Vector v a, Vector v b) => (a -> b -> b) -> b -> v a -> v b +{-# INLINE prescanr' #-} +prescanr' f z = unstreamR . inplace (S.prescanl' (flip f) z) id . streamR + +-- | /O(n)/ Right-to-left scan +postscanr :: (Vector v a, Vector v b) => (a -> b -> b) -> b -> v a -> v b +{-# INLINE postscanr #-} +postscanr f z = unstreamR . inplace (S.postscanl (flip f) z) id . streamR + +-- | /O(n)/ Right-to-left scan with strict accumulator +postscanr' :: (Vector v a, Vector v b) => (a -> b -> b) -> b -> v a -> v b +{-# INLINE postscanr' #-} +postscanr' f z = unstreamR . inplace (S.postscanl' (flip f) z) id . streamR + +-- | /O(n)/ Right-to-left Haskell-style scan +scanr :: (Vector v a, Vector v b) => (a -> b -> b) -> b -> v a -> v b +{-# INLINE scanr #-} +scanr f z = unstreamR . Bundle.scanl (flip f) z . streamR + +-- | /O(n)/ Right-to-left Haskell-style scan with strict accumulator +scanr' :: (Vector v a, Vector v b) => (a -> b -> b) -> b -> v a -> v b +{-# INLINE scanr' #-} +scanr' f z = unstreamR . Bundle.scanl' (flip f) z . streamR + +-- | /O(n)/ Right-to-left scan over a vector with its index +iscanr :: (Vector v a, Vector v b) => (Int -> a -> b -> b) -> b -> v a -> v b +{-# INLINE iscanr #-} +iscanr f z v = + unstreamR + . inplace (S.scanl (flip $ uncurry f) z . S.indexedR n) (+1) + . streamR + $ v + where n = length v + +-- | /O(n)/ Right-to-left scan over a vector (strictly) with its index +iscanr' :: (Vector v a, Vector v b) => (Int -> a -> b -> b) -> b -> v a -> v b +{-# INLINE iscanr' #-} +iscanr' f z v = + unstreamR + . inplace (S.scanl' (flip $ uncurry f) z . S.indexedR n) (+1) + . streamR + $ v + where n = length v + +-- | /O(n)/ Right-to-left scan over a non-empty vector +scanr1 :: Vector v a => (a -> a -> a) -> v a -> v a +{-# INLINE scanr1 #-} +scanr1 f = unstreamR . inplace (S.scanl1 (flip f)) id . streamR + +-- | /O(n)/ Right-to-left scan over a non-empty vector with a strict +-- accumulator +scanr1' :: Vector v a => (a -> a -> a) -> v a -> v a +{-# INLINE scanr1' #-} +scanr1' f = unstreamR . inplace (S.scanl1' (flip f)) id . streamR + +-- Conversions - Lists +-- ------------------------ + +-- | /O(n)/ Convert a vector to a list +toList :: Vector v a => v a -> [a] +{-# INLINE toList #-} +toList = Bundle.toList . stream + +-- | /O(n)/ Convert a list to a vector +fromList :: Vector v a => [a] -> v a +{-# INLINE fromList #-} +fromList = unstream . Bundle.fromList + +-- | /O(n)/ Convert the first @n@ elements of a list to a vector +-- +-- @ +-- fromListN n xs = 'fromList' ('take' n xs) +-- @ +fromListN :: Vector v a => Int -> [a] -> v a +{-# INLINE fromListN #-} +fromListN n = unstream . Bundle.fromListN n + +-- Conversions - Immutable vectors +-- ------------------------------- + +-- | /O(n)/ Convert different vector types +convert :: (Vector v a, Vector w a) => v a -> w a +{-# INLINE convert #-} +convert = unstream . Bundle.reVector . stream + +-- Conversions - Mutable vectors +-- ----------------------------- + +-- | /O(1)/ Unsafe convert a mutable vector to an immutable one without +-- copying. The mutable vector may not be used after this operation. +unsafeFreeze + :: (PrimMonad m, Vector v a) => Mutable v (PrimState m) a -> m (v a) +{-# INLINE unsafeFreeze #-} +unsafeFreeze = basicUnsafeFreeze + +-- | /O(n)/ Yield an immutable copy of the mutable vector. +freeze :: (PrimMonad m, Vector v a) => Mutable v (PrimState m) a -> m (v a) +{-# INLINE freeze #-} +freeze mv = unsafeFreeze =<< M.clone mv + +-- | /O(1)/ Unsafely convert an immutable vector to a mutable one without +-- copying. The immutable vector may not be used after this operation. +unsafeThaw :: (PrimMonad m, Vector v a) => v a -> m (Mutable v (PrimState m) a) +{-# INLINE_FUSED unsafeThaw #-} +unsafeThaw = basicUnsafeThaw + +-- | /O(n)/ Yield a mutable copy of the immutable vector. +thaw :: (PrimMonad m, Vector v a) => v a -> m (Mutable v (PrimState m) a) +{-# INLINE_FUSED thaw #-} +thaw v = do + mv <- M.unsafeNew (length v) + unsafeCopy mv v + return mv + +{-# RULES + +"unsafeThaw/new [Vector]" forall p. + unsafeThaw (new p) = New.runPrim p + +"thaw/new [Vector]" forall p. + thaw (new p) = New.runPrim p #-} + + + +{- +-- | /O(n)/ Yield a mutable vector containing copies of each vector in the +-- list. +thawMany :: (PrimMonad m, Vector v a) => [v a] -> m (Mutable v (PrimState m) a) +{-# INLINE_FUSED thawMany #-} +-- FIXME: add rule for (stream (new (New.create (thawMany vs)))) +-- NOTE: We don't try to consume the list lazily as this wouldn't significantly +-- change the space requirements anyway. +thawMany vs = do + mv <- M.new n + thaw_loop mv vs + return mv + where + n = List.foldl' (\k v -> k + length v) 0 vs + + thaw_loop mv [] = mv `seq` return () + thaw_loop mv (v:vs) + = do + let n = length v + unsafeCopy (M.unsafeTake n mv) v + thaw_loop (M.unsafeDrop n mv) vs +-} + +-- | /O(n)/ Copy an immutable vector into a mutable one. The two vectors must +-- have the same length. +copy + :: (PrimMonad m, Vector v a) => Mutable v (PrimState m) a -> v a -> m () +{-# INLINE copy #-} +copy dst src = BOUNDS_CHECK(check) "copy" "length mismatch" + (M.length dst == length src) + $ unsafeCopy dst src + +-- | /O(n)/ Copy an immutable vector into a mutable one. The two vectors must +-- have the same length. This is not checked. +unsafeCopy + :: (PrimMonad m, Vector v a) => Mutable v (PrimState m) a -> v a -> m () +{-# INLINE unsafeCopy #-} +unsafeCopy dst src = UNSAFE_CHECK(check) "unsafeCopy" "length mismatch" + (M.length dst == length src) + $ (dst `seq` src `seq` basicUnsafeCopy dst src) + +-- Conversions to/from Bundles +-- --------------------------- + +-- | /O(1)/ Convert a vector to a 'Bundle' +stream :: Vector v a => v a -> Bundle v a +{-# INLINE_FUSED stream #-} +stream v = stream' v + +-- Same as 'stream', but can be used to avoid having a cycle in the dependency +-- graph of functions, which forces GHC to create a loop breaker. +stream' :: Vector v a => v a -> Bundle v a +{-# INLINE stream' #-} +stream' v = Bundle.fromVector v + +{- +stream v = v `seq` n `seq` (Bundle.unfoldr get 0 `Bundle.sized` Exact n) + where + n = length v + + -- NOTE: the False case comes first in Core so making it the recursive one + -- makes the code easier to read + {-# INLINE get #-} + get i | i >= n = Nothing + | otherwise = case basicUnsafeIndexM v i of Box x -> Just (x, i+1) +-} + +-- | /O(n)/ Construct a vector from a 'Bundle' +unstream :: Vector v a => Bundle v a -> v a +{-# INLINE unstream #-} +unstream s = new (New.unstream s) + +{-# RULES + +"stream/unstream [Vector]" forall s. + stream (new (New.unstream s)) = s + +"New.unstream/stream [Vector]" forall v. + New.unstream (stream v) = clone v + +"clone/new [Vector]" forall p. + clone (new p) = p + +"inplace [Vector]" + forall (f :: forall m. Monad m => Stream m a -> Stream m a) g m. + New.unstream (inplace f g (stream (new m))) = New.transform f g m + +"uninplace [Vector]" + forall (f :: forall m. Monad m => Stream m a -> Stream m a) g m. + stream (new (New.transform f g m)) = inplace f g (stream (new m)) #-} + + + +-- | /O(1)/ Convert a vector to a 'Bundle', proceeding from right to left +streamR :: Vector v a => v a -> Bundle u a +{-# INLINE_FUSED streamR #-} +streamR v = v `seq` n `seq` (Bundle.unfoldr get n `Bundle.sized` Exact n) + where + n = length v + + {-# INLINE get #-} + get 0 = Nothing + get i = let i' = i-1 + in + case basicUnsafeIndexM v i' of Box x -> Just (x, i') + +-- | /O(n)/ Construct a vector from a 'Bundle', proceeding from right to left +unstreamR :: Vector v a => Bundle v a -> v a +{-# INLINE unstreamR #-} +unstreamR s = new (New.unstreamR s) + +{-# RULES + +"streamR/unstreamR [Vector]" forall s. + streamR (new (New.unstreamR s)) = s + +"New.unstreamR/streamR/new [Vector]" forall p. + New.unstreamR (streamR (new p)) = p + +"New.unstream/streamR/new [Vector]" forall p. + New.unstream (streamR (new p)) = New.modify M.reverse p + +"New.unstreamR/stream/new [Vector]" forall p. + New.unstreamR (stream (new p)) = New.modify M.reverse p + +"inplace right [Vector]" + forall (f :: forall m. Monad m => Stream m a -> Stream m a) g m. + New.unstreamR (inplace f g (streamR (new m))) = New.transformR f g m + +"uninplace right [Vector]" + forall (f :: forall m. Monad m => Stream m a -> Stream m a) g m. + streamR (new (New.transformR f g m)) = inplace f g (streamR (new m)) #-} + + + +unstreamM :: (Monad m, Vector v a) => MBundle m u a -> m (v a) +{-# INLINE_FUSED unstreamM #-} +unstreamM s = do + xs <- MBundle.toList s + return $ unstream $ Bundle.unsafeFromList (MBundle.size s) xs + +unstreamPrimM :: (PrimMonad m, Vector v a) => MBundle m u a -> m (v a) +{-# INLINE_FUSED unstreamPrimM #-} +unstreamPrimM s = M.munstream s >>= unsafeFreeze + +-- FIXME: the next two functions are only necessary for the specialisations +unstreamPrimM_IO :: Vector v a => MBundle IO u a -> IO (v a) +{-# INLINE unstreamPrimM_IO #-} +unstreamPrimM_IO = unstreamPrimM + +unstreamPrimM_ST :: Vector v a => MBundle (ST s) u a -> ST s (v a) +{-# INLINE unstreamPrimM_ST #-} +unstreamPrimM_ST = unstreamPrimM + +{-# RULES + +"unstreamM[IO]" unstreamM = unstreamPrimM_IO +"unstreamM[ST]" unstreamM = unstreamPrimM_ST #-} + + + + +-- Recycling support +-- ----------------- + +-- | Construct a vector from a monadic initialiser. +new :: Vector v a => New v a -> v a +{-# INLINE_FUSED new #-} +new m = m `seq` runST (unsafeFreeze =<< New.run m) + +-- | Convert a vector to an initialiser which, when run, produces a copy of +-- the vector. +clone :: Vector v a => v a -> New v a +{-# INLINE_FUSED clone #-} +clone v = v `seq` New.create ( + do + mv <- M.new (length v) + unsafeCopy mv v + return mv) + +-- Comparisons +-- ----------- + +-- | /O(n)/ Check if two vectors are equal. All 'Vector' instances are also +-- instances of 'Eq' and it is usually more appropriate to use those. This +-- function is primarily intended for implementing 'Eq' instances for new +-- vector types. +eq :: (Vector v a, Eq a) => v a -> v a -> Bool +{-# INLINE eq #-} +xs `eq` ys = stream xs == stream ys + +-- | /O(n)/ +eqBy :: (Vector v a, Vector v b) => (a -> b -> Bool) -> v a -> v b -> Bool +{-# INLINE eqBy #-} +eqBy e xs ys = Bundle.eqBy e (stream xs) (stream ys) + +-- | /O(n)/ Compare two vectors lexicographically. All 'Vector' instances are +-- also instances of 'Ord' and it is usually more appropriate to use those. This +-- function is primarily intended for implementing 'Ord' instances for new +-- vector types. +cmp :: (Vector v a, Ord a) => v a -> v a -> Ordering +{-# INLINE cmp #-} +cmp xs ys = compare (stream xs) (stream ys) + +-- | /O(n)/ +cmpBy :: (Vector v a, Vector v b) => (a -> b -> Ordering) -> v a -> v b -> Ordering +cmpBy c xs ys = Bundle.cmpBy c (stream xs) (stream ys) + +-- Show +-- ---- + +-- | Generic definition of 'Prelude.showsPrec' +showsPrec :: (Vector v a, Show a) => Int -> v a -> ShowS +{-# INLINE showsPrec #-} +showsPrec _ = shows . toList + +liftShowsPrec :: (Vector v a) => (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> v a -> ShowS +{-# INLINE liftShowsPrec #-} +liftShowsPrec _ s _ = s . toList + +-- | Generic definition of 'Text.Read.readPrec' +readPrec :: (Vector v a, Read a) => Read.ReadPrec (v a) +{-# INLINE readPrec #-} +readPrec = do + xs <- Read.readPrec + return (fromList xs) + +-- | /Note:/ uses 'ReadS' +liftReadsPrec :: (Vector v a) => (Int -> Read.ReadS a) -> ReadS [a] -> Int -> Read.ReadS (v a) +liftReadsPrec _ r _ s = [ (fromList v, s') | (v, s') <- r s ] + +-- Data and Typeable +-- ----------------- + +-- | Generic definion of 'Data.Data.gfoldl' that views a 'Vector' as a +-- list. +gfoldl :: (Vector v a, Data a) + => (forall d b. Data d => c (d -> b) -> d -> c b) + -> (forall g. g -> c g) + -> v a + -> c (v a) +{-# INLINE gfoldl #-} +gfoldl f z v = z fromList `f` toList v + +mkType :: String -> DataType +{-# INLINE mkType #-} +mkType = mkNoRepType + +#if __GLASGOW_HASKELL__ >= 707 +dataCast :: (Vector v a, Data a, Typeable v, Typeable t) +#else +dataCast :: (Vector v a, Data a, Typeable1 v, Typeable1 t) +#endif + => (forall d. Data d => c (t d)) -> Maybe (c (v a)) +{-# INLINE dataCast #-} +dataCast f = gcast1 f diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic/Base.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic/Base.hs new file mode 100644 index 000000000000..a760329c599f --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic/Base.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE Rank2Types, MultiParamTypeClasses, FlexibleContexts, + TypeFamilies, ScopedTypeVariables, BangPatterns #-} +{-# OPTIONS_HADDOCK hide #-} + +-- | +-- Module : Data.Vector.Generic.Base +-- Copyright : (c) Roman Leshchinskiy 2008-2010 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> +-- Stability : experimental +-- Portability : non-portable +-- +-- Class of pure vectors +-- + +module Data.Vector.Generic.Base ( + Vector(..), Mutable +) where + +import Data.Vector.Generic.Mutable.Base ( MVector ) +import qualified Data.Vector.Generic.Mutable.Base as M + +import Control.Monad.Primitive + +-- | @Mutable v s a@ is the mutable version of the pure vector type @v a@ with +-- the state token @s@ +-- +type family Mutable (v :: * -> *) :: * -> * -> * + +-- | Class of immutable vectors. Every immutable vector is associated with its +-- mutable version through the 'Mutable' type family. Methods of this class +-- should not be used directly. Instead, "Data.Vector.Generic" and other +-- Data.Vector modules provide safe and fusible wrappers. +-- +-- Minimum complete implementation: +-- +-- * 'basicUnsafeFreeze' +-- +-- * 'basicUnsafeThaw' +-- +-- * 'basicLength' +-- +-- * 'basicUnsafeSlice' +-- +-- * 'basicUnsafeIndexM' +-- +class MVector (Mutable v) a => Vector v a where + -- | /Assumed complexity: O(1)/ + -- + -- Unsafely convert a mutable vector to its immutable version + -- without copying. The mutable vector may not be used after + -- this operation. + basicUnsafeFreeze :: PrimMonad m => Mutable v (PrimState m) a -> m (v a) + + -- | /Assumed complexity: O(1)/ + -- + -- Unsafely convert an immutable vector to its mutable version without + -- copying. The immutable vector may not be used after this operation. + basicUnsafeThaw :: PrimMonad m => v a -> m (Mutable v (PrimState m) a) + + -- | /Assumed complexity: O(1)/ + -- + -- Yield the length of the vector. + basicLength :: v a -> Int + + -- | /Assumed complexity: O(1)/ + -- + -- Yield a slice of the vector without copying it. No range checks are + -- performed. + basicUnsafeSlice :: Int -- ^ starting index + -> Int -- ^ length + -> v a -> v a + + -- | /Assumed complexity: O(1)/ + -- + -- Yield the element at the given position in a monad. No range checks are + -- performed. + -- + -- The monad allows us to be strict in the vector if we want. Suppose we had + -- + -- > unsafeIndex :: v a -> Int -> a + -- + -- instead. Now, if we wanted to copy a vector, we'd do something like + -- + -- > copy mv v ... = ... unsafeWrite mv i (unsafeIndex v i) ... + -- + -- For lazy vectors, the indexing would not be evaluated which means that we + -- would retain a reference to the original vector in each element we write. + -- This is not what we want! + -- + -- With 'basicUnsafeIndexM', we can do + -- + -- > copy mv v ... = ... case basicUnsafeIndexM v i of + -- > Box x -> unsafeWrite mv i x ... + -- + -- which does not have this problem because indexing (but not the returned + -- element!) is evaluated immediately. + -- + basicUnsafeIndexM :: Monad m => v a -> Int -> m a + + -- | /Assumed complexity: O(n)/ + -- + -- Copy an immutable vector into a mutable one. The two vectors must have + -- the same length but this is not checked. + -- + -- Instances of 'Vector' should redefine this method if they wish to support + -- an efficient block copy operation. + -- + -- Default definition: copying basic on 'basicUnsafeIndexM' and + -- 'basicUnsafeWrite'. + basicUnsafeCopy :: PrimMonad m => Mutable v (PrimState m) a -> v a -> m () + + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy !dst !src = do_copy 0 + where + !n = basicLength src + + do_copy i | i < n = do + x <- basicUnsafeIndexM src i + M.basicUnsafeWrite dst i x + do_copy (i+1) + | otherwise = return () + + -- | Evaluate @a@ as far as storing it in a vector would and yield @b@. + -- The @v a@ argument only fixes the type and is not touched. The method is + -- only used for optimisation purposes. Thus, it is safe for instances of + -- 'Vector' to evaluate @a@ less than it would be when stored in a vector + -- although this might result in suboptimal code. + -- + -- > elemseq v x y = (singleton x `asTypeOf` v) `seq` y + -- + -- Default defintion: @a@ is not evaluated at all + -- + elemseq :: v a -> a -> b -> b + + {-# INLINE elemseq #-} + elemseq _ = \_ x -> x + + diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic/Mutable.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic/Mutable.hs new file mode 100644 index 000000000000..89bebf360765 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic/Mutable.hs @@ -0,0 +1,1034 @@ +{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleContexts, BangPatterns, TypeFamilies, ScopedTypeVariables #-} +-- | +-- Module : Data.Vector.Generic.Mutable +-- Copyright : (c) Roman Leshchinskiy 2008-2010 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> +-- Stability : experimental +-- Portability : non-portable +-- +-- Generic interface to mutable vectors +-- + +module Data.Vector.Generic.Mutable ( + -- * Class of mutable vector types + MVector(..), + + -- * Accessors + + -- ** Length information + length, null, + + -- ** Extracting subvectors + slice, init, tail, take, drop, splitAt, + unsafeSlice, unsafeInit, unsafeTail, unsafeTake, unsafeDrop, + + -- ** Overlapping + overlaps, + + -- * Construction + + -- ** Initialisation + new, unsafeNew, replicate, replicateM, clone, + + -- ** Growing + grow, unsafeGrow, + growFront, unsafeGrowFront, + + -- ** Restricting memory usage + clear, + + -- * Accessing individual elements + read, write, modify, swap, exchange, + unsafeRead, unsafeWrite, unsafeModify, unsafeSwap, unsafeExchange, + + -- * Modifying vectors + nextPermutation, + + -- ** Filling and copying + set, copy, move, unsafeCopy, unsafeMove, + + -- * Internal operations + mstream, mstreamR, + unstream, unstreamR, vunstream, + munstream, munstreamR, + transform, transformR, + fill, fillR, + unsafeAccum, accum, unsafeUpdate, update, reverse, + unstablePartition, unstablePartitionBundle, partitionBundle +) where + +import Data.Vector.Generic.Mutable.Base +import qualified Data.Vector.Generic.Base as V + +import qualified Data.Vector.Fusion.Bundle as Bundle +import Data.Vector.Fusion.Bundle ( Bundle, MBundle, Chunk(..) ) +import qualified Data.Vector.Fusion.Bundle.Monadic as MBundle +import Data.Vector.Fusion.Stream.Monadic ( Stream ) +import qualified Data.Vector.Fusion.Stream.Monadic as Stream +import Data.Vector.Fusion.Bundle.Size +import Data.Vector.Fusion.Util ( delay_inline ) + +import Control.Monad.Primitive ( PrimMonad, PrimState ) + +import Prelude hiding ( length, null, replicate, reverse, map, read, + take, drop, splitAt, init, tail ) + +#include "vector.h" + +{- +type family Immutable (v :: * -> * -> *) :: * -> * + +-- | Class of mutable vectors parametrised with a primitive state token. +-- +class MBundle.Pointer u a => MVector v a where + -- | Length of the mutable vector. This method should not be + -- called directly, use 'length' instead. + basicLength :: v s a -> Int + + -- | Yield a part of the mutable vector without copying it. This method + -- should not be called directly, use 'unsafeSlice' instead. + basicUnsafeSlice :: Int -- ^ starting index + -> Int -- ^ length of the slice + -> v s a + -> v s a + + -- Check whether two vectors overlap. This method should not be + -- called directly, use 'overlaps' instead. + basicOverlaps :: v s a -> v s a -> Bool + + -- | Create a mutable vector of the given length. This method should not be + -- called directly, use 'unsafeNew' instead. + basicUnsafeNew :: PrimMonad m => Int -> m (v (PrimState m) a) + + -- | Create a mutable vector of the given length and fill it with an + -- initial value. This method should not be called directly, use + -- 'replicate' instead. + basicUnsafeReplicate :: PrimMonad m => Int -> a -> m (v (PrimState m) a) + + -- | Yield the element at the given position. This method should not be + -- called directly, use 'unsafeRead' instead. + basicUnsafeRead :: PrimMonad m => v (PrimState m) a -> Int -> m a + + -- | Replace the element at the given position. This method should not be + -- called directly, use 'unsafeWrite' instead. + basicUnsafeWrite :: PrimMonad m => v (PrimState m) a -> Int -> a -> m () + + -- | Reset all elements of the vector to some undefined value, clearing all + -- references to external objects. This is usually a noop for unboxed + -- vectors. This method should not be called directly, use 'clear' instead. + basicClear :: PrimMonad m => v (PrimState m) a -> m () + + -- | Set all elements of the vector to the given value. This method should + -- not be called directly, use 'set' instead. + basicSet :: PrimMonad m => v (PrimState m) a -> a -> m () + + basicUnsafeCopyPointer :: PrimMonad m => v (PrimState m) a + -> Immutable v a + -> m () + + -- | Copy a vector. The two vectors may not overlap. This method should not + -- be called directly, use 'unsafeCopy' instead. + basicUnsafeCopy :: PrimMonad m => v (PrimState m) a -- ^ target + -> v (PrimState m) a -- ^ source + -> m () + + -- | Move the contents of a vector. The two vectors may overlap. This method + -- should not be called directly, use 'unsafeMove' instead. + basicUnsafeMove :: PrimMonad m => v (PrimState m) a -- ^ target + -> v (PrimState m) a -- ^ source + -> m () + + -- | Grow a vector by the given number of elements. This method should not be + -- called directly, use 'unsafeGrow' instead. + basicUnsafeGrow :: PrimMonad m => v (PrimState m) a -> Int + -> m (v (PrimState m) a) + + {-# INLINE basicUnsafeReplicate #-} + basicUnsafeReplicate n x + = do + v <- basicUnsafeNew n + basicSet v x + return v + + {-# INLINE basicClear #-} + basicClear _ = return () + + {-# INLINE basicSet #-} + basicSet !v x + | n == 0 = return () + | otherwise = do + basicUnsafeWrite v 0 x + do_set 1 + where + !n = basicLength v + + do_set i | 2*i < n = do basicUnsafeCopy (basicUnsafeSlice i i v) + (basicUnsafeSlice 0 i v) + do_set (2*i) + | otherwise = basicUnsafeCopy (basicUnsafeSlice i (n-i) v) + (basicUnsafeSlice 0 (n-i) v) + + {-# INLINE basicUnsafeCopyPointer #-} + basicUnsafeCopyPointer !dst !src = do_copy 0 src + where + do_copy !i p | Just (x,q) <- MBundle.pget p = do + basicUnsafeWrite dst i x + do_copy (i+1) q + | otherwise = return () + + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy !dst !src = do_copy 0 + where + !n = basicLength src + + do_copy i | i < n = do + x <- basicUnsafeRead src i + basicUnsafeWrite dst i x + do_copy (i+1) + | otherwise = return () + + {-# INLINE basicUnsafeMove #-} + basicUnsafeMove !dst !src + | basicOverlaps dst src = do + srcCopy <- clone src + basicUnsafeCopy dst srcCopy + | otherwise = basicUnsafeCopy dst src + + {-# INLINE basicUnsafeGrow #-} + basicUnsafeGrow v by + = do + v' <- basicUnsafeNew (n+by) + basicUnsafeCopy (basicUnsafeSlice 0 n v') v + return v' + where + n = basicLength v +-} + +-- ------------------ +-- Internal functions +-- ------------------ + +unsafeAppend1 :: (PrimMonad m, MVector v a) + => v (PrimState m) a -> Int -> a -> m (v (PrimState m) a) +{-# INLINE_INNER unsafeAppend1 #-} + -- NOTE: The case distinction has to be on the outside because + -- GHC creates a join point for the unsafeWrite even when everything + -- is inlined. This is bad because with the join point, v isn't getting + -- unboxed. +unsafeAppend1 v i x + | i < length v = do + unsafeWrite v i x + return v + | otherwise = do + v' <- enlarge v + INTERNAL_CHECK(checkIndex) "unsafeAppend1" i (length v') + $ unsafeWrite v' i x + return v' + +unsafePrepend1 :: (PrimMonad m, MVector v a) + => v (PrimState m) a -> Int -> a -> m (v (PrimState m) a, Int) +{-# INLINE_INNER unsafePrepend1 #-} +unsafePrepend1 v i x + | i /= 0 = do + let i' = i-1 + unsafeWrite v i' x + return (v, i') + | otherwise = do + (v', j) <- enlargeFront v + let i' = j-1 + INTERNAL_CHECK(checkIndex) "unsafePrepend1" i' (length v') + $ unsafeWrite v' i' x + return (v', i') + +mstream :: (PrimMonad m, MVector v a) => v (PrimState m) a -> Stream m a +{-# INLINE mstream #-} +mstream v = v `seq` n `seq` (Stream.unfoldrM get 0) + where + n = length v + + {-# INLINE_INNER get #-} + get i | i < n = do x <- unsafeRead v i + return $ Just (x, i+1) + | otherwise = return $ Nothing + +fill :: (PrimMonad m, MVector v a) + => v (PrimState m) a -> Stream m a -> m (v (PrimState m) a) +{-# INLINE fill #-} +fill v s = v `seq` do + n' <- Stream.foldM put 0 s + return $ unsafeSlice 0 n' v + where + {-# INLINE_INNER put #-} + put i x = do + INTERNAL_CHECK(checkIndex) "fill" i (length v) + $ unsafeWrite v i x + return (i+1) + +transform + :: (PrimMonad m, MVector v a) + => (Stream m a -> Stream m a) -> v (PrimState m) a -> m (v (PrimState m) a) +{-# INLINE_FUSED transform #-} +transform f v = fill v (f (mstream v)) + +mstreamR :: (PrimMonad m, MVector v a) => v (PrimState m) a -> Stream m a +{-# INLINE mstreamR #-} +mstreamR v = v `seq` n `seq` (Stream.unfoldrM get n) + where + n = length v + + {-# INLINE_INNER get #-} + get i | j >= 0 = do x <- unsafeRead v j + return $ Just (x,j) + | otherwise = return Nothing + where + j = i-1 + +fillR :: (PrimMonad m, MVector v a) + => v (PrimState m) a -> Stream m a -> m (v (PrimState m) a) +{-# INLINE fillR #-} +fillR v s = v `seq` do + i <- Stream.foldM put n s + return $ unsafeSlice i (n-i) v + where + n = length v + + {-# INLINE_INNER put #-} + put i x = do + unsafeWrite v j x + return j + where + j = i-1 + +transformR + :: (PrimMonad m, MVector v a) + => (Stream m a -> Stream m a) -> v (PrimState m) a -> m (v (PrimState m) a) +{-# INLINE_FUSED transformR #-} +transformR f v = fillR v (f (mstreamR v)) + +-- | Create a new mutable vector and fill it with elements from the 'Bundle'. +-- The vector will grow exponentially if the maximum size of the 'Bundle' is +-- unknown. +unstream :: (PrimMonad m, MVector v a) + => Bundle u a -> m (v (PrimState m) a) +-- NOTE: replace INLINE_FUSED by INLINE? (also in unstreamR) +{-# INLINE_FUSED unstream #-} +unstream s = munstream (Bundle.lift s) + +-- | Create a new mutable vector and fill it with elements from the monadic +-- stream. The vector will grow exponentially if the maximum size of the stream +-- is unknown. +munstream :: (PrimMonad m, MVector v a) + => MBundle m u a -> m (v (PrimState m) a) +{-# INLINE_FUSED munstream #-} +munstream s = case upperBound (MBundle.size s) of + Just n -> munstreamMax s n + Nothing -> munstreamUnknown s + +-- FIXME: I can't think of how to prevent GHC from floating out +-- unstreamUnknown. That is bad because SpecConstr then generates two +-- specialisations: one for when it is called from unstream (it doesn't know +-- the shape of the vector) and one for when the vector has grown. To see the +-- problem simply compile this: +-- +-- fromList = Data.Vector.Unboxed.unstream . Bundle.fromList +-- +-- I'm not sure this still applies (19/04/2010) + +munstreamMax :: (PrimMonad m, MVector v a) + => MBundle m u a -> Int -> m (v (PrimState m) a) +{-# INLINE munstreamMax #-} +munstreamMax s n + = do + v <- INTERNAL_CHECK(checkLength) "munstreamMax" n + $ unsafeNew n + let put i x = do + INTERNAL_CHECK(checkIndex) "munstreamMax" i n + $ unsafeWrite v i x + return (i+1) + n' <- MBundle.foldM' put 0 s + return $ INTERNAL_CHECK(checkSlice) "munstreamMax" 0 n' n + $ unsafeSlice 0 n' v + +munstreamUnknown :: (PrimMonad m, MVector v a) + => MBundle m u a -> m (v (PrimState m) a) +{-# INLINE munstreamUnknown #-} +munstreamUnknown s + = do + v <- unsafeNew 0 + (v', n) <- MBundle.foldM put (v, 0) s + return $ INTERNAL_CHECK(checkSlice) "munstreamUnknown" 0 n (length v') + $ unsafeSlice 0 n v' + where + {-# INLINE_INNER put #-} + put (v,i) x = do + v' <- unsafeAppend1 v i x + return (v',i+1) + + + + + + + +-- | Create a new mutable vector and fill it with elements from the 'Bundle'. +-- The vector will grow exponentially if the maximum size of the 'Bundle' is +-- unknown. +vunstream :: (PrimMonad m, V.Vector v a) + => Bundle v a -> m (V.Mutable v (PrimState m) a) +-- NOTE: replace INLINE_FUSED by INLINE? (also in unstreamR) +{-# INLINE_FUSED vunstream #-} +vunstream s = vmunstream (Bundle.lift s) + +-- | Create a new mutable vector and fill it with elements from the monadic +-- stream. The vector will grow exponentially if the maximum size of the stream +-- is unknown. +vmunstream :: (PrimMonad m, V.Vector v a) + => MBundle m v a -> m (V.Mutable v (PrimState m) a) +{-# INLINE_FUSED vmunstream #-} +vmunstream s = case upperBound (MBundle.size s) of + Just n -> vmunstreamMax s n + Nothing -> vmunstreamUnknown s + +-- FIXME: I can't think of how to prevent GHC from floating out +-- unstreamUnknown. That is bad because SpecConstr then generates two +-- specialisations: one for when it is called from unstream (it doesn't know +-- the shape of the vector) and one for when the vector has grown. To see the +-- problem simply compile this: +-- +-- fromList = Data.Vector.Unboxed.unstream . Bundle.fromList +-- +-- I'm not sure this still applies (19/04/2010) + +vmunstreamMax :: (PrimMonad m, V.Vector v a) + => MBundle m v a -> Int -> m (V.Mutable v (PrimState m) a) +{-# INLINE vmunstreamMax #-} +vmunstreamMax s n + = do + v <- INTERNAL_CHECK(checkLength) "munstreamMax" n + $ unsafeNew n + let {-# INLINE_INNER copyChunk #-} + copyChunk i (Chunk m f) = + INTERNAL_CHECK(checkSlice) "munstreamMax.copyChunk" i m (length v) $ do + f (basicUnsafeSlice i m v) + return (i+m) + + n' <- Stream.foldlM' copyChunk 0 (MBundle.chunks s) + return $ INTERNAL_CHECK(checkSlice) "munstreamMax" 0 n' n + $ unsafeSlice 0 n' v + +vmunstreamUnknown :: (PrimMonad m, V.Vector v a) + => MBundle m v a -> m (V.Mutable v (PrimState m) a) +{-# INLINE vmunstreamUnknown #-} +vmunstreamUnknown s + = do + v <- unsafeNew 0 + (v', n) <- Stream.foldlM copyChunk (v,0) (MBundle.chunks s) + return $ INTERNAL_CHECK(checkSlice) "munstreamUnknown" 0 n (length v') + $ unsafeSlice 0 n v' + where + {-# INLINE_INNER copyChunk #-} + copyChunk (v,i) (Chunk n f) + = do + let j = i+n + v' <- if basicLength v < j + then unsafeGrow v (delay_inline max (enlarge_delta v) (j - basicLength v)) + else return v + INTERNAL_CHECK(checkSlice) "munstreamUnknown.copyChunk" i n (length v') + $ f (basicUnsafeSlice i n v') + return (v',j) + + + + +-- | Create a new mutable vector and fill it with elements from the 'Bundle' +-- from right to left. The vector will grow exponentially if the maximum size +-- of the 'Bundle' is unknown. +unstreamR :: (PrimMonad m, MVector v a) + => Bundle u a -> m (v (PrimState m) a) +-- NOTE: replace INLINE_FUSED by INLINE? (also in unstream) +{-# INLINE_FUSED unstreamR #-} +unstreamR s = munstreamR (Bundle.lift s) + +-- | Create a new mutable vector and fill it with elements from the monadic +-- stream from right to left. The vector will grow exponentially if the maximum +-- size of the stream is unknown. +munstreamR :: (PrimMonad m, MVector v a) + => MBundle m u a -> m (v (PrimState m) a) +{-# INLINE_FUSED munstreamR #-} +munstreamR s = case upperBound (MBundle.size s) of + Just n -> munstreamRMax s n + Nothing -> munstreamRUnknown s + +munstreamRMax :: (PrimMonad m, MVector v a) + => MBundle m u a -> Int -> m (v (PrimState m) a) +{-# INLINE munstreamRMax #-} +munstreamRMax s n + = do + v <- INTERNAL_CHECK(checkLength) "munstreamRMax" n + $ unsafeNew n + let put i x = do + let i' = i-1 + INTERNAL_CHECK(checkIndex) "munstreamRMax" i' n + $ unsafeWrite v i' x + return i' + i <- MBundle.foldM' put n s + return $ INTERNAL_CHECK(checkSlice) "munstreamRMax" i (n-i) n + $ unsafeSlice i (n-i) v + +munstreamRUnknown :: (PrimMonad m, MVector v a) + => MBundle m u a -> m (v (PrimState m) a) +{-# INLINE munstreamRUnknown #-} +munstreamRUnknown s + = do + v <- unsafeNew 0 + (v', i) <- MBundle.foldM put (v, 0) s + let n = length v' + return $ INTERNAL_CHECK(checkSlice) "unstreamRUnknown" i (n-i) n + $ unsafeSlice i (n-i) v' + where + {-# INLINE_INNER put #-} + put (v,i) x = unsafePrepend1 v i x + +-- Length +-- ------ + +-- | Length of the mutable vector. +length :: MVector v a => v s a -> Int +{-# INLINE length #-} +length = basicLength + +-- | Check whether the vector is empty +null :: MVector v a => v s a -> Bool +{-# INLINE null #-} +null v = length v == 0 + +-- Extracting subvectors +-- --------------------- + +-- | Yield a part of the mutable vector without copying it. +slice :: MVector v a => Int -> Int -> v s a -> v s a +{-# INLINE slice #-} +slice i n v = BOUNDS_CHECK(checkSlice) "slice" i n (length v) + $ unsafeSlice i n v + +take :: MVector v a => Int -> v s a -> v s a +{-# INLINE take #-} +take n v = unsafeSlice 0 (min (max n 0) (length v)) v + +drop :: MVector v a => Int -> v s a -> v s a +{-# INLINE drop #-} +drop n v = unsafeSlice (min m n') (max 0 (m - n')) v + where + n' = max n 0 + m = length v + +{-# INLINE splitAt #-} +splitAt :: MVector v a => Int -> v s a -> (v s a, v s a) +splitAt n v = ( unsafeSlice 0 m v + , unsafeSlice m (max 0 (len - n')) v + ) + where + m = min n' len + n' = max n 0 + len = length v + +init :: MVector v a => v s a -> v s a +{-# INLINE init #-} +init v = slice 0 (length v - 1) v + +tail :: MVector v a => v s a -> v s a +{-# INLINE tail #-} +tail v = slice 1 (length v - 1) v + +-- | Yield a part of the mutable vector without copying it. No bounds checks +-- are performed. +unsafeSlice :: MVector v a => Int -- ^ starting index + -> Int -- ^ length of the slice + -> v s a + -> v s a +{-# INLINE unsafeSlice #-} +unsafeSlice i n v = UNSAFE_CHECK(checkSlice) "unsafeSlice" i n (length v) + $ basicUnsafeSlice i n v + +unsafeInit :: MVector v a => v s a -> v s a +{-# INLINE unsafeInit #-} +unsafeInit v = unsafeSlice 0 (length v - 1) v + +unsafeTail :: MVector v a => v s a -> v s a +{-# INLINE unsafeTail #-} +unsafeTail v = unsafeSlice 1 (length v - 1) v + +unsafeTake :: MVector v a => Int -> v s a -> v s a +{-# INLINE unsafeTake #-} +unsafeTake n v = unsafeSlice 0 n v + +unsafeDrop :: MVector v a => Int -> v s a -> v s a +{-# INLINE unsafeDrop #-} +unsafeDrop n v = unsafeSlice n (length v - n) v + +-- Overlapping +-- ----------- + +-- | Check whether two vectors overlap. +overlaps :: MVector v a => v s a -> v s a -> Bool +{-# INLINE overlaps #-} +overlaps = basicOverlaps + +-- Initialisation +-- -------------- + +-- | Create a mutable vector of the given length. +new :: (PrimMonad m, MVector v a) => Int -> m (v (PrimState m) a) +{-# INLINE new #-} +new n = BOUNDS_CHECK(checkLength) "new" n + $ unsafeNew n >>= \v -> basicInitialize v >> return v + +-- | Create a mutable vector of the given length. The memory is not initialized. +unsafeNew :: (PrimMonad m, MVector v a) => Int -> m (v (PrimState m) a) +{-# INLINE unsafeNew #-} +unsafeNew n = UNSAFE_CHECK(checkLength) "unsafeNew" n + $ basicUnsafeNew n + +-- | Create a mutable vector of the given length (0 if the length is negative) +-- and fill it with an initial value. +replicate :: (PrimMonad m, MVector v a) => Int -> a -> m (v (PrimState m) a) +{-# INLINE replicate #-} +replicate n x = basicUnsafeReplicate (delay_inline max 0 n) x + +-- | Create a mutable vector of the given length (0 if the length is negative) +-- and fill it with values produced by repeatedly executing the monadic action. +replicateM :: (PrimMonad m, MVector v a) => Int -> m a -> m (v (PrimState m) a) +{-# INLINE replicateM #-} +replicateM n m = munstream (MBundle.replicateM n m) + +-- | Create a copy of a mutable vector. +clone :: (PrimMonad m, MVector v a) => v (PrimState m) a -> m (v (PrimState m) a) +{-# INLINE clone #-} +clone v = do + v' <- unsafeNew (length v) + unsafeCopy v' v + return v' + +-- Growing +-- ------- + +-- | Grow a vector by the given number of elements. The number must be +-- positive. +grow :: (PrimMonad m, MVector v a) + => v (PrimState m) a -> Int -> m (v (PrimState m) a) +{-# INLINE grow #-} +grow v by = BOUNDS_CHECK(checkLength) "grow" by + $ do vnew <- unsafeGrow v by + basicInitialize $ basicUnsafeSlice (length v) by vnew + return vnew + +growFront :: (PrimMonad m, MVector v a) + => v (PrimState m) a -> Int -> m (v (PrimState m) a) +{-# INLINE growFront #-} +growFront v by = BOUNDS_CHECK(checkLength) "growFront" by + $ do vnew <- unsafeGrowFront v by + basicInitialize $ basicUnsafeSlice 0 by vnew + return vnew + +enlarge_delta :: MVector v a => v s a -> Int +enlarge_delta v = max (length v) 1 + +-- | Grow a vector logarithmically +enlarge :: (PrimMonad m, MVector v a) + => v (PrimState m) a -> m (v (PrimState m) a) +{-# INLINE enlarge #-} +enlarge v = do vnew <- unsafeGrow v by + basicInitialize $ basicUnsafeSlice (length v) by vnew + return vnew + where + by = enlarge_delta v + +enlargeFront :: (PrimMonad m, MVector v a) + => v (PrimState m) a -> m (v (PrimState m) a, Int) +{-# INLINE enlargeFront #-} +enlargeFront v = do + v' <- unsafeGrowFront v by + basicInitialize $ basicUnsafeSlice 0 by v' + return (v', by) + where + by = enlarge_delta v + +-- | Grow a vector by the given number of elements. The number must be +-- positive but this is not checked. +unsafeGrow :: (PrimMonad m, MVector v a) + => v (PrimState m) a -> Int -> m (v (PrimState m) a) +{-# INLINE unsafeGrow #-} +unsafeGrow v n = UNSAFE_CHECK(checkLength) "unsafeGrow" n + $ basicUnsafeGrow v n + +unsafeGrowFront :: (PrimMonad m, MVector v a) + => v (PrimState m) a -> Int -> m (v (PrimState m) a) +{-# INLINE unsafeGrowFront #-} +unsafeGrowFront v by = UNSAFE_CHECK(checkLength) "unsafeGrowFront" by + $ do + let n = length v + v' <- basicUnsafeNew (by+n) + basicUnsafeCopy (basicUnsafeSlice by n v') v + return v' + +-- Restricting memory usage +-- ------------------------ + +-- | Reset all elements of the vector to some undefined value, clearing all +-- references to external objects. This is usually a noop for unboxed vectors. +clear :: (PrimMonad m, MVector v a) => v (PrimState m) a -> m () +{-# INLINE clear #-} +clear = basicClear + +-- Accessing individual elements +-- ----------------------------- + +-- | Yield the element at the given position. +read :: (PrimMonad m, MVector v a) => v (PrimState m) a -> Int -> m a +{-# INLINE read #-} +read v i = BOUNDS_CHECK(checkIndex) "read" i (length v) + $ unsafeRead v i + +-- | Replace the element at the given position. +write :: (PrimMonad m, MVector v a) => v (PrimState m) a -> Int -> a -> m () +{-# INLINE write #-} +write v i x = BOUNDS_CHECK(checkIndex) "write" i (length v) + $ unsafeWrite v i x + +-- | Modify the element at the given position. +modify :: (PrimMonad m, MVector v a) => v (PrimState m) a -> (a -> a) -> Int -> m () +{-# INLINE modify #-} +modify v f i = BOUNDS_CHECK(checkIndex) "modify" i (length v) + $ unsafeModify v f i + +-- | Swap the elements at the given positions. +swap :: (PrimMonad m, MVector v a) => v (PrimState m) a -> Int -> Int -> m () +{-# INLINE swap #-} +swap v i j = BOUNDS_CHECK(checkIndex) "swap" i (length v) + $ BOUNDS_CHECK(checkIndex) "swap" j (length v) + $ unsafeSwap v i j + +-- | Replace the element at the give position and return the old element. +exchange :: (PrimMonad m, MVector v a) => v (PrimState m) a -> Int -> a -> m a +{-# INLINE exchange #-} +exchange v i x = BOUNDS_CHECK(checkIndex) "exchange" i (length v) + $ unsafeExchange v i x + +-- | Yield the element at the given position. No bounds checks are performed. +unsafeRead :: (PrimMonad m, MVector v a) => v (PrimState m) a -> Int -> m a +{-# INLINE unsafeRead #-} +unsafeRead v i = UNSAFE_CHECK(checkIndex) "unsafeRead" i (length v) + $ basicUnsafeRead v i + +-- | Replace the element at the given position. No bounds checks are performed. +unsafeWrite :: (PrimMonad m, MVector v a) + => v (PrimState m) a -> Int -> a -> m () +{-# INLINE unsafeWrite #-} +unsafeWrite v i x = UNSAFE_CHECK(checkIndex) "unsafeWrite" i (length v) + $ basicUnsafeWrite v i x + +-- | Modify the element at the given position. No bounds checks are performed. +unsafeModify :: (PrimMonad m, MVector v a) => v (PrimState m) a -> (a -> a) -> Int -> m () +{-# INLINE unsafeModify #-} +unsafeModify v f i = UNSAFE_CHECK(checkIndex) "unsafeModify" i (length v) + $ basicUnsafeRead v i >>= \x -> + basicUnsafeWrite v i (f x) + +-- | Swap the elements at the given positions. No bounds checks are performed. +unsafeSwap :: (PrimMonad m, MVector v a) + => v (PrimState m) a -> Int -> Int -> m () +{-# INLINE unsafeSwap #-} +unsafeSwap v i j = UNSAFE_CHECK(checkIndex) "unsafeSwap" i (length v) + $ UNSAFE_CHECK(checkIndex) "unsafeSwap" j (length v) + $ do + x <- unsafeRead v i + y <- unsafeRead v j + unsafeWrite v i y + unsafeWrite v j x + +-- | Replace the element at the give position and return the old element. No +-- bounds checks are performed. +unsafeExchange :: (PrimMonad m, MVector v a) + => v (PrimState m) a -> Int -> a -> m a +{-# INLINE unsafeExchange #-} +unsafeExchange v i x = UNSAFE_CHECK(checkIndex) "unsafeExchange" i (length v) + $ do + y <- unsafeRead v i + unsafeWrite v i x + return y + +-- Filling and copying +-- ------------------- + +-- | Set all elements of the vector to the given value. +set :: (PrimMonad m, MVector v a) => v (PrimState m) a -> a -> m () +{-# INLINE set #-} +set = basicSet + +-- | Copy a vector. The two vectors must have the same length and may not +-- overlap. +copy :: (PrimMonad m, MVector v a) => v (PrimState m) a -- ^ target + -> v (PrimState m) a -- ^ source + -> m () +{-# INLINE copy #-} +copy dst src = BOUNDS_CHECK(check) "copy" "overlapping vectors" + (not (dst `overlaps` src)) + $ BOUNDS_CHECK(check) "copy" "length mismatch" + (length dst == length src) + $ unsafeCopy dst src + +-- | Move the contents of a vector. The two vectors must have the same +-- length. +-- +-- If the vectors do not overlap, then this is equivalent to 'copy'. +-- Otherwise, the copying is performed as if the source vector were +-- copied to a temporary vector and then the temporary vector was copied +-- to the target vector. +move :: (PrimMonad m, MVector v a) + => v (PrimState m) a -> v (PrimState m) a -> m () +{-# INLINE move #-} +move dst src = BOUNDS_CHECK(check) "move" "length mismatch" + (length dst == length src) + $ unsafeMove dst src + +-- | Copy a vector. The two vectors must have the same length and may not +-- overlap. This is not checked. +unsafeCopy :: (PrimMonad m, MVector v a) => v (PrimState m) a -- ^ target + -> v (PrimState m) a -- ^ source + -> m () +{-# INLINE unsafeCopy #-} +unsafeCopy dst src = UNSAFE_CHECK(check) "unsafeCopy" "length mismatch" + (length dst == length src) + $ UNSAFE_CHECK(check) "unsafeCopy" "overlapping vectors" + (not (dst `overlaps` src)) + $ (dst `seq` src `seq` basicUnsafeCopy dst src) + +-- | Move the contents of a vector. The two vectors must have the same +-- length, but this is not checked. +-- +-- If the vectors do not overlap, then this is equivalent to 'unsafeCopy'. +-- Otherwise, the copying is performed as if the source vector were +-- copied to a temporary vector and then the temporary vector was copied +-- to the target vector. +unsafeMove :: (PrimMonad m, MVector v a) => v (PrimState m) a -- ^ target + -> v (PrimState m) a -- ^ source + -> m () +{-# INLINE unsafeMove #-} +unsafeMove dst src = UNSAFE_CHECK(check) "unsafeMove" "length mismatch" + (length dst == length src) + $ (dst `seq` src `seq` basicUnsafeMove dst src) + +-- Permutations +-- ------------ + +accum :: (PrimMonad m, MVector v a) + => (a -> b -> a) -> v (PrimState m) a -> Bundle u (Int, b) -> m () +{-# INLINE accum #-} +accum f !v s = Bundle.mapM_ upd s + where + {-# INLINE_INNER upd #-} + upd (i,b) = do + a <- BOUNDS_CHECK(checkIndex) "accum" i n + $ unsafeRead v i + unsafeWrite v i (f a b) + + !n = length v + +update :: (PrimMonad m, MVector v a) + => v (PrimState m) a -> Bundle u (Int, a) -> m () +{-# INLINE update #-} +update !v s = Bundle.mapM_ upd s + where + {-# INLINE_INNER upd #-} + upd (i,b) = BOUNDS_CHECK(checkIndex) "update" i n + $ unsafeWrite v i b + + !n = length v + +unsafeAccum :: (PrimMonad m, MVector v a) + => (a -> b -> a) -> v (PrimState m) a -> Bundle u (Int, b) -> m () +{-# INLINE unsafeAccum #-} +unsafeAccum f !v s = Bundle.mapM_ upd s + where + {-# INLINE_INNER upd #-} + upd (i,b) = do + a <- UNSAFE_CHECK(checkIndex) "accum" i n + $ unsafeRead v i + unsafeWrite v i (f a b) + + !n = length v + +unsafeUpdate :: (PrimMonad m, MVector v a) + => v (PrimState m) a -> Bundle u (Int, a) -> m () +{-# INLINE unsafeUpdate #-} +unsafeUpdate !v s = Bundle.mapM_ upd s + where + {-# INLINE_INNER upd #-} + upd (i,b) = UNSAFE_CHECK(checkIndex) "accum" i n + $ unsafeWrite v i b + + !n = length v + +reverse :: (PrimMonad m, MVector v a) => v (PrimState m) a -> m () +{-# INLINE reverse #-} +reverse !v = reverse_loop 0 (length v - 1) + where + reverse_loop i j | i < j = do + unsafeSwap v i j + reverse_loop (i + 1) (j - 1) + reverse_loop _ _ = return () + +unstablePartition :: forall m v a. (PrimMonad m, MVector v a) + => (a -> Bool) -> v (PrimState m) a -> m Int +{-# INLINE unstablePartition #-} +unstablePartition f !v = from_left 0 (length v) + where + -- NOTE: GHC 6.10.4 panics without the signatures on from_left and + -- from_right + from_left :: Int -> Int -> m Int + from_left i j + | i == j = return i + | otherwise = do + x <- unsafeRead v i + if f x + then from_left (i+1) j + else from_right i (j-1) + + from_right :: Int -> Int -> m Int + from_right i j + | i == j = return i + | otherwise = do + x <- unsafeRead v j + if f x + then do + y <- unsafeRead v i + unsafeWrite v i x + unsafeWrite v j y + from_left (i+1) j + else from_right i (j-1) + +unstablePartitionBundle :: (PrimMonad m, MVector v a) + => (a -> Bool) -> Bundle u a -> m (v (PrimState m) a, v (PrimState m) a) +{-# INLINE unstablePartitionBundle #-} +unstablePartitionBundle f s + = case upperBound (Bundle.size s) of + Just n -> unstablePartitionMax f s n + Nothing -> partitionUnknown f s + +unstablePartitionMax :: (PrimMonad m, MVector v a) + => (a -> Bool) -> Bundle u a -> Int + -> m (v (PrimState m) a, v (PrimState m) a) +{-# INLINE unstablePartitionMax #-} +unstablePartitionMax f s n + = do + v <- INTERNAL_CHECK(checkLength) "unstablePartitionMax" n + $ unsafeNew n + let {-# INLINE_INNER put #-} + put (i, j) x + | f x = do + unsafeWrite v i x + return (i+1, j) + | otherwise = do + unsafeWrite v (j-1) x + return (i, j-1) + + (i,j) <- Bundle.foldM' put (0, n) s + return (unsafeSlice 0 i v, unsafeSlice j (n-j) v) + +partitionBundle :: (PrimMonad m, MVector v a) + => (a -> Bool) -> Bundle u a -> m (v (PrimState m) a, v (PrimState m) a) +{-# INLINE partitionBundle #-} +partitionBundle f s + = case upperBound (Bundle.size s) of + Just n -> partitionMax f s n + Nothing -> partitionUnknown f s + +partitionMax :: (PrimMonad m, MVector v a) + => (a -> Bool) -> Bundle u a -> Int -> m (v (PrimState m) a, v (PrimState m) a) +{-# INLINE partitionMax #-} +partitionMax f s n + = do + v <- INTERNAL_CHECK(checkLength) "unstablePartitionMax" n + $ unsafeNew n + + let {-# INLINE_INNER put #-} + put (i,j) x + | f x = do + unsafeWrite v i x + return (i+1,j) + + | otherwise = let j' = j-1 in + do + unsafeWrite v j' x + return (i,j') + + (i,j) <- Bundle.foldM' put (0,n) s + INTERNAL_CHECK(check) "partitionMax" "invalid indices" (i <= j) + $ return () + let l = unsafeSlice 0 i v + r = unsafeSlice j (n-j) v + reverse r + return (l,r) + +partitionUnknown :: (PrimMonad m, MVector v a) + => (a -> Bool) -> Bundle u a -> m (v (PrimState m) a, v (PrimState m) a) +{-# INLINE partitionUnknown #-} +partitionUnknown f s + = do + v1 <- unsafeNew 0 + v2 <- unsafeNew 0 + (v1', n1, v2', n2) <- Bundle.foldM' put (v1, 0, v2, 0) s + INTERNAL_CHECK(checkSlice) "partitionUnknown" 0 n1 (length v1') + $ INTERNAL_CHECK(checkSlice) "partitionUnknown" 0 n2 (length v2') + $ return (unsafeSlice 0 n1 v1', unsafeSlice 0 n2 v2') + where + -- NOTE: The case distinction has to be on the outside because + -- GHC creates a join point for the unsafeWrite even when everything + -- is inlined. This is bad because with the join point, v isn't getting + -- unboxed. + {-# INLINE_INNER put #-} + put (v1, i1, v2, i2) x + | f x = do + v1' <- unsafeAppend1 v1 i1 x + return (v1', i1+1, v2, i2) + | otherwise = do + v2' <- unsafeAppend1 v2 i2 x + return (v1, i1, v2', i2+1) + +{- +http://en.wikipedia.org/wiki/Permutation#Algorithms_to_generate_permutations + +The following algorithm generates the next permutation lexicographically after +a given permutation. It changes the given permutation in-place. + +1. Find the largest index k such that a[k] < a[k + 1]. If no such index exists, + the permutation is the last permutation. +2. Find the largest index l greater than k such that a[k] < a[l]. +3. Swap the value of a[k] with that of a[l]. +4. Reverse the sequence from a[k + 1] up to and including the final element a[n] +-} + +-- | Compute the next (lexicographically) permutation of given vector in-place. +-- Returns False when input is the last permtuation +nextPermutation :: (PrimMonad m,Ord e,MVector v e) => v (PrimState m) e -> m Bool +nextPermutation v + | dim < 2 = return False + | otherwise = do + val <- unsafeRead v 0 + (k,l) <- loop val (-1) 0 val 1 + if k < 0 + then return False + else unsafeSwap v k l >> + reverse (unsafeSlice (k+1) (dim-k-1) v) >> + return True + where loop !kval !k !l !prev !i + | i == dim = return (k,l) + | otherwise = do + cur <- unsafeRead v i + -- TODO: make tuple unboxed + let (kval',k') = if prev < cur then (prev,i-1) else (kval,k) + l' = if kval' < cur then i else l + loop kval' k' l' cur (i+1) + dim = length v diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic/Mutable/Base.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic/Mutable/Base.hs new file mode 100644 index 000000000000..ce931eec9b41 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic/Mutable/Base.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE CPP, MultiParamTypeClasses, BangPatterns, TypeFamilies #-} +-- | +-- Module : Data.Vector.Generic.Mutable.Base +-- Copyright : (c) Roman Leshchinskiy 2008-2011 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> +-- Stability : experimental +-- Portability : non-portable +-- +-- Class of mutable vectors +-- + +module Data.Vector.Generic.Mutable.Base ( + MVector(..) +) where + +import Control.Monad.Primitive ( PrimMonad, PrimState ) + +-- Data.Vector.Internal.Check is unused +#define NOT_VECTOR_MODULE +#include "vector.h" + +-- | Class of mutable vectors parametrised with a primitive state token. +-- +class MVector v a where + -- | Length of the mutable vector. This method should not be + -- called directly, use 'length' instead. + basicLength :: v s a -> Int + + -- | Yield a part of the mutable vector without copying it. This method + -- should not be called directly, use 'unsafeSlice' instead. + basicUnsafeSlice :: Int -- ^ starting index + -> Int -- ^ length of the slice + -> v s a + -> v s a + + -- | Check whether two vectors overlap. This method should not be + -- called directly, use 'overlaps' instead. + basicOverlaps :: v s a -> v s a -> Bool + + -- | Create a mutable vector of the given length. This method should not be + -- called directly, use 'unsafeNew' instead. + basicUnsafeNew :: PrimMonad m => Int -> m (v (PrimState m) a) + + -- | Initialize a vector to a standard value. This is intended to be called as + -- part of the safe new operation (and similar operations), to properly blank + -- the newly allocated memory if necessary. + -- + -- Vectors that are necessarily initialized as part of creation may implement + -- this as a no-op. + basicInitialize :: PrimMonad m => v (PrimState m) a -> m () + + -- | Create a mutable vector of the given length and fill it with an + -- initial value. This method should not be called directly, use + -- 'replicate' instead. + basicUnsafeReplicate :: PrimMonad m => Int -> a -> m (v (PrimState m) a) + + -- | Yield the element at the given position. This method should not be + -- called directly, use 'unsafeRead' instead. + basicUnsafeRead :: PrimMonad m => v (PrimState m) a -> Int -> m a + + -- | Replace the element at the given position. This method should not be + -- called directly, use 'unsafeWrite' instead. + basicUnsafeWrite :: PrimMonad m => v (PrimState m) a -> Int -> a -> m () + + -- | Reset all elements of the vector to some undefined value, clearing all + -- references to external objects. This is usually a noop for unboxed + -- vectors. This method should not be called directly, use 'clear' instead. + basicClear :: PrimMonad m => v (PrimState m) a -> m () + + -- | Set all elements of the vector to the given value. This method should + -- not be called directly, use 'set' instead. + basicSet :: PrimMonad m => v (PrimState m) a -> a -> m () + + -- | Copy a vector. The two vectors may not overlap. This method should not + -- be called directly, use 'unsafeCopy' instead. + basicUnsafeCopy :: PrimMonad m => v (PrimState m) a -- ^ target + -> v (PrimState m) a -- ^ source + -> m () + + -- | Move the contents of a vector. The two vectors may overlap. This method + -- should not be called directly, use 'unsafeMove' instead. + basicUnsafeMove :: PrimMonad m => v (PrimState m) a -- ^ target + -> v (PrimState m) a -- ^ source + -> m () + + -- | Grow a vector by the given number of elements. This method should not be + -- called directly, use 'unsafeGrow' instead. + basicUnsafeGrow :: PrimMonad m => v (PrimState m) a -> Int + -> m (v (PrimState m) a) + + {-# INLINE basicUnsafeReplicate #-} + basicUnsafeReplicate n x + = do + v <- basicUnsafeNew n + basicSet v x + return v + + {-# INLINE basicClear #-} + basicClear _ = return () + + {-# INLINE basicSet #-} + basicSet !v x + | n == 0 = return () + | otherwise = do + basicUnsafeWrite v 0 x + do_set 1 + where + !n = basicLength v + + do_set i | 2*i < n = do basicUnsafeCopy (basicUnsafeSlice i i v) + (basicUnsafeSlice 0 i v) + do_set (2*i) + | otherwise = basicUnsafeCopy (basicUnsafeSlice i (n-i) v) + (basicUnsafeSlice 0 (n-i) v) + + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy !dst !src = do_copy 0 + where + !n = basicLength src + + do_copy i | i < n = do + x <- basicUnsafeRead src i + basicUnsafeWrite dst i x + do_copy (i+1) + | otherwise = return () + + {-# INLINE basicUnsafeMove #-} + basicUnsafeMove !dst !src + | basicOverlaps dst src = do + srcCopy <- basicUnsafeNew (basicLength src) + basicUnsafeCopy srcCopy src + basicUnsafeCopy dst srcCopy + | otherwise = basicUnsafeCopy dst src + + {-# INLINE basicUnsafeGrow #-} + basicUnsafeGrow v by + = do + v' <- basicUnsafeNew (n+by) + basicUnsafeCopy (basicUnsafeSlice 0 n v') v + return v' + where + n = basicLength v + diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic/New.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic/New.hs new file mode 100644 index 000000000000..e94ce19e1669 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic/New.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE CPP, Rank2Types, FlexibleContexts, MultiParamTypeClasses #-} + +-- | +-- Module : Data.Vector.Generic.New +-- Copyright : (c) Roman Leshchinskiy 2008-2010 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> +-- Stability : experimental +-- Portability : non-portable +-- +-- Purely functional interface to initialisation of mutable vectors +-- + +module Data.Vector.Generic.New ( + New(..), create, run, runPrim, apply, modify, modifyWithBundle, + unstream, transform, unstreamR, transformR, + slice, init, tail, take, drop, + unsafeSlice, unsafeInit, unsafeTail +) where + +import qualified Data.Vector.Generic.Mutable as MVector + +import Data.Vector.Generic.Base ( Vector, Mutable ) + +import Data.Vector.Fusion.Bundle ( Bundle ) +import qualified Data.Vector.Fusion.Bundle as Bundle +import Data.Vector.Fusion.Stream.Monadic ( Stream ) +import Data.Vector.Fusion.Bundle.Size + +import Control.Monad.Primitive +import Control.Monad.ST ( ST ) +import Control.Monad ( liftM ) +import Prelude hiding ( init, tail, take, drop, reverse, map, filter ) + +-- Data.Vector.Internal.Check is unused +#define NOT_VECTOR_MODULE +#include "vector.h" + +data New v a = New (forall s. ST s (Mutable v s a)) + +create :: (forall s. ST s (Mutable v s a)) -> New v a +{-# INLINE create #-} +create p = New p + +run :: New v a -> ST s (Mutable v s a) +{-# INLINE run #-} +run (New p) = p + +runPrim :: PrimMonad m => New v a -> m (Mutable v (PrimState m) a) +{-# INLINE runPrim #-} +runPrim (New p) = primToPrim p + +apply :: (forall s. Mutable v s a -> Mutable v s a) -> New v a -> New v a +{-# INLINE apply #-} +apply f (New p) = New (liftM f p) + +modify :: (forall s. Mutable v s a -> ST s ()) -> New v a -> New v a +{-# INLINE modify #-} +modify f (New p) = New (do { v <- p; f v; return v }) + +modifyWithBundle :: (forall s. Mutable v s a -> Bundle u b -> ST s ()) + -> New v a -> Bundle u b -> New v a +{-# INLINE_FUSED modifyWithBundle #-} +modifyWithBundle f (New p) s = s `seq` New (do { v <- p; f v s; return v }) + +unstream :: Vector v a => Bundle v a -> New v a +{-# INLINE_FUSED unstream #-} +unstream s = s `seq` New (MVector.vunstream s) + +transform + :: Vector v a => (forall m. Monad m => Stream m a -> Stream m a) + -> (Size -> Size) -> New v a -> New v a +{-# INLINE_FUSED transform #-} +transform f _ (New p) = New (MVector.transform f =<< p) + +{-# RULES + +"transform/transform [New]" + forall (f1 :: forall m. Monad m => Stream m a -> Stream m a) + (f2 :: forall m. Monad m => Stream m a -> Stream m a) + g1 g2 p . + transform f1 g1 (transform f2 g2 p) = transform (f1 . f2) (g1 . g2) p + +"transform/unstream [New]" + forall (f :: forall m. Monad m => Stream m a -> Stream m a) + g s. + transform f g (unstream s) = unstream (Bundle.inplace f g s) #-} + + + + +unstreamR :: Vector v a => Bundle v a -> New v a +{-# INLINE_FUSED unstreamR #-} +unstreamR s = s `seq` New (MVector.unstreamR s) + +transformR + :: Vector v a => (forall m. Monad m => Stream m a -> Stream m a) + -> (Size -> Size) -> New v a -> New v a +{-# INLINE_FUSED transformR #-} +transformR f _ (New p) = New (MVector.transformR f =<< p) + +{-# RULES + +"transformR/transformR [New]" + forall (f1 :: forall m. Monad m => Stream m a -> Stream m a) + (f2 :: forall m. Monad m => Stream m a -> Stream m a) + g1 g2 + p . + transformR f1 g1 (transformR f2 g2 p) = transformR (f1 . f2) (g1 . g2) p + +"transformR/unstreamR [New]" + forall (f :: forall m. Monad m => Stream m a -> Stream m a) + g s. + transformR f g (unstreamR s) = unstreamR (Bundle.inplace f g s) #-} + + + +slice :: Vector v a => Int -> Int -> New v a -> New v a +{-# INLINE_FUSED slice #-} +slice i n m = apply (MVector.slice i n) m + +init :: Vector v a => New v a -> New v a +{-# INLINE_FUSED init #-} +init m = apply MVector.init m + +tail :: Vector v a => New v a -> New v a +{-# INLINE_FUSED tail #-} +tail m = apply MVector.tail m + +take :: Vector v a => Int -> New v a -> New v a +{-# INLINE_FUSED take #-} +take n m = apply (MVector.take n) m + +drop :: Vector v a => Int -> New v a -> New v a +{-# INLINE_FUSED drop #-} +drop n m = apply (MVector.drop n) m + +unsafeSlice :: Vector v a => Int -> Int -> New v a -> New v a +{-# INLINE_FUSED unsafeSlice #-} +unsafeSlice i n m = apply (MVector.unsafeSlice i n) m + +unsafeInit :: Vector v a => New v a -> New v a +{-# INLINE_FUSED unsafeInit #-} +unsafeInit m = apply MVector.unsafeInit m + +unsafeTail :: Vector v a => New v a -> New v a +{-# INLINE_FUSED unsafeTail #-} +unsafeTail m = apply MVector.unsafeTail m + +{-# RULES + +"slice/unstream [New]" forall i n s. + slice i n (unstream s) = unstream (Bundle.slice i n s) + +"init/unstream [New]" forall s. + init (unstream s) = unstream (Bundle.init s) + +"tail/unstream [New]" forall s. + tail (unstream s) = unstream (Bundle.tail s) + +"take/unstream [New]" forall n s. + take n (unstream s) = unstream (Bundle.take n s) + +"drop/unstream [New]" forall n s. + drop n (unstream s) = unstream (Bundle.drop n s) + +"unsafeSlice/unstream [New]" forall i n s. + unsafeSlice i n (unstream s) = unstream (Bundle.slice i n s) + +"unsafeInit/unstream [New]" forall s. + unsafeInit (unstream s) = unstream (Bundle.init s) + +"unsafeTail/unstream [New]" forall s. + unsafeTail (unstream s) = unstream (Bundle.tail s) #-} + + + diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Internal/Check.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Internal/Check.hs new file mode 100644 index 000000000000..4a4ef80fe172 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Internal/Check.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE CPP #-} + +-- | +-- Module : Data.Vector.Internal.Check +-- Copyright : (c) Roman Leshchinskiy 2009 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> +-- Stability : experimental +-- Portability : non-portable +-- +-- Bounds checking infrastructure +-- + +{-# LANGUAGE MagicHash #-} + +module Data.Vector.Internal.Check ( + Checks(..), doChecks, + + error, internalError, + check, checkIndex, checkLength, checkSlice +) where + +import GHC.Base( Int(..) ) +import GHC.Prim( Int# ) +import Prelude hiding( error, (&&), (||), not ) +import qualified Prelude as P + +-- NOTE: This is a workaround for GHC's weird behaviour where it doesn't inline +-- these functions into unfoldings which makes the intermediate code size +-- explode. See http://hackage.haskell.org/trac/ghc/ticket/5539. +infixr 2 || +infixr 3 && + +not :: Bool -> Bool +{-# INLINE not #-} +not True = False +not False = True + +(&&) :: Bool -> Bool -> Bool +{-# INLINE (&&) #-} +False && _ = False +True && x = x + +(||) :: Bool -> Bool -> Bool +{-# INLINE (||) #-} +True || _ = True +False || x = x + + +data Checks = Bounds | Unsafe | Internal deriving( Eq ) + +doBoundsChecks :: Bool +#ifdef VECTOR_BOUNDS_CHECKS +doBoundsChecks = True +#else +doBoundsChecks = False +#endif + +doUnsafeChecks :: Bool +#ifdef VECTOR_UNSAFE_CHECKS +doUnsafeChecks = True +#else +doUnsafeChecks = False +#endif + +doInternalChecks :: Bool +#ifdef VECTOR_INTERNAL_CHECKS +doInternalChecks = True +#else +doInternalChecks = False +#endif + + +doChecks :: Checks -> Bool +{-# INLINE doChecks #-} +doChecks Bounds = doBoundsChecks +doChecks Unsafe = doUnsafeChecks +doChecks Internal = doInternalChecks + +error_msg :: String -> Int -> String -> String -> String +error_msg file line loc msg = file ++ ":" ++ show line ++ " (" ++ loc ++ "): " ++ msg + +error :: String -> Int -> String -> String -> a +{-# NOINLINE error #-} +error file line loc msg + = P.error $ error_msg file line loc msg + +internalError :: String -> Int -> String -> String -> a +{-# NOINLINE internalError #-} +internalError file line loc msg + = P.error $ unlines + ["*** Internal error in package vector ***" + ,"*** Please submit a bug report at http://trac.haskell.org/vector" + ,error_msg file line loc msg] + + +checkError :: String -> Int -> Checks -> String -> String -> a +{-# NOINLINE checkError #-} +checkError file line kind loc msg + = case kind of + Internal -> internalError file line loc msg + _ -> error file line loc msg + +check :: String -> Int -> Checks -> String -> String -> Bool -> a -> a +{-# INLINE check #-} +check file line kind loc msg cond x + | not (doChecks kind) || cond = x + | otherwise = checkError file line kind loc msg + +checkIndex_msg :: Int -> Int -> String +{-# INLINE checkIndex_msg #-} +checkIndex_msg (I# i#) (I# n#) = checkIndex_msg# i# n# + +checkIndex_msg# :: Int# -> Int# -> String +{-# NOINLINE checkIndex_msg# #-} +checkIndex_msg# i# n# = "index out of bounds " ++ show (I# i#, I# n#) + +checkIndex :: String -> Int -> Checks -> String -> Int -> Int -> a -> a +{-# INLINE checkIndex #-} +checkIndex file line kind loc i n x + = check file line kind loc (checkIndex_msg i n) (i >= 0 && i<n) x + + +checkLength_msg :: Int -> String +{-# INLINE checkLength_msg #-} +checkLength_msg (I# n#) = checkLength_msg# n# + +checkLength_msg# :: Int# -> String +{-# NOINLINE checkLength_msg# #-} +checkLength_msg# n# = "negative length " ++ show (I# n#) + +checkLength :: String -> Int -> Checks -> String -> Int -> a -> a +{-# INLINE checkLength #-} +checkLength file line kind loc n x + = check file line kind loc (checkLength_msg n) (n >= 0) x + + +checkSlice_msg :: Int -> Int -> Int -> String +{-# INLINE checkSlice_msg #-} +checkSlice_msg (I# i#) (I# m#) (I# n#) = checkSlice_msg# i# m# n# + +checkSlice_msg# :: Int# -> Int# -> Int# -> String +{-# NOINLINE checkSlice_msg# #-} +checkSlice_msg# i# m# n# = "invalid slice " ++ show (I# i#, I# m#, I# n#) + +checkSlice :: String -> Int -> Checks -> String -> Int -> Int -> Int -> a -> a +{-# INLINE checkSlice #-} +checkSlice file line kind loc i m n x + = check file line kind loc (checkSlice_msg i m n) + (i >= 0 && m >= 0 && i+m <= n) x + diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Mutable.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Mutable.hs new file mode 100644 index 000000000000..ba701afb6a19 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Mutable.hs @@ -0,0 +1,416 @@ +{-# LANGUAGE CPP, DeriveDataTypeable, MultiParamTypeClasses, FlexibleInstances, BangPatterns, TypeFamilies #-} + +-- | +-- Module : Data.Vector.Mutable +-- Copyright : (c) Roman Leshchinskiy 2008-2010 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> +-- Stability : experimental +-- Portability : non-portable +-- +-- Mutable boxed vectors. +-- + +module Data.Vector.Mutable ( + -- * Mutable boxed vectors + MVector(..), IOVector, STVector, + + -- * Accessors + + -- ** Length information + length, null, + + -- ** Extracting subvectors + slice, init, tail, take, drop, splitAt, + unsafeSlice, unsafeInit, unsafeTail, unsafeTake, unsafeDrop, + + -- ** Overlapping + overlaps, + + -- * Construction + + -- ** Initialisation + new, unsafeNew, replicate, replicateM, clone, + + -- ** Growing + grow, unsafeGrow, + + -- ** Restricting memory usage + clear, + + -- * Accessing individual elements + read, write, modify, swap, + unsafeRead, unsafeWrite, unsafeModify, unsafeSwap, + + -- * Modifying vectors + nextPermutation, + + -- ** Filling and copying + set, copy, move, unsafeCopy, unsafeMove +) where + +import Control.Monad (when) +import qualified Data.Vector.Generic.Mutable as G +import Data.Primitive.Array +import Control.Monad.Primitive + +import Prelude hiding ( length, null, replicate, reverse, read, + take, drop, splitAt, init, tail ) + +import Data.Typeable ( Typeable ) + +#include "vector.h" + +-- | Mutable boxed vectors keyed on the monad they live in ('IO' or @'ST' s@). +data MVector s a = MVector {-# UNPACK #-} !Int + {-# UNPACK #-} !Int + {-# UNPACK #-} !(MutableArray s a) + deriving ( Typeable ) + +type IOVector = MVector RealWorld +type STVector s = MVector s + +-- NOTE: This seems unsafe, see http://trac.haskell.org/vector/ticket/54 +{- +instance NFData a => NFData (MVector s a) where + rnf (MVector i n arr) = unsafeInlineST $ force i + where + force !ix | ix < n = do x <- readArray arr ix + rnf x `seq` force (ix+1) + | otherwise = return () +-} + +instance G.MVector MVector a where + {-# INLINE basicLength #-} + basicLength (MVector _ n _) = n + + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice j m (MVector i _ arr) = MVector (i+j) m arr + + {-# INLINE basicOverlaps #-} + basicOverlaps (MVector i m arr1) (MVector j n arr2) + = sameMutableArray arr1 arr2 + && (between i j (j+n) || between j i (i+m)) + where + between x y z = x >= y && x < z + + {-# INLINE basicUnsafeNew #-} + basicUnsafeNew n + = do + arr <- newArray n uninitialised + return (MVector 0 n arr) + + {-# INLINE basicInitialize #-} + -- initialization is unnecessary for boxed vectors + basicInitialize _ = return () + + {-# INLINE basicUnsafeReplicate #-} + basicUnsafeReplicate n x + = do + arr <- newArray n x + return (MVector 0 n arr) + + {-# INLINE basicUnsafeRead #-} + basicUnsafeRead (MVector i _ arr) j = readArray arr (i+j) + + {-# INLINE basicUnsafeWrite #-} + basicUnsafeWrite (MVector i _ arr) j x = writeArray arr (i+j) x + + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy (MVector i n dst) (MVector j _ src) + = copyMutableArray dst i src j n + + basicUnsafeMove dst@(MVector iDst n arrDst) src@(MVector iSrc _ arrSrc) + = case n of + 0 -> return () + 1 -> readArray arrSrc iSrc >>= writeArray arrDst iDst + 2 -> do + x <- readArray arrSrc iSrc + y <- readArray arrSrc (iSrc + 1) + writeArray arrDst iDst x + writeArray arrDst (iDst + 1) y + _ + | overlaps dst src + -> case compare iDst iSrc of + LT -> moveBackwards arrDst iDst iSrc n + EQ -> return () + GT | (iDst - iSrc) * 2 < n + -> moveForwardsLargeOverlap arrDst iDst iSrc n + | otherwise + -> moveForwardsSmallOverlap arrDst iDst iSrc n + | otherwise -> G.basicUnsafeCopy dst src + + {-# INLINE basicClear #-} + basicClear v = G.set v uninitialised + +{-# INLINE moveBackwards #-} +moveBackwards :: PrimMonad m => MutableArray (PrimState m) a -> Int -> Int -> Int -> m () +moveBackwards !arr !dstOff !srcOff !len = + INTERNAL_CHECK(check) "moveBackwards" "not a backwards move" (dstOff < srcOff) + $ loopM len $ \ i -> readArray arr (srcOff + i) >>= writeArray arr (dstOff + i) + +{-# INLINE moveForwardsSmallOverlap #-} +-- Performs a move when dstOff > srcOff, optimized for when the overlap of the intervals is small. +moveForwardsSmallOverlap :: PrimMonad m => MutableArray (PrimState m) a -> Int -> Int -> Int -> m () +moveForwardsSmallOverlap !arr !dstOff !srcOff !len = + INTERNAL_CHECK(check) "moveForwardsSmallOverlap" "not a forward move" (dstOff > srcOff) + $ do + tmp <- newArray overlap uninitialised + loopM overlap $ \ i -> readArray arr (dstOff + i) >>= writeArray tmp i + loopM nonOverlap $ \ i -> readArray arr (srcOff + i) >>= writeArray arr (dstOff + i) + loopM overlap $ \ i -> readArray tmp i >>= writeArray arr (dstOff + nonOverlap + i) + where nonOverlap = dstOff - srcOff; overlap = len - nonOverlap + +-- Performs a move when dstOff > srcOff, optimized for when the overlap of the intervals is large. +moveForwardsLargeOverlap :: PrimMonad m => MutableArray (PrimState m) a -> Int -> Int -> Int -> m () +moveForwardsLargeOverlap !arr !dstOff !srcOff !len = + INTERNAL_CHECK(check) "moveForwardsLargeOverlap" "not a forward move" (dstOff > srcOff) + $ do + queue <- newArray nonOverlap uninitialised + loopM nonOverlap $ \ i -> readArray arr (srcOff + i) >>= writeArray queue i + let mov !i !qTop = when (i < dstOff + len) $ do + x <- readArray arr i + y <- readArray queue qTop + writeArray arr i y + writeArray queue qTop x + mov (i+1) (if qTop + 1 >= nonOverlap then 0 else qTop + 1) + mov dstOff 0 + where nonOverlap = dstOff - srcOff + +{-# INLINE loopM #-} +loopM :: Monad m => Int -> (Int -> m a) -> m () +loopM !n k = let + go i = when (i < n) (k i >> go (i+1)) + in go 0 + +uninitialised :: a +uninitialised = error "Data.Vector.Mutable: uninitialised element" + +-- Length information +-- ------------------ + +-- | Length of the mutable vector. +length :: MVector s a -> Int +{-# INLINE length #-} +length = G.length + +-- | Check whether the vector is empty +null :: MVector s a -> Bool +{-# INLINE null #-} +null = G.null + +-- Extracting subvectors +-- --------------------- + +-- | Yield a part of the mutable vector without copying it. +slice :: Int -> Int -> MVector s a -> MVector s a +{-# INLINE slice #-} +slice = G.slice + +take :: Int -> MVector s a -> MVector s a +{-# INLINE take #-} +take = G.take + +drop :: Int -> MVector s a -> MVector s a +{-# INLINE drop #-} +drop = G.drop + +{-# INLINE splitAt #-} +splitAt :: Int -> MVector s a -> (MVector s a, MVector s a) +splitAt = G.splitAt + +init :: MVector s a -> MVector s a +{-# INLINE init #-} +init = G.init + +tail :: MVector s a -> MVector s a +{-# INLINE tail #-} +tail = G.tail + +-- | Yield a part of the mutable vector without copying it. No bounds checks +-- are performed. +unsafeSlice :: Int -- ^ starting index + -> Int -- ^ length of the slice + -> MVector s a + -> MVector s a +{-# INLINE unsafeSlice #-} +unsafeSlice = G.unsafeSlice + +unsafeTake :: Int -> MVector s a -> MVector s a +{-# INLINE unsafeTake #-} +unsafeTake = G.unsafeTake + +unsafeDrop :: Int -> MVector s a -> MVector s a +{-# INLINE unsafeDrop #-} +unsafeDrop = G.unsafeDrop + +unsafeInit :: MVector s a -> MVector s a +{-# INLINE unsafeInit #-} +unsafeInit = G.unsafeInit + +unsafeTail :: MVector s a -> MVector s a +{-# INLINE unsafeTail #-} +unsafeTail = G.unsafeTail + +-- Overlapping +-- ----------- + +-- | Check whether two vectors overlap. +overlaps :: MVector s a -> MVector s a -> Bool +{-# INLINE overlaps #-} +overlaps = G.overlaps + +-- Initialisation +-- -------------- + +-- | Create a mutable vector of the given length. +new :: PrimMonad m => Int -> m (MVector (PrimState m) a) +{-# INLINE new #-} +new = G.new + +-- | Create a mutable vector of the given length. The memory is not initialized. +unsafeNew :: PrimMonad m => Int -> m (MVector (PrimState m) a) +{-# INLINE unsafeNew #-} +unsafeNew = G.unsafeNew + +-- | Create a mutable vector of the given length (0 if the length is negative) +-- and fill it with an initial value. +replicate :: PrimMonad m => Int -> a -> m (MVector (PrimState m) a) +{-# INLINE replicate #-} +replicate = G.replicate + +-- | Create a mutable vector of the given length (0 if the length is negative) +-- and fill it with values produced by repeatedly executing the monadic action. +replicateM :: PrimMonad m => Int -> m a -> m (MVector (PrimState m) a) +{-# INLINE replicateM #-} +replicateM = G.replicateM + +-- | Create a copy of a mutable vector. +clone :: PrimMonad m => MVector (PrimState m) a -> m (MVector (PrimState m) a) +{-# INLINE clone #-} +clone = G.clone + +-- Growing +-- ------- + +-- | Grow a vector by the given number of elements. The number must be +-- positive. +grow :: PrimMonad m + => MVector (PrimState m) a -> Int -> m (MVector (PrimState m) a) +{-# INLINE grow #-} +grow = G.grow + +-- | Grow a vector by the given number of elements. The number must be +-- positive but this is not checked. +unsafeGrow :: PrimMonad m + => MVector (PrimState m) a -> Int -> m (MVector (PrimState m) a) +{-# INLINE unsafeGrow #-} +unsafeGrow = G.unsafeGrow + +-- Restricting memory usage +-- ------------------------ + +-- | Reset all elements of the vector to some undefined value, clearing all +-- references to external objects. This is usually a noop for unboxed vectors. +clear :: PrimMonad m => MVector (PrimState m) a -> m () +{-# INLINE clear #-} +clear = G.clear + +-- Accessing individual elements +-- ----------------------------- + +-- | Yield the element at the given position. +read :: PrimMonad m => MVector (PrimState m) a -> Int -> m a +{-# INLINE read #-} +read = G.read + +-- | Replace the element at the given position. +write :: PrimMonad m => MVector (PrimState m) a -> Int -> a -> m () +{-# INLINE write #-} +write = G.write + +-- | Modify the element at the given position. +modify :: PrimMonad m => MVector (PrimState m) a -> (a -> a) -> Int -> m () +{-# INLINE modify #-} +modify = G.modify + +-- | Swap the elements at the given positions. +swap :: PrimMonad m => MVector (PrimState m) a -> Int -> Int -> m () +{-# INLINE swap #-} +swap = G.swap + + +-- | Yield the element at the given position. No bounds checks are performed. +unsafeRead :: PrimMonad m => MVector (PrimState m) a -> Int -> m a +{-# INLINE unsafeRead #-} +unsafeRead = G.unsafeRead + +-- | Replace the element at the given position. No bounds checks are performed. +unsafeWrite :: PrimMonad m => MVector (PrimState m) a -> Int -> a -> m () +{-# INLINE unsafeWrite #-} +unsafeWrite = G.unsafeWrite + +-- | Modify the element at the given position. No bounds checks are performed. +unsafeModify :: PrimMonad m => MVector (PrimState m) a -> (a -> a) -> Int -> m () +{-# INLINE unsafeModify #-} +unsafeModify = G.unsafeModify + +-- | Swap the elements at the given positions. No bounds checks are performed. +unsafeSwap :: PrimMonad m => MVector (PrimState m) a -> Int -> Int -> m () +{-# INLINE unsafeSwap #-} +unsafeSwap = G.unsafeSwap + +-- Filling and copying +-- ------------------- + +-- | Set all elements of the vector to the given value. +set :: PrimMonad m => MVector (PrimState m) a -> a -> m () +{-# INLINE set #-} +set = G.set + +-- | Copy a vector. The two vectors must have the same length and may not +-- overlap. +copy :: PrimMonad m + => MVector (PrimState m) a -> MVector (PrimState m) a -> m () +{-# INLINE copy #-} +copy = G.copy + +-- | Copy a vector. The two vectors must have the same length and may not +-- overlap. This is not checked. +unsafeCopy :: PrimMonad m => MVector (PrimState m) a -- ^ target + -> MVector (PrimState m) a -- ^ source + -> m () +{-# INLINE unsafeCopy #-} +unsafeCopy = G.unsafeCopy + +-- | Move the contents of a vector. The two vectors must have the same +-- length. +-- +-- If the vectors do not overlap, then this is equivalent to 'copy'. +-- Otherwise, the copying is performed as if the source vector were +-- copied to a temporary vector and then the temporary vector was copied +-- to the target vector. +move :: PrimMonad m + => MVector (PrimState m) a -> MVector (PrimState m) a -> m () +{-# INLINE move #-} +move = G.move + +-- | Move the contents of a vector. The two vectors must have the same +-- length, but this is not checked. +-- +-- If the vectors do not overlap, then this is equivalent to 'unsafeCopy'. +-- Otherwise, the copying is performed as if the source vector were +-- copied to a temporary vector and then the temporary vector was copied +-- to the target vector. +unsafeMove :: PrimMonad m => MVector (PrimState m) a -- ^ target + -> MVector (PrimState m) a -- ^ source + -> m () +{-# INLINE unsafeMove #-} +unsafeMove = G.unsafeMove + +-- | Compute the next (lexicographically) permutation of given vector in-place. +-- Returns False when input is the last permtuation +nextPermutation :: (PrimMonad m,Ord e) => MVector (PrimState m) e -> m Bool +{-# INLINE nextPermutation #-} +nextPermutation = G.nextPermutation diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Primitive.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Primitive.hs new file mode 100644 index 000000000000..ba18f9ba957f --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Primitive.hs @@ -0,0 +1,1393 @@ +{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, ScopedTypeVariables, Rank2Types #-} + +-- | +-- Module : Data.Vector.Primitive +-- Copyright : (c) Roman Leshchinskiy 2008-2010 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> +-- Stability : experimental +-- Portability : non-portable +-- +-- Unboxed vectors of primitive types. The use of this module is not +-- recommended except in very special cases. Adaptive unboxed vectors defined +-- in "Data.Vector.Unboxed" are significantly more flexible at no performance +-- cost. +-- + +module Data.Vector.Primitive ( + -- * Primitive vectors + Vector(..), MVector(..), Prim, + + -- * Accessors + + -- ** Length information + length, null, + + -- ** Indexing + (!), (!?), head, last, + unsafeIndex, unsafeHead, unsafeLast, + + -- ** Monadic indexing + indexM, headM, lastM, + unsafeIndexM, unsafeHeadM, unsafeLastM, + + -- ** Extracting subvectors (slicing) + slice, init, tail, take, drop, splitAt, + unsafeSlice, unsafeInit, unsafeTail, unsafeTake, unsafeDrop, + + -- * Construction + + -- ** Initialisation + empty, singleton, replicate, generate, iterateN, + + -- ** Monadic initialisation + replicateM, generateM, iterateNM, create, createT, + + -- ** Unfolding + unfoldr, unfoldrN, + unfoldrM, unfoldrNM, + constructN, constructrN, + + -- ** Enumeration + enumFromN, enumFromStepN, enumFromTo, enumFromThenTo, + + -- ** Concatenation + cons, snoc, (++), concat, + + -- ** Restricting memory usage + force, + + -- * Modifying vectors + + -- ** Bulk updates + (//), update_, + unsafeUpd, unsafeUpdate_, + + -- ** Accumulations + accum, accumulate_, + unsafeAccum, unsafeAccumulate_, + + -- ** Permutations + reverse, backpermute, unsafeBackpermute, + + -- ** Safe destructive updates + modify, + + -- * Elementwise operations + + -- ** Mapping + map, imap, concatMap, + + -- ** Monadic mapping + mapM, mapM_, forM, forM_, + + -- ** Zipping + zipWith, zipWith3, zipWith4, zipWith5, zipWith6, + izipWith, izipWith3, izipWith4, izipWith5, izipWith6, + + -- ** Monadic zipping + zipWithM, zipWithM_, + + -- * Working with predicates + + -- ** Filtering + filter, ifilter, uniq, + mapMaybe, imapMaybe, + filterM, + takeWhile, dropWhile, + + -- ** Partitioning + partition, unstablePartition, span, break, + + -- ** Searching + elem, notElem, find, findIndex, findIndices, elemIndex, elemIndices, + + -- * Folding + foldl, foldl1, foldl', foldl1', foldr, foldr1, foldr', foldr1', + ifoldl, ifoldl', ifoldr, ifoldr', + + -- ** Specialised folds + all, any, + sum, product, + maximum, maximumBy, minimum, minimumBy, + minIndex, minIndexBy, maxIndex, maxIndexBy, + + -- ** Monadic folds + foldM, foldM', fold1M, fold1M', + foldM_, foldM'_, fold1M_, fold1M'_, + + -- * Prefix sums (scans) + prescanl, prescanl', + postscanl, postscanl', + scanl, scanl', scanl1, scanl1', + prescanr, prescanr', + postscanr, postscanr', + scanr, scanr', scanr1, scanr1', + + -- * Conversions + + -- ** Lists + toList, fromList, fromListN, + + -- ** Other vector types + G.convert, + + -- ** Mutable vectors + freeze, thaw, copy, unsafeFreeze, unsafeThaw, unsafeCopy +) where + +import qualified Data.Vector.Generic as G +import Data.Vector.Primitive.Mutable ( MVector(..) ) +import qualified Data.Vector.Fusion.Bundle as Bundle +import Data.Primitive.ByteArray +import Data.Primitive ( Prim, sizeOf ) + +import Control.DeepSeq ( NFData(rnf) ) + +import Control.Monad ( liftM ) +import Control.Monad.ST ( ST ) +import Control.Monad.Primitive + +import Prelude hiding ( length, null, + replicate, (++), concat, + head, last, + init, tail, take, drop, splitAt, reverse, + map, concatMap, + zipWith, zipWith3, zip, zip3, unzip, unzip3, + filter, takeWhile, dropWhile, span, break, + elem, notElem, + foldl, foldl1, foldr, foldr1, + all, any, sum, product, minimum, maximum, + scanl, scanl1, scanr, scanr1, + enumFromTo, enumFromThenTo, + mapM, mapM_ ) + +import Data.Typeable ( Typeable ) +import Data.Data ( Data(..) ) +import Text.Read ( Read(..), readListPrecDefault ) +import Data.Semigroup ( Semigroup(..) ) + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid ( Monoid(..) ) +import Data.Traversable ( Traversable ) +#endif + +#if __GLASGOW_HASKELL__ >= 708 +import qualified GHC.Exts as Exts +#endif + +-- | Unboxed vectors of primitive types +data Vector a = Vector {-# UNPACK #-} !Int + {-# UNPACK #-} !Int + {-# UNPACK #-} !ByteArray -- ^ offset, length, underlying byte array + deriving ( Typeable ) + +instance NFData (Vector a) where + rnf (Vector _ _ _) = () + +instance (Show a, Prim a) => Show (Vector a) where + showsPrec = G.showsPrec + +instance (Read a, Prim a) => Read (Vector a) where + readPrec = G.readPrec + readListPrec = readListPrecDefault + +instance (Data a, Prim a) => Data (Vector a) where + gfoldl = G.gfoldl + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = G.mkType "Data.Vector.Primitive.Vector" + dataCast1 = G.dataCast + + +type instance G.Mutable Vector = MVector + +instance Prim a => G.Vector Vector a where + {-# INLINE basicUnsafeFreeze #-} + basicUnsafeFreeze (MVector i n marr) + = Vector i n `liftM` unsafeFreezeByteArray marr + + {-# INLINE basicUnsafeThaw #-} + basicUnsafeThaw (Vector i n arr) + = MVector i n `liftM` unsafeThawByteArray arr + + {-# INLINE basicLength #-} + basicLength (Vector _ n _) = n + + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice j n (Vector i _ arr) = Vector (i+j) n arr + + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeIndexM (Vector i _ arr) j = return $! indexByteArray arr (i+j) + + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy (MVector i n dst) (Vector j _ src) + = copyByteArray dst (i*sz) src (j*sz) (n*sz) + where + sz = sizeOf (undefined :: a) + + {-# INLINE elemseq #-} + elemseq _ = seq + +-- See http://trac.haskell.org/vector/ticket/12 +instance (Prim a, Eq a) => Eq (Vector a) where + {-# INLINE (==) #-} + xs == ys = Bundle.eq (G.stream xs) (G.stream ys) + + {-# INLINE (/=) #-} + xs /= ys = not (Bundle.eq (G.stream xs) (G.stream ys)) + +-- See http://trac.haskell.org/vector/ticket/12 +instance (Prim a, Ord a) => Ord (Vector a) where + {-# INLINE compare #-} + compare xs ys = Bundle.cmp (G.stream xs) (G.stream ys) + + {-# INLINE (<) #-} + xs < ys = Bundle.cmp (G.stream xs) (G.stream ys) == LT + + {-# INLINE (<=) #-} + xs <= ys = Bundle.cmp (G.stream xs) (G.stream ys) /= GT + + {-# INLINE (>) #-} + xs > ys = Bundle.cmp (G.stream xs) (G.stream ys) == GT + + {-# INLINE (>=) #-} + xs >= ys = Bundle.cmp (G.stream xs) (G.stream ys) /= LT + +instance Prim a => Semigroup (Vector a) where + {-# INLINE (<>) #-} + (<>) = (++) + + {-# INLINE sconcat #-} + sconcat = G.concatNE + +instance Prim a => Monoid (Vector a) where + {-# INLINE mempty #-} + mempty = empty + + {-# INLINE mappend #-} + mappend = (++) + + {-# INLINE mconcat #-} + mconcat = concat + +#if __GLASGOW_HASKELL__ >= 708 + +instance Prim a => Exts.IsList (Vector a) where + type Item (Vector a) = a + fromList = fromList + fromListN = fromListN + toList = toList + +#endif +-- Length +-- ------ + +-- | /O(1)/ Yield the length of the vector +length :: Prim a => Vector a -> Int +{-# INLINE length #-} +length = G.length + +-- | /O(1)/ Test whether a vector is empty +null :: Prim a => Vector a -> Bool +{-# INLINE null #-} +null = G.null + +-- Indexing +-- -------- + +-- | O(1) Indexing +(!) :: Prim a => Vector a -> Int -> a +{-# INLINE (!) #-} +(!) = (G.!) + +-- | O(1) Safe indexing +(!?) :: Prim a => Vector a -> Int -> Maybe a +{-# INLINE (!?) #-} +(!?) = (G.!?) + +-- | /O(1)/ First element +head :: Prim a => Vector a -> a +{-# INLINE head #-} +head = G.head + +-- | /O(1)/ Last element +last :: Prim a => Vector a -> a +{-# INLINE last #-} +last = G.last + +-- | /O(1)/ Unsafe indexing without bounds checking +unsafeIndex :: Prim a => Vector a -> Int -> a +{-# INLINE unsafeIndex #-} +unsafeIndex = G.unsafeIndex + +-- | /O(1)/ First element without checking if the vector is empty +unsafeHead :: Prim a => Vector a -> a +{-# INLINE unsafeHead #-} +unsafeHead = G.unsafeHead + +-- | /O(1)/ Last element without checking if the vector is empty +unsafeLast :: Prim a => Vector a -> a +{-# INLINE unsafeLast #-} +unsafeLast = G.unsafeLast + +-- Monadic indexing +-- ---------------- + +-- | /O(1)/ Indexing in a monad. +-- +-- The monad allows operations to be strict in the vector when necessary. +-- Suppose vector copying is implemented like this: +-- +-- > copy mv v = ... write mv i (v ! i) ... +-- +-- For lazy vectors, @v ! i@ would not be evaluated which means that @mv@ +-- would unnecessarily retain a reference to @v@ in each element written. +-- +-- With 'indexM', copying can be implemented like this instead: +-- +-- > copy mv v = ... do +-- > x <- indexM v i +-- > write mv i x +-- +-- Here, no references to @v@ are retained because indexing (but /not/ the +-- elements) is evaluated eagerly. +-- +indexM :: (Prim a, Monad m) => Vector a -> Int -> m a +{-# INLINE indexM #-} +indexM = G.indexM + +-- | /O(1)/ First element of a vector in a monad. See 'indexM' for an +-- explanation of why this is useful. +headM :: (Prim a, Monad m) => Vector a -> m a +{-# INLINE headM #-} +headM = G.headM + +-- | /O(1)/ Last element of a vector in a monad. See 'indexM' for an +-- explanation of why this is useful. +lastM :: (Prim a, Monad m) => Vector a -> m a +{-# INLINE lastM #-} +lastM = G.lastM + +-- | /O(1)/ Indexing in a monad without bounds checks. See 'indexM' for an +-- explanation of why this is useful. +unsafeIndexM :: (Prim a, Monad m) => Vector a -> Int -> m a +{-# INLINE unsafeIndexM #-} +unsafeIndexM = G.unsafeIndexM + +-- | /O(1)/ First element in a monad without checking for empty vectors. +-- See 'indexM' for an explanation of why this is useful. +unsafeHeadM :: (Prim a, Monad m) => Vector a -> m a +{-# INLINE unsafeHeadM #-} +unsafeHeadM = G.unsafeHeadM + +-- | /O(1)/ Last element in a monad without checking for empty vectors. +-- See 'indexM' for an explanation of why this is useful. +unsafeLastM :: (Prim a, Monad m) => Vector a -> m a +{-# INLINE unsafeLastM #-} +unsafeLastM = G.unsafeLastM + +-- Extracting subvectors (slicing) +-- ------------------------------- + +-- | /O(1)/ Yield a slice of the vector without copying it. The vector must +-- contain at least @i+n@ elements. +slice :: Prim a + => Int -- ^ @i@ starting index + -> Int -- ^ @n@ length + -> Vector a + -> Vector a +{-# INLINE slice #-} +slice = G.slice + +-- | /O(1)/ Yield all but the last element without copying. The vector may not +-- be empty. +init :: Prim a => Vector a -> Vector a +{-# INLINE init #-} +init = G.init + +-- | /O(1)/ Yield all but the first element without copying. The vector may not +-- be empty. +tail :: Prim a => Vector a -> Vector a +{-# INLINE tail #-} +tail = G.tail + +-- | /O(1)/ Yield at the first @n@ elements without copying. The vector may +-- contain less than @n@ elements in which case it is returned unchanged. +take :: Prim a => Int -> Vector a -> Vector a +{-# INLINE take #-} +take = G.take + +-- | /O(1)/ Yield all but the first @n@ elements without copying. The vector may +-- contain less than @n@ elements in which case an empty vector is returned. +drop :: Prim a => Int -> Vector a -> Vector a +{-# INLINE drop #-} +drop = G.drop + +-- | /O(1)/ Yield the first @n@ elements paired with the remainder without copying. +-- +-- Note that @'splitAt' n v@ is equivalent to @('take' n v, 'drop' n v)@ +-- but slightly more efficient. +{-# INLINE splitAt #-} +splitAt :: Prim a => Int -> Vector a -> (Vector a, Vector a) +splitAt = G.splitAt + +-- | /O(1)/ Yield a slice of the vector without copying. The vector must +-- contain at least @i+n@ elements but this is not checked. +unsafeSlice :: Prim a => Int -- ^ @i@ starting index + -> Int -- ^ @n@ length + -> Vector a + -> Vector a +{-# INLINE unsafeSlice #-} +unsafeSlice = G.unsafeSlice + +-- | /O(1)/ Yield all but the last element without copying. The vector may not +-- be empty but this is not checked. +unsafeInit :: Prim a => Vector a -> Vector a +{-# INLINE unsafeInit #-} +unsafeInit = G.unsafeInit + +-- | /O(1)/ Yield all but the first element without copying. The vector may not +-- be empty but this is not checked. +unsafeTail :: Prim a => Vector a -> Vector a +{-# INLINE unsafeTail #-} +unsafeTail = G.unsafeTail + +-- | /O(1)/ Yield the first @n@ elements without copying. The vector must +-- contain at least @n@ elements but this is not checked. +unsafeTake :: Prim a => Int -> Vector a -> Vector a +{-# INLINE unsafeTake #-} +unsafeTake = G.unsafeTake + +-- | /O(1)/ Yield all but the first @n@ elements without copying. The vector +-- must contain at least @n@ elements but this is not checked. +unsafeDrop :: Prim a => Int -> Vector a -> Vector a +{-# INLINE unsafeDrop #-} +unsafeDrop = G.unsafeDrop + +-- Initialisation +-- -------------- + +-- | /O(1)/ Empty vector +empty :: Prim a => Vector a +{-# INLINE empty #-} +empty = G.empty + +-- | /O(1)/ Vector with exactly one element +singleton :: Prim a => a -> Vector a +{-# INLINE singleton #-} +singleton = G.singleton + +-- | /O(n)/ Vector of the given length with the same value in each position +replicate :: Prim a => Int -> a -> Vector a +{-# INLINE replicate #-} +replicate = G.replicate + +-- | /O(n)/ Construct a vector of the given length by applying the function to +-- each index +generate :: Prim a => Int -> (Int -> a) -> Vector a +{-# INLINE generate #-} +generate = G.generate + +-- | /O(n)/ Apply function n times to value. Zeroth element is original value. +iterateN :: Prim a => Int -> (a -> a) -> a -> Vector a +{-# INLINE iterateN #-} +iterateN = G.iterateN + +-- Unfolding +-- --------- + +-- | /O(n)/ Construct a vector by repeatedly applying the generator function +-- to a seed. The generator function yields 'Just' the next element and the +-- new seed or 'Nothing' if there are no more elements. +-- +-- > unfoldr (\n -> if n == 0 then Nothing else Just (n,n-1)) 10 +-- > = <10,9,8,7,6,5,4,3,2,1> +unfoldr :: Prim a => (b -> Maybe (a, b)) -> b -> Vector a +{-# INLINE unfoldr #-} +unfoldr = G.unfoldr + +-- | /O(n)/ Construct a vector with at most @n@ elements by repeatedly applying +-- the generator function to a seed. The generator function yields 'Just' the +-- next element and the new seed or 'Nothing' if there are no more elements. +-- +-- > unfoldrN 3 (\n -> Just (n,n-1)) 10 = <10,9,8> +unfoldrN :: Prim a => Int -> (b -> Maybe (a, b)) -> b -> Vector a +{-# INLINE unfoldrN #-} +unfoldrN = G.unfoldrN + +-- | /O(n)/ Construct a vector by repeatedly applying the monadic +-- generator function to a seed. The generator function yields 'Just' +-- the next element and the new seed or 'Nothing' if there are no more +-- elements. +unfoldrM :: (Monad m, Prim a) => (b -> m (Maybe (a, b))) -> b -> m (Vector a) +{-# INLINE unfoldrM #-} +unfoldrM = G.unfoldrM + +-- | /O(n)/ Construct a vector by repeatedly applying the monadic +-- generator function to a seed. The generator function yields 'Just' +-- the next element and the new seed or 'Nothing' if there are no more +-- elements. +unfoldrNM :: (Monad m, Prim a) => Int -> (b -> m (Maybe (a, b))) -> b -> m (Vector a) +{-# INLINE unfoldrNM #-} +unfoldrNM = G.unfoldrNM + +-- | /O(n)/ Construct a vector with @n@ elements by repeatedly applying the +-- generator function to the already constructed part of the vector. +-- +-- > constructN 3 f = let a = f <> ; b = f <a> ; c = f <a,b> in f <a,b,c> +-- +constructN :: Prim a => Int -> (Vector a -> a) -> Vector a +{-# INLINE constructN #-} +constructN = G.constructN + +-- | /O(n)/ Construct a vector with @n@ elements from right to left by +-- repeatedly applying the generator function to the already constructed part +-- of the vector. +-- +-- > constructrN 3 f = let a = f <> ; b = f<a> ; c = f <b,a> in f <c,b,a> +-- +constructrN :: Prim a => Int -> (Vector a -> a) -> Vector a +{-# INLINE constructrN #-} +constructrN = G.constructrN + +-- Enumeration +-- ----------- + +-- | /O(n)/ Yield a vector of the given length containing the values @x@, @x+1@ +-- etc. This operation is usually more efficient than 'enumFromTo'. +-- +-- > enumFromN 5 3 = <5,6,7> +enumFromN :: (Prim a, Num a) => a -> Int -> Vector a +{-# INLINE enumFromN #-} +enumFromN = G.enumFromN + +-- | /O(n)/ Yield a vector of the given length containing the values @x@, @x+y@, +-- @x+y+y@ etc. This operations is usually more efficient than 'enumFromThenTo'. +-- +-- > enumFromStepN 1 0.1 5 = <1,1.1,1.2,1.3,1.4> +enumFromStepN :: (Prim a, Num a) => a -> a -> Int -> Vector a +{-# INLINE enumFromStepN #-} +enumFromStepN = G.enumFromStepN + +-- | /O(n)/ Enumerate values from @x@ to @y@. +-- +-- /WARNING:/ This operation can be very inefficient. If at all possible, use +-- 'enumFromN' instead. +enumFromTo :: (Prim a, Enum a) => a -> a -> Vector a +{-# INLINE enumFromTo #-} +enumFromTo = G.enumFromTo + +-- | /O(n)/ Enumerate values from @x@ to @y@ with a specific step @z@. +-- +-- /WARNING:/ This operation can be very inefficient. If at all possible, use +-- 'enumFromStepN' instead. +enumFromThenTo :: (Prim a, Enum a) => a -> a -> a -> Vector a +{-# INLINE enumFromThenTo #-} +enumFromThenTo = G.enumFromThenTo + +-- Concatenation +-- ------------- + +-- | /O(n)/ Prepend an element +cons :: Prim a => a -> Vector a -> Vector a +{-# INLINE cons #-} +cons = G.cons + +-- | /O(n)/ Append an element +snoc :: Prim a => Vector a -> a -> Vector a +{-# INLINE snoc #-} +snoc = G.snoc + +infixr 5 ++ +-- | /O(m+n)/ Concatenate two vectors +(++) :: Prim a => Vector a -> Vector a -> Vector a +{-# INLINE (++) #-} +(++) = (G.++) + +-- | /O(n)/ Concatenate all vectors in the list +concat :: Prim a => [Vector a] -> Vector a +{-# INLINE concat #-} +concat = G.concat + +-- Monadic initialisation +-- ---------------------- + +-- | /O(n)/ Execute the monadic action the given number of times and store the +-- results in a vector. +replicateM :: (Monad m, Prim a) => Int -> m a -> m (Vector a) +{-# INLINE replicateM #-} +replicateM = G.replicateM + +-- | /O(n)/ Construct a vector of the given length by applying the monadic +-- action to each index +generateM :: (Monad m, Prim a) => Int -> (Int -> m a) -> m (Vector a) +{-# INLINE generateM #-} +generateM = G.generateM + +-- | /O(n)/ Apply monadic function n times to value. Zeroth element is original value. +iterateNM :: (Monad m, Prim a) => Int -> (a -> m a) -> a -> m (Vector a) +{-# INLINE iterateNM #-} +iterateNM = G.iterateNM + +-- | Execute the monadic action and freeze the resulting vector. +-- +-- @ +-- create (do { v \<- new 2; write v 0 \'a\'; write v 1 \'b\'; return v }) = \<'a','b'\> +-- @ +create :: Prim a => (forall s. ST s (MVector s a)) -> Vector a +{-# INLINE create #-} +-- NOTE: eta-expanded due to http://hackage.haskell.org/trac/ghc/ticket/4120 +create p = G.create p + +-- | Execute the monadic action and freeze the resulting vectors. +createT :: (Traversable f, Prim a) => (forall s. ST s (f (MVector s a))) -> f (Vector a) +{-# INLINE createT #-} +createT p = G.createT p + +-- Restricting memory usage +-- ------------------------ + +-- | /O(n)/ Yield the argument but force it not to retain any extra memory, +-- possibly by copying it. +-- +-- This is especially useful when dealing with slices. For example: +-- +-- > force (slice 0 2 <huge vector>) +-- +-- Here, the slice retains a reference to the huge vector. Forcing it creates +-- a copy of just the elements that belong to the slice and allows the huge +-- vector to be garbage collected. +force :: Prim a => Vector a -> Vector a +{-# INLINE force #-} +force = G.force + +-- Bulk updates +-- ------------ + +-- | /O(m+n)/ For each pair @(i,a)@ from the list, replace the vector +-- element at position @i@ by @a@. +-- +-- > <5,9,2,7> // [(2,1),(0,3),(2,8)] = <3,9,8,7> +-- +(//) :: Prim a => Vector a -- ^ initial vector (of length @m@) + -> [(Int, a)] -- ^ list of index/value pairs (of length @n@) + -> Vector a +{-# INLINE (//) #-} +(//) = (G.//) + +-- | /O(m+min(n1,n2))/ For each index @i@ from the index vector and the +-- corresponding value @a@ from the value vector, replace the element of the +-- initial vector at position @i@ by @a@. +-- +-- > update_ <5,9,2,7> <2,0,2> <1,3,8> = <3,9,8,7> +-- +update_ :: Prim a + => Vector a -- ^ initial vector (of length @m@) + -> Vector Int -- ^ index vector (of length @n1@) + -> Vector a -- ^ value vector (of length @n2@) + -> Vector a +{-# INLINE update_ #-} +update_ = G.update_ + +-- | Same as ('//') but without bounds checking. +unsafeUpd :: Prim a => Vector a -> [(Int, a)] -> Vector a +{-# INLINE unsafeUpd #-} +unsafeUpd = G.unsafeUpd + +-- | Same as 'update_' but without bounds checking. +unsafeUpdate_ :: Prim a => Vector a -> Vector Int -> Vector a -> Vector a +{-# INLINE unsafeUpdate_ #-} +unsafeUpdate_ = G.unsafeUpdate_ + +-- Accumulations +-- ------------- + +-- | /O(m+n)/ For each pair @(i,b)@ from the list, replace the vector element +-- @a@ at position @i@ by @f a b@. +-- +-- > accum (+) <5,9,2> [(2,4),(1,6),(0,3),(1,7)] = <5+3, 9+6+7, 2+4> +accum :: Prim a + => (a -> b -> a) -- ^ accumulating function @f@ + -> Vector a -- ^ initial vector (of length @m@) + -> [(Int,b)] -- ^ list of index/value pairs (of length @n@) + -> Vector a +{-# INLINE accum #-} +accum = G.accum + +-- | /O(m+min(n1,n2))/ For each index @i@ from the index vector and the +-- corresponding value @b@ from the the value vector, +-- replace the element of the initial vector at +-- position @i@ by @f a b@. +-- +-- > accumulate_ (+) <5,9,2> <2,1,0,1> <4,6,3,7> = <5+3, 9+6+7, 2+4> +-- +accumulate_ :: (Prim a, Prim b) + => (a -> b -> a) -- ^ accumulating function @f@ + -> Vector a -- ^ initial vector (of length @m@) + -> Vector Int -- ^ index vector (of length @n1@) + -> Vector b -- ^ value vector (of length @n2@) + -> Vector a +{-# INLINE accumulate_ #-} +accumulate_ = G.accumulate_ + +-- | Same as 'accum' but without bounds checking. +unsafeAccum :: Prim a => (a -> b -> a) -> Vector a -> [(Int,b)] -> Vector a +{-# INLINE unsafeAccum #-} +unsafeAccum = G.unsafeAccum + +-- | Same as 'accumulate_' but without bounds checking. +unsafeAccumulate_ :: (Prim a, Prim b) => + (a -> b -> a) -> Vector a -> Vector Int -> Vector b -> Vector a +{-# INLINE unsafeAccumulate_ #-} +unsafeAccumulate_ = G.unsafeAccumulate_ + +-- Permutations +-- ------------ + +-- | /O(n)/ Reverse a vector +reverse :: Prim a => Vector a -> Vector a +{-# INLINE reverse #-} +reverse = G.reverse + +-- | /O(n)/ Yield the vector obtained by replacing each element @i@ of the +-- index vector by @xs'!'i@. This is equivalent to @'map' (xs'!') is@ but is +-- often much more efficient. +-- +-- > backpermute <a,b,c,d> <0,3,2,3,1,0> = <a,d,c,d,b,a> +backpermute :: Prim a => Vector a -> Vector Int -> Vector a +{-# INLINE backpermute #-} +backpermute = G.backpermute + +-- | Same as 'backpermute' but without bounds checking. +unsafeBackpermute :: Prim a => Vector a -> Vector Int -> Vector a +{-# INLINE unsafeBackpermute #-} +unsafeBackpermute = G.unsafeBackpermute + +-- Safe destructive updates +-- ------------------------ + +-- | Apply a destructive operation to a vector. The operation will be +-- performed in place if it is safe to do so and will modify a copy of the +-- vector otherwise. +-- +-- @ +-- modify (\\v -> write v 0 \'x\') ('replicate' 3 \'a\') = \<\'x\',\'a\',\'a\'\> +-- @ +modify :: Prim a => (forall s. MVector s a -> ST s ()) -> Vector a -> Vector a +{-# INLINE modify #-} +modify p = G.modify p + +-- Mapping +-- ------- + +-- | /O(n)/ Map a function over a vector +map :: (Prim a, Prim b) => (a -> b) -> Vector a -> Vector b +{-# INLINE map #-} +map = G.map + +-- | /O(n)/ Apply a function to every element of a vector and its index +imap :: (Prim a, Prim b) => (Int -> a -> b) -> Vector a -> Vector b +{-# INLINE imap #-} +imap = G.imap + +-- | Map a function over a vector and concatenate the results. +concatMap :: (Prim a, Prim b) => (a -> Vector b) -> Vector a -> Vector b +{-# INLINE concatMap #-} +concatMap = G.concatMap + +-- Monadic mapping +-- --------------- + +-- | /O(n)/ Apply the monadic action to all elements of the vector, yielding a +-- vector of results +mapM :: (Monad m, Prim a, Prim b) => (a -> m b) -> Vector a -> m (Vector b) +{-# INLINE mapM #-} +mapM = G.mapM + +-- | /O(n)/ Apply the monadic action to all elements of a vector and ignore the +-- results +mapM_ :: (Monad m, Prim a) => (a -> m b) -> Vector a -> m () +{-# INLINE mapM_ #-} +mapM_ = G.mapM_ + +-- | /O(n)/ Apply the monadic action to all elements of the vector, yielding a +-- vector of results. Equivalent to @flip 'mapM'@. +forM :: (Monad m, Prim a, Prim b) => Vector a -> (a -> m b) -> m (Vector b) +{-# INLINE forM #-} +forM = G.forM + +-- | /O(n)/ Apply the monadic action to all elements of a vector and ignore the +-- results. Equivalent to @flip 'mapM_'@. +forM_ :: (Monad m, Prim a) => Vector a -> (a -> m b) -> m () +{-# INLINE forM_ #-} +forM_ = G.forM_ + +-- Zipping +-- ------- + +-- | /O(min(m,n))/ Zip two vectors with the given function. +zipWith :: (Prim a, Prim b, Prim c) + => (a -> b -> c) -> Vector a -> Vector b -> Vector c +{-# INLINE zipWith #-} +zipWith = G.zipWith + +-- | Zip three vectors with the given function. +zipWith3 :: (Prim a, Prim b, Prim c, Prim d) + => (a -> b -> c -> d) -> Vector a -> Vector b -> Vector c -> Vector d +{-# INLINE zipWith3 #-} +zipWith3 = G.zipWith3 + +zipWith4 :: (Prim a, Prim b, Prim c, Prim d, Prim e) + => (a -> b -> c -> d -> e) + -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e +{-# INLINE zipWith4 #-} +zipWith4 = G.zipWith4 + +zipWith5 :: (Prim a, Prim b, Prim c, Prim d, Prim e, + Prim f) + => (a -> b -> c -> d -> e -> f) + -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e + -> Vector f +{-# INLINE zipWith5 #-} +zipWith5 = G.zipWith5 + +zipWith6 :: (Prim a, Prim b, Prim c, Prim d, Prim e, + Prim f, Prim g) + => (a -> b -> c -> d -> e -> f -> g) + -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e + -> Vector f -> Vector g +{-# INLINE zipWith6 #-} +zipWith6 = G.zipWith6 + +-- | /O(min(m,n))/ Zip two vectors with a function that also takes the +-- elements' indices. +izipWith :: (Prim a, Prim b, Prim c) + => (Int -> a -> b -> c) -> Vector a -> Vector b -> Vector c +{-# INLINE izipWith #-} +izipWith = G.izipWith + +-- | Zip three vectors and their indices with the given function. +izipWith3 :: (Prim a, Prim b, Prim c, Prim d) + => (Int -> a -> b -> c -> d) + -> Vector a -> Vector b -> Vector c -> Vector d +{-# INLINE izipWith3 #-} +izipWith3 = G.izipWith3 + +izipWith4 :: (Prim a, Prim b, Prim c, Prim d, Prim e) + => (Int -> a -> b -> c -> d -> e) + -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e +{-# INLINE izipWith4 #-} +izipWith4 = G.izipWith4 + +izipWith5 :: (Prim a, Prim b, Prim c, Prim d, Prim e, + Prim f) + => (Int -> a -> b -> c -> d -> e -> f) + -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e + -> Vector f +{-# INLINE izipWith5 #-} +izipWith5 = G.izipWith5 + +izipWith6 :: (Prim a, Prim b, Prim c, Prim d, Prim e, + Prim f, Prim g) + => (Int -> a -> b -> c -> d -> e -> f -> g) + -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e + -> Vector f -> Vector g +{-# INLINE izipWith6 #-} +izipWith6 = G.izipWith6 + +-- Monadic zipping +-- --------------- + +-- | /O(min(m,n))/ Zip the two vectors with the monadic action and yield a +-- vector of results +zipWithM :: (Monad m, Prim a, Prim b, Prim c) + => (a -> b -> m c) -> Vector a -> Vector b -> m (Vector c) +{-# INLINE zipWithM #-} +zipWithM = G.zipWithM + +-- | /O(min(m,n))/ Zip the two vectors with the monadic action and ignore the +-- results +zipWithM_ :: (Monad m, Prim a, Prim b) + => (a -> b -> m c) -> Vector a -> Vector b -> m () +{-# INLINE zipWithM_ #-} +zipWithM_ = G.zipWithM_ + +-- Filtering +-- --------- + +-- | /O(n)/ Drop elements that do not satisfy the predicate +filter :: Prim a => (a -> Bool) -> Vector a -> Vector a +{-# INLINE filter #-} +filter = G.filter + +-- | /O(n)/ Drop elements that do not satisfy the predicate which is applied to +-- values and their indices +ifilter :: Prim a => (Int -> a -> Bool) -> Vector a -> Vector a +{-# INLINE ifilter #-} +ifilter = G.ifilter + +-- | /O(n)/ Drop repeated adjacent elements. +uniq :: (Prim a, Eq a) => Vector a -> Vector a +{-# INLINE uniq #-} +uniq = G.uniq + +-- | /O(n)/ Drop elements when predicate returns Nothing +mapMaybe :: (Prim a, Prim b) => (a -> Maybe b) -> Vector a -> Vector b +{-# INLINE mapMaybe #-} +mapMaybe = G.mapMaybe + +-- | /O(n)/ Drop elements when predicate, applied to index and value, returns Nothing +imapMaybe :: (Prim a, Prim b) => (Int -> a -> Maybe b) -> Vector a -> Vector b +{-# INLINE imapMaybe #-} +imapMaybe = G.imapMaybe + +-- | /O(n)/ Drop elements that do not satisfy the monadic predicate +filterM :: (Monad m, Prim a) => (a -> m Bool) -> Vector a -> m (Vector a) +{-# INLINE filterM #-} +filterM = G.filterM + +-- | /O(n)/ Yield the longest prefix of elements satisfying the predicate +-- without copying. +takeWhile :: Prim a => (a -> Bool) -> Vector a -> Vector a +{-# INLINE takeWhile #-} +takeWhile = G.takeWhile + +-- | /O(n)/ Drop the longest prefix of elements that satisfy the predicate +-- without copying. +dropWhile :: Prim a => (a -> Bool) -> Vector a -> Vector a +{-# INLINE dropWhile #-} +dropWhile = G.dropWhile + +-- Parititioning +-- ------------- + +-- | /O(n)/ Split the vector in two parts, the first one containing those +-- elements that satisfy the predicate and the second one those that don't. The +-- relative order of the elements is preserved at the cost of a sometimes +-- reduced performance compared to 'unstablePartition'. +partition :: Prim a => (a -> Bool) -> Vector a -> (Vector a, Vector a) +{-# INLINE partition #-} +partition = G.partition + +-- | /O(n)/ Split the vector in two parts, the first one containing those +-- elements that satisfy the predicate and the second one those that don't. +-- The order of the elements is not preserved but the operation is often +-- faster than 'partition'. +unstablePartition :: Prim a => (a -> Bool) -> Vector a -> (Vector a, Vector a) +{-# INLINE unstablePartition #-} +unstablePartition = G.unstablePartition + +-- | /O(n)/ Split the vector into the longest prefix of elements that satisfy +-- the predicate and the rest without copying. +span :: Prim a => (a -> Bool) -> Vector a -> (Vector a, Vector a) +{-# INLINE span #-} +span = G.span + +-- | /O(n)/ Split the vector into the longest prefix of elements that do not +-- satisfy the predicate and the rest without copying. +break :: Prim a => (a -> Bool) -> Vector a -> (Vector a, Vector a) +{-# INLINE break #-} +break = G.break + +-- Searching +-- --------- + +infix 4 `elem` +-- | /O(n)/ Check if the vector contains an element +elem :: (Prim a, Eq a) => a -> Vector a -> Bool +{-# INLINE elem #-} +elem = G.elem + +infix 4 `notElem` +-- | /O(n)/ Check if the vector does not contain an element (inverse of 'elem') +notElem :: (Prim a, Eq a) => a -> Vector a -> Bool +{-# INLINE notElem #-} +notElem = G.notElem + +-- | /O(n)/ Yield 'Just' the first element matching the predicate or 'Nothing' +-- if no such element exists. +find :: Prim a => (a -> Bool) -> Vector a -> Maybe a +{-# INLINE find #-} +find = G.find + +-- | /O(n)/ Yield 'Just' the index of the first element matching the predicate +-- or 'Nothing' if no such element exists. +findIndex :: Prim a => (a -> Bool) -> Vector a -> Maybe Int +{-# INLINE findIndex #-} +findIndex = G.findIndex + +-- | /O(n)/ Yield the indices of elements satisfying the predicate in ascending +-- order. +findIndices :: Prim a => (a -> Bool) -> Vector a -> Vector Int +{-# INLINE findIndices #-} +findIndices = G.findIndices + +-- | /O(n)/ Yield 'Just' the index of the first occurence of the given element or +-- 'Nothing' if the vector does not contain the element. This is a specialised +-- version of 'findIndex'. +elemIndex :: (Prim a, Eq a) => a -> Vector a -> Maybe Int +{-# INLINE elemIndex #-} +elemIndex = G.elemIndex + +-- | /O(n)/ Yield the indices of all occurences of the given element in +-- ascending order. This is a specialised version of 'findIndices'. +elemIndices :: (Prim a, Eq a) => a -> Vector a -> Vector Int +{-# INLINE elemIndices #-} +elemIndices = G.elemIndices + +-- Folding +-- ------- + +-- | /O(n)/ Left fold +foldl :: Prim b => (a -> b -> a) -> a -> Vector b -> a +{-# INLINE foldl #-} +foldl = G.foldl + +-- | /O(n)/ Left fold on non-empty vectors +foldl1 :: Prim a => (a -> a -> a) -> Vector a -> a +{-# INLINE foldl1 #-} +foldl1 = G.foldl1 + +-- | /O(n)/ Left fold with strict accumulator +foldl' :: Prim b => (a -> b -> a) -> a -> Vector b -> a +{-# INLINE foldl' #-} +foldl' = G.foldl' + +-- | /O(n)/ Left fold on non-empty vectors with strict accumulator +foldl1' :: Prim a => (a -> a -> a) -> Vector a -> a +{-# INLINE foldl1' #-} +foldl1' = G.foldl1' + +-- | /O(n)/ Right fold +foldr :: Prim a => (a -> b -> b) -> b -> Vector a -> b +{-# INLINE foldr #-} +foldr = G.foldr + +-- | /O(n)/ Right fold on non-empty vectors +foldr1 :: Prim a => (a -> a -> a) -> Vector a -> a +{-# INLINE foldr1 #-} +foldr1 = G.foldr1 + +-- | /O(n)/ Right fold with a strict accumulator +foldr' :: Prim a => (a -> b -> b) -> b -> Vector a -> b +{-# INLINE foldr' #-} +foldr' = G.foldr' + +-- | /O(n)/ Right fold on non-empty vectors with strict accumulator +foldr1' :: Prim a => (a -> a -> a) -> Vector a -> a +{-# INLINE foldr1' #-} +foldr1' = G.foldr1' + +-- | /O(n)/ Left fold (function applied to each element and its index) +ifoldl :: Prim b => (a -> Int -> b -> a) -> a -> Vector b -> a +{-# INLINE ifoldl #-} +ifoldl = G.ifoldl + +-- | /O(n)/ Left fold with strict accumulator (function applied to each element +-- and its index) +ifoldl' :: Prim b => (a -> Int -> b -> a) -> a -> Vector b -> a +{-# INLINE ifoldl' #-} +ifoldl' = G.ifoldl' + +-- | /O(n)/ Right fold (function applied to each element and its index) +ifoldr :: Prim a => (Int -> a -> b -> b) -> b -> Vector a -> b +{-# INLINE ifoldr #-} +ifoldr = G.ifoldr + +-- | /O(n)/ Right fold with strict accumulator (function applied to each +-- element and its index) +ifoldr' :: Prim a => (Int -> a -> b -> b) -> b -> Vector a -> b +{-# INLINE ifoldr' #-} +ifoldr' = G.ifoldr' + +-- Specialised folds +-- ----------------- + +-- | /O(n)/ Check if all elements satisfy the predicate. +all :: Prim a => (a -> Bool) -> Vector a -> Bool +{-# INLINE all #-} +all = G.all + +-- | /O(n)/ Check if any element satisfies the predicate. +any :: Prim a => (a -> Bool) -> Vector a -> Bool +{-# INLINE any #-} +any = G.any + +-- | /O(n)/ Compute the sum of the elements +sum :: (Prim a, Num a) => Vector a -> a +{-# INLINE sum #-} +sum = G.sum + +-- | /O(n)/ Compute the produce of the elements +product :: (Prim a, Num a) => Vector a -> a +{-# INLINE product #-} +product = G.product + +-- | /O(n)/ Yield the maximum element of the vector. The vector may not be +-- empty. +maximum :: (Prim a, Ord a) => Vector a -> a +{-# INLINE maximum #-} +maximum = G.maximum + +-- | /O(n)/ Yield the maximum element of the vector according to the given +-- comparison function. The vector may not be empty. +maximumBy :: Prim a => (a -> a -> Ordering) -> Vector a -> a +{-# INLINE maximumBy #-} +maximumBy = G.maximumBy + +-- | /O(n)/ Yield the minimum element of the vector. The vector may not be +-- empty. +minimum :: (Prim a, Ord a) => Vector a -> a +{-# INLINE minimum #-} +minimum = G.minimum + +-- | /O(n)/ Yield the minimum element of the vector according to the given +-- comparison function. The vector may not be empty. +minimumBy :: Prim a => (a -> a -> Ordering) -> Vector a -> a +{-# INLINE minimumBy #-} +minimumBy = G.minimumBy + +-- | /O(n)/ Yield the index of the maximum element of the vector. The vector +-- may not be empty. +maxIndex :: (Prim a, Ord a) => Vector a -> Int +{-# INLINE maxIndex #-} +maxIndex = G.maxIndex + +-- | /O(n)/ Yield the index of the maximum element of the vector according to +-- the given comparison function. The vector may not be empty. +maxIndexBy :: Prim a => (a -> a -> Ordering) -> Vector a -> Int +{-# INLINE maxIndexBy #-} +maxIndexBy = G.maxIndexBy + +-- | /O(n)/ Yield the index of the minimum element of the vector. The vector +-- may not be empty. +minIndex :: (Prim a, Ord a) => Vector a -> Int +{-# INLINE minIndex #-} +minIndex = G.minIndex + +-- | /O(n)/ Yield the index of the minimum element of the vector according to +-- the given comparison function. The vector may not be empty. +minIndexBy :: Prim a => (a -> a -> Ordering) -> Vector a -> Int +{-# INLINE minIndexBy #-} +minIndexBy = G.minIndexBy + +-- Monadic folds +-- ------------- + +-- | /O(n)/ Monadic fold +foldM :: (Monad m, Prim b) => (a -> b -> m a) -> a -> Vector b -> m a +{-# INLINE foldM #-} +foldM = G.foldM + +-- | /O(n)/ Monadic fold over non-empty vectors +fold1M :: (Monad m, Prim a) => (a -> a -> m a) -> Vector a -> m a +{-# INLINE fold1M #-} +fold1M = G.fold1M + +-- | /O(n)/ Monadic fold with strict accumulator +foldM' :: (Monad m, Prim b) => (a -> b -> m a) -> a -> Vector b -> m a +{-# INLINE foldM' #-} +foldM' = G.foldM' + +-- | /O(n)/ Monadic fold over non-empty vectors with strict accumulator +fold1M' :: (Monad m, Prim a) => (a -> a -> m a) -> Vector a -> m a +{-# INLINE fold1M' #-} +fold1M' = G.fold1M' + +-- | /O(n)/ Monadic fold that discards the result +foldM_ :: (Monad m, Prim b) => (a -> b -> m a) -> a -> Vector b -> m () +{-# INLINE foldM_ #-} +foldM_ = G.foldM_ + +-- | /O(n)/ Monadic fold over non-empty vectors that discards the result +fold1M_ :: (Monad m, Prim a) => (a -> a -> m a) -> Vector a -> m () +{-# INLINE fold1M_ #-} +fold1M_ = G.fold1M_ + +-- | /O(n)/ Monadic fold with strict accumulator that discards the result +foldM'_ :: (Monad m, Prim b) => (a -> b -> m a) -> a -> Vector b -> m () +{-# INLINE foldM'_ #-} +foldM'_ = G.foldM'_ + +-- | /O(n)/ Monadic fold over non-empty vectors with strict accumulator +-- that discards the result +fold1M'_ :: (Monad m, Prim a) => (a -> a -> m a) -> Vector a -> m () +{-# INLINE fold1M'_ #-} +fold1M'_ = G.fold1M'_ + +-- Prefix sums (scans) +-- ------------------- + +-- | /O(n)/ Prescan +-- +-- @ +-- prescanl f z = 'init' . 'scanl' f z +-- @ +-- +-- Example: @prescanl (+) 0 \<1,2,3,4\> = \<0,1,3,6\>@ +-- +prescanl :: (Prim a, Prim b) => (a -> b -> a) -> a -> Vector b -> Vector a +{-# INLINE prescanl #-} +prescanl = G.prescanl + +-- | /O(n)/ Prescan with strict accumulator +prescanl' :: (Prim a, Prim b) => (a -> b -> a) -> a -> Vector b -> Vector a +{-# INLINE prescanl' #-} +prescanl' = G.prescanl' + +-- | /O(n)/ Scan +-- +-- @ +-- postscanl f z = 'tail' . 'scanl' f z +-- @ +-- +-- Example: @postscanl (+) 0 \<1,2,3,4\> = \<1,3,6,10\>@ +-- +postscanl :: (Prim a, Prim b) => (a -> b -> a) -> a -> Vector b -> Vector a +{-# INLINE postscanl #-} +postscanl = G.postscanl + +-- | /O(n)/ Scan with strict accumulator +postscanl' :: (Prim a, Prim b) => (a -> b -> a) -> a -> Vector b -> Vector a +{-# INLINE postscanl' #-} +postscanl' = G.postscanl' + +-- | /O(n)/ Haskell-style scan +-- +-- > scanl f z <x1,...,xn> = <y1,...,y(n+1)> +-- > where y1 = z +-- > yi = f y(i-1) x(i-1) +-- +-- Example: @scanl (+) 0 \<1,2,3,4\> = \<0,1,3,6,10\>@ +-- +scanl :: (Prim a, Prim b) => (a -> b -> a) -> a -> Vector b -> Vector a +{-# INLINE scanl #-} +scanl = G.scanl + +-- | /O(n)/ Haskell-style scan with strict accumulator +scanl' :: (Prim a, Prim b) => (a -> b -> a) -> a -> Vector b -> Vector a +{-# INLINE scanl' #-} +scanl' = G.scanl' + +-- | /O(n)/ Scan over a non-empty vector +-- +-- > scanl f <x1,...,xn> = <y1,...,yn> +-- > where y1 = x1 +-- > yi = f y(i-1) xi +-- +scanl1 :: Prim a => (a -> a -> a) -> Vector a -> Vector a +{-# INLINE scanl1 #-} +scanl1 = G.scanl1 + +-- | /O(n)/ Scan over a non-empty vector with a strict accumulator +scanl1' :: Prim a => (a -> a -> a) -> Vector a -> Vector a +{-# INLINE scanl1' #-} +scanl1' = G.scanl1' + +-- | /O(n)/ Right-to-left prescan +-- +-- @ +-- prescanr f z = 'reverse' . 'prescanl' (flip f) z . 'reverse' +-- @ +-- +prescanr :: (Prim a, Prim b) => (a -> b -> b) -> b -> Vector a -> Vector b +{-# INLINE prescanr #-} +prescanr = G.prescanr + +-- | /O(n)/ Right-to-left prescan with strict accumulator +prescanr' :: (Prim a, Prim b) => (a -> b -> b) -> b -> Vector a -> Vector b +{-# INLINE prescanr' #-} +prescanr' = G.prescanr' + +-- | /O(n)/ Right-to-left scan +postscanr :: (Prim a, Prim b) => (a -> b -> b) -> b -> Vector a -> Vector b +{-# INLINE postscanr #-} +postscanr = G.postscanr + +-- | /O(n)/ Right-to-left scan with strict accumulator +postscanr' :: (Prim a, Prim b) => (a -> b -> b) -> b -> Vector a -> Vector b +{-# INLINE postscanr' #-} +postscanr' = G.postscanr' + +-- | /O(n)/ Right-to-left Haskell-style scan +scanr :: (Prim a, Prim b) => (a -> b -> b) -> b -> Vector a -> Vector b +{-# INLINE scanr #-} +scanr = G.scanr + +-- | /O(n)/ Right-to-left Haskell-style scan with strict accumulator +scanr' :: (Prim a, Prim b) => (a -> b -> b) -> b -> Vector a -> Vector b +{-# INLINE scanr' #-} +scanr' = G.scanr' + +-- | /O(n)/ Right-to-left scan over a non-empty vector +scanr1 :: Prim a => (a -> a -> a) -> Vector a -> Vector a +{-# INLINE scanr1 #-} +scanr1 = G.scanr1 + +-- | /O(n)/ Right-to-left scan over a non-empty vector with a strict +-- accumulator +scanr1' :: Prim a => (a -> a -> a) -> Vector a -> Vector a +{-# INLINE scanr1' #-} +scanr1' = G.scanr1' + +-- Conversions - Lists +-- ------------------------ + +-- | /O(n)/ Convert a vector to a list +toList :: Prim a => Vector a -> [a] +{-# INLINE toList #-} +toList = G.toList + +-- | /O(n)/ Convert a list to a vector +fromList :: Prim a => [a] -> Vector a +{-# INLINE fromList #-} +fromList = G.fromList + +-- | /O(n)/ Convert the first @n@ elements of a list to a vector +-- +-- @ +-- fromListN n xs = 'fromList' ('take' n xs) +-- @ +fromListN :: Prim a => Int -> [a] -> Vector a +{-# INLINE fromListN #-} +fromListN = G.fromListN + +-- Conversions - Mutable vectors +-- ----------------------------- + +-- | /O(1)/ Unsafe convert a mutable vector to an immutable one without +-- copying. The mutable vector may not be used after this operation. +unsafeFreeze :: (Prim a, PrimMonad m) => MVector (PrimState m) a -> m (Vector a) +{-# INLINE unsafeFreeze #-} +unsafeFreeze = G.unsafeFreeze + +-- | /O(1)/ Unsafely convert an immutable vector to a mutable one without +-- copying. The immutable vector may not be used after this operation. +unsafeThaw :: (Prim a, PrimMonad m) => Vector a -> m (MVector (PrimState m) a) +{-# INLINE unsafeThaw #-} +unsafeThaw = G.unsafeThaw + +-- | /O(n)/ Yield a mutable copy of the immutable vector. +thaw :: (Prim a, PrimMonad m) => Vector a -> m (MVector (PrimState m) a) +{-# INLINE thaw #-} +thaw = G.thaw + +-- | /O(n)/ Yield an immutable copy of the mutable vector. +freeze :: (Prim a, PrimMonad m) => MVector (PrimState m) a -> m (Vector a) +{-# INLINE freeze #-} +freeze = G.freeze + +-- | /O(n)/ Copy an immutable vector into a mutable one. The two vectors must +-- have the same length. This is not checked. +unsafeCopy + :: (Prim a, PrimMonad m) => MVector (PrimState m) a -> Vector a -> m () +{-# INLINE unsafeCopy #-} +unsafeCopy = G.unsafeCopy + +-- | /O(n)/ Copy an immutable vector into a mutable one. The two vectors must +-- have the same length. +copy :: (Prim a, PrimMonad m) => MVector (PrimState m) a -> Vector a -> m () +{-# INLINE copy #-} +copy = G.copy diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Primitive/Mutable.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Primitive/Mutable.hs new file mode 100644 index 000000000000..33aca812e208 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Primitive/Mutable.hs @@ -0,0 +1,366 @@ +{-# LANGUAGE CPP, DeriveDataTypeable, MultiParamTypeClasses, FlexibleInstances, ScopedTypeVariables #-} + +-- | +-- Module : Data.Vector.Primitive.Mutable +-- Copyright : (c) Roman Leshchinskiy 2008-2010 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> +-- Stability : experimental +-- Portability : non-portable +-- +-- Mutable primitive vectors. +-- + +module Data.Vector.Primitive.Mutable ( + -- * Mutable vectors of primitive types + MVector(..), IOVector, STVector, Prim, + + -- * Accessors + + -- ** Length information + length, null, + + -- ** Extracting subvectors + slice, init, tail, take, drop, splitAt, + unsafeSlice, unsafeInit, unsafeTail, unsafeTake, unsafeDrop, + + -- ** Overlapping + overlaps, + + -- * Construction + + -- ** Initialisation + new, unsafeNew, replicate, replicateM, clone, + + -- ** Growing + grow, unsafeGrow, + + -- ** Restricting memory usage + clear, + + -- * Accessing individual elements + read, write, modify, swap, + unsafeRead, unsafeWrite, unsafeModify, unsafeSwap, + + -- * Modifying vectors + nextPermutation, + + -- ** Filling and copying + set, copy, move, unsafeCopy, unsafeMove +) where + +import qualified Data.Vector.Generic.Mutable as G +import Data.Primitive.ByteArray +import Data.Primitive ( Prim, sizeOf ) +import Data.Word ( Word8 ) +import Control.Monad.Primitive +import Control.Monad ( liftM ) + +import Control.DeepSeq ( NFData(rnf) ) + +import Prelude hiding ( length, null, replicate, reverse, map, read, + take, drop, splitAt, init, tail ) + +import Data.Typeable ( Typeable ) + +-- Data.Vector.Internal.Check is unnecessary +#define NOT_VECTOR_MODULE +#include "vector.h" + +-- | Mutable vectors of primitive types. +data MVector s a = MVector {-# UNPACK #-} !Int + {-# UNPACK #-} !Int + {-# UNPACK #-} !(MutableByteArray s) -- ^ offset, length, underlying mutable byte array + deriving ( Typeable ) + +type IOVector = MVector RealWorld +type STVector s = MVector s + +instance NFData (MVector s a) where + rnf (MVector _ _ _) = () + +instance Prim a => G.MVector MVector a where + basicLength (MVector _ n _) = n + basicUnsafeSlice j m (MVector i _ arr) + = MVector (i+j) m arr + + {-# INLINE basicOverlaps #-} + basicOverlaps (MVector i m arr1) (MVector j n arr2) + = sameMutableByteArray arr1 arr2 + && (between i j (j+n) || between j i (i+m)) + where + between x y z = x >= y && x < z + + {-# INLINE basicUnsafeNew #-} + basicUnsafeNew n + | n < 0 = error $ "Primitive.basicUnsafeNew: negative length: " ++ show n + | n > mx = error $ "Primitive.basicUnsafeNew: length to large: " ++ show n + | otherwise = MVector 0 n `liftM` newByteArray (n * size) + where + size = sizeOf (undefined :: a) + mx = maxBound `div` size :: Int + + {-# INLINE basicInitialize #-} + basicInitialize (MVector off n v) = + setByteArray v (off * size) (n * size) (0 :: Word8) + where + size = sizeOf (undefined :: a) + + + {-# INLINE basicUnsafeRead #-} + basicUnsafeRead (MVector i _ arr) j = readByteArray arr (i+j) + + {-# INLINE basicUnsafeWrite #-} + basicUnsafeWrite (MVector i _ arr) j x = writeByteArray arr (i+j) x + + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy (MVector i n dst) (MVector j _ src) + = copyMutableByteArray dst (i*sz) src (j*sz) (n*sz) + where + sz = sizeOf (undefined :: a) + + {-# INLINE basicUnsafeMove #-} + basicUnsafeMove (MVector i n dst) (MVector j _ src) + = moveByteArray dst (i*sz) src (j*sz) (n * sz) + where + sz = sizeOf (undefined :: a) + + {-# INLINE basicSet #-} + basicSet (MVector i n arr) x = setByteArray arr i n x + +-- Length information +-- ------------------ + +-- | Length of the mutable vector. +length :: Prim a => MVector s a -> Int +{-# INLINE length #-} +length = G.length + +-- | Check whether the vector is empty +null :: Prim a => MVector s a -> Bool +{-# INLINE null #-} +null = G.null + +-- Extracting subvectors +-- --------------------- + +-- | Yield a part of the mutable vector without copying it. +slice :: Prim a => Int -> Int -> MVector s a -> MVector s a +{-# INLINE slice #-} +slice = G.slice + +take :: Prim a => Int -> MVector s a -> MVector s a +{-# INLINE take #-} +take = G.take + +drop :: Prim a => Int -> MVector s a -> MVector s a +{-# INLINE drop #-} +drop = G.drop + +splitAt :: Prim a => Int -> MVector s a -> (MVector s a, MVector s a) +{-# INLINE splitAt #-} +splitAt = G.splitAt + +init :: Prim a => MVector s a -> MVector s a +{-# INLINE init #-} +init = G.init + +tail :: Prim a => MVector s a -> MVector s a +{-# INLINE tail #-} +tail = G.tail + +-- | Yield a part of the mutable vector without copying it. No bounds checks +-- are performed. +unsafeSlice :: Prim a + => Int -- ^ starting index + -> Int -- ^ length of the slice + -> MVector s a + -> MVector s a +{-# INLINE unsafeSlice #-} +unsafeSlice = G.unsafeSlice + +unsafeTake :: Prim a => Int -> MVector s a -> MVector s a +{-# INLINE unsafeTake #-} +unsafeTake = G.unsafeTake + +unsafeDrop :: Prim a => Int -> MVector s a -> MVector s a +{-# INLINE unsafeDrop #-} +unsafeDrop = G.unsafeDrop + +unsafeInit :: Prim a => MVector s a -> MVector s a +{-# INLINE unsafeInit #-} +unsafeInit = G.unsafeInit + +unsafeTail :: Prim a => MVector s a -> MVector s a +{-# INLINE unsafeTail #-} +unsafeTail = G.unsafeTail + +-- Overlapping +-- ----------- + +-- | Check whether two vectors overlap. +overlaps :: Prim a => MVector s a -> MVector s a -> Bool +{-# INLINE overlaps #-} +overlaps = G.overlaps + +-- Initialisation +-- -------------- + +-- | Create a mutable vector of the given length. +new :: (PrimMonad m, Prim a) => Int -> m (MVector (PrimState m) a) +{-# INLINE new #-} +new = G.new + +-- | Create a mutable vector of the given length. The memory is not initialized. +unsafeNew :: (PrimMonad m, Prim a) => Int -> m (MVector (PrimState m) a) +{-# INLINE unsafeNew #-} +unsafeNew = G.unsafeNew + +-- | Create a mutable vector of the given length (0 if the length is negative) +-- and fill it with an initial value. +replicate :: (PrimMonad m, Prim a) => Int -> a -> m (MVector (PrimState m) a) +{-# INLINE replicate #-} +replicate = G.replicate + +-- | Create a mutable vector of the given length (0 if the length is negative) +-- and fill it with values produced by repeatedly executing the monadic action. +replicateM :: (PrimMonad m, Prim a) => Int -> m a -> m (MVector (PrimState m) a) +{-# INLINE replicateM #-} +replicateM = G.replicateM + +-- | Create a copy of a mutable vector. +clone :: (PrimMonad m, Prim a) + => MVector (PrimState m) a -> m (MVector (PrimState m) a) +{-# INLINE clone #-} +clone = G.clone + +-- Growing +-- ------- + +-- | Grow a vector by the given number of elements. The number must be +-- positive. +grow :: (PrimMonad m, Prim a) + => MVector (PrimState m) a -> Int -> m (MVector (PrimState m) a) +{-# INLINE grow #-} +grow = G.grow + +-- | Grow a vector by the given number of elements. The number must be +-- positive but this is not checked. +unsafeGrow :: (PrimMonad m, Prim a) + => MVector (PrimState m) a -> Int -> m (MVector (PrimState m) a) +{-# INLINE unsafeGrow #-} +unsafeGrow = G.unsafeGrow + +-- Restricting memory usage +-- ------------------------ + +-- | Reset all elements of the vector to some undefined value, clearing all +-- references to external objects. This is usually a noop for unboxed vectors. +clear :: (PrimMonad m, Prim a) => MVector (PrimState m) a -> m () +{-# INLINE clear #-} +clear = G.clear + +-- Accessing individual elements +-- ----------------------------- + +-- | Yield the element at the given position. +read :: (PrimMonad m, Prim a) => MVector (PrimState m) a -> Int -> m a +{-# INLINE read #-} +read = G.read + +-- | Replace the element at the given position. +write :: (PrimMonad m, Prim a) => MVector (PrimState m) a -> Int -> a -> m () +{-# INLINE write #-} +write = G.write + +-- | Modify the element at the given position. +modify :: (PrimMonad m, Prim a) => MVector (PrimState m) a -> (a -> a) -> Int -> m () +{-# INLINE modify #-} +modify = G.modify + +-- | Swap the elements at the given positions. +swap :: (PrimMonad m, Prim a) => MVector (PrimState m) a -> Int -> Int -> m () +{-# INLINE swap #-} +swap = G.swap + + +-- | Yield the element at the given position. No bounds checks are performed. +unsafeRead :: (PrimMonad m, Prim a) => MVector (PrimState m) a -> Int -> m a +{-# INLINE unsafeRead #-} +unsafeRead = G.unsafeRead + +-- | Replace the element at the given position. No bounds checks are performed. +unsafeWrite + :: (PrimMonad m, Prim a) => MVector (PrimState m) a -> Int -> a -> m () +{-# INLINE unsafeWrite #-} +unsafeWrite = G.unsafeWrite + +-- | Modify the element at the given position. No bounds checks are performed. +unsafeModify :: (PrimMonad m, Prim a) => MVector (PrimState m) a -> (a -> a) -> Int -> m () +{-# INLINE unsafeModify #-} +unsafeModify = G.unsafeModify + +-- | Swap the elements at the given positions. No bounds checks are performed. +unsafeSwap + :: (PrimMonad m, Prim a) => MVector (PrimState m) a -> Int -> Int -> m () +{-# INLINE unsafeSwap #-} +unsafeSwap = G.unsafeSwap + +-- Filling and copying +-- ------------------- + +-- | Set all elements of the vector to the given value. +set :: (PrimMonad m, Prim a) => MVector (PrimState m) a -> a -> m () +{-# INLINE set #-} +set = G.set + +-- | Copy a vector. The two vectors must have the same length and may not +-- overlap. +copy :: (PrimMonad m, Prim a) + => MVector (PrimState m) a -- ^ target + -> MVector (PrimState m) a -- ^ source + -> m () +{-# INLINE copy #-} +copy = G.copy + +-- | Copy a vector. The two vectors must have the same length and may not +-- overlap. This is not checked. +unsafeCopy :: (PrimMonad m, Prim a) + => MVector (PrimState m) a -- ^ target + -> MVector (PrimState m) a -- ^ source + -> m () +{-# INLINE unsafeCopy #-} +unsafeCopy = G.unsafeCopy + +-- | Move the contents of a vector. The two vectors must have the same +-- length. +-- +-- If the vectors do not overlap, then this is equivalent to 'copy'. +-- Otherwise, the copying is performed as if the source vector were +-- copied to a temporary vector and then the temporary vector was copied +-- to the target vector. +move :: (PrimMonad m, Prim a) + => MVector (PrimState m) a -> MVector (PrimState m) a -> m () +{-# INLINE move #-} +move = G.move + +-- | Move the contents of a vector. The two vectors must have the same +-- length, but this is not checked. +-- +-- If the vectors do not overlap, then this is equivalent to 'unsafeCopy'. +-- Otherwise, the copying is performed as if the source vector were +-- copied to a temporary vector and then the temporary vector was copied +-- to the target vector. +unsafeMove :: (PrimMonad m, Prim a) + => MVector (PrimState m) a -- ^ target + -> MVector (PrimState m) a -- ^ source + -> m () +{-# INLINE unsafeMove #-} +unsafeMove = G.unsafeMove + +-- | Compute the next (lexicographically) permutation of given vector in-place. +-- Returns False when input is the last permtuation +nextPermutation :: (PrimMonad m,Ord e,Prim e) => MVector (PrimState m) e -> m Bool +{-# INLINE nextPermutation #-} +nextPermutation = G.nextPermutation diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Storable.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Storable.hs new file mode 100644 index 000000000000..30c9a4615c60 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Storable.hs @@ -0,0 +1,1489 @@ +{-# LANGUAGE CPP, DeriveDataTypeable, MultiParamTypeClasses, FlexibleInstances, TypeFamilies, Rank2Types, ScopedTypeVariables #-} + +-- | +-- Module : Data.Vector.Storable +-- Copyright : (c) Roman Leshchinskiy 2009-2010 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> +-- Stability : experimental +-- Portability : non-portable +-- +-- 'Storable'-based vectors. +-- + +module Data.Vector.Storable ( + -- * Storable vectors + Vector, MVector(..), Storable, + + -- * Accessors + + -- ** Length information + length, null, + + -- ** Indexing + (!), (!?), head, last, + unsafeIndex, unsafeHead, unsafeLast, + + -- ** Monadic indexing + indexM, headM, lastM, + unsafeIndexM, unsafeHeadM, unsafeLastM, + + -- ** Extracting subvectors (slicing) + slice, init, tail, take, drop, splitAt, + unsafeSlice, unsafeInit, unsafeTail, unsafeTake, unsafeDrop, + + -- * Construction + + -- ** Initialisation + empty, singleton, replicate, generate, iterateN, + + -- ** Monadic initialisation + replicateM, generateM, iterateNM, create, createT, + + -- ** Unfolding + unfoldr, unfoldrN, + unfoldrM, unfoldrNM, + constructN, constructrN, + + -- ** Enumeration + enumFromN, enumFromStepN, enumFromTo, enumFromThenTo, + + -- ** Concatenation + cons, snoc, (++), concat, + + -- ** Restricting memory usage + force, + + -- * Modifying vectors + + -- ** Bulk updates + (//), update_, + unsafeUpd, unsafeUpdate_, + + -- ** Accumulations + accum, accumulate_, + unsafeAccum, unsafeAccumulate_, + + -- ** Permutations + reverse, backpermute, unsafeBackpermute, + + -- ** Safe destructive updates + modify, + + -- * Elementwise operations + + -- ** Mapping + map, imap, concatMap, + + -- ** Monadic mapping + mapM, mapM_, forM, forM_, + + -- ** Zipping + zipWith, zipWith3, zipWith4, zipWith5, zipWith6, + izipWith, izipWith3, izipWith4, izipWith5, izipWith6, + + -- ** Monadic zipping + zipWithM, zipWithM_, + + -- * Working with predicates + + -- ** Filtering + filter, ifilter, uniq, + mapMaybe, imapMaybe, + filterM, + takeWhile, dropWhile, + + -- ** Partitioning + partition, unstablePartition, span, break, + + -- ** Searching + elem, notElem, find, findIndex, findIndices, elemIndex, elemIndices, + + -- * Folding + foldl, foldl1, foldl', foldl1', foldr, foldr1, foldr', foldr1', + ifoldl, ifoldl', ifoldr, ifoldr', + + -- ** Specialised folds + all, any, and, or, + sum, product, + maximum, maximumBy, minimum, minimumBy, + minIndex, minIndexBy, maxIndex, maxIndexBy, + + -- ** Monadic folds + foldM, foldM', fold1M, fold1M', + foldM_, foldM'_, fold1M_, fold1M'_, + + -- * Prefix sums (scans) + prescanl, prescanl', + postscanl, postscanl', + scanl, scanl', scanl1, scanl1', + prescanr, prescanr', + postscanr, postscanr', + scanr, scanr', scanr1, scanr1', + + -- * Conversions + + -- ** Lists + toList, fromList, fromListN, + + -- ** Other vector types + G.convert, unsafeCast, + + -- ** Mutable vectors + freeze, thaw, copy, unsafeFreeze, unsafeThaw, unsafeCopy, + + -- * Raw pointers + unsafeFromForeignPtr, unsafeFromForeignPtr0, + unsafeToForeignPtr, unsafeToForeignPtr0, + unsafeWith +) where + +import qualified Data.Vector.Generic as G +import Data.Vector.Storable.Mutable ( MVector(..) ) +import Data.Vector.Storable.Internal +import qualified Data.Vector.Fusion.Bundle as Bundle + +import Foreign.Storable +import Foreign.ForeignPtr +import Foreign.Ptr +import Foreign.Marshal.Array ( advancePtr, copyArray ) + +import Control.DeepSeq ( NFData(rnf) ) + +import Control.Monad.ST ( ST ) +import Control.Monad.Primitive + +import Prelude hiding ( length, null, + replicate, (++), concat, + head, last, + init, tail, take, drop, splitAt, reverse, + map, concatMap, + zipWith, zipWith3, zip, zip3, unzip, unzip3, + filter, takeWhile, dropWhile, span, break, + elem, notElem, + foldl, foldl1, foldr, foldr1, + all, any, and, or, sum, product, minimum, maximum, + scanl, scanl1, scanr, scanr1, + enumFromTo, enumFromThenTo, + mapM, mapM_ ) + +import Data.Typeable ( Typeable ) +import Data.Data ( Data(..) ) +import Text.Read ( Read(..), readListPrecDefault ) +import Data.Semigroup ( Semigroup(..) ) + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid ( Monoid(..) ) +import Data.Traversable ( Traversable ) +#endif + +#if __GLASGOW_HASKELL__ >= 708 +import qualified GHC.Exts as Exts +#endif + +-- Data.Vector.Internal.Check is unused +#define NOT_VECTOR_MODULE +#include "vector.h" + +-- | 'Storable'-based vectors +data Vector a = Vector {-# UNPACK #-} !Int + {-# UNPACK #-} !(ForeignPtr a) + deriving ( Typeable ) + +instance NFData (Vector a) where + rnf (Vector _ _) = () + +instance (Show a, Storable a) => Show (Vector a) where + showsPrec = G.showsPrec + +instance (Read a, Storable a) => Read (Vector a) where + readPrec = G.readPrec + readListPrec = readListPrecDefault + +instance (Data a, Storable a) => Data (Vector a) where + gfoldl = G.gfoldl + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = G.mkType "Data.Vector.Storable.Vector" + dataCast1 = G.dataCast + +type instance G.Mutable Vector = MVector + +instance Storable a => G.Vector Vector a where + {-# INLINE basicUnsafeFreeze #-} + basicUnsafeFreeze (MVector n fp) = return $ Vector n fp + + {-# INLINE basicUnsafeThaw #-} + basicUnsafeThaw (Vector n fp) = return $ MVector n fp + + {-# INLINE basicLength #-} + basicLength (Vector n _) = n + + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice i n (Vector _ fp) = Vector n (updPtr (`advancePtr` i) fp) + + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeIndexM (Vector _ fp) i = return + . unsafeInlineIO + $ withForeignPtr fp $ \p -> + peekElemOff p i + + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy (MVector n fp) (Vector _ fq) + = unsafePrimToPrim + $ withForeignPtr fp $ \p -> + withForeignPtr fq $ \q -> + copyArray p q n + + {-# INLINE elemseq #-} + elemseq _ = seq + +-- See http://trac.haskell.org/vector/ticket/12 +instance (Storable a, Eq a) => Eq (Vector a) where + {-# INLINE (==) #-} + xs == ys = Bundle.eq (G.stream xs) (G.stream ys) + + {-# INLINE (/=) #-} + xs /= ys = not (Bundle.eq (G.stream xs) (G.stream ys)) + +-- See http://trac.haskell.org/vector/ticket/12 +instance (Storable a, Ord a) => Ord (Vector a) where + {-# INLINE compare #-} + compare xs ys = Bundle.cmp (G.stream xs) (G.stream ys) + + {-# INLINE (<) #-} + xs < ys = Bundle.cmp (G.stream xs) (G.stream ys) == LT + + {-# INLINE (<=) #-} + xs <= ys = Bundle.cmp (G.stream xs) (G.stream ys) /= GT + + {-# INLINE (>) #-} + xs > ys = Bundle.cmp (G.stream xs) (G.stream ys) == GT + + {-# INLINE (>=) #-} + xs >= ys = Bundle.cmp (G.stream xs) (G.stream ys) /= LT + +instance Storable a => Semigroup (Vector a) where + {-# INLINE (<>) #-} + (<>) = (++) + + {-# INLINE sconcat #-} + sconcat = G.concatNE + +instance Storable a => Monoid (Vector a) where + {-# INLINE mempty #-} + mempty = empty + + {-# INLINE mappend #-} + mappend = (++) + + {-# INLINE mconcat #-} + mconcat = concat + +#if __GLASGOW_HASKELL__ >= 708 + +instance Storable a => Exts.IsList (Vector a) where + type Item (Vector a) = a + fromList = fromList + fromListN = fromListN + toList = toList + +#endif + +-- Length +-- ------ + +-- | /O(1)/ Yield the length of the vector +length :: Storable a => Vector a -> Int +{-# INLINE length #-} +length = G.length + +-- | /O(1)/ Test whether a vector is empty +null :: Storable a => Vector a -> Bool +{-# INLINE null #-} +null = G.null + +-- Indexing +-- -------- + +-- | O(1) Indexing +(!) :: Storable a => Vector a -> Int -> a +{-# INLINE (!) #-} +(!) = (G.!) + +-- | O(1) Safe indexing +(!?) :: Storable a => Vector a -> Int -> Maybe a +{-# INLINE (!?) #-} +(!?) = (G.!?) + +-- | /O(1)/ First element +head :: Storable a => Vector a -> a +{-# INLINE head #-} +head = G.head + +-- | /O(1)/ Last element +last :: Storable a => Vector a -> a +{-# INLINE last #-} +last = G.last + +-- | /O(1)/ Unsafe indexing without bounds checking +unsafeIndex :: Storable a => Vector a -> Int -> a +{-# INLINE unsafeIndex #-} +unsafeIndex = G.unsafeIndex + +-- | /O(1)/ First element without checking if the vector is empty +unsafeHead :: Storable a => Vector a -> a +{-# INLINE unsafeHead #-} +unsafeHead = G.unsafeHead + +-- | /O(1)/ Last element without checking if the vector is empty +unsafeLast :: Storable a => Vector a -> a +{-# INLINE unsafeLast #-} +unsafeLast = G.unsafeLast + +-- Monadic indexing +-- ---------------- + +-- | /O(1)/ Indexing in a monad. +-- +-- The monad allows operations to be strict in the vector when necessary. +-- Suppose vector copying is implemented like this: +-- +-- > copy mv v = ... write mv i (v ! i) ... +-- +-- For lazy vectors, @v ! i@ would not be evaluated which means that @mv@ +-- would unnecessarily retain a reference to @v@ in each element written. +-- +-- With 'indexM', copying can be implemented like this instead: +-- +-- > copy mv v = ... do +-- > x <- indexM v i +-- > write mv i x +-- +-- Here, no references to @v@ are retained because indexing (but /not/ the +-- elements) is evaluated eagerly. +-- +indexM :: (Storable a, Monad m) => Vector a -> Int -> m a +{-# INLINE indexM #-} +indexM = G.indexM + +-- | /O(1)/ First element of a vector in a monad. See 'indexM' for an +-- explanation of why this is useful. +headM :: (Storable a, Monad m) => Vector a -> m a +{-# INLINE headM #-} +headM = G.headM + +-- | /O(1)/ Last element of a vector in a monad. See 'indexM' for an +-- explanation of why this is useful. +lastM :: (Storable a, Monad m) => Vector a -> m a +{-# INLINE lastM #-} +lastM = G.lastM + +-- | /O(1)/ Indexing in a monad without bounds checks. See 'indexM' for an +-- explanation of why this is useful. +unsafeIndexM :: (Storable a, Monad m) => Vector a -> Int -> m a +{-# INLINE unsafeIndexM #-} +unsafeIndexM = G.unsafeIndexM + +-- | /O(1)/ First element in a monad without checking for empty vectors. +-- See 'indexM' for an explanation of why this is useful. +unsafeHeadM :: (Storable a, Monad m) => Vector a -> m a +{-# INLINE unsafeHeadM #-} +unsafeHeadM = G.unsafeHeadM + +-- | /O(1)/ Last element in a monad without checking for empty vectors. +-- See 'indexM' for an explanation of why this is useful. +unsafeLastM :: (Storable a, Monad m) => Vector a -> m a +{-# INLINE unsafeLastM #-} +unsafeLastM = G.unsafeLastM + +-- Extracting subvectors (slicing) +-- ------------------------------- + +-- | /O(1)/ Yield a slice of the vector without copying it. The vector must +-- contain at least @i+n@ elements. +slice :: Storable a + => Int -- ^ @i@ starting index + -> Int -- ^ @n@ length + -> Vector a + -> Vector a +{-# INLINE slice #-} +slice = G.slice + +-- | /O(1)/ Yield all but the last element without copying. The vector may not +-- be empty. +init :: Storable a => Vector a -> Vector a +{-# INLINE init #-} +init = G.init + +-- | /O(1)/ Yield all but the first element without copying. The vector may not +-- be empty. +tail :: Storable a => Vector a -> Vector a +{-# INLINE tail #-} +tail = G.tail + +-- | /O(1)/ Yield at the first @n@ elements without copying. The vector may +-- contain less than @n@ elements in which case it is returned unchanged. +take :: Storable a => Int -> Vector a -> Vector a +{-# INLINE take #-} +take = G.take + +-- | /O(1)/ Yield all but the first @n@ elements without copying. The vector may +-- contain less than @n@ elements in which case an empty vector is returned. +drop :: Storable a => Int -> Vector a -> Vector a +{-# INLINE drop #-} +drop = G.drop + +-- | /O(1)/ Yield the first @n@ elements paired with the remainder without copying. +-- +-- Note that @'splitAt' n v@ is equivalent to @('take' n v, 'drop' n v)@ +-- but slightly more efficient. +{-# INLINE splitAt #-} +splitAt :: Storable a => Int -> Vector a -> (Vector a, Vector a) +splitAt = G.splitAt + +-- | /O(1)/ Yield a slice of the vector without copying. The vector must +-- contain at least @i+n@ elements but this is not checked. +unsafeSlice :: Storable a => Int -- ^ @i@ starting index + -> Int -- ^ @n@ length + -> Vector a + -> Vector a +{-# INLINE unsafeSlice #-} +unsafeSlice = G.unsafeSlice + +-- | /O(1)/ Yield all but the last element without copying. The vector may not +-- be empty but this is not checked. +unsafeInit :: Storable a => Vector a -> Vector a +{-# INLINE unsafeInit #-} +unsafeInit = G.unsafeInit + +-- | /O(1)/ Yield all but the first element without copying. The vector may not +-- be empty but this is not checked. +unsafeTail :: Storable a => Vector a -> Vector a +{-# INLINE unsafeTail #-} +unsafeTail = G.unsafeTail + +-- | /O(1)/ Yield the first @n@ elements without copying. The vector must +-- contain at least @n@ elements but this is not checked. +unsafeTake :: Storable a => Int -> Vector a -> Vector a +{-# INLINE unsafeTake #-} +unsafeTake = G.unsafeTake + +-- | /O(1)/ Yield all but the first @n@ elements without copying. The vector +-- must contain at least @n@ elements but this is not checked. +unsafeDrop :: Storable a => Int -> Vector a -> Vector a +{-# INLINE unsafeDrop #-} +unsafeDrop = G.unsafeDrop + +-- Initialisation +-- -------------- + +-- | /O(1)/ Empty vector +empty :: Storable a => Vector a +{-# INLINE empty #-} +empty = G.empty + +-- | /O(1)/ Vector with exactly one element +singleton :: Storable a => a -> Vector a +{-# INLINE singleton #-} +singleton = G.singleton + +-- | /O(n)/ Vector of the given length with the same value in each position +replicate :: Storable a => Int -> a -> Vector a +{-# INLINE replicate #-} +replicate = G.replicate + +-- | /O(n)/ Construct a vector of the given length by applying the function to +-- each index +generate :: Storable a => Int -> (Int -> a) -> Vector a +{-# INLINE generate #-} +generate = G.generate + +-- | /O(n)/ Apply function n times to value. Zeroth element is original value. +iterateN :: Storable a => Int -> (a -> a) -> a -> Vector a +{-# INLINE iterateN #-} +iterateN = G.iterateN + +-- Unfolding +-- --------- + +-- | /O(n)/ Construct a vector by repeatedly applying the generator function +-- to a seed. The generator function yields 'Just' the next element and the +-- new seed or 'Nothing' if there are no more elements. +-- +-- > unfoldr (\n -> if n == 0 then Nothing else Just (n,n-1)) 10 +-- > = <10,9,8,7,6,5,4,3,2,1> +unfoldr :: Storable a => (b -> Maybe (a, b)) -> b -> Vector a +{-# INLINE unfoldr #-} +unfoldr = G.unfoldr + +-- | /O(n)/ Construct a vector with at most @n@ elements by repeatedly applying +-- the generator function to a seed. The generator function yields 'Just' the +-- next element and the new seed or 'Nothing' if there are no more elements. +-- +-- > unfoldrN 3 (\n -> Just (n,n-1)) 10 = <10,9,8> +unfoldrN :: Storable a => Int -> (b -> Maybe (a, b)) -> b -> Vector a +{-# INLINE unfoldrN #-} +unfoldrN = G.unfoldrN + +-- | /O(n)/ Construct a vector by repeatedly applying the monadic +-- generator function to a seed. The generator function yields 'Just' +-- the next element and the new seed or 'Nothing' if there are no more +-- elements. +unfoldrM :: (Monad m, Storable a) => (b -> m (Maybe (a, b))) -> b -> m (Vector a) +{-# INLINE unfoldrM #-} +unfoldrM = G.unfoldrM + +-- | /O(n)/ Construct a vector by repeatedly applying the monadic +-- generator function to a seed. The generator function yields 'Just' +-- the next element and the new seed or 'Nothing' if there are no more +-- elements. +unfoldrNM :: (Monad m, Storable a) => Int -> (b -> m (Maybe (a, b))) -> b -> m (Vector a) +{-# INLINE unfoldrNM #-} +unfoldrNM = G.unfoldrNM + +-- | /O(n)/ Construct a vector with @n@ elements by repeatedly applying the +-- generator function to the already constructed part of the vector. +-- +-- > constructN 3 f = let a = f <> ; b = f <a> ; c = f <a,b> in f <a,b,c> +-- +constructN :: Storable a => Int -> (Vector a -> a) -> Vector a +{-# INLINE constructN #-} +constructN = G.constructN + +-- | /O(n)/ Construct a vector with @n@ elements from right to left by +-- repeatedly applying the generator function to the already constructed part +-- of the vector. +-- +-- > constructrN 3 f = let a = f <> ; b = f<a> ; c = f <b,a> in f <c,b,a> +-- +constructrN :: Storable a => Int -> (Vector a -> a) -> Vector a +{-# INLINE constructrN #-} +constructrN = G.constructrN + +-- Enumeration +-- ----------- + +-- | /O(n)/ Yield a vector of the given length containing the values @x@, @x+1@ +-- etc. This operation is usually more efficient than 'enumFromTo'. +-- +-- > enumFromN 5 3 = <5,6,7> +enumFromN :: (Storable a, Num a) => a -> Int -> Vector a +{-# INLINE enumFromN #-} +enumFromN = G.enumFromN + +-- | /O(n)/ Yield a vector of the given length containing the values @x@, @x+y@, +-- @x+y+y@ etc. This operations is usually more efficient than 'enumFromThenTo'. +-- +-- > enumFromStepN 1 0.1 5 = <1,1.1,1.2,1.3,1.4> +enumFromStepN :: (Storable a, Num a) => a -> a -> Int -> Vector a +{-# INLINE enumFromStepN #-} +enumFromStepN = G.enumFromStepN + +-- | /O(n)/ Enumerate values from @x@ to @y@. +-- +-- /WARNING:/ This operation can be very inefficient. If at all possible, use +-- 'enumFromN' instead. +enumFromTo :: (Storable a, Enum a) => a -> a -> Vector a +{-# INLINE enumFromTo #-} +enumFromTo = G.enumFromTo + +-- | /O(n)/ Enumerate values from @x@ to @y@ with a specific step @z@. +-- +-- /WARNING:/ This operation can be very inefficient. If at all possible, use +-- 'enumFromStepN' instead. +enumFromThenTo :: (Storable a, Enum a) => a -> a -> a -> Vector a +{-# INLINE enumFromThenTo #-} +enumFromThenTo = G.enumFromThenTo + +-- Concatenation +-- ------------- + +-- | /O(n)/ Prepend an element +cons :: Storable a => a -> Vector a -> Vector a +{-# INLINE cons #-} +cons = G.cons + +-- | /O(n)/ Append an element +snoc :: Storable a => Vector a -> a -> Vector a +{-# INLINE snoc #-} +snoc = G.snoc + +infixr 5 ++ +-- | /O(m+n)/ Concatenate two vectors +(++) :: Storable a => Vector a -> Vector a -> Vector a +{-# INLINE (++) #-} +(++) = (G.++) + +-- | /O(n)/ Concatenate all vectors in the list +concat :: Storable a => [Vector a] -> Vector a +{-# INLINE concat #-} +concat = G.concat + +-- Monadic initialisation +-- ---------------------- + +-- | /O(n)/ Execute the monadic action the given number of times and store the +-- results in a vector. +replicateM :: (Monad m, Storable a) => Int -> m a -> m (Vector a) +{-# INLINE replicateM #-} +replicateM = G.replicateM + +-- | /O(n)/ Construct a vector of the given length by applying the monadic +-- action to each index +generateM :: (Monad m, Storable a) => Int -> (Int -> m a) -> m (Vector a) +{-# INLINE generateM #-} +generateM = G.generateM + +-- | /O(n)/ Apply monadic function n times to value. Zeroth element is original value. +iterateNM :: (Monad m, Storable a) => Int -> (a -> m a) -> a -> m (Vector a) +{-# INLINE iterateNM #-} +iterateNM = G.iterateNM + +-- | Execute the monadic action and freeze the resulting vector. +-- +-- @ +-- create (do { v \<- new 2; write v 0 \'a\'; write v 1 \'b\'; return v }) = \<'a','b'\> +-- @ +create :: Storable a => (forall s. ST s (MVector s a)) -> Vector a +{-# INLINE create #-} +-- NOTE: eta-expanded due to http://hackage.haskell.org/trac/ghc/ticket/4120 +create p = G.create p + +-- | Execute the monadic action and freeze the resulting vectors. +createT :: (Traversable f, Storable a) => (forall s. ST s (f (MVector s a))) -> f (Vector a) +{-# INLINE createT #-} +createT p = G.createT p + +-- Restricting memory usage +-- ------------------------ + +-- | /O(n)/ Yield the argument but force it not to retain any extra memory, +-- possibly by copying it. +-- +-- This is especially useful when dealing with slices. For example: +-- +-- > force (slice 0 2 <huge vector>) +-- +-- Here, the slice retains a reference to the huge vector. Forcing it creates +-- a copy of just the elements that belong to the slice and allows the huge +-- vector to be garbage collected. +force :: Storable a => Vector a -> Vector a +{-# INLINE force #-} +force = G.force + +-- Bulk updates +-- ------------ + +-- | /O(m+n)/ For each pair @(i,a)@ from the list, replace the vector +-- element at position @i@ by @a@. +-- +-- > <5,9,2,7> // [(2,1),(0,3),(2,8)] = <3,9,8,7> +-- +(//) :: Storable a => Vector a -- ^ initial vector (of length @m@) + -> [(Int, a)] -- ^ list of index/value pairs (of length @n@) + -> Vector a +{-# INLINE (//) #-} +(//) = (G.//) + +-- | /O(m+min(n1,n2))/ For each index @i@ from the index vector and the +-- corresponding value @a@ from the value vector, replace the element of the +-- initial vector at position @i@ by @a@. +-- +-- > update_ <5,9,2,7> <2,0,2> <1,3,8> = <3,9,8,7> +-- +update_ :: Storable a + => Vector a -- ^ initial vector (of length @m@) + -> Vector Int -- ^ index vector (of length @n1@) + -> Vector a -- ^ value vector (of length @n2@) + -> Vector a +{-# INLINE update_ #-} +update_ = G.update_ + +-- | Same as ('//') but without bounds checking. +unsafeUpd :: Storable a => Vector a -> [(Int, a)] -> Vector a +{-# INLINE unsafeUpd #-} +unsafeUpd = G.unsafeUpd + +-- | Same as 'update_' but without bounds checking. +unsafeUpdate_ :: Storable a => Vector a -> Vector Int -> Vector a -> Vector a +{-# INLINE unsafeUpdate_ #-} +unsafeUpdate_ = G.unsafeUpdate_ + +-- Accumulations +-- ------------- + +-- | /O(m+n)/ For each pair @(i,b)@ from the list, replace the vector element +-- @a@ at position @i@ by @f a b@. +-- +-- > accum (+) <5,9,2> [(2,4),(1,6),(0,3),(1,7)] = <5+3, 9+6+7, 2+4> +accum :: Storable a + => (a -> b -> a) -- ^ accumulating function @f@ + -> Vector a -- ^ initial vector (of length @m@) + -> [(Int,b)] -- ^ list of index/value pairs (of length @n@) + -> Vector a +{-# INLINE accum #-} +accum = G.accum + +-- | /O(m+min(n1,n2))/ For each index @i@ from the index vector and the +-- corresponding value @b@ from the the value vector, +-- replace the element of the initial vector at +-- position @i@ by @f a b@. +-- +-- > accumulate_ (+) <5,9,2> <2,1,0,1> <4,6,3,7> = <5+3, 9+6+7, 2+4> +-- +accumulate_ :: (Storable a, Storable b) + => (a -> b -> a) -- ^ accumulating function @f@ + -> Vector a -- ^ initial vector (of length @m@) + -> Vector Int -- ^ index vector (of length @n1@) + -> Vector b -- ^ value vector (of length @n2@) + -> Vector a +{-# INLINE accumulate_ #-} +accumulate_ = G.accumulate_ + +-- | Same as 'accum' but without bounds checking. +unsafeAccum :: Storable a => (a -> b -> a) -> Vector a -> [(Int,b)] -> Vector a +{-# INLINE unsafeAccum #-} +unsafeAccum = G.unsafeAccum + +-- | Same as 'accumulate_' but without bounds checking. +unsafeAccumulate_ :: (Storable a, Storable b) => + (a -> b -> a) -> Vector a -> Vector Int -> Vector b -> Vector a +{-# INLINE unsafeAccumulate_ #-} +unsafeAccumulate_ = G.unsafeAccumulate_ + +-- Permutations +-- ------------ + +-- | /O(n)/ Reverse a vector +reverse :: Storable a => Vector a -> Vector a +{-# INLINE reverse #-} +reverse = G.reverse + +-- | /O(n)/ Yield the vector obtained by replacing each element @i@ of the +-- index vector by @xs'!'i@. This is equivalent to @'map' (xs'!') is@ but is +-- often much more efficient. +-- +-- > backpermute <a,b,c,d> <0,3,2,3,1,0> = <a,d,c,d,b,a> +backpermute :: Storable a => Vector a -> Vector Int -> Vector a +{-# INLINE backpermute #-} +backpermute = G.backpermute + +-- | Same as 'backpermute' but without bounds checking. +unsafeBackpermute :: Storable a => Vector a -> Vector Int -> Vector a +{-# INLINE unsafeBackpermute #-} +unsafeBackpermute = G.unsafeBackpermute + +-- Safe destructive updates +-- ------------------------ + +-- | Apply a destructive operation to a vector. The operation will be +-- performed in place if it is safe to do so and will modify a copy of the +-- vector otherwise. +-- +-- @ +-- modify (\\v -> write v 0 \'x\') ('replicate' 3 \'a\') = \<\'x\',\'a\',\'a\'\> +-- @ +modify :: Storable a => (forall s. MVector s a -> ST s ()) -> Vector a -> Vector a +{-# INLINE modify #-} +modify p = G.modify p + +-- Mapping +-- ------- + +-- | /O(n)/ Map a function over a vector +map :: (Storable a, Storable b) => (a -> b) -> Vector a -> Vector b +{-# INLINE map #-} +map = G.map + +-- | /O(n)/ Apply a function to every element of a vector and its index +imap :: (Storable a, Storable b) => (Int -> a -> b) -> Vector a -> Vector b +{-# INLINE imap #-} +imap = G.imap + +-- | Map a function over a vector and concatenate the results. +concatMap :: (Storable a, Storable b) => (a -> Vector b) -> Vector a -> Vector b +{-# INLINE concatMap #-} +concatMap = G.concatMap + +-- Monadic mapping +-- --------------- + +-- | /O(n)/ Apply the monadic action to all elements of the vector, yielding a +-- vector of results +mapM :: (Monad m, Storable a, Storable b) => (a -> m b) -> Vector a -> m (Vector b) +{-# INLINE mapM #-} +mapM = G.mapM + +-- | /O(n)/ Apply the monadic action to all elements of a vector and ignore the +-- results +mapM_ :: (Monad m, Storable a) => (a -> m b) -> Vector a -> m () +{-# INLINE mapM_ #-} +mapM_ = G.mapM_ + +-- | /O(n)/ Apply the monadic action to all elements of the vector, yielding a +-- vector of results. Equivalent to @flip 'mapM'@. +forM :: (Monad m, Storable a, Storable b) => Vector a -> (a -> m b) -> m (Vector b) +{-# INLINE forM #-} +forM = G.forM + +-- | /O(n)/ Apply the monadic action to all elements of a vector and ignore the +-- results. Equivalent to @flip 'mapM_'@. +forM_ :: (Monad m, Storable a) => Vector a -> (a -> m b) -> m () +{-# INLINE forM_ #-} +forM_ = G.forM_ + +-- Zipping +-- ------- + +-- | /O(min(m,n))/ Zip two vectors with the given function. +zipWith :: (Storable a, Storable b, Storable c) + => (a -> b -> c) -> Vector a -> Vector b -> Vector c +{-# INLINE zipWith #-} +zipWith = G.zipWith + +-- | Zip three vectors with the given function. +zipWith3 :: (Storable a, Storable b, Storable c, Storable d) + => (a -> b -> c -> d) -> Vector a -> Vector b -> Vector c -> Vector d +{-# INLINE zipWith3 #-} +zipWith3 = G.zipWith3 + +zipWith4 :: (Storable a, Storable b, Storable c, Storable d, Storable e) + => (a -> b -> c -> d -> e) + -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e +{-# INLINE zipWith4 #-} +zipWith4 = G.zipWith4 + +zipWith5 :: (Storable a, Storable b, Storable c, Storable d, Storable e, + Storable f) + => (a -> b -> c -> d -> e -> f) + -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e + -> Vector f +{-# INLINE zipWith5 #-} +zipWith5 = G.zipWith5 + +zipWith6 :: (Storable a, Storable b, Storable c, Storable d, Storable e, + Storable f, Storable g) + => (a -> b -> c -> d -> e -> f -> g) + -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e + -> Vector f -> Vector g +{-# INLINE zipWith6 #-} +zipWith6 = G.zipWith6 + +-- | /O(min(m,n))/ Zip two vectors with a function that also takes the +-- elements' indices. +izipWith :: (Storable a, Storable b, Storable c) + => (Int -> a -> b -> c) -> Vector a -> Vector b -> Vector c +{-# INLINE izipWith #-} +izipWith = G.izipWith + +-- | Zip three vectors and their indices with the given function. +izipWith3 :: (Storable a, Storable b, Storable c, Storable d) + => (Int -> a -> b -> c -> d) + -> Vector a -> Vector b -> Vector c -> Vector d +{-# INLINE izipWith3 #-} +izipWith3 = G.izipWith3 + +izipWith4 :: (Storable a, Storable b, Storable c, Storable d, Storable e) + => (Int -> a -> b -> c -> d -> e) + -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e +{-# INLINE izipWith4 #-} +izipWith4 = G.izipWith4 + +izipWith5 :: (Storable a, Storable b, Storable c, Storable d, Storable e, + Storable f) + => (Int -> a -> b -> c -> d -> e -> f) + -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e + -> Vector f +{-# INLINE izipWith5 #-} +izipWith5 = G.izipWith5 + +izipWith6 :: (Storable a, Storable b, Storable c, Storable d, Storable e, + Storable f, Storable g) + => (Int -> a -> b -> c -> d -> e -> f -> g) + -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e + -> Vector f -> Vector g +{-# INLINE izipWith6 #-} +izipWith6 = G.izipWith6 + +-- Monadic zipping +-- --------------- + +-- | /O(min(m,n))/ Zip the two vectors with the monadic action and yield a +-- vector of results +zipWithM :: (Monad m, Storable a, Storable b, Storable c) + => (a -> b -> m c) -> Vector a -> Vector b -> m (Vector c) +{-# INLINE zipWithM #-} +zipWithM = G.zipWithM + +-- | /O(min(m,n))/ Zip the two vectors with the monadic action and ignore the +-- results +zipWithM_ :: (Monad m, Storable a, Storable b) + => (a -> b -> m c) -> Vector a -> Vector b -> m () +{-# INLINE zipWithM_ #-} +zipWithM_ = G.zipWithM_ + +-- Filtering +-- --------- + +-- | /O(n)/ Drop elements that do not satisfy the predicate +filter :: Storable a => (a -> Bool) -> Vector a -> Vector a +{-# INLINE filter #-} +filter = G.filter + +-- | /O(n)/ Drop elements that do not satisfy the predicate which is applied to +-- values and their indices +ifilter :: Storable a => (Int -> a -> Bool) -> Vector a -> Vector a +{-# INLINE ifilter #-} +ifilter = G.ifilter + +-- | /O(n)/ Drop repeated adjacent elements. +uniq :: (Storable a, Eq a) => Vector a -> Vector a +{-# INLINE uniq #-} +uniq = G.uniq + +-- | /O(n)/ Drop elements when predicate returns Nothing +mapMaybe :: (Storable a, Storable b) => (a -> Maybe b) -> Vector a -> Vector b +{-# INLINE mapMaybe #-} +mapMaybe = G.mapMaybe + +-- | /O(n)/ Drop elements when predicate, applied to index and value, returns Nothing +imapMaybe :: (Storable a, Storable b) => (Int -> a -> Maybe b) -> Vector a -> Vector b +{-# INLINE imapMaybe #-} +imapMaybe = G.imapMaybe + +-- | /O(n)/ Drop elements that do not satisfy the monadic predicate +filterM :: (Monad m, Storable a) => (a -> m Bool) -> Vector a -> m (Vector a) +{-# INLINE filterM #-} +filterM = G.filterM + +-- | /O(n)/ Yield the longest prefix of elements satisfying the predicate +-- without copying. +takeWhile :: Storable a => (a -> Bool) -> Vector a -> Vector a +{-# INLINE takeWhile #-} +takeWhile = G.takeWhile + +-- | /O(n)/ Drop the longest prefix of elements that satisfy the predicate +-- without copying. +dropWhile :: Storable a => (a -> Bool) -> Vector a -> Vector a +{-# INLINE dropWhile #-} +dropWhile = G.dropWhile + +-- Parititioning +-- ------------- + +-- | /O(n)/ Split the vector in two parts, the first one containing those +-- elements that satisfy the predicate and the second one those that don't. The +-- relative order of the elements is preserved at the cost of a sometimes +-- reduced performance compared to 'unstablePartition'. +partition :: Storable a => (a -> Bool) -> Vector a -> (Vector a, Vector a) +{-# INLINE partition #-} +partition = G.partition + +-- | /O(n)/ Split the vector in two parts, the first one containing those +-- elements that satisfy the predicate and the second one those that don't. +-- The order of the elements is not preserved but the operation is often +-- faster than 'partition'. +unstablePartition :: Storable a => (a -> Bool) -> Vector a -> (Vector a, Vector a) +{-# INLINE unstablePartition #-} +unstablePartition = G.unstablePartition + +-- | /O(n)/ Split the vector into the longest prefix of elements that satisfy +-- the predicate and the rest without copying. +span :: Storable a => (a -> Bool) -> Vector a -> (Vector a, Vector a) +{-# INLINE span #-} +span = G.span + +-- | /O(n)/ Split the vector into the longest prefix of elements that do not +-- satisfy the predicate and the rest without copying. +break :: Storable a => (a -> Bool) -> Vector a -> (Vector a, Vector a) +{-# INLINE break #-} +break = G.break + +-- Searching +-- --------- + +infix 4 `elem` +-- | /O(n)/ Check if the vector contains an element +elem :: (Storable a, Eq a) => a -> Vector a -> Bool +{-# INLINE elem #-} +elem = G.elem + +infix 4 `notElem` +-- | /O(n)/ Check if the vector does not contain an element (inverse of 'elem') +notElem :: (Storable a, Eq a) => a -> Vector a -> Bool +{-# INLINE notElem #-} +notElem = G.notElem + +-- | /O(n)/ Yield 'Just' the first element matching the predicate or 'Nothing' +-- if no such element exists. +find :: Storable a => (a -> Bool) -> Vector a -> Maybe a +{-# INLINE find #-} +find = G.find + +-- | /O(n)/ Yield 'Just' the index of the first element matching the predicate +-- or 'Nothing' if no such element exists. +findIndex :: Storable a => (a -> Bool) -> Vector a -> Maybe Int +{-# INLINE findIndex #-} +findIndex = G.findIndex + +-- | /O(n)/ Yield the indices of elements satisfying the predicate in ascending +-- order. +findIndices :: Storable a => (a -> Bool) -> Vector a -> Vector Int +{-# INLINE findIndices #-} +findIndices = G.findIndices + +-- | /O(n)/ Yield 'Just' the index of the first occurence of the given element or +-- 'Nothing' if the vector does not contain the element. This is a specialised +-- version of 'findIndex'. +elemIndex :: (Storable a, Eq a) => a -> Vector a -> Maybe Int +{-# INLINE elemIndex #-} +elemIndex = G.elemIndex + +-- | /O(n)/ Yield the indices of all occurences of the given element in +-- ascending order. This is a specialised version of 'findIndices'. +elemIndices :: (Storable a, Eq a) => a -> Vector a -> Vector Int +{-# INLINE elemIndices #-} +elemIndices = G.elemIndices + +-- Folding +-- ------- + +-- | /O(n)/ Left fold +foldl :: Storable b => (a -> b -> a) -> a -> Vector b -> a +{-# INLINE foldl #-} +foldl = G.foldl + +-- | /O(n)/ Left fold on non-empty vectors +foldl1 :: Storable a => (a -> a -> a) -> Vector a -> a +{-# INLINE foldl1 #-} +foldl1 = G.foldl1 + +-- | /O(n)/ Left fold with strict accumulator +foldl' :: Storable b => (a -> b -> a) -> a -> Vector b -> a +{-# INLINE foldl' #-} +foldl' = G.foldl' + +-- | /O(n)/ Left fold on non-empty vectors with strict accumulator +foldl1' :: Storable a => (a -> a -> a) -> Vector a -> a +{-# INLINE foldl1' #-} +foldl1' = G.foldl1' + +-- | /O(n)/ Right fold +foldr :: Storable a => (a -> b -> b) -> b -> Vector a -> b +{-# INLINE foldr #-} +foldr = G.foldr + +-- | /O(n)/ Right fold on non-empty vectors +foldr1 :: Storable a => (a -> a -> a) -> Vector a -> a +{-# INLINE foldr1 #-} +foldr1 = G.foldr1 + +-- | /O(n)/ Right fold with a strict accumulator +foldr' :: Storable a => (a -> b -> b) -> b -> Vector a -> b +{-# INLINE foldr' #-} +foldr' = G.foldr' + +-- | /O(n)/ Right fold on non-empty vectors with strict accumulator +foldr1' :: Storable a => (a -> a -> a) -> Vector a -> a +{-# INLINE foldr1' #-} +foldr1' = G.foldr1' + +-- | /O(n)/ Left fold (function applied to each element and its index) +ifoldl :: Storable b => (a -> Int -> b -> a) -> a -> Vector b -> a +{-# INLINE ifoldl #-} +ifoldl = G.ifoldl + +-- | /O(n)/ Left fold with strict accumulator (function applied to each element +-- and its index) +ifoldl' :: Storable b => (a -> Int -> b -> a) -> a -> Vector b -> a +{-# INLINE ifoldl' #-} +ifoldl' = G.ifoldl' + +-- | /O(n)/ Right fold (function applied to each element and its index) +ifoldr :: Storable a => (Int -> a -> b -> b) -> b -> Vector a -> b +{-# INLINE ifoldr #-} +ifoldr = G.ifoldr + +-- | /O(n)/ Right fold with strict accumulator (function applied to each +-- element and its index) +ifoldr' :: Storable a => (Int -> a -> b -> b) -> b -> Vector a -> b +{-# INLINE ifoldr' #-} +ifoldr' = G.ifoldr' + +-- Specialised folds +-- ----------------- + +-- | /O(n)/ Check if all elements satisfy the predicate. +all :: Storable a => (a -> Bool) -> Vector a -> Bool +{-# INLINE all #-} +all = G.all + +-- | /O(n)/ Check if any element satisfies the predicate. +any :: Storable a => (a -> Bool) -> Vector a -> Bool +{-# INLINE any #-} +any = G.any + +-- | /O(n)/ Check if all elements are 'True' +and :: Vector Bool -> Bool +{-# INLINE and #-} +and = G.and + +-- | /O(n)/ Check if any element is 'True' +or :: Vector Bool -> Bool +{-# INLINE or #-} +or = G.or + +-- | /O(n)/ Compute the sum of the elements +sum :: (Storable a, Num a) => Vector a -> a +{-# INLINE sum #-} +sum = G.sum + +-- | /O(n)/ Compute the produce of the elements +product :: (Storable a, Num a) => Vector a -> a +{-# INLINE product #-} +product = G.product + +-- | /O(n)/ Yield the maximum element of the vector. The vector may not be +-- empty. +maximum :: (Storable a, Ord a) => Vector a -> a +{-# INLINE maximum #-} +maximum = G.maximum + +-- | /O(n)/ Yield the maximum element of the vector according to the given +-- comparison function. The vector may not be empty. +maximumBy :: Storable a => (a -> a -> Ordering) -> Vector a -> a +{-# INLINE maximumBy #-} +maximumBy = G.maximumBy + +-- | /O(n)/ Yield the minimum element of the vector. The vector may not be +-- empty. +minimum :: (Storable a, Ord a) => Vector a -> a +{-# INLINE minimum #-} +minimum = G.minimum + +-- | /O(n)/ Yield the minimum element of the vector according to the given +-- comparison function. The vector may not be empty. +minimumBy :: Storable a => (a -> a -> Ordering) -> Vector a -> a +{-# INLINE minimumBy #-} +minimumBy = G.minimumBy + +-- | /O(n)/ Yield the index of the maximum element of the vector. The vector +-- may not be empty. +maxIndex :: (Storable a, Ord a) => Vector a -> Int +{-# INLINE maxIndex #-} +maxIndex = G.maxIndex + +-- | /O(n)/ Yield the index of the maximum element of the vector according to +-- the given comparison function. The vector may not be empty. +maxIndexBy :: Storable a => (a -> a -> Ordering) -> Vector a -> Int +{-# INLINE maxIndexBy #-} +maxIndexBy = G.maxIndexBy + +-- | /O(n)/ Yield the index of the minimum element of the vector. The vector +-- may not be empty. +minIndex :: (Storable a, Ord a) => Vector a -> Int +{-# INLINE minIndex #-} +minIndex = G.minIndex + +-- | /O(n)/ Yield the index of the minimum element of the vector according to +-- the given comparison function. The vector may not be empty. +minIndexBy :: Storable a => (a -> a -> Ordering) -> Vector a -> Int +{-# INLINE minIndexBy #-} +minIndexBy = G.minIndexBy + +-- Monadic folds +-- ------------- + +-- | /O(n)/ Monadic fold +foldM :: (Monad m, Storable b) => (a -> b -> m a) -> a -> Vector b -> m a +{-# INLINE foldM #-} +foldM = G.foldM + +-- | /O(n)/ Monadic fold over non-empty vectors +fold1M :: (Monad m, Storable a) => (a -> a -> m a) -> Vector a -> m a +{-# INLINE fold1M #-} +fold1M = G.fold1M + +-- | /O(n)/ Monadic fold with strict accumulator +foldM' :: (Monad m, Storable b) => (a -> b -> m a) -> a -> Vector b -> m a +{-# INLINE foldM' #-} +foldM' = G.foldM' + +-- | /O(n)/ Monadic fold over non-empty vectors with strict accumulator +fold1M' :: (Monad m, Storable a) => (a -> a -> m a) -> Vector a -> m a +{-# INLINE fold1M' #-} +fold1M' = G.fold1M' + +-- | /O(n)/ Monadic fold that discards the result +foldM_ :: (Monad m, Storable b) => (a -> b -> m a) -> a -> Vector b -> m () +{-# INLINE foldM_ #-} +foldM_ = G.foldM_ + +-- | /O(n)/ Monadic fold over non-empty vectors that discards the result +fold1M_ :: (Monad m, Storable a) => (a -> a -> m a) -> Vector a -> m () +{-# INLINE fold1M_ #-} +fold1M_ = G.fold1M_ + +-- | /O(n)/ Monadic fold with strict accumulator that discards the result +foldM'_ :: (Monad m, Storable b) => (a -> b -> m a) -> a -> Vector b -> m () +{-# INLINE foldM'_ #-} +foldM'_ = G.foldM'_ + +-- | /O(n)/ Monadic fold over non-empty vectors with strict accumulator +-- that discards the result +fold1M'_ :: (Monad m, Storable a) => (a -> a -> m a) -> Vector a -> m () +{-# INLINE fold1M'_ #-} +fold1M'_ = G.fold1M'_ + +-- Prefix sums (scans) +-- ------------------- + +-- | /O(n)/ Prescan +-- +-- @ +-- prescanl f z = 'init' . 'scanl' f z +-- @ +-- +-- Example: @prescanl (+) 0 \<1,2,3,4\> = \<0,1,3,6\>@ +-- +prescanl :: (Storable a, Storable b) => (a -> b -> a) -> a -> Vector b -> Vector a +{-# INLINE prescanl #-} +prescanl = G.prescanl + +-- | /O(n)/ Prescan with strict accumulator +prescanl' :: (Storable a, Storable b) => (a -> b -> a) -> a -> Vector b -> Vector a +{-# INLINE prescanl' #-} +prescanl' = G.prescanl' + +-- | /O(n)/ Scan +-- +-- @ +-- postscanl f z = 'tail' . 'scanl' f z +-- @ +-- +-- Example: @postscanl (+) 0 \<1,2,3,4\> = \<1,3,6,10\>@ +-- +postscanl :: (Storable a, Storable b) => (a -> b -> a) -> a -> Vector b -> Vector a +{-# INLINE postscanl #-} +postscanl = G.postscanl + +-- | /O(n)/ Scan with strict accumulator +postscanl' :: (Storable a, Storable b) => (a -> b -> a) -> a -> Vector b -> Vector a +{-# INLINE postscanl' #-} +postscanl' = G.postscanl' + +-- | /O(n)/ Haskell-style scan +-- +-- > scanl f z <x1,...,xn> = <y1,...,y(n+1)> +-- > where y1 = z +-- > yi = f y(i-1) x(i-1) +-- +-- Example: @scanl (+) 0 \<1,2,3,4\> = \<0,1,3,6,10\>@ +-- +scanl :: (Storable a, Storable b) => (a -> b -> a) -> a -> Vector b -> Vector a +{-# INLINE scanl #-} +scanl = G.scanl + +-- | /O(n)/ Haskell-style scan with strict accumulator +scanl' :: (Storable a, Storable b) => (a -> b -> a) -> a -> Vector b -> Vector a +{-# INLINE scanl' #-} +scanl' = G.scanl' + +-- | /O(n)/ Scan over a non-empty vector +-- +-- > scanl f <x1,...,xn> = <y1,...,yn> +-- > where y1 = x1 +-- > yi = f y(i-1) xi +-- +scanl1 :: Storable a => (a -> a -> a) -> Vector a -> Vector a +{-# INLINE scanl1 #-} +scanl1 = G.scanl1 + +-- | /O(n)/ Scan over a non-empty vector with a strict accumulator +scanl1' :: Storable a => (a -> a -> a) -> Vector a -> Vector a +{-# INLINE scanl1' #-} +scanl1' = G.scanl1' + +-- | /O(n)/ Right-to-left prescan +-- +-- @ +-- prescanr f z = 'reverse' . 'prescanl' (flip f) z . 'reverse' +-- @ +-- +prescanr :: (Storable a, Storable b) => (a -> b -> b) -> b -> Vector a -> Vector b +{-# INLINE prescanr #-} +prescanr = G.prescanr + +-- | /O(n)/ Right-to-left prescan with strict accumulator +prescanr' :: (Storable a, Storable b) => (a -> b -> b) -> b -> Vector a -> Vector b +{-# INLINE prescanr' #-} +prescanr' = G.prescanr' + +-- | /O(n)/ Right-to-left scan +postscanr :: (Storable a, Storable b) => (a -> b -> b) -> b -> Vector a -> Vector b +{-# INLINE postscanr #-} +postscanr = G.postscanr + +-- | /O(n)/ Right-to-left scan with strict accumulator +postscanr' :: (Storable a, Storable b) => (a -> b -> b) -> b -> Vector a -> Vector b +{-# INLINE postscanr' #-} +postscanr' = G.postscanr' + +-- | /O(n)/ Right-to-left Haskell-style scan +scanr :: (Storable a, Storable b) => (a -> b -> b) -> b -> Vector a -> Vector b +{-# INLINE scanr #-} +scanr = G.scanr + +-- | /O(n)/ Right-to-left Haskell-style scan with strict accumulator +scanr' :: (Storable a, Storable b) => (a -> b -> b) -> b -> Vector a -> Vector b +{-# INLINE scanr' #-} +scanr' = G.scanr' + +-- | /O(n)/ Right-to-left scan over a non-empty vector +scanr1 :: Storable a => (a -> a -> a) -> Vector a -> Vector a +{-# INLINE scanr1 #-} +scanr1 = G.scanr1 + +-- | /O(n)/ Right-to-left scan over a non-empty vector with a strict +-- accumulator +scanr1' :: Storable a => (a -> a -> a) -> Vector a -> Vector a +{-# INLINE scanr1' #-} +scanr1' = G.scanr1' + +-- Conversions - Lists +-- ------------------------ + +-- | /O(n)/ Convert a vector to a list +toList :: Storable a => Vector a -> [a] +{-# INLINE toList #-} +toList = G.toList + +-- | /O(n)/ Convert a list to a vector +fromList :: Storable a => [a] -> Vector a +{-# INLINE fromList #-} +fromList = G.fromList + +-- | /O(n)/ Convert the first @n@ elements of a list to a vector +-- +-- @ +-- fromListN n xs = 'fromList' ('take' n xs) +-- @ +fromListN :: Storable a => Int -> [a] -> Vector a +{-# INLINE fromListN #-} +fromListN = G.fromListN + +-- Conversions - Unsafe casts +-- -------------------------- + +-- | /O(1)/ Unsafely cast a vector from one element type to another. +-- The operation just changes the type of the underlying pointer and does not +-- modify the elements. +-- +-- The resulting vector contains as many elements as can fit into the +-- underlying memory block. +-- +unsafeCast :: forall a b. (Storable a, Storable b) => Vector a -> Vector b +{-# INLINE unsafeCast #-} +unsafeCast (Vector n fp) + = Vector ((n * sizeOf (undefined :: a)) `div` sizeOf (undefined :: b)) + (castForeignPtr fp) + + +-- Conversions - Mutable vectors +-- ----------------------------- + +-- | /O(1)/ Unsafe convert a mutable vector to an immutable one without +-- copying. The mutable vector may not be used after this operation. +unsafeFreeze + :: (Storable a, PrimMonad m) => MVector (PrimState m) a -> m (Vector a) +{-# INLINE unsafeFreeze #-} +unsafeFreeze = G.unsafeFreeze + +-- | /O(1)/ Unsafely convert an immutable vector to a mutable one without +-- copying. The immutable vector may not be used after this operation. +unsafeThaw + :: (Storable a, PrimMonad m) => Vector a -> m (MVector (PrimState m) a) +{-# INLINE unsafeThaw #-} +unsafeThaw = G.unsafeThaw + +-- | /O(n)/ Yield a mutable copy of the immutable vector. +thaw :: (Storable a, PrimMonad m) => Vector a -> m (MVector (PrimState m) a) +{-# INLINE thaw #-} +thaw = G.thaw + +-- | /O(n)/ Yield an immutable copy of the mutable vector. +freeze :: (Storable a, PrimMonad m) => MVector (PrimState m) a -> m (Vector a) +{-# INLINE freeze #-} +freeze = G.freeze + +-- | /O(n)/ Copy an immutable vector into a mutable one. The two vectors must +-- have the same length. This is not checked. +unsafeCopy + :: (Storable a, PrimMonad m) => MVector (PrimState m) a -> Vector a -> m () +{-# INLINE unsafeCopy #-} +unsafeCopy = G.unsafeCopy + +-- | /O(n)/ Copy an immutable vector into a mutable one. The two vectors must +-- have the same length. +copy :: (Storable a, PrimMonad m) => MVector (PrimState m) a -> Vector a -> m () +{-# INLINE copy #-} +copy = G.copy + +-- Conversions - Raw pointers +-- -------------------------- + +-- | /O(1)/ Create a vector from a 'ForeignPtr' with an offset and a length. +-- +-- The data may not be modified through the 'ForeignPtr' afterwards. +-- +-- If your offset is 0 it is more efficient to use 'unsafeFromForeignPtr0'. +unsafeFromForeignPtr :: Storable a + => ForeignPtr a -- ^ pointer + -> Int -- ^ offset + -> Int -- ^ length + -> Vector a +{-# INLINE_FUSED unsafeFromForeignPtr #-} +unsafeFromForeignPtr fp i n = unsafeFromForeignPtr0 fp' n + where + fp' = updPtr (`advancePtr` i) fp + +{-# RULES +"unsafeFromForeignPtr fp 0 n -> unsafeFromForeignPtr0 fp n " forall fp n. + unsafeFromForeignPtr fp 0 n = unsafeFromForeignPtr0 fp n #-} + + +-- | /O(1)/ Create a vector from a 'ForeignPtr' and a length. +-- +-- It is assumed the pointer points directly to the data (no offset). +-- Use `unsafeFromForeignPtr` if you need to specify an offset. +-- +-- The data may not be modified through the 'ForeignPtr' afterwards. +unsafeFromForeignPtr0 :: Storable a + => ForeignPtr a -- ^ pointer + -> Int -- ^ length + -> Vector a +{-# INLINE unsafeFromForeignPtr0 #-} +unsafeFromForeignPtr0 fp n = Vector n fp + +-- | /O(1)/ Yield the underlying 'ForeignPtr' together with the offset to the +-- data and its length. The data may not be modified through the 'ForeignPtr'. +unsafeToForeignPtr :: Storable a => Vector a -> (ForeignPtr a, Int, Int) +{-# INLINE unsafeToForeignPtr #-} +unsafeToForeignPtr (Vector n fp) = (fp, 0, n) + +-- | /O(1)/ Yield the underlying 'ForeignPtr' together with its length. +-- +-- You can assume the pointer points directly to the data (no offset). +-- +-- The data may not be modified through the 'ForeignPtr'. +unsafeToForeignPtr0 :: Storable a => Vector a -> (ForeignPtr a, Int) +{-# INLINE unsafeToForeignPtr0 #-} +unsafeToForeignPtr0 (Vector n fp) = (fp, n) + +-- | Pass a pointer to the vector's data to the IO action. The data may not be +-- modified through the 'Ptr. +unsafeWith :: Storable a => Vector a -> (Ptr a -> IO b) -> IO b +{-# INLINE unsafeWith #-} +unsafeWith (Vector _ fp) = withForeignPtr fp diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Storable/Internal.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Storable/Internal.hs new file mode 100644 index 000000000000..69a46d84215b --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Storable/Internal.hs @@ -0,0 +1,33 @@ +-- | +-- Module : Data.Vector.Storable.Internal +-- Copyright : (c) Roman Leshchinskiy 2009-2010 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> +-- Stability : experimental +-- Portability : non-portable +-- +-- Ugly internal utility functions for implementing 'Storable'-based vectors. +-- + +module Data.Vector.Storable.Internal ( + getPtr, setPtr, updPtr +) where + +import Foreign.ForeignPtr +import Foreign.Ptr +import GHC.ForeignPtr ( ForeignPtr(..) ) +import GHC.Ptr ( Ptr(..) ) + +getPtr :: ForeignPtr a -> Ptr a +{-# INLINE getPtr #-} +getPtr (ForeignPtr addr _) = Ptr addr + +setPtr :: ForeignPtr a -> Ptr a -> ForeignPtr a +{-# INLINE setPtr #-} +setPtr (ForeignPtr _ c) (Ptr addr) = ForeignPtr addr c + +updPtr :: (Ptr a -> Ptr a) -> ForeignPtr a -> ForeignPtr a +{-# INLINE updPtr #-} +updPtr f (ForeignPtr p c) = case f (Ptr p) of { Ptr q -> ForeignPtr q c } + diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Storable/Mutable.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Storable/Mutable.hs new file mode 100644 index 000000000000..29eb2fbfa31e --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Storable/Mutable.hs @@ -0,0 +1,543 @@ +{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleInstances, MagicHash, MultiParamTypeClasses, ScopedTypeVariables #-} + +-- | +-- Module : Data.Vector.Storable.Mutable +-- Copyright : (c) Roman Leshchinskiy 2009-2010 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> +-- Stability : experimental +-- Portability : non-portable +-- +-- Mutable vectors based on Storable. +-- + +module Data.Vector.Storable.Mutable( + -- * Mutable vectors of 'Storable' types + MVector(..), IOVector, STVector, Storable, + + -- * Accessors + + -- ** Length information + length, null, + + -- ** Extracting subvectors + slice, init, tail, take, drop, splitAt, + unsafeSlice, unsafeInit, unsafeTail, unsafeTake, unsafeDrop, + + -- ** Overlapping + overlaps, + + -- * Construction + + -- ** Initialisation + new, unsafeNew, replicate, replicateM, clone, + + -- ** Growing + grow, unsafeGrow, + + -- ** Restricting memory usage + clear, + + -- * Accessing individual elements + read, write, modify, swap, + unsafeRead, unsafeWrite, unsafeModify, unsafeSwap, + + -- * Modifying vectors + + -- ** Filling and copying + set, copy, move, unsafeCopy, unsafeMove, + + -- * Unsafe conversions + unsafeCast, + + -- * Raw pointers + unsafeFromForeignPtr, unsafeFromForeignPtr0, + unsafeToForeignPtr, unsafeToForeignPtr0, + unsafeWith +) where + +import Control.DeepSeq ( NFData(rnf) ) + +import qualified Data.Vector.Generic.Mutable as G +import Data.Vector.Storable.Internal + +import Foreign.Storable +import Foreign.ForeignPtr + +#if __GLASGOW_HASKELL__ >= 706 +import GHC.ForeignPtr (mallocPlainForeignPtrAlignedBytes) +#elif __GLASGOW_HASKELL__ >= 700 +import Data.Primitive.ByteArray (MutableByteArray(..), newAlignedPinnedByteArray, + unsafeFreezeByteArray) +import GHC.Prim (byteArrayContents#, unsafeCoerce#) +import GHC.ForeignPtr +#endif + +import Foreign.Ptr +import Foreign.Marshal.Array ( advancePtr, copyArray, moveArray ) + +import Control.Monad.Primitive +import Data.Primitive.Addr +import Data.Primitive.Types (Prim) + +import GHC.Word (Word8, Word16, Word32, Word64) +import GHC.Ptr (Ptr(..)) + +import Prelude hiding ( length, null, replicate, reverse, map, read, + take, drop, splitAt, init, tail ) + +import Data.Typeable ( Typeable ) + +-- Data.Vector.Internal.Check is not needed +#define NOT_VECTOR_MODULE +#include "vector.h" + +-- | Mutable 'Storable'-based vectors +data MVector s a = MVector {-# UNPACK #-} !Int + {-# UNPACK #-} !(ForeignPtr a) + deriving ( Typeable ) + +type IOVector = MVector RealWorld +type STVector s = MVector s + +instance NFData (MVector s a) where + rnf (MVector _ _) = () + +instance Storable a => G.MVector MVector a where + {-# INLINE basicLength #-} + basicLength (MVector n _) = n + + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice j m (MVector _ fp) = MVector m (updPtr (`advancePtr` j) fp) + + -- FIXME: this relies on non-portable pointer comparisons + {-# INLINE basicOverlaps #-} + basicOverlaps (MVector m fp) (MVector n fq) + = between p q (q `advancePtr` n) || between q p (p `advancePtr` m) + where + between x y z = x >= y && x < z + p = getPtr fp + q = getPtr fq + + {-# INLINE basicUnsafeNew #-} + basicUnsafeNew n + | n < 0 = error $ "Storable.basicUnsafeNew: negative length: " ++ show n + | n > mx = error $ "Storable.basicUnsafeNew: length too large: " ++ show n + | otherwise = unsafePrimToPrim $ do + fp <- mallocVector n + return $ MVector n fp + where + size = sizeOf (undefined :: a) + mx = maxBound `quot` size :: Int + + {-# INLINE basicInitialize #-} + basicInitialize = storableZero + + {-# INLINE basicUnsafeRead #-} + basicUnsafeRead (MVector _ fp) i + = unsafePrimToPrim + $ withForeignPtr fp (`peekElemOff` i) + + {-# INLINE basicUnsafeWrite #-} + basicUnsafeWrite (MVector _ fp) i x + = unsafePrimToPrim + $ withForeignPtr fp $ \p -> pokeElemOff p i x + + {-# INLINE basicSet #-} + basicSet = storableSet + + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy (MVector n fp) (MVector _ fq) + = unsafePrimToPrim + $ withForeignPtr fp $ \p -> + withForeignPtr fq $ \q -> + copyArray p q n + + {-# INLINE basicUnsafeMove #-} + basicUnsafeMove (MVector n fp) (MVector _ fq) + = unsafePrimToPrim + $ withForeignPtr fp $ \p -> + withForeignPtr fq $ \q -> + moveArray p q n + +storableZero :: forall a m. (Storable a, PrimMonad m) => MVector (PrimState m) a -> m () +{-# INLINE storableZero #-} +storableZero (MVector n fp) = unsafePrimToPrim . withForeignPtr fp $ \(Ptr p) -> do + let q = Addr p + setAddr q byteSize (0 :: Word8) + where + x :: a + x = undefined + + byteSize :: Int + byteSize = n * sizeOf x + +storableSet :: (Storable a, PrimMonad m) => MVector (PrimState m) a -> a -> m () +{-# INLINE storableSet #-} +storableSet (MVector n fp) x + | n == 0 = return () + | otherwise = unsafePrimToPrim $ + case sizeOf x of + 1 -> storableSetAsPrim n fp x (undefined :: Word8) + 2 -> storableSetAsPrim n fp x (undefined :: Word16) + 4 -> storableSetAsPrim n fp x (undefined :: Word32) + 8 -> storableSetAsPrim n fp x (undefined :: Word64) + _ -> withForeignPtr fp $ \p -> do + poke p x + + let do_set i + | 2*i < n = do + copyArray (p `advancePtr` i) p i + do_set (2*i) + | otherwise = copyArray (p `advancePtr` i) p (n-i) + + do_set 1 + +storableSetAsPrim + :: (Storable a, Prim b) => Int -> ForeignPtr a -> a -> b -> IO () +{-# INLINE [0] storableSetAsPrim #-} +storableSetAsPrim n fp x y = withForeignPtr fp $ \(Ptr p) -> do + poke (Ptr p) x + let q = Addr p + w <- readOffAddr q 0 + setAddr (q `plusAddr` sizeOf x) (n-1) (w `asTypeOf` y) + +{-# INLINE mallocVector #-} +mallocVector :: Storable a => Int -> IO (ForeignPtr a) +mallocVector = +#if __GLASGOW_HASKELL__ >= 706 + doMalloc undefined + where + doMalloc :: Storable b => b -> Int -> IO (ForeignPtr b) + doMalloc dummy size = + mallocPlainForeignPtrAlignedBytes (size * sizeOf dummy) (alignment dummy) +#elif __GLASGOW_HASKELL__ >= 700 + doMalloc undefined + where + doMalloc :: Storable b => b -> Int -> IO (ForeignPtr b) + doMalloc dummy size = do + arr@(MutableByteArray arr#) <- newAlignedPinnedByteArray arrSize arrAlign + newConcForeignPtr + (Ptr (byteArrayContents# (unsafeCoerce# arr#))) + -- Keep reference to mutable byte array until whole ForeignPtr goes out + -- of scope. + (touch arr) + where + arrSize = size * sizeOf dummy + arrAlign = alignment dummy +#else + mallocForeignPtrArray +#endif + +-- Length information +-- ------------------ + +-- | Length of the mutable vector. +length :: Storable a => MVector s a -> Int +{-# INLINE length #-} +length = G.length + +-- | Check whether the vector is empty +null :: Storable a => MVector s a -> Bool +{-# INLINE null #-} +null = G.null + +-- Extracting subvectors +-- --------------------- + +-- | Yield a part of the mutable vector without copying it. +slice :: Storable a => Int -> Int -> MVector s a -> MVector s a +{-# INLINE slice #-} +slice = G.slice + +take :: Storable a => Int -> MVector s a -> MVector s a +{-# INLINE take #-} +take = G.take + +drop :: Storable a => Int -> MVector s a -> MVector s a +{-# INLINE drop #-} +drop = G.drop + +splitAt :: Storable a => Int -> MVector s a -> (MVector s a, MVector s a) +{-# INLINE splitAt #-} +splitAt = G.splitAt + +init :: Storable a => MVector s a -> MVector s a +{-# INLINE init #-} +init = G.init + +tail :: Storable a => MVector s a -> MVector s a +{-# INLINE tail #-} +tail = G.tail + +-- | Yield a part of the mutable vector without copying it. No bounds checks +-- are performed. +unsafeSlice :: Storable a + => Int -- ^ starting index + -> Int -- ^ length of the slice + -> MVector s a + -> MVector s a +{-# INLINE unsafeSlice #-} +unsafeSlice = G.unsafeSlice + +unsafeTake :: Storable a => Int -> MVector s a -> MVector s a +{-# INLINE unsafeTake #-} +unsafeTake = G.unsafeTake + +unsafeDrop :: Storable a => Int -> MVector s a -> MVector s a +{-# INLINE unsafeDrop #-} +unsafeDrop = G.unsafeDrop + +unsafeInit :: Storable a => MVector s a -> MVector s a +{-# INLINE unsafeInit #-} +unsafeInit = G.unsafeInit + +unsafeTail :: Storable a => MVector s a -> MVector s a +{-# INLINE unsafeTail #-} +unsafeTail = G.unsafeTail + +-- Overlapping +-- ----------- + +-- | Check whether two vectors overlap. +overlaps :: Storable a => MVector s a -> MVector s a -> Bool +{-# INLINE overlaps #-} +overlaps = G.overlaps + +-- Initialisation +-- -------------- + +-- | Create a mutable vector of the given length. +new :: (PrimMonad m, Storable a) => Int -> m (MVector (PrimState m) a) +{-# INLINE new #-} +new = G.new + +-- | Create a mutable vector of the given length. The memory is not initialized. +unsafeNew :: (PrimMonad m, Storable a) => Int -> m (MVector (PrimState m) a) +{-# INLINE unsafeNew #-} +unsafeNew = G.unsafeNew + +-- | Create a mutable vector of the given length (0 if the length is negative) +-- and fill it with an initial value. +replicate :: (PrimMonad m, Storable a) => Int -> a -> m (MVector (PrimState m) a) +{-# INLINE replicate #-} +replicate = G.replicate + +-- | Create a mutable vector of the given length (0 if the length is negative) +-- and fill it with values produced by repeatedly executing the monadic action. +replicateM :: (PrimMonad m, Storable a) => Int -> m a -> m (MVector (PrimState m) a) +{-# INLINE replicateM #-} +replicateM = G.replicateM + +-- | Create a copy of a mutable vector. +clone :: (PrimMonad m, Storable a) + => MVector (PrimState m) a -> m (MVector (PrimState m) a) +{-# INLINE clone #-} +clone = G.clone + +-- Growing +-- ------- + +-- | Grow a vector by the given number of elements. The number must be +-- positive. +grow :: (PrimMonad m, Storable a) + => MVector (PrimState m) a -> Int -> m (MVector (PrimState m) a) +{-# INLINE grow #-} +grow = G.grow + +-- | Grow a vector by the given number of elements. The number must be +-- positive but this is not checked. +unsafeGrow :: (PrimMonad m, Storable a) + => MVector (PrimState m) a -> Int -> m (MVector (PrimState m) a) +{-# INLINE unsafeGrow #-} +unsafeGrow = G.unsafeGrow + +-- Restricting memory usage +-- ------------------------ + +-- | Reset all elements of the vector to some undefined value, clearing all +-- references to external objects. This is usually a noop for unboxed vectors. +clear :: (PrimMonad m, Storable a) => MVector (PrimState m) a -> m () +{-# INLINE clear #-} +clear = G.clear + +-- Accessing individual elements +-- ----------------------------- + +-- | Yield the element at the given position. +read :: (PrimMonad m, Storable a) => MVector (PrimState m) a -> Int -> m a +{-# INLINE read #-} +read = G.read + +-- | Replace the element at the given position. +write + :: (PrimMonad m, Storable a) => MVector (PrimState m) a -> Int -> a -> m () +{-# INLINE write #-} +write = G.write + +-- | Modify the element at the given position. +modify :: (PrimMonad m, Storable a) => MVector (PrimState m) a -> (a -> a) -> Int -> m () +{-# INLINE modify #-} +modify = G.modify + +-- | Swap the elements at the given positions. +swap + :: (PrimMonad m, Storable a) => MVector (PrimState m) a -> Int -> Int -> m () +{-# INLINE swap #-} +swap = G.swap + + +-- | Yield the element at the given position. No bounds checks are performed. +unsafeRead :: (PrimMonad m, Storable a) => MVector (PrimState m) a -> Int -> m a +{-# INLINE unsafeRead #-} +unsafeRead = G.unsafeRead + +-- | Replace the element at the given position. No bounds checks are performed. +unsafeWrite + :: (PrimMonad m, Storable a) => MVector (PrimState m) a -> Int -> a -> m () +{-# INLINE unsafeWrite #-} +unsafeWrite = G.unsafeWrite + +-- | Modify the element at the given position. No bounds checks are performed. +unsafeModify :: (PrimMonad m, Storable a) => MVector (PrimState m) a -> (a -> a) -> Int -> m () +{-# INLINE unsafeModify #-} +unsafeModify = G.unsafeModify + +-- | Swap the elements at the given positions. No bounds checks are performed. +unsafeSwap + :: (PrimMonad m, Storable a) => MVector (PrimState m) a -> Int -> Int -> m () +{-# INLINE unsafeSwap #-} +unsafeSwap = G.unsafeSwap + +-- Filling and copying +-- ------------------- + +-- | Set all elements of the vector to the given value. +set :: (PrimMonad m, Storable a) => MVector (PrimState m) a -> a -> m () +{-# INLINE set #-} +set = G.set + +-- | Copy a vector. The two vectors must have the same length and may not +-- overlap. +copy :: (PrimMonad m, Storable a) + => MVector (PrimState m) a -- ^ target + -> MVector (PrimState m) a -- ^ source + -> m () +{-# INLINE copy #-} +copy = G.copy + +-- | Copy a vector. The two vectors must have the same length and may not +-- overlap. This is not checked. +unsafeCopy :: (PrimMonad m, Storable a) + => MVector (PrimState m) a -- ^ target + -> MVector (PrimState m) a -- ^ source + -> m () +{-# INLINE unsafeCopy #-} +unsafeCopy = G.unsafeCopy + +-- | Move the contents of a vector. The two vectors must have the same +-- length. +-- +-- If the vectors do not overlap, then this is equivalent to 'copy'. +-- Otherwise, the copying is performed as if the source vector were +-- copied to a temporary vector and then the temporary vector was copied +-- to the target vector. +move :: (PrimMonad m, Storable a) + => MVector (PrimState m) a -> MVector (PrimState m) a -> m () +{-# INLINE move #-} +move = G.move + +-- | Move the contents of a vector. The two vectors must have the same +-- length, but this is not checked. +-- +-- If the vectors do not overlap, then this is equivalent to 'unsafeCopy'. +-- Otherwise, the copying is performed as if the source vector were +-- copied to a temporary vector and then the temporary vector was copied +-- to the target vector. +unsafeMove :: (PrimMonad m, Storable a) + => MVector (PrimState m) a -- ^ target + -> MVector (PrimState m) a -- ^ source + -> m () +{-# INLINE unsafeMove #-} +unsafeMove = G.unsafeMove + +-- Unsafe conversions +-- ------------------ + +-- | /O(1)/ Unsafely cast a mutable vector from one element type to another. +-- The operation just changes the type of the underlying pointer and does not +-- modify the elements. +-- +-- The resulting vector contains as many elements as can fit into the +-- underlying memory block. +-- +unsafeCast :: forall a b s. + (Storable a, Storable b) => MVector s a -> MVector s b +{-# INLINE unsafeCast #-} +unsafeCast (MVector n fp) + = MVector ((n * sizeOf (undefined :: a)) `div` sizeOf (undefined :: b)) + (castForeignPtr fp) + +-- Raw pointers +-- ------------ + +-- | Create a mutable vector from a 'ForeignPtr' with an offset and a length. +-- +-- Modifying data through the 'ForeignPtr' afterwards is unsafe if the vector +-- could have been frozen before the modification. +-- +-- If your offset is 0 it is more efficient to use 'unsafeFromForeignPtr0'. +unsafeFromForeignPtr :: Storable a + => ForeignPtr a -- ^ pointer + -> Int -- ^ offset + -> Int -- ^ length + -> MVector s a +{-# INLINE_FUSED unsafeFromForeignPtr #-} +unsafeFromForeignPtr fp i n = unsafeFromForeignPtr0 fp' n + where + fp' = updPtr (`advancePtr` i) fp + +{-# RULES +"unsafeFromForeignPtr fp 0 n -> unsafeFromForeignPtr0 fp n " forall fp n. + unsafeFromForeignPtr fp 0 n = unsafeFromForeignPtr0 fp n #-} + + +-- | /O(1)/ Create a mutable vector from a 'ForeignPtr' and a length. +-- +-- It is assumed the pointer points directly to the data (no offset). +-- Use `unsafeFromForeignPtr` if you need to specify an offset. +-- +-- Modifying data through the 'ForeignPtr' afterwards is unsafe if the vector +-- could have been frozen before the modification. +unsafeFromForeignPtr0 :: Storable a + => ForeignPtr a -- ^ pointer + -> Int -- ^ length + -> MVector s a +{-# INLINE unsafeFromForeignPtr0 #-} +unsafeFromForeignPtr0 fp n = MVector n fp + +-- | Yield the underlying 'ForeignPtr' together with the offset to the data +-- and its length. Modifying the data through the 'ForeignPtr' is +-- unsafe if the vector could have frozen before the modification. +unsafeToForeignPtr :: Storable a => MVector s a -> (ForeignPtr a, Int, Int) +{-# INLINE unsafeToForeignPtr #-} +unsafeToForeignPtr (MVector n fp) = (fp, 0, n) + +-- | /O(1)/ Yield the underlying 'ForeignPtr' together with its length. +-- +-- You can assume the pointer points directly to the data (no offset). +-- +-- Modifying the data through the 'ForeignPtr' is unsafe if the vector could +-- have frozen before the modification. +unsafeToForeignPtr0 :: Storable a => MVector s a -> (ForeignPtr a, Int) +{-# INLINE unsafeToForeignPtr0 #-} +unsafeToForeignPtr0 (MVector n fp) = (fp, n) + +-- | Pass a pointer to the vector's data to the IO action. Modifying data +-- through the pointer is unsafe if the vector could have been frozen before +-- the modification. +unsafeWith :: Storable a => IOVector a -> (Ptr a -> IO b) -> IO b +{-# INLINE unsafeWith #-} +unsafeWith (MVector _ fp) = withForeignPtr fp + diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Unboxed.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Unboxed.hs new file mode 100644 index 000000000000..72dd109fb3b4 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Unboxed.hs @@ -0,0 +1,1488 @@ +{-# LANGUAGE CPP, Rank2Types, TypeFamilies #-} + +-- | +-- Module : Data.Vector.Unboxed +-- Copyright : (c) Roman Leshchinskiy 2009-2010 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> +-- Stability : experimental +-- Portability : non-portable +-- +-- Adaptive unboxed vectors. The implementation is based on type families +-- and picks an efficient, specialised representation for every element type. +-- In particular, unboxed vectors of pairs are represented as pairs of unboxed +-- vectors. +-- +-- Implementing unboxed vectors for new data types can be very easy. Here is +-- how the library does this for 'Complex' by simply wrapping vectors of +-- pairs. +-- +-- @ +-- newtype instance 'MVector' s ('Complex' a) = MV_Complex ('MVector' s (a,a)) +-- newtype instance 'Vector' ('Complex' a) = V_Complex ('Vector' (a,a)) +-- +-- instance ('RealFloat' a, 'Unbox' a) => 'Data.Vector.Generic.Mutable.MVector' 'MVector' ('Complex' a) where +-- {-\# INLINE basicLength \#-} +-- basicLength (MV_Complex v) = 'Data.Vector.Generic.Mutable.basicLength' v +-- ... +-- +-- instance ('RealFloat' a, 'Unbox' a) => Data.Vector.Generic.Vector 'Vector' ('Complex' a) where +-- {-\# INLINE basicLength \#-} +-- basicLength (V_Complex v) = Data.Vector.Generic.basicLength v +-- ... +-- +-- instance ('RealFloat' a, 'Unbox' a) => 'Unbox' ('Complex' a) +-- @ + +module Data.Vector.Unboxed ( + -- * Unboxed vectors + Vector, MVector(..), Unbox, + + -- * Accessors + + -- ** Length information + length, null, + + -- ** Indexing + (!), (!?), head, last, + unsafeIndex, unsafeHead, unsafeLast, + + -- ** Monadic indexing + indexM, headM, lastM, + unsafeIndexM, unsafeHeadM, unsafeLastM, + + -- ** Extracting subvectors (slicing) + slice, init, tail, take, drop, splitAt, + unsafeSlice, unsafeInit, unsafeTail, unsafeTake, unsafeDrop, + + -- * Construction + + -- ** Initialisation + empty, singleton, replicate, generate, iterateN, + + -- ** Monadic initialisation + replicateM, generateM, iterateNM, create, createT, + + -- ** Unfolding + unfoldr, unfoldrN, + unfoldrM, unfoldrNM, + constructN, constructrN, + + -- ** Enumeration + enumFromN, enumFromStepN, enumFromTo, enumFromThenTo, + + -- ** Concatenation + cons, snoc, (++), concat, + + -- ** Restricting memory usage + force, + + -- * Modifying vectors + + -- ** Bulk updates + (//), update, update_, + unsafeUpd, unsafeUpdate, unsafeUpdate_, + + -- ** Accumulations + accum, accumulate, accumulate_, + unsafeAccum, unsafeAccumulate, unsafeAccumulate_, + + -- ** Permutations + reverse, backpermute, unsafeBackpermute, + + -- ** Safe destructive updates + modify, + + -- * Elementwise operations + + -- ** Indexing + indexed, + + -- ** Mapping + map, imap, concatMap, + + -- ** Monadic mapping + mapM, imapM, mapM_, imapM_, forM, forM_, + + -- ** Zipping + zipWith, zipWith3, zipWith4, zipWith5, zipWith6, + izipWith, izipWith3, izipWith4, izipWith5, izipWith6, + zip, zip3, zip4, zip5, zip6, + + -- ** Monadic zipping + zipWithM, izipWithM, zipWithM_, izipWithM_, + + -- ** Unzipping + unzip, unzip3, unzip4, unzip5, unzip6, + + -- * Working with predicates + + -- ** Filtering + filter, ifilter, uniq, + mapMaybe, imapMaybe, + filterM, + takeWhile, dropWhile, + + -- ** Partitioning + partition, unstablePartition, span, break, + + -- ** Searching + elem, notElem, find, findIndex, findIndices, elemIndex, elemIndices, + + -- * Folding + foldl, foldl1, foldl', foldl1', foldr, foldr1, foldr', foldr1', + ifoldl, ifoldl', ifoldr, ifoldr', + + -- ** Specialised folds + all, any, and, or, + sum, product, + maximum, maximumBy, minimum, minimumBy, + minIndex, minIndexBy, maxIndex, maxIndexBy, + + -- ** Monadic folds + foldM, ifoldM, foldM', ifoldM', + fold1M, fold1M', foldM_, ifoldM_, + foldM'_, ifoldM'_, fold1M_, fold1M'_, + + -- * Prefix sums (scans) + prescanl, prescanl', + postscanl, postscanl', + scanl, scanl', scanl1, scanl1', + prescanr, prescanr', + postscanr, postscanr', + scanr, scanr', scanr1, scanr1', + + -- * Conversions + + -- ** Lists + toList, fromList, fromListN, + + -- ** Other vector types + G.convert, + + -- ** Mutable vectors + freeze, thaw, copy, unsafeFreeze, unsafeThaw, unsafeCopy +) where + +import Data.Vector.Unboxed.Base +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Fusion.Bundle as Bundle +import Data.Vector.Fusion.Util ( delayed_min ) + +import Control.Monad.ST ( ST ) +import Control.Monad.Primitive + +import Prelude hiding ( length, null, + replicate, (++), concat, + head, last, + init, tail, take, drop, splitAt, reverse, + map, concatMap, + zipWith, zipWith3, zip, zip3, unzip, unzip3, + filter, takeWhile, dropWhile, span, break, + elem, notElem, + foldl, foldl1, foldr, foldr1, + all, any, and, or, sum, product, minimum, maximum, + scanl, scanl1, scanr, scanr1, + enumFromTo, enumFromThenTo, + mapM, mapM_ ) + +import Text.Read ( Read(..), readListPrecDefault ) +import Data.Semigroup ( Semigroup(..) ) + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid ( Monoid(..) ) +import Data.Traversable ( Traversable ) +#endif + +#if __GLASGOW_HASKELL__ >= 708 +import qualified GHC.Exts as Exts (IsList(..)) +#endif + +#define NOT_VECTOR_MODULE +#include "vector.h" + +-- See http://trac.haskell.org/vector/ticket/12 +instance (Unbox a, Eq a) => Eq (Vector a) where + {-# INLINE (==) #-} + xs == ys = Bundle.eq (G.stream xs) (G.stream ys) + + {-# INLINE (/=) #-} + xs /= ys = not (Bundle.eq (G.stream xs) (G.stream ys)) + +-- See http://trac.haskell.org/vector/ticket/12 +instance (Unbox a, Ord a) => Ord (Vector a) where + {-# INLINE compare #-} + compare xs ys = Bundle.cmp (G.stream xs) (G.stream ys) + + {-# INLINE (<) #-} + xs < ys = Bundle.cmp (G.stream xs) (G.stream ys) == LT + + {-# INLINE (<=) #-} + xs <= ys = Bundle.cmp (G.stream xs) (G.stream ys) /= GT + + {-# INLINE (>) #-} + xs > ys = Bundle.cmp (G.stream xs) (G.stream ys) == GT + + {-# INLINE (>=) #-} + xs >= ys = Bundle.cmp (G.stream xs) (G.stream ys) /= LT + +instance Unbox a => Semigroup (Vector a) where + {-# INLINE (<>) #-} + (<>) = (++) + + {-# INLINE sconcat #-} + sconcat = G.concatNE + +instance Unbox a => Monoid (Vector a) where + {-# INLINE mempty #-} + mempty = empty + + {-# INLINE mappend #-} + mappend = (++) + + {-# INLINE mconcat #-} + mconcat = concat + +instance (Show a, Unbox a) => Show (Vector a) where + showsPrec = G.showsPrec + +instance (Read a, Unbox a) => Read (Vector a) where + readPrec = G.readPrec + readListPrec = readListPrecDefault + +#if __GLASGOW_HASKELL__ >= 708 + +instance (Unbox e) => Exts.IsList (Vector e) where + type Item (Vector e) = e + fromList = fromList + fromListN = fromListN + toList = toList + +#endif + +-- Length information +-- ------------------ + +-- | /O(1)/ Yield the length of the vector +length :: Unbox a => Vector a -> Int +{-# INLINE length #-} +length = G.length + +-- | /O(1)/ Test whether a vector is empty +null :: Unbox a => Vector a -> Bool +{-# INLINE null #-} +null = G.null + +-- Indexing +-- -------- + +-- | O(1) Indexing +(!) :: Unbox a => Vector a -> Int -> a +{-# INLINE (!) #-} +(!) = (G.!) + +-- | O(1) Safe indexing +(!?) :: Unbox a => Vector a -> Int -> Maybe a +{-# INLINE (!?) #-} +(!?) = (G.!?) + +-- | /O(1)/ First element +head :: Unbox a => Vector a -> a +{-# INLINE head #-} +head = G.head + +-- | /O(1)/ Last element +last :: Unbox a => Vector a -> a +{-# INLINE last #-} +last = G.last + +-- | /O(1)/ Unsafe indexing without bounds checking +unsafeIndex :: Unbox a => Vector a -> Int -> a +{-# INLINE unsafeIndex #-} +unsafeIndex = G.unsafeIndex + +-- | /O(1)/ First element without checking if the vector is empty +unsafeHead :: Unbox a => Vector a -> a +{-# INLINE unsafeHead #-} +unsafeHead = G.unsafeHead + +-- | /O(1)/ Last element without checking if the vector is empty +unsafeLast :: Unbox a => Vector a -> a +{-# INLINE unsafeLast #-} +unsafeLast = G.unsafeLast + +-- Monadic indexing +-- ---------------- + +-- | /O(1)/ Indexing in a monad. +-- +-- The monad allows operations to be strict in the vector when necessary. +-- Suppose vector copying is implemented like this: +-- +-- > copy mv v = ... write mv i (v ! i) ... +-- +-- For lazy vectors, @v ! i@ would not be evaluated which means that @mv@ +-- would unnecessarily retain a reference to @v@ in each element written. +-- +-- With 'indexM', copying can be implemented like this instead: +-- +-- > copy mv v = ... do +-- > x <- indexM v i +-- > write mv i x +-- +-- Here, no references to @v@ are retained because indexing (but /not/ the +-- elements) is evaluated eagerly. +-- +indexM :: (Unbox a, Monad m) => Vector a -> Int -> m a +{-# INLINE indexM #-} +indexM = G.indexM + +-- | /O(1)/ First element of a vector in a monad. See 'indexM' for an +-- explanation of why this is useful. +headM :: (Unbox a, Monad m) => Vector a -> m a +{-# INLINE headM #-} +headM = G.headM + +-- | /O(1)/ Last element of a vector in a monad. See 'indexM' for an +-- explanation of why this is useful. +lastM :: (Unbox a, Monad m) => Vector a -> m a +{-# INLINE lastM #-} +lastM = G.lastM + +-- | /O(1)/ Indexing in a monad without bounds checks. See 'indexM' for an +-- explanation of why this is useful. +unsafeIndexM :: (Unbox a, Monad m) => Vector a -> Int -> m a +{-# INLINE unsafeIndexM #-} +unsafeIndexM = G.unsafeIndexM + +-- | /O(1)/ First element in a monad without checking for empty vectors. +-- See 'indexM' for an explanation of why this is useful. +unsafeHeadM :: (Unbox a, Monad m) => Vector a -> m a +{-# INLINE unsafeHeadM #-} +unsafeHeadM = G.unsafeHeadM + +-- | /O(1)/ Last element in a monad without checking for empty vectors. +-- See 'indexM' for an explanation of why this is useful. +unsafeLastM :: (Unbox a, Monad m) => Vector a -> m a +{-# INLINE unsafeLastM #-} +unsafeLastM = G.unsafeLastM + +-- Extracting subvectors (slicing) +-- ------------------------------- + +-- | /O(1)/ Yield a slice of the vector without copying it. The vector must +-- contain at least @i+n@ elements. +slice :: Unbox a => Int -- ^ @i@ starting index + -> Int -- ^ @n@ length + -> Vector a + -> Vector a +{-# INLINE slice #-} +slice = G.slice + +-- | /O(1)/ Yield all but the last element without copying. The vector may not +-- be empty. +init :: Unbox a => Vector a -> Vector a +{-# INLINE init #-} +init = G.init + +-- | /O(1)/ Yield all but the first element without copying. The vector may not +-- be empty. +tail :: Unbox a => Vector a -> Vector a +{-# INLINE tail #-} +tail = G.tail + +-- | /O(1)/ Yield at the first @n@ elements without copying. The vector may +-- contain less than @n@ elements in which case it is returned unchanged. +take :: Unbox a => Int -> Vector a -> Vector a +{-# INLINE take #-} +take = G.take + +-- | /O(1)/ Yield all but the first @n@ elements without copying. The vector may +-- contain less than @n@ elements in which case an empty vector is returned. +drop :: Unbox a => Int -> Vector a -> Vector a +{-# INLINE drop #-} +drop = G.drop + +-- | /O(1)/ Yield the first @n@ elements paired with the remainder without copying. +-- +-- Note that @'splitAt' n v@ is equivalent to @('take' n v, 'drop' n v)@ +-- but slightly more efficient. +{-# INLINE splitAt #-} +splitAt :: Unbox a => Int -> Vector a -> (Vector a, Vector a) +splitAt = G.splitAt + +-- | /O(1)/ Yield a slice of the vector without copying. The vector must +-- contain at least @i+n@ elements but this is not checked. +unsafeSlice :: Unbox a => Int -- ^ @i@ starting index + -> Int -- ^ @n@ length + -> Vector a + -> Vector a +{-# INLINE unsafeSlice #-} +unsafeSlice = G.unsafeSlice + +-- | /O(1)/ Yield all but the last element without copying. The vector may not +-- be empty but this is not checked. +unsafeInit :: Unbox a => Vector a -> Vector a +{-# INLINE unsafeInit #-} +unsafeInit = G.unsafeInit + +-- | /O(1)/ Yield all but the first element without copying. The vector may not +-- be empty but this is not checked. +unsafeTail :: Unbox a => Vector a -> Vector a +{-# INLINE unsafeTail #-} +unsafeTail = G.unsafeTail + +-- | /O(1)/ Yield the first @n@ elements without copying. The vector must +-- contain at least @n@ elements but this is not checked. +unsafeTake :: Unbox a => Int -> Vector a -> Vector a +{-# INLINE unsafeTake #-} +unsafeTake = G.unsafeTake + +-- | /O(1)/ Yield all but the first @n@ elements without copying. The vector +-- must contain at least @n@ elements but this is not checked. +unsafeDrop :: Unbox a => Int -> Vector a -> Vector a +{-# INLINE unsafeDrop #-} +unsafeDrop = G.unsafeDrop + +-- Initialisation +-- -------------- + +-- | /O(1)/ Empty vector +empty :: Unbox a => Vector a +{-# INLINE empty #-} +empty = G.empty + +-- | /O(1)/ Vector with exactly one element +singleton :: Unbox a => a -> Vector a +{-# INLINE singleton #-} +singleton = G.singleton + +-- | /O(n)/ Vector of the given length with the same value in each position +replicate :: Unbox a => Int -> a -> Vector a +{-# INLINE replicate #-} +replicate = G.replicate + +-- | /O(n)/ Construct a vector of the given length by applying the function to +-- each index +generate :: Unbox a => Int -> (Int -> a) -> Vector a +{-# INLINE generate #-} +generate = G.generate + +-- | /O(n)/ Apply function n times to value. Zeroth element is original value. +iterateN :: Unbox a => Int -> (a -> a) -> a -> Vector a +{-# INLINE iterateN #-} +iterateN = G.iterateN + +-- Unfolding +-- --------- + +-- | /O(n)/ Construct a vector by repeatedly applying the generator function +-- to a seed. The generator function yields 'Just' the next element and the +-- new seed or 'Nothing' if there are no more elements. +-- +-- > unfoldr (\n -> if n == 0 then Nothing else Just (n,n-1)) 10 +-- > = <10,9,8,7,6,5,4,3,2,1> +unfoldr :: Unbox a => (b -> Maybe (a, b)) -> b -> Vector a +{-# INLINE unfoldr #-} +unfoldr = G.unfoldr + +-- | /O(n)/ Construct a vector with at most @n@ elements by repeatedly applying +-- the generator function to a seed. The generator function yields 'Just' the +-- next element and the new seed or 'Nothing' if there are no more elements. +-- +-- > unfoldrN 3 (\n -> Just (n,n-1)) 10 = <10,9,8> +unfoldrN :: Unbox a => Int -> (b -> Maybe (a, b)) -> b -> Vector a +{-# INLINE unfoldrN #-} +unfoldrN = G.unfoldrN + +-- | /O(n)/ Construct a vector by repeatedly applying the monadic +-- generator function to a seed. The generator function yields 'Just' +-- the next element and the new seed or 'Nothing' if there are no more +-- elements. +unfoldrM :: (Monad m, Unbox a) => (b -> m (Maybe (a, b))) -> b -> m (Vector a) +{-# INLINE unfoldrM #-} +unfoldrM = G.unfoldrM + +-- | /O(n)/ Construct a vector by repeatedly applying the monadic +-- generator function to a seed. The generator function yields 'Just' +-- the next element and the new seed or 'Nothing' if there are no more +-- elements. +unfoldrNM :: (Monad m, Unbox a) => Int -> (b -> m (Maybe (a, b))) -> b -> m (Vector a) +{-# INLINE unfoldrNM #-} +unfoldrNM = G.unfoldrNM + +-- | /O(n)/ Construct a vector with @n@ elements by repeatedly applying the +-- generator function to the already constructed part of the vector. +-- +-- > constructN 3 f = let a = f <> ; b = f <a> ; c = f <a,b> in f <a,b,c> +-- +constructN :: Unbox a => Int -> (Vector a -> a) -> Vector a +{-# INLINE constructN #-} +constructN = G.constructN + +-- | /O(n)/ Construct a vector with @n@ elements from right to left by +-- repeatedly applying the generator function to the already constructed part +-- of the vector. +-- +-- > constructrN 3 f = let a = f <> ; b = f<a> ; c = f <b,a> in f <c,b,a> +-- +constructrN :: Unbox a => Int -> (Vector a -> a) -> Vector a +{-# INLINE constructrN #-} +constructrN = G.constructrN + +-- Enumeration +-- ----------- + +-- | /O(n)/ Yield a vector of the given length containing the values @x@, @x+1@ +-- etc. This operation is usually more efficient than 'enumFromTo'. +-- +-- > enumFromN 5 3 = <5,6,7> +enumFromN :: (Unbox a, Num a) => a -> Int -> Vector a +{-# INLINE enumFromN #-} +enumFromN = G.enumFromN + +-- | /O(n)/ Yield a vector of the given length containing the values @x@, @x+y@, +-- @x+y+y@ etc. This operations is usually more efficient than 'enumFromThenTo'. +-- +-- > enumFromStepN 1 0.1 5 = <1,1.1,1.2,1.3,1.4> +enumFromStepN :: (Unbox a, Num a) => a -> a -> Int -> Vector a +{-# INLINE enumFromStepN #-} +enumFromStepN = G.enumFromStepN + +-- | /O(n)/ Enumerate values from @x@ to @y@. +-- +-- /WARNING:/ This operation can be very inefficient. If at all possible, use +-- 'enumFromN' instead. +enumFromTo :: (Unbox a, Enum a) => a -> a -> Vector a +{-# INLINE enumFromTo #-} +enumFromTo = G.enumFromTo + +-- | /O(n)/ Enumerate values from @x@ to @y@ with a specific step @z@. +-- +-- /WARNING:/ This operation can be very inefficient. If at all possible, use +-- 'enumFromStepN' instead. +enumFromThenTo :: (Unbox a, Enum a) => a -> a -> a -> Vector a +{-# INLINE enumFromThenTo #-} +enumFromThenTo = G.enumFromThenTo + +-- Concatenation +-- ------------- + +-- | /O(n)/ Prepend an element +cons :: Unbox a => a -> Vector a -> Vector a +{-# INLINE cons #-} +cons = G.cons + +-- | /O(n)/ Append an element +snoc :: Unbox a => Vector a -> a -> Vector a +{-# INLINE snoc #-} +snoc = G.snoc + +infixr 5 ++ +-- | /O(m+n)/ Concatenate two vectors +(++) :: Unbox a => Vector a -> Vector a -> Vector a +{-# INLINE (++) #-} +(++) = (G.++) + +-- | /O(n)/ Concatenate all vectors in the list +concat :: Unbox a => [Vector a] -> Vector a +{-# INLINE concat #-} +concat = G.concat + +-- Monadic initialisation +-- ---------------------- + +-- | /O(n)/ Execute the monadic action the given number of times and store the +-- results in a vector. +replicateM :: (Monad m, Unbox a) => Int -> m a -> m (Vector a) +{-# INLINE replicateM #-} +replicateM = G.replicateM + +-- | /O(n)/ Construct a vector of the given length by applying the monadic +-- action to each index +generateM :: (Monad m, Unbox a) => Int -> (Int -> m a) -> m (Vector a) +{-# INLINE generateM #-} +generateM = G.generateM + +-- | /O(n)/ Apply monadic function n times to value. Zeroth element is original value. +iterateNM :: (Monad m, Unbox a) => Int -> (a -> m a) -> a -> m (Vector a) +{-# INLINE iterateNM #-} +iterateNM = G.iterateNM + +-- | Execute the monadic action and freeze the resulting vector. +-- +-- @ +-- create (do { v \<- new 2; write v 0 \'a\'; write v 1 \'b\'; return v }) = \<'a','b'\> +-- @ +create :: Unbox a => (forall s. ST s (MVector s a)) -> Vector a +{-# INLINE create #-} +-- NOTE: eta-expanded due to http://hackage.haskell.org/trac/ghc/ticket/4120 +create p = G.create p + +-- | Execute the monadic action and freeze the resulting vectors. +createT :: (Traversable f, Unbox a) => (forall s. ST s (f (MVector s a))) -> f (Vector a) +{-# INLINE createT #-} +createT p = G.createT p + +-- Restricting memory usage +-- ------------------------ + +-- | /O(n)/ Yield the argument but force it not to retain any extra memory, +-- possibly by copying it. +-- +-- This is especially useful when dealing with slices. For example: +-- +-- > force (slice 0 2 <huge vector>) +-- +-- Here, the slice retains a reference to the huge vector. Forcing it creates +-- a copy of just the elements that belong to the slice and allows the huge +-- vector to be garbage collected. +force :: Unbox a => Vector a -> Vector a +{-# INLINE force #-} +force = G.force + +-- Bulk updates +-- ------------ + +-- | /O(m+n)/ For each pair @(i,a)@ from the list, replace the vector +-- element at position @i@ by @a@. +-- +-- > <5,9,2,7> // [(2,1),(0,3),(2,8)] = <3,9,8,7> +-- +(//) :: Unbox a => Vector a -- ^ initial vector (of length @m@) + -> [(Int, a)] -- ^ list of index/value pairs (of length @n@) + -> Vector a +{-# INLINE (//) #-} +(//) = (G.//) + +-- | /O(m+n)/ For each pair @(i,a)@ from the vector of index/value pairs, +-- replace the vector element at position @i@ by @a@. +-- +-- > update <5,9,2,7> <(2,1),(0,3),(2,8)> = <3,9,8,7> +-- +update :: Unbox a + => Vector a -- ^ initial vector (of length @m@) + -> Vector (Int, a) -- ^ vector of index/value pairs (of length @n@) + -> Vector a +{-# INLINE update #-} +update = G.update + +-- | /O(m+min(n1,n2))/ For each index @i@ from the index vector and the +-- corresponding value @a@ from the value vector, replace the element of the +-- initial vector at position @i@ by @a@. +-- +-- > update_ <5,9,2,7> <2,0,2> <1,3,8> = <3,9,8,7> +-- +-- The function 'update' provides the same functionality and is usually more +-- convenient. +-- +-- @ +-- update_ xs is ys = 'update' xs ('zip' is ys) +-- @ +update_ :: Unbox a + => Vector a -- ^ initial vector (of length @m@) + -> Vector Int -- ^ index vector (of length @n1@) + -> Vector a -- ^ value vector (of length @n2@) + -> Vector a +{-# INLINE update_ #-} +update_ = G.update_ + +-- | Same as ('//') but without bounds checking. +unsafeUpd :: Unbox a => Vector a -> [(Int, a)] -> Vector a +{-# INLINE unsafeUpd #-} +unsafeUpd = G.unsafeUpd + +-- | Same as 'update' but without bounds checking. +unsafeUpdate :: Unbox a => Vector a -> Vector (Int, a) -> Vector a +{-# INLINE unsafeUpdate #-} +unsafeUpdate = G.unsafeUpdate + +-- | Same as 'update_' but without bounds checking. +unsafeUpdate_ :: Unbox a => Vector a -> Vector Int -> Vector a -> Vector a +{-# INLINE unsafeUpdate_ #-} +unsafeUpdate_ = G.unsafeUpdate_ + +-- Accumulations +-- ------------- + +-- | /O(m+n)/ For each pair @(i,b)@ from the list, replace the vector element +-- @a@ at position @i@ by @f a b@. +-- +-- > accum (+) <5,9,2> [(2,4),(1,6),(0,3),(1,7)] = <5+3, 9+6+7, 2+4> +accum :: Unbox a + => (a -> b -> a) -- ^ accumulating function @f@ + -> Vector a -- ^ initial vector (of length @m@) + -> [(Int,b)] -- ^ list of index/value pairs (of length @n@) + -> Vector a +{-# INLINE accum #-} +accum = G.accum + +-- | /O(m+n)/ For each pair @(i,b)@ from the vector of pairs, replace the vector +-- element @a@ at position @i@ by @f a b@. +-- +-- > accumulate (+) <5,9,2> <(2,4),(1,6),(0,3),(1,7)> = <5+3, 9+6+7, 2+4> +accumulate :: (Unbox a, Unbox b) + => (a -> b -> a) -- ^ accumulating function @f@ + -> Vector a -- ^ initial vector (of length @m@) + -> Vector (Int,b) -- ^ vector of index/value pairs (of length @n@) + -> Vector a +{-# INLINE accumulate #-} +accumulate = G.accumulate + +-- | /O(m+min(n1,n2))/ For each index @i@ from the index vector and the +-- corresponding value @b@ from the the value vector, +-- replace the element of the initial vector at +-- position @i@ by @f a b@. +-- +-- > accumulate_ (+) <5,9,2> <2,1,0,1> <4,6,3,7> = <5+3, 9+6+7, 2+4> +-- +-- The function 'accumulate' provides the same functionality and is usually more +-- convenient. +-- +-- @ +-- accumulate_ f as is bs = 'accumulate' f as ('zip' is bs) +-- @ +accumulate_ :: (Unbox a, Unbox b) + => (a -> b -> a) -- ^ accumulating function @f@ + -> Vector a -- ^ initial vector (of length @m@) + -> Vector Int -- ^ index vector (of length @n1@) + -> Vector b -- ^ value vector (of length @n2@) + -> Vector a +{-# INLINE accumulate_ #-} +accumulate_ = G.accumulate_ + +-- | Same as 'accum' but without bounds checking. +unsafeAccum :: Unbox a => (a -> b -> a) -> Vector a -> [(Int,b)] -> Vector a +{-# INLINE unsafeAccum #-} +unsafeAccum = G.unsafeAccum + +-- | Same as 'accumulate' but without bounds checking. +unsafeAccumulate :: (Unbox a, Unbox b) + => (a -> b -> a) -> Vector a -> Vector (Int,b) -> Vector a +{-# INLINE unsafeAccumulate #-} +unsafeAccumulate = G.unsafeAccumulate + +-- | Same as 'accumulate_' but without bounds checking. +unsafeAccumulate_ :: (Unbox a, Unbox b) => + (a -> b -> a) -> Vector a -> Vector Int -> Vector b -> Vector a +{-# INLINE unsafeAccumulate_ #-} +unsafeAccumulate_ = G.unsafeAccumulate_ + +-- Permutations +-- ------------ + +-- | /O(n)/ Reverse a vector +reverse :: Unbox a => Vector a -> Vector a +{-# INLINE reverse #-} +reverse = G.reverse + +-- | /O(n)/ Yield the vector obtained by replacing each element @i@ of the +-- index vector by @xs'!'i@. This is equivalent to @'map' (xs'!') is@ but is +-- often much more efficient. +-- +-- > backpermute <a,b,c,d> <0,3,2,3,1,0> = <a,d,c,d,b,a> +backpermute :: Unbox a => Vector a -> Vector Int -> Vector a +{-# INLINE backpermute #-} +backpermute = G.backpermute + +-- | Same as 'backpermute' but without bounds checking. +unsafeBackpermute :: Unbox a => Vector a -> Vector Int -> Vector a +{-# INLINE unsafeBackpermute #-} +unsafeBackpermute = G.unsafeBackpermute + +-- Safe destructive updates +-- ------------------------ + +-- | Apply a destructive operation to a vector. The operation will be +-- performed in place if it is safe to do so and will modify a copy of the +-- vector otherwise. +-- +-- @ +-- modify (\\v -> write v 0 \'x\') ('replicate' 3 \'a\') = \<\'x\',\'a\',\'a\'\> +-- @ +modify :: Unbox a => (forall s. MVector s a -> ST s ()) -> Vector a -> Vector a +{-# INLINE modify #-} +modify p = G.modify p + +-- Indexing +-- -------- + +-- | /O(n)/ Pair each element in a vector with its index +indexed :: Unbox a => Vector a -> Vector (Int,a) +{-# INLINE indexed #-} +indexed = G.indexed + +-- Mapping +-- ------- + +-- | /O(n)/ Map a function over a vector +map :: (Unbox a, Unbox b) => (a -> b) -> Vector a -> Vector b +{-# INLINE map #-} +map = G.map + +-- | /O(n)/ Apply a function to every element of a vector and its index +imap :: (Unbox a, Unbox b) => (Int -> a -> b) -> Vector a -> Vector b +{-# INLINE imap #-} +imap = G.imap + +-- | Map a function over a vector and concatenate the results. +concatMap :: (Unbox a, Unbox b) => (a -> Vector b) -> Vector a -> Vector b +{-# INLINE concatMap #-} +concatMap = G.concatMap + +-- Monadic mapping +-- --------------- + +-- | /O(n)/ Apply the monadic action to all elements of the vector, yielding a +-- vector of results +mapM :: (Monad m, Unbox a, Unbox b) => (a -> m b) -> Vector a -> m (Vector b) +{-# INLINE mapM #-} +mapM = G.mapM + +-- | /O(n)/ Apply the monadic action to every element of a vector and its +-- index, yielding a vector of results +imapM :: (Monad m, Unbox a, Unbox b) + => (Int -> a -> m b) -> Vector a -> m (Vector b) +{-# INLINE imapM #-} +imapM = G.imapM + +-- | /O(n)/ Apply the monadic action to all elements of a vector and ignore the +-- results +mapM_ :: (Monad m, Unbox a) => (a -> m b) -> Vector a -> m () +{-# INLINE mapM_ #-} +mapM_ = G.mapM_ + +-- | /O(n)/ Apply the monadic action to every element of a vector and its +-- index, ignoring the results +imapM_ :: (Monad m, Unbox a) => (Int -> a -> m b) -> Vector a -> m () +{-# INLINE imapM_ #-} +imapM_ = G.imapM_ + +-- | /O(n)/ Apply the monadic action to all elements of the vector, yielding a +-- vector of results. Equivalent to @flip 'mapM'@. +forM :: (Monad m, Unbox a, Unbox b) => Vector a -> (a -> m b) -> m (Vector b) +{-# INLINE forM #-} +forM = G.forM + +-- | /O(n)/ Apply the monadic action to all elements of a vector and ignore the +-- results. Equivalent to @flip 'mapM_'@. +forM_ :: (Monad m, Unbox a) => Vector a -> (a -> m b) -> m () +{-# INLINE forM_ #-} +forM_ = G.forM_ + +-- Zipping +-- ------- + +-- | /O(min(m,n))/ Zip two vectors with the given function. +zipWith :: (Unbox a, Unbox b, Unbox c) + => (a -> b -> c) -> Vector a -> Vector b -> Vector c +{-# INLINE zipWith #-} +zipWith = G.zipWith + +-- | Zip three vectors with the given function. +zipWith3 :: (Unbox a, Unbox b, Unbox c, Unbox d) + => (a -> b -> c -> d) -> Vector a -> Vector b -> Vector c -> Vector d +{-# INLINE zipWith3 #-} +zipWith3 = G.zipWith3 + +zipWith4 :: (Unbox a, Unbox b, Unbox c, Unbox d, Unbox e) + => (a -> b -> c -> d -> e) + -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e +{-# INLINE zipWith4 #-} +zipWith4 = G.zipWith4 + +zipWith5 :: (Unbox a, Unbox b, Unbox c, Unbox d, Unbox e, Unbox f) + => (a -> b -> c -> d -> e -> f) + -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e + -> Vector f +{-# INLINE zipWith5 #-} +zipWith5 = G.zipWith5 + +zipWith6 :: (Unbox a, Unbox b, Unbox c, Unbox d, Unbox e, Unbox f, Unbox g) + => (a -> b -> c -> d -> e -> f -> g) + -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e + -> Vector f -> Vector g +{-# INLINE zipWith6 #-} +zipWith6 = G.zipWith6 + +-- | /O(min(m,n))/ Zip two vectors with a function that also takes the +-- elements' indices. +izipWith :: (Unbox a, Unbox b, Unbox c) + => (Int -> a -> b -> c) -> Vector a -> Vector b -> Vector c +{-# INLINE izipWith #-} +izipWith = G.izipWith + +-- | Zip three vectors and their indices with the given function. +izipWith3 :: (Unbox a, Unbox b, Unbox c, Unbox d) + => (Int -> a -> b -> c -> d) + -> Vector a -> Vector b -> Vector c -> Vector d +{-# INLINE izipWith3 #-} +izipWith3 = G.izipWith3 + +izipWith4 :: (Unbox a, Unbox b, Unbox c, Unbox d, Unbox e) + => (Int -> a -> b -> c -> d -> e) + -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e +{-# INLINE izipWith4 #-} +izipWith4 = G.izipWith4 + +izipWith5 :: (Unbox a, Unbox b, Unbox c, Unbox d, Unbox e, Unbox f) + => (Int -> a -> b -> c -> d -> e -> f) + -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e + -> Vector f +{-# INLINE izipWith5 #-} +izipWith5 = G.izipWith5 + +izipWith6 :: (Unbox a, Unbox b, Unbox c, Unbox d, Unbox e, Unbox f, Unbox g) + => (Int -> a -> b -> c -> d -> e -> f -> g) + -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e + -> Vector f -> Vector g +{-# INLINE izipWith6 #-} +izipWith6 = G.izipWith6 + +-- Monadic zipping +-- --------------- + +-- | /O(min(m,n))/ Zip the two vectors with the monadic action and yield a +-- vector of results +zipWithM :: (Monad m, Unbox a, Unbox b, Unbox c) + => (a -> b -> m c) -> Vector a -> Vector b -> m (Vector c) +{-# INLINE zipWithM #-} +zipWithM = G.zipWithM + +-- | /O(min(m,n))/ Zip the two vectors with a monadic action that also takes +-- the element index and yield a vector of results +izipWithM :: (Monad m, Unbox a, Unbox b, Unbox c) + => (Int -> a -> b -> m c) -> Vector a -> Vector b -> m (Vector c) +{-# INLINE izipWithM #-} +izipWithM = G.izipWithM + +-- | /O(min(m,n))/ Zip the two vectors with the monadic action and ignore the +-- results +zipWithM_ :: (Monad m, Unbox a, Unbox b) + => (a -> b -> m c) -> Vector a -> Vector b -> m () +{-# INLINE zipWithM_ #-} +zipWithM_ = G.zipWithM_ + +-- | /O(min(m,n))/ Zip the two vectors with a monadic action that also takes +-- the element index and ignore the results +izipWithM_ :: (Monad m, Unbox a, Unbox b) + => (Int -> a -> b -> m c) -> Vector a -> Vector b -> m () +{-# INLINE izipWithM_ #-} +izipWithM_ = G.izipWithM_ + +-- Filtering +-- --------- + +-- | /O(n)/ Drop elements that do not satisfy the predicate +filter :: Unbox a => (a -> Bool) -> Vector a -> Vector a +{-# INLINE filter #-} +filter = G.filter + +-- | /O(n)/ Drop repeated adjacent elements. +uniq :: (Unbox a, Eq a) => Vector a -> Vector a +{-# INLINE uniq #-} +uniq = G.uniq + +-- | /O(n)/ Drop elements that do not satisfy the predicate which is applied to +-- values and their indices +ifilter :: Unbox a => (Int -> a -> Bool) -> Vector a -> Vector a +{-# INLINE ifilter #-} +ifilter = G.ifilter + +-- | /O(n)/ Drop elements when predicate returns Nothing +mapMaybe :: (Unbox a, Unbox b) => (a -> Maybe b) -> Vector a -> Vector b +{-# INLINE mapMaybe #-} +mapMaybe = G.mapMaybe + +-- | /O(n)/ Drop elements when predicate, applied to index and value, returns Nothing +imapMaybe :: (Unbox a, Unbox b) => (Int -> a -> Maybe b) -> Vector a -> Vector b +{-# INLINE imapMaybe #-} +imapMaybe = G.imapMaybe + +-- | /O(n)/ Drop elements that do not satisfy the monadic predicate +filterM :: (Monad m, Unbox a) => (a -> m Bool) -> Vector a -> m (Vector a) +{-# INLINE filterM #-} +filterM = G.filterM + +-- | /O(n)/ Yield the longest prefix of elements satisfying the predicate +-- without copying. +takeWhile :: Unbox a => (a -> Bool) -> Vector a -> Vector a +{-# INLINE takeWhile #-} +takeWhile = G.takeWhile + +-- | /O(n)/ Drop the longest prefix of elements that satisfy the predicate +-- without copying. +dropWhile :: Unbox a => (a -> Bool) -> Vector a -> Vector a +{-# INLINE dropWhile #-} +dropWhile = G.dropWhile + +-- Parititioning +-- ------------- + +-- | /O(n)/ Split the vector in two parts, the first one containing those +-- elements that satisfy the predicate and the second one those that don't. The +-- relative order of the elements is preserved at the cost of a sometimes +-- reduced performance compared to 'unstablePartition'. +partition :: Unbox a => (a -> Bool) -> Vector a -> (Vector a, Vector a) +{-# INLINE partition #-} +partition = G.partition + +-- | /O(n)/ Split the vector in two parts, the first one containing those +-- elements that satisfy the predicate and the second one those that don't. +-- The order of the elements is not preserved but the operation is often +-- faster than 'partition'. +unstablePartition :: Unbox a => (a -> Bool) -> Vector a -> (Vector a, Vector a) +{-# INLINE unstablePartition #-} +unstablePartition = G.unstablePartition + +-- | /O(n)/ Split the vector into the longest prefix of elements that satisfy +-- the predicate and the rest without copying. +span :: Unbox a => (a -> Bool) -> Vector a -> (Vector a, Vector a) +{-# INLINE span #-} +span = G.span + +-- | /O(n)/ Split the vector into the longest prefix of elements that do not +-- satisfy the predicate and the rest without copying. +break :: Unbox a => (a -> Bool) -> Vector a -> (Vector a, Vector a) +{-# INLINE break #-} +break = G.break + +-- Searching +-- --------- + +infix 4 `elem` +-- | /O(n)/ Check if the vector contains an element +elem :: (Unbox a, Eq a) => a -> Vector a -> Bool +{-# INLINE elem #-} +elem = G.elem + +infix 4 `notElem` +-- | /O(n)/ Check if the vector does not contain an element (inverse of 'elem') +notElem :: (Unbox a, Eq a) => a -> Vector a -> Bool +{-# INLINE notElem #-} +notElem = G.notElem + +-- | /O(n)/ Yield 'Just' the first element matching the predicate or 'Nothing' +-- if no such element exists. +find :: Unbox a => (a -> Bool) -> Vector a -> Maybe a +{-# INLINE find #-} +find = G.find + +-- | /O(n)/ Yield 'Just' the index of the first element matching the predicate +-- or 'Nothing' if no such element exists. +findIndex :: Unbox a => (a -> Bool) -> Vector a -> Maybe Int +{-# INLINE findIndex #-} +findIndex = G.findIndex + +-- | /O(n)/ Yield the indices of elements satisfying the predicate in ascending +-- order. +findIndices :: Unbox a => (a -> Bool) -> Vector a -> Vector Int +{-# INLINE findIndices #-} +findIndices = G.findIndices + +-- | /O(n)/ Yield 'Just' the index of the first occurence of the given element or +-- 'Nothing' if the vector does not contain the element. This is a specialised +-- version of 'findIndex'. +elemIndex :: (Unbox a, Eq a) => a -> Vector a -> Maybe Int +{-# INLINE elemIndex #-} +elemIndex = G.elemIndex + +-- | /O(n)/ Yield the indices of all occurences of the given element in +-- ascending order. This is a specialised version of 'findIndices'. +elemIndices :: (Unbox a, Eq a) => a -> Vector a -> Vector Int +{-# INLINE elemIndices #-} +elemIndices = G.elemIndices + +-- Folding +-- ------- + +-- | /O(n)/ Left fold +foldl :: Unbox b => (a -> b -> a) -> a -> Vector b -> a +{-# INLINE foldl #-} +foldl = G.foldl + +-- | /O(n)/ Left fold on non-empty vectors +foldl1 :: Unbox a => (a -> a -> a) -> Vector a -> a +{-# INLINE foldl1 #-} +foldl1 = G.foldl1 + +-- | /O(n)/ Left fold with strict accumulator +foldl' :: Unbox b => (a -> b -> a) -> a -> Vector b -> a +{-# INLINE foldl' #-} +foldl' = G.foldl' + +-- | /O(n)/ Left fold on non-empty vectors with strict accumulator +foldl1' :: Unbox a => (a -> a -> a) -> Vector a -> a +{-# INLINE foldl1' #-} +foldl1' = G.foldl1' + +-- | /O(n)/ Right fold +foldr :: Unbox a => (a -> b -> b) -> b -> Vector a -> b +{-# INLINE foldr #-} +foldr = G.foldr + +-- | /O(n)/ Right fold on non-empty vectors +foldr1 :: Unbox a => (a -> a -> a) -> Vector a -> a +{-# INLINE foldr1 #-} +foldr1 = G.foldr1 + +-- | /O(n)/ Right fold with a strict accumulator +foldr' :: Unbox a => (a -> b -> b) -> b -> Vector a -> b +{-# INLINE foldr' #-} +foldr' = G.foldr' + +-- | /O(n)/ Right fold on non-empty vectors with strict accumulator +foldr1' :: Unbox a => (a -> a -> a) -> Vector a -> a +{-# INLINE foldr1' #-} +foldr1' = G.foldr1' + +-- | /O(n)/ Left fold (function applied to each element and its index) +ifoldl :: Unbox b => (a -> Int -> b -> a) -> a -> Vector b -> a +{-# INLINE ifoldl #-} +ifoldl = G.ifoldl + +-- | /O(n)/ Left fold with strict accumulator (function applied to each element +-- and its index) +ifoldl' :: Unbox b => (a -> Int -> b -> a) -> a -> Vector b -> a +{-# INLINE ifoldl' #-} +ifoldl' = G.ifoldl' + +-- | /O(n)/ Right fold (function applied to each element and its index) +ifoldr :: Unbox a => (Int -> a -> b -> b) -> b -> Vector a -> b +{-# INLINE ifoldr #-} +ifoldr = G.ifoldr + +-- | /O(n)/ Right fold with strict accumulator (function applied to each +-- element and its index) +ifoldr' :: Unbox a => (Int -> a -> b -> b) -> b -> Vector a -> b +{-# INLINE ifoldr' #-} +ifoldr' = G.ifoldr' + +-- Specialised folds +-- ----------------- + +-- | /O(n)/ Check if all elements satisfy the predicate. +all :: Unbox a => (a -> Bool) -> Vector a -> Bool +{-# INLINE all #-} +all = G.all + +-- | /O(n)/ Check if any element satisfies the predicate. +any :: Unbox a => (a -> Bool) -> Vector a -> Bool +{-# INLINE any #-} +any = G.any + +-- | /O(n)/ Check if all elements are 'True' +and :: Vector Bool -> Bool +{-# INLINE and #-} +and = G.and + +-- | /O(n)/ Check if any element is 'True' +or :: Vector Bool -> Bool +{-# INLINE or #-} +or = G.or + +-- | /O(n)/ Compute the sum of the elements +sum :: (Unbox a, Num a) => Vector a -> a +{-# INLINE sum #-} +sum = G.sum + +-- | /O(n)/ Compute the produce of the elements +product :: (Unbox a, Num a) => Vector a -> a +{-# INLINE product #-} +product = G.product + +-- | /O(n)/ Yield the maximum element of the vector. The vector may not be +-- empty. +maximum :: (Unbox a, Ord a) => Vector a -> a +{-# INLINE maximum #-} +maximum = G.maximum + +-- | /O(n)/ Yield the maximum element of the vector according to the given +-- comparison function. The vector may not be empty. +maximumBy :: Unbox a => (a -> a -> Ordering) -> Vector a -> a +{-# INLINE maximumBy #-} +maximumBy = G.maximumBy + +-- | /O(n)/ Yield the minimum element of the vector. The vector may not be +-- empty. +minimum :: (Unbox a, Ord a) => Vector a -> a +{-# INLINE minimum #-} +minimum = G.minimum + +-- | /O(n)/ Yield the minimum element of the vector according to the given +-- comparison function. The vector may not be empty. +minimumBy :: Unbox a => (a -> a -> Ordering) -> Vector a -> a +{-# INLINE minimumBy #-} +minimumBy = G.minimumBy + +-- | /O(n)/ Yield the index of the maximum element of the vector. The vector +-- may not be empty. +maxIndex :: (Unbox a, Ord a) => Vector a -> Int +{-# INLINE maxIndex #-} +maxIndex = G.maxIndex + +-- | /O(n)/ Yield the index of the maximum element of the vector according to +-- the given comparison function. The vector may not be empty. +maxIndexBy :: Unbox a => (a -> a -> Ordering) -> Vector a -> Int +{-# INLINE maxIndexBy #-} +maxIndexBy = G.maxIndexBy + +-- | /O(n)/ Yield the index of the minimum element of the vector. The vector +-- may not be empty. +minIndex :: (Unbox a, Ord a) => Vector a -> Int +{-# INLINE minIndex #-} +minIndex = G.minIndex + +-- | /O(n)/ Yield the index of the minimum element of the vector according to +-- the given comparison function. The vector may not be empty. +minIndexBy :: Unbox a => (a -> a -> Ordering) -> Vector a -> Int +{-# INLINE minIndexBy #-} +minIndexBy = G.minIndexBy + +-- Monadic folds +-- ------------- + +-- | /O(n)/ Monadic fold +foldM :: (Monad m, Unbox b) => (a -> b -> m a) -> a -> Vector b -> m a +{-# INLINE foldM #-} +foldM = G.foldM + +-- | /O(n)/ Monadic fold (action applied to each element and its index) +ifoldM :: (Monad m, Unbox b) => (a -> Int -> b -> m a) -> a -> Vector b -> m a +{-# INLINE ifoldM #-} +ifoldM = G.ifoldM + +-- | /O(n)/ Monadic fold over non-empty vectors +fold1M :: (Monad m, Unbox a) => (a -> a -> m a) -> Vector a -> m a +{-# INLINE fold1M #-} +fold1M = G.fold1M + +-- | /O(n)/ Monadic fold with strict accumulator +foldM' :: (Monad m, Unbox b) => (a -> b -> m a) -> a -> Vector b -> m a +{-# INLINE foldM' #-} +foldM' = G.foldM' + +-- | /O(n)/ Monadic fold with strict accumulator (action applied to each +-- element and its index) +ifoldM' :: (Monad m, Unbox b) => (a -> Int -> b -> m a) -> a -> Vector b -> m a +{-# INLINE ifoldM' #-} +ifoldM' = G.ifoldM' + +-- | /O(n)/ Monadic fold over non-empty vectors with strict accumulator +fold1M' :: (Monad m, Unbox a) => (a -> a -> m a) -> Vector a -> m a +{-# INLINE fold1M' #-} +fold1M' = G.fold1M' + +-- | /O(n)/ Monadic fold that discards the result +foldM_ :: (Monad m, Unbox b) => (a -> b -> m a) -> a -> Vector b -> m () +{-# INLINE foldM_ #-} +foldM_ = G.foldM_ + +-- | /O(n)/ Monadic fold that discards the result (action applied to each +-- element and its index) +ifoldM_ :: (Monad m, Unbox b) => (a -> Int -> b -> m a) -> a -> Vector b -> m () +{-# INLINE ifoldM_ #-} +ifoldM_ = G.ifoldM_ + +-- | /O(n)/ Monadic fold over non-empty vectors that discards the result +fold1M_ :: (Monad m, Unbox a) => (a -> a -> m a) -> Vector a -> m () +{-# INLINE fold1M_ #-} +fold1M_ = G.fold1M_ + +-- | /O(n)/ Monadic fold with strict accumulator that discards the result +foldM'_ :: (Monad m, Unbox b) => (a -> b -> m a) -> a -> Vector b -> m () +{-# INLINE foldM'_ #-} +foldM'_ = G.foldM'_ + +-- | /O(n)/ Monadic fold with strict accumulator that discards the result +-- (action applied to each element and its index) +ifoldM'_ :: (Monad m, Unbox b) + => (a -> Int -> b -> m a) -> a -> Vector b -> m () +{-# INLINE ifoldM'_ #-} +ifoldM'_ = G.ifoldM'_ + +-- | /O(n)/ Monadic fold over non-empty vectors with strict accumulator +-- that discards the result +fold1M'_ :: (Monad m, Unbox a) => (a -> a -> m a) -> Vector a -> m () +{-# INLINE fold1M'_ #-} +fold1M'_ = G.fold1M'_ + +-- Prefix sums (scans) +-- ------------------- + +-- | /O(n)/ Prescan +-- +-- @ +-- prescanl f z = 'init' . 'scanl' f z +-- @ +-- +-- Example: @prescanl (+) 0 \<1,2,3,4\> = \<0,1,3,6\>@ +-- +prescanl :: (Unbox a, Unbox b) => (a -> b -> a) -> a -> Vector b -> Vector a +{-# INLINE prescanl #-} +prescanl = G.prescanl + +-- | /O(n)/ Prescan with strict accumulator +prescanl' :: (Unbox a, Unbox b) => (a -> b -> a) -> a -> Vector b -> Vector a +{-# INLINE prescanl' #-} +prescanl' = G.prescanl' + +-- | /O(n)/ Scan +-- +-- @ +-- postscanl f z = 'tail' . 'scanl' f z +-- @ +-- +-- Example: @postscanl (+) 0 \<1,2,3,4\> = \<1,3,6,10\>@ +-- +postscanl :: (Unbox a, Unbox b) => (a -> b -> a) -> a -> Vector b -> Vector a +{-# INLINE postscanl #-} +postscanl = G.postscanl + +-- | /O(n)/ Scan with strict accumulator +postscanl' :: (Unbox a, Unbox b) => (a -> b -> a) -> a -> Vector b -> Vector a +{-# INLINE postscanl' #-} +postscanl' = G.postscanl' + +-- | /O(n)/ Haskell-style scan +-- +-- > scanl f z <x1,...,xn> = <y1,...,y(n+1)> +-- > where y1 = z +-- > yi = f y(i-1) x(i-1) +-- +-- Example: @scanl (+) 0 \<1,2,3,4\> = \<0,1,3,6,10\>@ +-- +scanl :: (Unbox a, Unbox b) => (a -> b -> a) -> a -> Vector b -> Vector a +{-# INLINE scanl #-} +scanl = G.scanl + +-- | /O(n)/ Haskell-style scan with strict accumulator +scanl' :: (Unbox a, Unbox b) => (a -> b -> a) -> a -> Vector b -> Vector a +{-# INLINE scanl' #-} +scanl' = G.scanl' + +-- | /O(n)/ Scan over a non-empty vector +-- +-- > scanl f <x1,...,xn> = <y1,...,yn> +-- > where y1 = x1 +-- > yi = f y(i-1) xi +-- +scanl1 :: Unbox a => (a -> a -> a) -> Vector a -> Vector a +{-# INLINE scanl1 #-} +scanl1 = G.scanl1 + +-- | /O(n)/ Scan over a non-empty vector with a strict accumulator +scanl1' :: Unbox a => (a -> a -> a) -> Vector a -> Vector a +{-# INLINE scanl1' #-} +scanl1' = G.scanl1' + +-- | /O(n)/ Right-to-left prescan +-- +-- @ +-- prescanr f z = 'reverse' . 'prescanl' (flip f) z . 'reverse' +-- @ +-- +prescanr :: (Unbox a, Unbox b) => (a -> b -> b) -> b -> Vector a -> Vector b +{-# INLINE prescanr #-} +prescanr = G.prescanr + +-- | /O(n)/ Right-to-left prescan with strict accumulator +prescanr' :: (Unbox a, Unbox b) => (a -> b -> b) -> b -> Vector a -> Vector b +{-# INLINE prescanr' #-} +prescanr' = G.prescanr' + +-- | /O(n)/ Right-to-left scan +postscanr :: (Unbox a, Unbox b) => (a -> b -> b) -> b -> Vector a -> Vector b +{-# INLINE postscanr #-} +postscanr = G.postscanr + +-- | /O(n)/ Right-to-left scan with strict accumulator +postscanr' :: (Unbox a, Unbox b) => (a -> b -> b) -> b -> Vector a -> Vector b +{-# INLINE postscanr' #-} +postscanr' = G.postscanr' + +-- | /O(n)/ Right-to-left Haskell-style scan +scanr :: (Unbox a, Unbox b) => (a -> b -> b) -> b -> Vector a -> Vector b +{-# INLINE scanr #-} +scanr = G.scanr + +-- | /O(n)/ Right-to-left Haskell-style scan with strict accumulator +scanr' :: (Unbox a, Unbox b) => (a -> b -> b) -> b -> Vector a -> Vector b +{-# INLINE scanr' #-} +scanr' = G.scanr' + +-- | /O(n)/ Right-to-left scan over a non-empty vector +scanr1 :: Unbox a => (a -> a -> a) -> Vector a -> Vector a +{-# INLINE scanr1 #-} +scanr1 = G.scanr1 + +-- | /O(n)/ Right-to-left scan over a non-empty vector with a strict +-- accumulator +scanr1' :: Unbox a => (a -> a -> a) -> Vector a -> Vector a +{-# INLINE scanr1' #-} +scanr1' = G.scanr1' + +-- Conversions - Lists +-- ------------------------ + +-- | /O(n)/ Convert a vector to a list +toList :: Unbox a => Vector a -> [a] +{-# INLINE toList #-} +toList = G.toList + +-- | /O(n)/ Convert a list to a vector +fromList :: Unbox a => [a] -> Vector a +{-# INLINE fromList #-} +fromList = G.fromList + +-- | /O(n)/ Convert the first @n@ elements of a list to a vector +-- +-- @ +-- fromListN n xs = 'fromList' ('take' n xs) +-- @ +fromListN :: Unbox a => Int -> [a] -> Vector a +{-# INLINE fromListN #-} +fromListN = G.fromListN + +-- Conversions - Mutable vectors +-- ----------------------------- + +-- | /O(1)/ Unsafe convert a mutable vector to an immutable one without +-- copying. The mutable vector may not be used after this operation. +unsafeFreeze :: (Unbox a, PrimMonad m) => MVector (PrimState m) a -> m (Vector a) +{-# INLINE unsafeFreeze #-} +unsafeFreeze = G.unsafeFreeze + +-- | /O(1)/ Unsafely convert an immutable vector to a mutable one without +-- copying. The immutable vector may not be used after this operation. +unsafeThaw :: (Unbox a, PrimMonad m) => Vector a -> m (MVector (PrimState m) a) +{-# INLINE unsafeThaw #-} +unsafeThaw = G.unsafeThaw + +-- | /O(n)/ Yield a mutable copy of the immutable vector. +thaw :: (Unbox a, PrimMonad m) => Vector a -> m (MVector (PrimState m) a) +{-# INLINE thaw #-} +thaw = G.thaw + +-- | /O(n)/ Yield an immutable copy of the mutable vector. +freeze :: (Unbox a, PrimMonad m) => MVector (PrimState m) a -> m (Vector a) +{-# INLINE freeze #-} +freeze = G.freeze + +-- | /O(n)/ Copy an immutable vector into a mutable one. The two vectors must +-- have the same length. This is not checked. +unsafeCopy + :: (Unbox a, PrimMonad m) => MVector (PrimState m) a -> Vector a -> m () +{-# INLINE unsafeCopy #-} +unsafeCopy = G.unsafeCopy + +-- | /O(n)/ Copy an immutable vector into a mutable one. The two vectors must +-- have the same length. +copy :: (Unbox a, PrimMonad m) => MVector (PrimState m) a -> Vector a -> m () +{-# INLINE copy #-} +copy = G.copy + + +#define DEFINE_IMMUTABLE +#include "unbox-tuple-instances" diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Unboxed/Base.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Unboxed/Base.hs new file mode 100644 index 000000000000..a88795c5b4bc --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Unboxed/Base.hs @@ -0,0 +1,408 @@ +{-# LANGUAGE BangPatterns, CPP, MultiParamTypeClasses, TypeFamilies, FlexibleContexts #-} +#if __GLASGOW_HASKELL__ >= 707 +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} +#endif +{-# OPTIONS_HADDOCK hide #-} + +-- | +-- Module : Data.Vector.Unboxed.Base +-- Copyright : (c) Roman Leshchinskiy 2009-2010 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> +-- Stability : experimental +-- Portability : non-portable +-- +-- Adaptive unboxed vectors: basic implementation +-- + +module Data.Vector.Unboxed.Base ( + MVector(..), IOVector, STVector, Vector(..), Unbox +) where + +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Generic.Mutable as M + +import qualified Data.Vector.Primitive as P + +import Control.DeepSeq ( NFData(rnf) ) + +import Control.Monad.Primitive +import Control.Monad ( liftM ) + +import Data.Word ( Word8, Word16, Word32, Word64 ) +import Data.Int ( Int8, Int16, Int32, Int64 ) +import Data.Complex + +#if !MIN_VERSION_base(4,8,0) +import Data.Word ( Word ) +#endif + +#if __GLASGOW_HASKELL__ >= 707 +import Data.Typeable ( Typeable ) +#else +import Data.Typeable ( Typeable1(..), Typeable2(..), mkTyConApp, + mkTyCon3 + ) +#endif + +import Data.Data ( Data(..) ) + +-- Data.Vector.Internal.Check is unused +#define NOT_VECTOR_MODULE +#include "vector.h" + +data family MVector s a +data family Vector a + +type IOVector = MVector RealWorld +type STVector s = MVector s + +type instance G.Mutable Vector = MVector + +class (G.Vector Vector a, M.MVector MVector a) => Unbox a + +instance NFData (Vector a) where rnf !_ = () +instance NFData (MVector s a) where rnf !_ = () + +-- ----------------- +-- Data and Typeable +-- ----------------- +#if __GLASGOW_HASKELL__ >= 707 +deriving instance Typeable Vector +deriving instance Typeable MVector +#else +vectorTyCon = mkTyCon3 "vector" + +instance Typeable1 Vector where + typeOf1 _ = mkTyConApp (vectorTyCon "Data.Vector.Unboxed" "Vector") [] + +instance Typeable2 MVector where + typeOf2 _ = mkTyConApp (vectorTyCon "Data.Vector.Unboxed.Mutable" "MVector") [] +#endif + +instance (Data a, Unbox a) => Data (Vector a) where + gfoldl = G.gfoldl + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = G.mkType "Data.Vector.Unboxed.Vector" + dataCast1 = G.dataCast + +-- ---- +-- Unit +-- ---- + +newtype instance MVector s () = MV_Unit Int +newtype instance Vector () = V_Unit Int + +instance Unbox () + +instance M.MVector MVector () where + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicOverlaps #-} + {-# INLINE basicUnsafeNew #-} + {-# INLINE basicInitialize #-} + {-# INLINE basicUnsafeRead #-} + {-# INLINE basicUnsafeWrite #-} + {-# INLINE basicClear #-} + {-# INLINE basicSet #-} + {-# INLINE basicUnsafeCopy #-} + {-# INLINE basicUnsafeGrow #-} + + basicLength (MV_Unit n) = n + + basicUnsafeSlice _ m (MV_Unit _) = MV_Unit m + + basicOverlaps _ _ = False + + basicUnsafeNew n = return (MV_Unit n) + + -- Nothing to initialize + basicInitialize _ = return () + + basicUnsafeRead (MV_Unit _) _ = return () + + basicUnsafeWrite (MV_Unit _) _ () = return () + + basicClear _ = return () + + basicSet (MV_Unit _) () = return () + + basicUnsafeCopy (MV_Unit _) (MV_Unit _) = return () + + basicUnsafeGrow (MV_Unit n) m = return $ MV_Unit (n+m) + +instance G.Vector Vector () where + {-# INLINE basicUnsafeFreeze #-} + basicUnsafeFreeze (MV_Unit n) = return $ V_Unit n + + {-# INLINE basicUnsafeThaw #-} + basicUnsafeThaw (V_Unit n) = return $ MV_Unit n + + {-# INLINE basicLength #-} + basicLength (V_Unit n) = n + + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice _ m (V_Unit _) = V_Unit m + + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeIndexM (V_Unit _) _ = return () + + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy (MV_Unit _) (V_Unit _) = return () + + {-# INLINE elemseq #-} + elemseq _ = seq + + +-- --------------- +-- Primitive types +-- --------------- + +#define primMVector(ty,con) \ +instance M.MVector MVector ty where { \ + {-# INLINE basicLength #-} \ +; {-# INLINE basicUnsafeSlice #-} \ +; {-# INLINE basicOverlaps #-} \ +; {-# INLINE basicUnsafeNew #-} \ +; {-# INLINE basicInitialize #-} \ +; {-# INLINE basicUnsafeReplicate #-} \ +; {-# INLINE basicUnsafeRead #-} \ +; {-# INLINE basicUnsafeWrite #-} \ +; {-# INLINE basicClear #-} \ +; {-# INLINE basicSet #-} \ +; {-# INLINE basicUnsafeCopy #-} \ +; {-# INLINE basicUnsafeGrow #-} \ +; basicLength (con v) = M.basicLength v \ +; basicUnsafeSlice i n (con v) = con $ M.basicUnsafeSlice i n v \ +; basicOverlaps (con v1) (con v2) = M.basicOverlaps v1 v2 \ +; basicUnsafeNew n = con `liftM` M.basicUnsafeNew n \ +; basicInitialize (con v) = M.basicInitialize v \ +; basicUnsafeReplicate n x = con `liftM` M.basicUnsafeReplicate n x \ +; basicUnsafeRead (con v) i = M.basicUnsafeRead v i \ +; basicUnsafeWrite (con v) i x = M.basicUnsafeWrite v i x \ +; basicClear (con v) = M.basicClear v \ +; basicSet (con v) x = M.basicSet v x \ +; basicUnsafeCopy (con v1) (con v2) = M.basicUnsafeCopy v1 v2 \ +; basicUnsafeMove (con v1) (con v2) = M.basicUnsafeMove v1 v2 \ +; basicUnsafeGrow (con v) n = con `liftM` M.basicUnsafeGrow v n } + +#define primVector(ty,con,mcon) \ +instance G.Vector Vector ty where { \ + {-# INLINE basicUnsafeFreeze #-} \ +; {-# INLINE basicUnsafeThaw #-} \ +; {-# INLINE basicLength #-} \ +; {-# INLINE basicUnsafeSlice #-} \ +; {-# INLINE basicUnsafeIndexM #-} \ +; {-# INLINE elemseq #-} \ +; basicUnsafeFreeze (mcon v) = con `liftM` G.basicUnsafeFreeze v \ +; basicUnsafeThaw (con v) = mcon `liftM` G.basicUnsafeThaw v \ +; basicLength (con v) = G.basicLength v \ +; basicUnsafeSlice i n (con v) = con $ G.basicUnsafeSlice i n v \ +; basicUnsafeIndexM (con v) i = G.basicUnsafeIndexM v i \ +; basicUnsafeCopy (mcon mv) (con v) = G.basicUnsafeCopy mv v \ +; elemseq _ = seq } + +newtype instance MVector s Int = MV_Int (P.MVector s Int) +newtype instance Vector Int = V_Int (P.Vector Int) +instance Unbox Int +primMVector(Int, MV_Int) +primVector(Int, V_Int, MV_Int) + +newtype instance MVector s Int8 = MV_Int8 (P.MVector s Int8) +newtype instance Vector Int8 = V_Int8 (P.Vector Int8) +instance Unbox Int8 +primMVector(Int8, MV_Int8) +primVector(Int8, V_Int8, MV_Int8) + +newtype instance MVector s Int16 = MV_Int16 (P.MVector s Int16) +newtype instance Vector Int16 = V_Int16 (P.Vector Int16) +instance Unbox Int16 +primMVector(Int16, MV_Int16) +primVector(Int16, V_Int16, MV_Int16) + +newtype instance MVector s Int32 = MV_Int32 (P.MVector s Int32) +newtype instance Vector Int32 = V_Int32 (P.Vector Int32) +instance Unbox Int32 +primMVector(Int32, MV_Int32) +primVector(Int32, V_Int32, MV_Int32) + +newtype instance MVector s Int64 = MV_Int64 (P.MVector s Int64) +newtype instance Vector Int64 = V_Int64 (P.Vector Int64) +instance Unbox Int64 +primMVector(Int64, MV_Int64) +primVector(Int64, V_Int64, MV_Int64) + + +newtype instance MVector s Word = MV_Word (P.MVector s Word) +newtype instance Vector Word = V_Word (P.Vector Word) +instance Unbox Word +primMVector(Word, MV_Word) +primVector(Word, V_Word, MV_Word) + +newtype instance MVector s Word8 = MV_Word8 (P.MVector s Word8) +newtype instance Vector Word8 = V_Word8 (P.Vector Word8) +instance Unbox Word8 +primMVector(Word8, MV_Word8) +primVector(Word8, V_Word8, MV_Word8) + +newtype instance MVector s Word16 = MV_Word16 (P.MVector s Word16) +newtype instance Vector Word16 = V_Word16 (P.Vector Word16) +instance Unbox Word16 +primMVector(Word16, MV_Word16) +primVector(Word16, V_Word16, MV_Word16) + +newtype instance MVector s Word32 = MV_Word32 (P.MVector s Word32) +newtype instance Vector Word32 = V_Word32 (P.Vector Word32) +instance Unbox Word32 +primMVector(Word32, MV_Word32) +primVector(Word32, V_Word32, MV_Word32) + +newtype instance MVector s Word64 = MV_Word64 (P.MVector s Word64) +newtype instance Vector Word64 = V_Word64 (P.Vector Word64) +instance Unbox Word64 +primMVector(Word64, MV_Word64) +primVector(Word64, V_Word64, MV_Word64) + + +newtype instance MVector s Float = MV_Float (P.MVector s Float) +newtype instance Vector Float = V_Float (P.Vector Float) +instance Unbox Float +primMVector(Float, MV_Float) +primVector(Float, V_Float, MV_Float) + +newtype instance MVector s Double = MV_Double (P.MVector s Double) +newtype instance Vector Double = V_Double (P.Vector Double) +instance Unbox Double +primMVector(Double, MV_Double) +primVector(Double, V_Double, MV_Double) + + +newtype instance MVector s Char = MV_Char (P.MVector s Char) +newtype instance Vector Char = V_Char (P.Vector Char) +instance Unbox Char +primMVector(Char, MV_Char) +primVector(Char, V_Char, MV_Char) + +-- ---- +-- Bool +-- ---- + +fromBool :: Bool -> Word8 +{-# INLINE fromBool #-} +fromBool True = 1 +fromBool False = 0 + +toBool :: Word8 -> Bool +{-# INLINE toBool #-} +toBool 0 = False +toBool _ = True + +newtype instance MVector s Bool = MV_Bool (P.MVector s Word8) +newtype instance Vector Bool = V_Bool (P.Vector Word8) + +instance Unbox Bool + +instance M.MVector MVector Bool where + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicOverlaps #-} + {-# INLINE basicUnsafeNew #-} + {-# INLINE basicInitialize #-} + {-# INLINE basicUnsafeReplicate #-} + {-# INLINE basicUnsafeRead #-} + {-# INLINE basicUnsafeWrite #-} + {-# INLINE basicClear #-} + {-# INLINE basicSet #-} + {-# INLINE basicUnsafeCopy #-} + {-# INLINE basicUnsafeGrow #-} + basicLength (MV_Bool v) = M.basicLength v + basicUnsafeSlice i n (MV_Bool v) = MV_Bool $ M.basicUnsafeSlice i n v + basicOverlaps (MV_Bool v1) (MV_Bool v2) = M.basicOverlaps v1 v2 + basicUnsafeNew n = MV_Bool `liftM` M.basicUnsafeNew n + basicInitialize (MV_Bool v) = M.basicInitialize v + basicUnsafeReplicate n x = MV_Bool `liftM` M.basicUnsafeReplicate n (fromBool x) + basicUnsafeRead (MV_Bool v) i = toBool `liftM` M.basicUnsafeRead v i + basicUnsafeWrite (MV_Bool v) i x = M.basicUnsafeWrite v i (fromBool x) + basicClear (MV_Bool v) = M.basicClear v + basicSet (MV_Bool v) x = M.basicSet v (fromBool x) + basicUnsafeCopy (MV_Bool v1) (MV_Bool v2) = M.basicUnsafeCopy v1 v2 + basicUnsafeMove (MV_Bool v1) (MV_Bool v2) = M.basicUnsafeMove v1 v2 + basicUnsafeGrow (MV_Bool v) n = MV_Bool `liftM` M.basicUnsafeGrow v n + +instance G.Vector Vector Bool where + {-# INLINE basicUnsafeFreeze #-} + {-# INLINE basicUnsafeThaw #-} + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicUnsafeIndexM #-} + {-# INLINE elemseq #-} + basicUnsafeFreeze (MV_Bool v) = V_Bool `liftM` G.basicUnsafeFreeze v + basicUnsafeThaw (V_Bool v) = MV_Bool `liftM` G.basicUnsafeThaw v + basicLength (V_Bool v) = G.basicLength v + basicUnsafeSlice i n (V_Bool v) = V_Bool $ G.basicUnsafeSlice i n v + basicUnsafeIndexM (V_Bool v) i = toBool `liftM` G.basicUnsafeIndexM v i + basicUnsafeCopy (MV_Bool mv) (V_Bool v) = G.basicUnsafeCopy mv v + elemseq _ = seq + +-- ------- +-- Complex +-- ------- + +newtype instance MVector s (Complex a) = MV_Complex (MVector s (a,a)) +newtype instance Vector (Complex a) = V_Complex (Vector (a,a)) + +instance (Unbox a) => Unbox (Complex a) + +instance (Unbox a) => M.MVector MVector (Complex a) where + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicOverlaps #-} + {-# INLINE basicUnsafeNew #-} + {-# INLINE basicInitialize #-} + {-# INLINE basicUnsafeReplicate #-} + {-# INLINE basicUnsafeRead #-} + {-# INLINE basicUnsafeWrite #-} + {-# INLINE basicClear #-} + {-# INLINE basicSet #-} + {-# INLINE basicUnsafeCopy #-} + {-# INLINE basicUnsafeGrow #-} + basicLength (MV_Complex v) = M.basicLength v + basicUnsafeSlice i n (MV_Complex v) = MV_Complex $ M.basicUnsafeSlice i n v + basicOverlaps (MV_Complex v1) (MV_Complex v2) = M.basicOverlaps v1 v2 + basicUnsafeNew n = MV_Complex `liftM` M.basicUnsafeNew n + basicInitialize (MV_Complex v) = M.basicInitialize v + basicUnsafeReplicate n (x :+ y) = MV_Complex `liftM` M.basicUnsafeReplicate n (x,y) + basicUnsafeRead (MV_Complex v) i = uncurry (:+) `liftM` M.basicUnsafeRead v i + basicUnsafeWrite (MV_Complex v) i (x :+ y) = M.basicUnsafeWrite v i (x,y) + basicClear (MV_Complex v) = M.basicClear v + basicSet (MV_Complex v) (x :+ y) = M.basicSet v (x,y) + basicUnsafeCopy (MV_Complex v1) (MV_Complex v2) = M.basicUnsafeCopy v1 v2 + basicUnsafeMove (MV_Complex v1) (MV_Complex v2) = M.basicUnsafeMove v1 v2 + basicUnsafeGrow (MV_Complex v) n = MV_Complex `liftM` M.basicUnsafeGrow v n + +instance (Unbox a) => G.Vector Vector (Complex a) where + {-# INLINE basicUnsafeFreeze #-} + {-# INLINE basicUnsafeThaw #-} + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicUnsafeIndexM #-} + {-# INLINE elemseq #-} + basicUnsafeFreeze (MV_Complex v) = V_Complex `liftM` G.basicUnsafeFreeze v + basicUnsafeThaw (V_Complex v) = MV_Complex `liftM` G.basicUnsafeThaw v + basicLength (V_Complex v) = G.basicLength v + basicUnsafeSlice i n (V_Complex v) = V_Complex $ G.basicUnsafeSlice i n v + basicUnsafeIndexM (V_Complex v) i + = uncurry (:+) `liftM` G.basicUnsafeIndexM v i + basicUnsafeCopy (MV_Complex mv) (V_Complex v) + = G.basicUnsafeCopy mv v + elemseq _ (x :+ y) z = G.elemseq (undefined :: Vector a) x + $ G.elemseq (undefined :: Vector a) y z + +-- ------ +-- Tuples +-- ------ + +#define DEFINE_INSTANCES +#include "unbox-tuple-instances" diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Unboxed/Mutable.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Unboxed/Mutable.hs new file mode 100644 index 000000000000..cb82acea8f87 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Unboxed/Mutable.hs @@ -0,0 +1,307 @@ +{-# LANGUAGE CPP #-} + +-- | +-- Module : Data.Vector.Unboxed.Mutable +-- Copyright : (c) Roman Leshchinskiy 2009-2010 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> +-- Stability : experimental +-- Portability : non-portable +-- +-- Mutable adaptive unboxed vectors +-- + +module Data.Vector.Unboxed.Mutable ( + -- * Mutable vectors of primitive types + MVector(..), IOVector, STVector, Unbox, + + -- * Accessors + + -- ** Length information + length, null, + + -- ** Extracting subvectors + slice, init, tail, take, drop, splitAt, + unsafeSlice, unsafeInit, unsafeTail, unsafeTake, unsafeDrop, + + -- ** Overlapping + overlaps, + + -- * Construction + + -- ** Initialisation + new, unsafeNew, replicate, replicateM, clone, + + -- ** Growing + grow, unsafeGrow, + + -- ** Restricting memory usage + clear, + + -- * Zipping and unzipping + zip, zip3, zip4, zip5, zip6, + unzip, unzip3, unzip4, unzip5, unzip6, + + -- * Accessing individual elements + read, write, modify, swap, + unsafeRead, unsafeWrite, unsafeModify, unsafeSwap, + + -- * Modifying vectors + nextPermutation, + + -- ** Filling and copying + set, copy, move, unsafeCopy, unsafeMove +) where + +import Data.Vector.Unboxed.Base +import qualified Data.Vector.Generic.Mutable as G +import Data.Vector.Fusion.Util ( delayed_min ) +import Control.Monad.Primitive + +import Prelude hiding ( length, null, replicate, reverse, map, read, + take, drop, splitAt, init, tail, + zip, zip3, unzip, unzip3 ) + +-- don't import an unused Data.Vector.Internal.Check +#define NOT_VECTOR_MODULE +#include "vector.h" + +-- Length information +-- ------------------ + +-- | Length of the mutable vector. +length :: Unbox a => MVector s a -> Int +{-# INLINE length #-} +length = G.length + +-- | Check whether the vector is empty +null :: Unbox a => MVector s a -> Bool +{-# INLINE null #-} +null = G.null + +-- Extracting subvectors +-- --------------------- + +-- | Yield a part of the mutable vector without copying it. +slice :: Unbox a => Int -> Int -> MVector s a -> MVector s a +{-# INLINE slice #-} +slice = G.slice + +take :: Unbox a => Int -> MVector s a -> MVector s a +{-# INLINE take #-} +take = G.take + +drop :: Unbox a => Int -> MVector s a -> MVector s a +{-# INLINE drop #-} +drop = G.drop + +splitAt :: Unbox a => Int -> MVector s a -> (MVector s a, MVector s a) +{-# INLINE splitAt #-} +splitAt = G.splitAt + +init :: Unbox a => MVector s a -> MVector s a +{-# INLINE init #-} +init = G.init + +tail :: Unbox a => MVector s a -> MVector s a +{-# INLINE tail #-} +tail = G.tail + +-- | Yield a part of the mutable vector without copying it. No bounds checks +-- are performed. +unsafeSlice :: Unbox a + => Int -- ^ starting index + -> Int -- ^ length of the slice + -> MVector s a + -> MVector s a +{-# INLINE unsafeSlice #-} +unsafeSlice = G.unsafeSlice + +unsafeTake :: Unbox a => Int -> MVector s a -> MVector s a +{-# INLINE unsafeTake #-} +unsafeTake = G.unsafeTake + +unsafeDrop :: Unbox a => Int -> MVector s a -> MVector s a +{-# INLINE unsafeDrop #-} +unsafeDrop = G.unsafeDrop + +unsafeInit :: Unbox a => MVector s a -> MVector s a +{-# INLINE unsafeInit #-} +unsafeInit = G.unsafeInit + +unsafeTail :: Unbox a => MVector s a -> MVector s a +{-# INLINE unsafeTail #-} +unsafeTail = G.unsafeTail + +-- Overlapping +-- ----------- + +-- | Check whether two vectors overlap. +overlaps :: Unbox a => MVector s a -> MVector s a -> Bool +{-# INLINE overlaps #-} +overlaps = G.overlaps + +-- Initialisation +-- -------------- + +-- | Create a mutable vector of the given length. +new :: (PrimMonad m, Unbox a) => Int -> m (MVector (PrimState m) a) +{-# INLINE new #-} +new = G.new + +-- | Create a mutable vector of the given length. The memory is not initialized. +unsafeNew :: (PrimMonad m, Unbox a) => Int -> m (MVector (PrimState m) a) +{-# INLINE unsafeNew #-} +unsafeNew = G.unsafeNew + +-- | Create a mutable vector of the given length (0 if the length is negative) +-- and fill it with an initial value. +replicate :: (PrimMonad m, Unbox a) => Int -> a -> m (MVector (PrimState m) a) +{-# INLINE replicate #-} +replicate = G.replicate + +-- | Create a mutable vector of the given length (0 if the length is negative) +-- and fill it with values produced by repeatedly executing the monadic action. +replicateM :: (PrimMonad m, Unbox a) => Int -> m a -> m (MVector (PrimState m) a) +{-# INLINE replicateM #-} +replicateM = G.replicateM + +-- | Create a copy of a mutable vector. +clone :: (PrimMonad m, Unbox a) + => MVector (PrimState m) a -> m (MVector (PrimState m) a) +{-# INLINE clone #-} +clone = G.clone + +-- Growing +-- ------- + +-- | Grow a vector by the given number of elements. The number must be +-- positive. +grow :: (PrimMonad m, Unbox a) + => MVector (PrimState m) a -> Int -> m (MVector (PrimState m) a) +{-# INLINE grow #-} +grow = G.grow + +-- | Grow a vector by the given number of elements. The number must be +-- positive but this is not checked. +unsafeGrow :: (PrimMonad m, Unbox a) + => MVector (PrimState m) a -> Int -> m (MVector (PrimState m) a) +{-# INLINE unsafeGrow #-} +unsafeGrow = G.unsafeGrow + +-- Restricting memory usage +-- ------------------------ + +-- | Reset all elements of the vector to some undefined value, clearing all +-- references to external objects. This is usually a noop for unboxed vectors. +clear :: (PrimMonad m, Unbox a) => MVector (PrimState m) a -> m () +{-# INLINE clear #-} +clear = G.clear + +-- Accessing individual elements +-- ----------------------------- + +-- | Yield the element at the given position. +read :: (PrimMonad m, Unbox a) => MVector (PrimState m) a -> Int -> m a +{-# INLINE read #-} +read = G.read + +-- | Replace the element at the given position. +write :: (PrimMonad m, Unbox a) => MVector (PrimState m) a -> Int -> a -> m () +{-# INLINE write #-} +write = G.write + +-- | Modify the element at the given position. +modify :: (PrimMonad m, Unbox a) => MVector (PrimState m) a -> (a -> a) -> Int -> m () +{-# INLINE modify #-} +modify = G.modify + +-- | Swap the elements at the given positions. +swap :: (PrimMonad m, Unbox a) => MVector (PrimState m) a -> Int -> Int -> m () +{-# INLINE swap #-} +swap = G.swap + + +-- | Yield the element at the given position. No bounds checks are performed. +unsafeRead :: (PrimMonad m, Unbox a) => MVector (PrimState m) a -> Int -> m a +{-# INLINE unsafeRead #-} +unsafeRead = G.unsafeRead + +-- | Replace the element at the given position. No bounds checks are performed. +unsafeWrite + :: (PrimMonad m, Unbox a) => MVector (PrimState m) a -> Int -> a -> m () +{-# INLINE unsafeWrite #-} +unsafeWrite = G.unsafeWrite + +-- | Modify the element at the given position. No bounds checks are performed. +unsafeModify :: (PrimMonad m, Unbox a) => MVector (PrimState m) a -> (a -> a) -> Int -> m () +{-# INLINE unsafeModify #-} +unsafeModify = G.unsafeModify + +-- | Swap the elements at the given positions. No bounds checks are performed. +unsafeSwap + :: (PrimMonad m, Unbox a) => MVector (PrimState m) a -> Int -> Int -> m () +{-# INLINE unsafeSwap #-} +unsafeSwap = G.unsafeSwap + +-- Filling and copying +-- ------------------- + +-- | Set all elements of the vector to the given value. +set :: (PrimMonad m, Unbox a) => MVector (PrimState m) a -> a -> m () +{-# INLINE set #-} +set = G.set + +-- | Copy a vector. The two vectors must have the same length and may not +-- overlap. +copy :: (PrimMonad m, Unbox a) + => MVector (PrimState m) a -- ^ target + -> MVector (PrimState m) a -- ^ source + -> m () +{-# INLINE copy #-} +copy = G.copy + +-- | Copy a vector. The two vectors must have the same length and may not +-- overlap. This is not checked. +unsafeCopy :: (PrimMonad m, Unbox a) + => MVector (PrimState m) a -- ^ target + -> MVector (PrimState m) a -- ^ source + -> m () +{-# INLINE unsafeCopy #-} +unsafeCopy = G.unsafeCopy + +-- | Move the contents of a vector. The two vectors must have the same +-- length. +-- +-- If the vectors do not overlap, then this is equivalent to 'copy'. +-- Otherwise, the copying is performed as if the source vector were +-- copied to a temporary vector and then the temporary vector was copied +-- to the target vector. +move :: (PrimMonad m, Unbox a) + => MVector (PrimState m) a -> MVector (PrimState m) a -> m () +{-# INLINE move #-} +move = G.move + +-- | Move the contents of a vector. The two vectors must have the same +-- length, but this is not checked. +-- +-- If the vectors do not overlap, then this is equivalent to 'unsafeCopy'. +-- Otherwise, the copying is performed as if the source vector were +-- copied to a temporary vector and then the temporary vector was copied +-- to the target vector. +unsafeMove :: (PrimMonad m, Unbox a) + => MVector (PrimState m) a -- ^ target + -> MVector (PrimState m) a -- ^ source + -> m () +{-# INLINE unsafeMove #-} +unsafeMove = G.unsafeMove + +-- | Compute the next (lexicographically) permutation of given vector in-place. +-- Returns False when input is the last permtuation +nextPermutation :: (PrimMonad m,Ord e,Unbox e) => MVector (PrimState m) e -> m Bool +{-# INLINE nextPermutation #-} +nextPermutation = G.nextPermutation + +#define DEFINE_MUTABLE +#include "unbox-tuple-instances" diff --git a/third_party/bazel/rules_haskell/examples/vector/LICENSE b/third_party/bazel/rules_haskell/examples/vector/LICENSE new file mode 100644 index 000000000000..cafa68efb33e --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2008-2012, Roman Leshchinskiy +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. + diff --git a/third_party/bazel/rules_haskell/examples/vector/README.md b/third_party/bazel/rules_haskell/examples/vector/README.md new file mode 100644 index 000000000000..079dbd0b6b93 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/README.md @@ -0,0 +1,6 @@ +The `vector` package [](https://travis-ci.org/haskell/vector) +==================== + +An efficient implementation of Int-indexed arrays (both mutable and immutable), with a powerful loop optimisation framework. + +See [`vector` on Hackage](http://hackage.haskell.org/package/vector) for more information. diff --git a/third_party/bazel/rules_haskell/examples/vector/Setup.hs b/third_party/bazel/rules_haskell/examples/vector/Setup.hs new file mode 100644 index 000000000000..200a2e51d0b4 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/AwShCC.hs b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/AwShCC.hs new file mode 100644 index 000000000000..404e289fae15 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/AwShCC.hs @@ -0,0 +1,38 @@ +{-# OPTIONS -fno-spec-constr-count #-} +module Algo.AwShCC (awshcc) where + +import Data.Vector.Unboxed as V + +awshcc :: (Int, Vector Int, Vector Int) -> Vector Int +{-# NOINLINE awshcc #-} +awshcc (n, es1, es2) = concomp ds es1' es2' + where + ds = V.enumFromTo 0 (n-1) V.++ V.enumFromTo 0 (n-1) + es1' = es1 V.++ es2 + es2' = es2 V.++ es1 + + starCheck ds = V.backpermute st' gs + where + gs = V.backpermute ds ds + st = V.zipWith (==) ds gs + st' = V.update st . V.filter (not . snd) + $ V.zip gs st + + concomp ds es1 es2 + | V.and (starCheck ds'') = ds'' + | otherwise = concomp (V.backpermute ds'' ds'') es1 es2 + where + ds' = V.update ds + . V.map (\(di, dj, gi) -> (di, dj)) + . V.filter (\(di, dj, gi) -> gi == di && di > dj) + $ V.zip3 (V.backpermute ds es1) + (V.backpermute ds es2) + (V.backpermute ds (V.backpermute ds es1)) + + ds'' = V.update ds' + . V.map (\(di, dj, st) -> (di, dj)) + . V.filter (\(di, dj, st) -> st && di /= dj) + $ V.zip3 (V.backpermute ds' es1) + (V.backpermute ds' es2) + (V.backpermute (starCheck ds') es1) + diff --git a/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/HybCC.hs b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/HybCC.hs new file mode 100644 index 000000000000..876d08f75b62 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/HybCC.hs @@ -0,0 +1,42 @@ +module Algo.HybCC (hybcc) where + +import Data.Vector.Unboxed as V + +hybcc :: (Int, Vector Int, Vector Int) -> Vector Int +{-# NOINLINE hybcc #-} +hybcc (n, e1, e2) = concomp (V.zip e1 e2) n + where + concomp es n + | V.null es = V.enumFromTo 0 (n-1) + | otherwise = V.backpermute ins ins + where + p = shortcut_all + $ V.update (V.enumFromTo 0 (n-1)) es + + (es',i) = compress p es + r = concomp es' (V.length i) + ins = V.update_ p i + $ V.backpermute i r + + enumerate bs = V.prescanl' (+) 0 $ V.map (\b -> if b then 1 else 0) bs + + pack_index bs = V.map fst + . V.filter snd + $ V.zip (V.enumFromTo 0 (V.length bs - 1)) bs + + shortcut_all p | p == pp = pp + | otherwise = shortcut_all pp + where + pp = V.backpermute p p + + compress p es = (new_es, pack_index roots) + where + (e1,e2) = V.unzip es + es' = V.map (\(x,y) -> if x > y then (y,x) else (x,y)) + . V.filter (\(x,y) -> x /= y) + $ V.zip (V.backpermute p e1) (V.backpermute p e2) + + roots = V.zipWith (==) p (V.enumFromTo 0 (V.length p - 1)) + labels = enumerate roots + (e1',e2') = V.unzip es' + new_es = V.zip (V.backpermute labels e1') (V.backpermute labels e2') diff --git a/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Leaffix.hs b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Leaffix.hs new file mode 100644 index 000000000000..40ec517556fe --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Leaffix.hs @@ -0,0 +1,16 @@ +module Algo.Leaffix where + +import Data.Vector.Unboxed as V + +leaffix :: (Vector Int, Vector Int) -> Vector Int +{-# NOINLINE leaffix #-} +leaffix (ls,rs) + = leaffix (V.replicate (V.length ls) 1) ls rs + where + leaffix xs ls rs + = let zs = V.replicate (V.length ls * 2) 0 + vs = V.update_ zs ls xs + sums = V.prescanl' (+) 0 vs + in + V.zipWith (-) (V.backpermute sums ls) (V.backpermute sums rs) + diff --git a/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/ListRank.hs b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/ListRank.hs new file mode 100644 index 000000000000..933bd8eb2ec9 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/ListRank.hs @@ -0,0 +1,21 @@ +module Algo.ListRank +where + +import Data.Vector.Unboxed as V + +listRank :: Int -> Vector Int +{-# NOINLINE listRank #-} +listRank n = pointer_jump xs val + where + xs = 0 `V.cons` V.enumFromTo 0 (n-2) + + val = V.zipWith (\i j -> if i == j then 0 else 1) + xs (V.enumFromTo 0 (n-1)) + + pointer_jump pt val + | npt == pt = val + | otherwise = pointer_jump npt nval + where + npt = V.backpermute pt pt + nval = V.zipWith (+) val (V.backpermute val pt) + diff --git a/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Quickhull.hs b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Quickhull.hs new file mode 100644 index 000000000000..694bea3097a3 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Quickhull.hs @@ -0,0 +1,32 @@ +module Algo.Quickhull (quickhull) where + +import Data.Vector.Unboxed as V + +quickhull :: (Vector Double, Vector Double) -> (Vector Double, Vector Double) +{-# NOINLINE quickhull #-} +quickhull (xs, ys) = xs' `seq` ys' `seq` (xs',ys') + where + (xs',ys') = V.unzip + $ hsplit points pmin pmax V.++ hsplit points pmax pmin + + imin = V.minIndex xs + imax = V.maxIndex xs + + points = V.zip xs ys + pmin = points V.! imin + pmax = points V.! imax + + + hsplit points p1 p2 + | V.length packed < 2 = p1 `V.cons` packed + | otherwise = hsplit packed p1 pm V.++ hsplit packed pm p2 + where + cs = V.map (\p -> cross p p1 p2) points + packed = V.map fst + $ V.filter (\t -> snd t > 0) + $ V.zip points cs + + pm = points V.! V.maxIndex cs + + cross (x,y) (x1,y1) (x2,y2) = (x1-x)*(y2-y) - (y1-y)*(x2-x) + diff --git a/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Rootfix.hs b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Rootfix.hs new file mode 100644 index 000000000000..1b112a801a5e --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Rootfix.hs @@ -0,0 +1,15 @@ +module Algo.Rootfix where + +import Data.Vector.Unboxed as V + +rootfix :: (V.Vector Int, V.Vector Int) -> V.Vector Int +{-# NOINLINE rootfix #-} +rootfix (ls, rs) = rootfix (V.replicate (V.length ls) 1) ls rs + where + rootfix xs ls rs + = let zs = V.replicate (V.length ls * 2) 0 + vs = V.update_ (V.update_ zs ls xs) rs (V.map negate xs) + sums = V.prescanl' (+) 0 vs + in + V.backpermute sums ls + diff --git a/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Spectral.hs b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Spectral.hs new file mode 100644 index 000000000000..811c58269e84 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Spectral.hs @@ -0,0 +1,21 @@ +module Algo.Spectral ( spectral ) where + +import Data.Vector.Unboxed as V + +import Data.Bits + +spectral :: Vector Double -> Vector Double +{-# NOINLINE spectral #-} +spectral us = us `seq` V.map row (V.enumFromTo 0 (n-1)) + where + n = V.length us + + row i = i `seq` V.sum (V.imap (\j u -> eval_A i j * u) us) + + eval_A i j = 1 / fromIntegral r + where + r = u + (i+1) + u = t `shiftR` 1 + t = n * (n+1) + n = i+j + diff --git a/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Tridiag.hs b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Tridiag.hs new file mode 100644 index 000000000000..7668deace132 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Tridiag.hs @@ -0,0 +1,16 @@ +module Algo.Tridiag ( tridiag ) where + +import Data.Vector.Unboxed as V + +tridiag :: (Vector Double, Vector Double, Vector Double, Vector Double) + -> Vector Double +{-# NOINLINE tridiag #-} +tridiag (as,bs,cs,ds) = V.prescanr' (\(c,d) x' -> d - c*x') 0 + $ V.prescanl' modify (0,0) + $ V.zip (V.zip as bs) (V.zip cs ds) + where + modify (c',d') ((a,b),(c,d)) = + let id = 1 / (b - c'*a) + in + id `seq` (c*id, (d-d'*a)*id) + diff --git a/third_party/bazel/rules_haskell/examples/vector/benchmarks/LICENSE b/third_party/bazel/rules_haskell/examples/vector/benchmarks/LICENSE new file mode 100644 index 000000000000..fc213a6ffbfe --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/benchmarks/LICENSE @@ -0,0 +1,30 @@ +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. + diff --git a/third_party/bazel/rules_haskell/examples/vector/benchmarks/Main.hs b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Main.hs new file mode 100644 index 000000000000..65bd297a7552 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Main.hs @@ -0,0 +1,46 @@ +module Main where + +import Criterion.Main + +import Algo.ListRank (listRank) +import Algo.Rootfix (rootfix) +import Algo.Leaffix (leaffix) +import Algo.AwShCC (awshcc) +import Algo.HybCC (hybcc) +import Algo.Quickhull (quickhull) +import Algo.Spectral ( spectral ) +import Algo.Tridiag ( tridiag ) + +import TestData.ParenTree ( parenTree ) +import TestData.Graph ( randomGraph ) +import TestData.Random ( randomVector ) + +import Data.Vector.Unboxed ( Vector ) + +size :: Int +size = 100000 + +main = lparens `seq` rparens `seq` + nodes `seq` edges1 `seq` edges2 `seq` + do + as <- randomVector size :: IO (Vector Double) + bs <- randomVector size :: IO (Vector Double) + cs <- randomVector size :: IO (Vector Double) + ds <- randomVector size :: IO (Vector Double) + sp <- randomVector (floor $ sqrt $ fromIntegral size) + :: IO (Vector Double) + as `seq` bs `seq` cs `seq` ds `seq` sp `seq` + defaultMain [ bench "listRank" $ whnf listRank size + , bench "rootfix" $ whnf rootfix (lparens, rparens) + , bench "leaffix" $ whnf leaffix (lparens, rparens) + , bench "awshcc" $ whnf awshcc (nodes, edges1, edges2) + , bench "hybcc" $ whnf hybcc (nodes, edges1, edges2) + , bench "quickhull" $ whnf quickhull (as,bs) + , bench "spectral" $ whnf spectral sp + , bench "tridiag" $ whnf tridiag (as,bs,cs,ds) + ] + where + (lparens, rparens) = parenTree size + (nodes, edges1, edges2) = randomGraph size + + diff --git a/third_party/bazel/rules_haskell/examples/vector/benchmarks/Setup.hs b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Setup.hs new file mode 100644 index 000000000000..200a2e51d0b4 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/third_party/bazel/rules_haskell/examples/vector/benchmarks/TestData/Graph.hs b/third_party/bazel/rules_haskell/examples/vector/benchmarks/TestData/Graph.hs new file mode 100644 index 000000000000..8b8ca837b890 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/benchmarks/TestData/Graph.hs @@ -0,0 +1,45 @@ +module TestData.Graph ( randomGraph ) +where + +import System.Random.MWC +import qualified Data.Array.ST as STA +import qualified Data.Vector.Unboxed as V + +import Control.Monad.ST ( ST, runST ) + +randomGraph :: Int -> (Int, V.Vector Int, V.Vector Int) +randomGraph e + = runST ( + do + g <- create + arr <- STA.newArray (0,n-1) [] :: ST s (STA.STArray s Int [Int]) + addRandomEdges n g arr e + xs <- STA.getAssocs arr + let (as,bs) = unzip [(i,j) | (i,js) <- xs, j <- js ] + return (n, V.fromListN (length as) as, V.fromListN (length bs) bs) + ) + where + n = e `div` 10 + +addRandomEdges :: Int -> Gen s -> STA.STArray s Int [Int] -> Int -> ST s () +addRandomEdges n g arr = fill + where + fill 0 = return () + fill e + = do + m <- random_index + n <- random_index + let lo = min m n + hi = max m n + ns <- STA.readArray arr lo + if lo == hi || hi `elem` ns + then fill e + else do + STA.writeArray arr lo (hi:ns) + fill (e-1) + + random_index = do + x <- uniform g + let i = floor ((x::Double) * toEnum n) + if i == n then return 0 else return i + diff --git a/third_party/bazel/rules_haskell/examples/vector/benchmarks/TestData/ParenTree.hs b/third_party/bazel/rules_haskell/examples/vector/benchmarks/TestData/ParenTree.hs new file mode 100644 index 000000000000..4aeb750954a9 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/benchmarks/TestData/ParenTree.hs @@ -0,0 +1,20 @@ +module TestData.ParenTree where + +import qualified Data.Vector.Unboxed as V + +parenTree :: Int -> (V.Vector Int, V.Vector Int) +parenTree n = case go ([],[]) 0 (if even n then n else n+1) of + (ls,rs) -> (V.fromListN (length ls) (reverse ls), + V.fromListN (length rs) (reverse rs)) + where + go (ls,rs) i j = case j-i of + 0 -> (ls,rs) + 2 -> (ls',rs') + d -> let k = ((d-2) `div` 4) * 2 + in + go (go (ls',rs') (i+1) (i+1+k)) (i+1+k) (j-1) + where + ls' = i:ls + rs' = j-1:rs + + diff --git a/third_party/bazel/rules_haskell/examples/vector/benchmarks/TestData/Random.hs b/third_party/bazel/rules_haskell/examples/vector/benchmarks/TestData/Random.hs new file mode 100644 index 000000000000..f9b741fb97ae --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/benchmarks/TestData/Random.hs @@ -0,0 +1,16 @@ +module TestData.Random ( randomVector ) where + +import qualified Data.Vector.Unboxed as V + +import System.Random.MWC +import Control.Monad.ST ( runST ) + +randomVector :: (Variate a, V.Unbox a) => Int -> IO (V.Vector a) +randomVector n = withSystemRandom $ \g -> + do + xs <- sequence $ replicate n $ uniform g + io (return $ V.fromListN n xs) + where + io :: IO a -> IO a + io = id + diff --git a/third_party/bazel/rules_haskell/examples/vector/benchmarks/vector-benchmarks.cabal b/third_party/bazel/rules_haskell/examples/vector/benchmarks/vector-benchmarks.cabal new file mode 100644 index 000000000000..3e825c0fa4e6 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/benchmarks/vector-benchmarks.cabal @@ -0,0 +1,37 @@ +Name: vector-benchmarks +Version: 0.10.9 +License: BSD3 +License-File: LICENSE +Author: Roman Leshchinskiy <rl@cse.unsw.edu.au> +Maintainer: Roman Leshchinskiy <rl@cse.unsw.edu.au> +Copyright: (c) Roman Leshchinskiy 2010-2012 +Cabal-Version: >= 1.2 +Build-Type: Simple + +Executable algorithms + Main-Is: Main.hs + + Build-Depends: base >= 2 && < 5, array, + criterion >= 0.5 && < 0.7, + mwc-random >= 0.5 && < 0.13, + vector == 0.10.9 + + if impl(ghc<6.13) + Ghc-Options: -finline-if-enough-args -fno-method-sharing + + Ghc-Options: -O2 + + Other-Modules: + Algo.ListRank + Algo.Rootfix + Algo.Leaffix + Algo.AwShCC + Algo.HybCC + Algo.Quickhull + Algo.Spectral + Algo.Tridiag + + TestData.ParenTree + TestData.Graph + TestData.Random + diff --git a/third_party/bazel/rules_haskell/examples/vector/changelog b/third_party/bazel/rules_haskell/examples/vector/changelog new file mode 100644 index 000000000000..3d824b74d123 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/changelog @@ -0,0 +1,75 @@ +Changes in version 0.12.0.1 + + * Make sure `length` can be inlined + * Include modules that test-suites depend on in other-modules + +Changes in version 0.12.0.0 + + * Documentation fixes/additions + * New functions: createT, iscanl/r, iterateNM, unfoldrM, uniq + * New instances for various vector types: Semigroup, MonadZip + * Made `Storable` vectors respect memory alignment + * Changed some macros to ConstraintKinds + - Dropped compatibility with old GHCs to support this + * Add `Eq1`, `Ord1`, `Show1`, and `Read1` `Vector` instances, and related + helper functions. + * Relax context for `Unbox (Complex a)`. + +Changes in version 0.11.0.0 + + * Define `Applicative` instances for `Data.Vector.Fusion.Util.{Box,Id}` + * Define non-bottom `fail` for `instance Monad Vector` + * New generalized stream fusion framework + * Various safety fixes + - Various overflows due to vector size have been eliminated + - Memory is initialized on creation of unboxed vectors + * Changes to SPEC usage to allow building under more conditions + +Changes in version 0.10.12.3 + + * Allow building with `primtive-0.6` + +Changes in version 0.10.12.2 + + * Add support for `deepseq-1.4.0.0` + +Changes in version 0.10.12.1 + + * Fixed compilation on non-head GHCs + +Changes in version 0.10.12.0 + + * Export MVector constructor from Data.Vector.Primitive to match Vector's + (which was already exported). + + * Fix building on GHC 7.9 by adding Applicative instances for Id and Box + +Changes in version 0.10.11.0 + + * Support OverloadedLists for boxed Vector in GHC >= 7.8 + +Changes in version 0.10.10.0 + + * Minor version bump to rectify PVP violation occured in 0.10.9.3 release + +Changes in version 0.10.9.3 (deprecated) + + * Add support for OverloadedLists in GHC >= 7.8 + +Changes in version 0.10.9.2 + + * Fix compilation with GHC 7.9 + +Changes in version 0.10.9.1 + + * Implement poly-kinded Typeable + +Changes in version 0.10.0.1 + + * Require `primitive` to include workaround for a GHC array copying bug + +Changes in version 0.10 + + * `NFData` instances + * More efficient block fills + * Safe Haskell support removed diff --git a/third_party/bazel/rules_haskell/examples/vector/include/vector.h b/third_party/bazel/rules_haskell/examples/vector/include/vector.h new file mode 100644 index 000000000000..1568bb290633 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/include/vector.h @@ -0,0 +1,20 @@ +#define PHASE_FUSED [1] +#define PHASE_INNER [0] + +#define INLINE_FUSED INLINE PHASE_FUSED +#define INLINE_INNER INLINE PHASE_INNER + +#ifndef NOT_VECTOR_MODULE +import qualified Data.Vector.Internal.Check as Ck +#endif + +#define ERROR (Ck.error __FILE__ __LINE__) +#define INTERNAL_ERROR (Ck.internalError __FILE__ __LINE__) + +#define CHECK(f) (Ck.f __FILE__ __LINE__) +#define BOUNDS_CHECK(f) (CHECK(f) Ck.Bounds) +#define UNSAFE_CHECK(f) (CHECK(f) Ck.Unsafe) +#define INTERNAL_CHECK(f) (CHECK(f) Ck.Internal) + +#define PHASE_STREAM Please use "PHASE_FUSED" instead +#define INLINE_STREAM Please use "INLINE_FUSED" instead diff --git a/third_party/bazel/rules_haskell/examples/vector/internal/GenUnboxTuple.hs b/third_party/bazel/rules_haskell/examples/vector/internal/GenUnboxTuple.hs new file mode 100644 index 000000000000..8debff23a975 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/internal/GenUnboxTuple.hs @@ -0,0 +1,239 @@ +{-# LANGUAGE ParallelListComp #-} +module Main where + +import Text.PrettyPrint + +import System.Environment ( getArgs ) + +main = do + [s] <- getArgs + let n = read s + mapM_ (putStrLn . render . generate) [2..n] + +generate :: Int -> Doc +generate n = + vcat [ text "#ifdef DEFINE_INSTANCES" + , data_instance "MVector s" "MV" + , data_instance "Vector" "V" + , class_instance "Unbox" + , class_instance "M.MVector MVector" <+> text "where" + , nest 2 $ vcat $ map method methods_MVector + , class_instance "G.Vector Vector" <+> text "where" + , nest 2 $ vcat $ map method methods_Vector + , text "#endif" + , text "#ifdef DEFINE_MUTABLE" + , define_zip "MVector s" "MV" + , define_unzip "MVector s" "MV" + , text "#endif" + , text "#ifdef DEFINE_IMMUTABLE" + , define_zip "Vector" "V" + , define_zip_rule + , define_unzip "Vector" "V" + , text "#endif" + ] + + where + vars = map (\c -> text ['_',c]) $ take n ['a'..] + varss = map (<> char 's') vars + tuple xs = parens $ hsep $ punctuate comma xs + vtuple xs = parens $ sep $ punctuate comma xs + con s = text s <> char '_' <> int n + var c = text ('_' : c : "_") + + data_instance ty c + = hang (hsep [text "data instance", text ty, tuple vars]) + 4 + (hsep [char '=', con c, text "{-# UNPACK #-} !Int" + , vcat $ map (\v -> char '!' <> parens (text ty <+> v)) vars]) + + class_instance cls + = text "instance" <+> vtuple [text "Unbox" <+> v | v <- vars] + <+> text "=>" <+> text cls <+> tuple vars + + + define_zip ty c + = sep [text "-- | /O(1)/ Zip" <+> int n <+> text "vectors" + ,name <+> text "::" + <+> vtuple [text "Unbox" <+> v | v <- vars] + <+> text "=>" + <+> sep (punctuate (text " ->") [text ty <+> v | v <- vars]) + <+> text "->" + <+> text ty <+> tuple vars + ,text "{-# INLINE_FUSED" <+> name <+> text "#-}" + ,name <+> sep varss + <+> text "=" + <+> con c + <+> text "len" + <+> sep [parens $ text "unsafeSlice" + <+> char '0' + <+> text "len" + <+> vs | vs <- varss] + ,nest 2 $ hang (text "where") + 2 + $ text "len =" + <+> sep (punctuate (text " `delayed_min`") + [text "length" <+> vs | vs <- varss]) + ] + where + name | n == 2 = text "zip" + | otherwise = text "zip" <> int n + + define_zip_rule + = hang (text "{-# RULES" <+> text "\"stream/" <> name "zip" + <> text " [Vector.Unboxed]\" forall" <+> sep varss <+> char '.') + 2 $ + text "G.stream" <+> parens (name "zip" <+> sep varss) + <+> char '=' + <+> text "Bundle." <> name "zipWith" <+> tuple (replicate n empty) + <+> sep [parens $ text "G.stream" <+> vs | vs <- varss] + $$ text "#-}" + where + name s | n == 2 = text s + | otherwise = text s <> int n + + + define_unzip ty c + = sep [text "-- | /O(1)/ Unzip" <+> int n <+> text "vectors" + ,name <+> text "::" + <+> vtuple [text "Unbox" <+> v | v <- vars] + <+> text "=>" + <+> text ty <+> tuple vars + <+> text "->" <+> vtuple [text ty <+> v | v <- vars] + ,text "{-# INLINE" <+> name <+> text "#-}" + ,name <+> pat c <+> text "=" + <+> vtuple varss + ] + where + name | n == 2 = text "unzip" + | otherwise = text "unzip" <> int n + + pat c = parens $ con c <+> var 'n' <+> sep varss + patn c n = parens $ con c <+> (var 'n' <> int n) + <+> sep [v <> int n | v <- varss] + + qM s = text "M." <> text s + qG s = text "G." <> text s + + gen_length c _ = (pat c, var 'n') + + gen_unsafeSlice mod c rec + = (var 'i' <+> var 'm' <+> pat c, + con c <+> var 'm' + <+> vcat [parens + $ text mod <> char '.' <> text rec + <+> var 'i' <+> var 'm' <+> vs + | vs <- varss]) + + + gen_overlaps rec = (patn "MV" 1 <+> patn "MV" 2, + vcat $ r : [text "||" <+> r | r <- rs]) + where + r : rs = [qM rec <+> v <> char '1' <+> v <> char '2' | v <- varss] + + gen_unsafeNew rec + = (var 'n', + mk_do [v <+> text "<-" <+> qM rec <+> var 'n' | v <- varss] + $ text "return $" <+> con "MV" <+> var 'n' <+> sep varss) + + gen_unsafeReplicate rec + = (var 'n' <+> tuple vars, + mk_do [vs <+> text "<-" <+> qM rec <+> var 'n' <+> v + | v <- vars | vs <- varss] + $ text "return $" <+> con "MV" <+> var 'n' <+> sep varss) + + gen_unsafeRead rec + = (pat "MV" <+> var 'i', + mk_do [v <+> text "<-" <+> qM rec <+> vs <+> var 'i' | v <- vars + | vs <- varss] + $ text "return" <+> tuple vars) + + gen_unsafeWrite rec + = (pat "MV" <+> var 'i' <+> tuple vars, + mk_do [qM rec <+> vs <+> var 'i' <+> v | v <- vars | vs <- varss] + empty) + + gen_clear rec + = (pat "MV", mk_do [qM rec <+> vs | vs <- varss] empty) + + gen_set rec + = (pat "MV" <+> tuple vars, + mk_do [qM rec <+> vs <+> v | vs <- varss | v <- vars] empty) + + gen_unsafeCopy c q rec + = (patn "MV" 1 <+> patn c 2, + mk_do [q rec <+> vs <> char '1' <+> vs <> char '2' | vs <- varss] + empty) + + gen_unsafeMove rec + = (patn "MV" 1 <+> patn "MV" 2, + mk_do [qM rec <+> vs <> char '1' <+> vs <> char '2' | vs <- varss] + empty) + + gen_unsafeGrow rec + = (pat "MV" <+> var 'm', + mk_do [vs <> char '\'' <+> text "<-" + <+> qM rec <+> vs <+> var 'm' | vs <- varss] + $ text "return $" <+> con "MV" + <+> parens (var 'm' <> char '+' <> var 'n') + <+> sep (map (<> char '\'') varss)) + + gen_initialize rec + = (pat "MV", mk_do [qM rec <+> vs | vs <- varss] empty) + + gen_unsafeFreeze rec + = (pat "MV", + mk_do [vs <> char '\'' <+> text "<-" <+> qG rec <+> vs | vs <- varss] + $ text "return $" <+> con "V" <+> var 'n' + <+> sep [vs <> char '\'' | vs <- varss]) + + gen_unsafeThaw rec + = (pat "V", + mk_do [vs <> char '\'' <+> text "<-" <+> qG rec <+> vs | vs <- varss] + $ text "return $" <+> con "MV" <+> var 'n' + <+> sep [vs <> char '\'' | vs <- varss]) + + gen_basicUnsafeIndexM rec + = (pat "V" <+> var 'i', + mk_do [v <+> text "<-" <+> qG rec <+> vs <+> var 'i' + | vs <- varss | v <- vars] + $ text "return" <+> tuple vars) + + gen_elemseq rec + = (char '_' <+> tuple vars, + vcat $ r : [char '.' <+> r | r <- rs]) + where + r : rs = [qG rec <+> parens (text "undefined :: Vector" <+> v) + <+> v | v <- vars] + + mk_do cmds ret = hang (text "do") + 2 + $ vcat $ cmds ++ [ret] + + method (s, f) = case f s of + (p,e) -> text "{-# INLINE" <+> text s <+> text " #-}" + $$ hang (text s <+> p) + 4 + (char '=' <+> e) + + + methods_MVector = [("basicLength", gen_length "MV") + ,("basicUnsafeSlice", gen_unsafeSlice "M" "MV") + ,("basicOverlaps", gen_overlaps) + ,("basicUnsafeNew", gen_unsafeNew) + ,("basicUnsafeReplicate", gen_unsafeReplicate) + ,("basicUnsafeRead", gen_unsafeRead) + ,("basicUnsafeWrite", gen_unsafeWrite) + ,("basicClear", gen_clear) + ,("basicSet", gen_set) + ,("basicUnsafeCopy", gen_unsafeCopy "MV" qM) + ,("basicUnsafeMove", gen_unsafeMove) + ,("basicUnsafeGrow", gen_unsafeGrow) + ,("basicInitialize", gen_initialize)] + + methods_Vector = [("basicUnsafeFreeze", gen_unsafeFreeze) + ,("basicUnsafeThaw", gen_unsafeThaw) + ,("basicLength", gen_length "V") + ,("basicUnsafeSlice", gen_unsafeSlice "G" "V") + ,("basicUnsafeIndexM", gen_basicUnsafeIndexM) + ,("basicUnsafeCopy", gen_unsafeCopy "V" qG) + ,("elemseq", gen_elemseq)] diff --git a/third_party/bazel/rules_haskell/examples/vector/internal/unbox-tuple-instances b/third_party/bazel/rules_haskell/examples/vector/internal/unbox-tuple-instances new file mode 100644 index 000000000000..6fb88d4a4047 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/internal/unbox-tuple-instances @@ -0,0 +1,1134 @@ +#ifdef DEFINE_INSTANCES +data instance MVector s (a, b) + = MV_2 {-# UNPACK #-} !Int !(MVector s a) + !(MVector s b) +data instance Vector (a, b) + = V_2 {-# UNPACK #-} !Int !(Vector a) + !(Vector b) +instance (Unbox a, Unbox b) => Unbox (a, b) +instance (Unbox a, Unbox b) => M.MVector MVector (a, b) where + {-# INLINE basicLength #-} + basicLength (MV_2 n_ _ _) = n_ + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice i_ m_ (MV_2 _ as bs) + = MV_2 m_ (M.basicUnsafeSlice i_ m_ as) + (M.basicUnsafeSlice i_ m_ bs) + {-# INLINE basicOverlaps #-} + basicOverlaps (MV_2 _ as1 bs1) (MV_2 _ as2 bs2) + = M.basicOverlaps as1 as2 + || M.basicOverlaps bs1 bs2 + {-# INLINE basicUnsafeNew #-} + basicUnsafeNew n_ + = do + as <- M.basicUnsafeNew n_ + bs <- M.basicUnsafeNew n_ + return $ MV_2 n_ as bs + {-# INLINE basicInitialize #-} + basicInitialize (MV_2 _ as bs) + = do + M.basicInitialize as + M.basicInitialize bs + {-# INLINE basicUnsafeReplicate #-} + basicUnsafeReplicate n_ (a, b) + = do + as <- M.basicUnsafeReplicate n_ a + bs <- M.basicUnsafeReplicate n_ b + return $ MV_2 n_ as bs + {-# INLINE basicUnsafeRead #-} + basicUnsafeRead (MV_2 _ as bs) i_ + = do + a <- M.basicUnsafeRead as i_ + b <- M.basicUnsafeRead bs i_ + return (a, b) + {-# INLINE basicUnsafeWrite #-} + basicUnsafeWrite (MV_2 _ as bs) i_ (a, b) + = do + M.basicUnsafeWrite as i_ a + M.basicUnsafeWrite bs i_ b + {-# INLINE basicClear #-} + basicClear (MV_2 _ as bs) + = do + M.basicClear as + M.basicClear bs + {-# INLINE basicSet #-} + basicSet (MV_2 _ as bs) (a, b) + = do + M.basicSet as a + M.basicSet bs b + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy (MV_2 _ as1 bs1) (MV_2 _ as2 bs2) + = do + M.basicUnsafeCopy as1 as2 + M.basicUnsafeCopy bs1 bs2 + {-# INLINE basicUnsafeMove #-} + basicUnsafeMove (MV_2 _ as1 bs1) (MV_2 _ as2 bs2) + = do + M.basicUnsafeMove as1 as2 + M.basicUnsafeMove bs1 bs2 + {-# INLINE basicUnsafeGrow #-} + basicUnsafeGrow (MV_2 n_ as bs) m_ + = do + as' <- M.basicUnsafeGrow as m_ + bs' <- M.basicUnsafeGrow bs m_ + return $ MV_2 (m_+n_) as' bs' +instance (Unbox a, Unbox b) => G.Vector Vector (a, b) where + {-# INLINE basicUnsafeFreeze #-} + basicUnsafeFreeze (MV_2 n_ as bs) + = do + as' <- G.basicUnsafeFreeze as + bs' <- G.basicUnsafeFreeze bs + return $ V_2 n_ as' bs' + {-# INLINE basicUnsafeThaw #-} + basicUnsafeThaw (V_2 n_ as bs) + = do + as' <- G.basicUnsafeThaw as + bs' <- G.basicUnsafeThaw bs + return $ MV_2 n_ as' bs' + {-# INLINE basicLength #-} + basicLength (V_2 n_ _ _) = n_ + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice i_ m_ (V_2 _ as bs) + = V_2 m_ (G.basicUnsafeSlice i_ m_ as) + (G.basicUnsafeSlice i_ m_ bs) + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeIndexM (V_2 _ as bs) i_ + = do + a <- G.basicUnsafeIndexM as i_ + b <- G.basicUnsafeIndexM bs i_ + return (a, b) + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy (MV_2 _ as1 bs1) (V_2 _ as2 bs2) + = do + G.basicUnsafeCopy as1 as2 + G.basicUnsafeCopy bs1 bs2 + {-# INLINE elemseq #-} + elemseq _ (a, b) + = G.elemseq (undefined :: Vector a) a + . G.elemseq (undefined :: Vector b) b +#endif +#ifdef DEFINE_MUTABLE +-- | /O(1)/ Zip 2 vectors +zip :: (Unbox a, Unbox b) => MVector s a -> + MVector s b -> MVector s (a, b) +{-# INLINE_FUSED zip #-} +zip as bs = MV_2 len (unsafeSlice 0 len as) (unsafeSlice 0 len bs) + where len = length as `delayed_min` length bs +-- | /O(1)/ Unzip 2 vectors +unzip :: (Unbox a, Unbox b) => MVector s (a, b) -> (MVector s a, + MVector s b) +{-# INLINE unzip #-} +unzip (MV_2 _ as bs) = (as, bs) +#endif +#ifdef DEFINE_IMMUTABLE +-- | /O(1)/ Zip 2 vectors +zip :: (Unbox a, Unbox b) => Vector a -> Vector b -> Vector (a, b) +{-# INLINE_FUSED zip #-} +zip as bs = V_2 len (unsafeSlice 0 len as) (unsafeSlice 0 len bs) + where len = length as `delayed_min` length bs +{-# RULES "stream/zip [Vector.Unboxed]" forall as bs . + G.stream (zip as bs) = Bundle.zipWith (,) (G.stream as) + (G.stream bs) #-} + +-- | /O(1)/ Unzip 2 vectors +unzip :: (Unbox a, Unbox b) => Vector (a, b) -> (Vector a, + Vector b) +{-# INLINE unzip #-} +unzip (V_2 _ as bs) = (as, bs) +#endif +#ifdef DEFINE_INSTANCES +data instance MVector s (a, b, c) + = MV_3 {-# UNPACK #-} !Int !(MVector s a) + !(MVector s b) + !(MVector s c) +data instance Vector (a, b, c) + = V_3 {-# UNPACK #-} !Int !(Vector a) + !(Vector b) + !(Vector c) +instance (Unbox a, Unbox b, Unbox c) => Unbox (a, b, c) +instance (Unbox a, + Unbox b, + Unbox c) => M.MVector MVector (a, b, c) where + {-# INLINE basicLength #-} + basicLength (MV_3 n_ _ _ _) = n_ + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice i_ m_ (MV_3 _ as bs cs) + = MV_3 m_ (M.basicUnsafeSlice i_ m_ as) + (M.basicUnsafeSlice i_ m_ bs) + (M.basicUnsafeSlice i_ m_ cs) + {-# INLINE basicOverlaps #-} + basicOverlaps (MV_3 _ as1 bs1 cs1) (MV_3 _ as2 bs2 cs2) + = M.basicOverlaps as1 as2 + || M.basicOverlaps bs1 bs2 + || M.basicOverlaps cs1 cs2 + {-# INLINE basicUnsafeNew #-} + basicUnsafeNew n_ + = do + as <- M.basicUnsafeNew n_ + bs <- M.basicUnsafeNew n_ + cs <- M.basicUnsafeNew n_ + return $ MV_3 n_ as bs cs + {-# INLINE basicInitialize #-} + basicInitialize (MV_3 _ as bs cs) + = do + M.basicInitialize as + M.basicInitialize bs + M.basicInitialize cs + {-# INLINE basicUnsafeReplicate #-} + basicUnsafeReplicate n_ (a, b, c) + = do + as <- M.basicUnsafeReplicate n_ a + bs <- M.basicUnsafeReplicate n_ b + cs <- M.basicUnsafeReplicate n_ c + return $ MV_3 n_ as bs cs + {-# INLINE basicUnsafeRead #-} + basicUnsafeRead (MV_3 _ as bs cs) i_ + = do + a <- M.basicUnsafeRead as i_ + b <- M.basicUnsafeRead bs i_ + c <- M.basicUnsafeRead cs i_ + return (a, b, c) + {-# INLINE basicUnsafeWrite #-} + basicUnsafeWrite (MV_3 _ as bs cs) i_ (a, b, c) + = do + M.basicUnsafeWrite as i_ a + M.basicUnsafeWrite bs i_ b + M.basicUnsafeWrite cs i_ c + {-# INLINE basicClear #-} + basicClear (MV_3 _ as bs cs) + = do + M.basicClear as + M.basicClear bs + M.basicClear cs + {-# INLINE basicSet #-} + basicSet (MV_3 _ as bs cs) (a, b, c) + = do + M.basicSet as a + M.basicSet bs b + M.basicSet cs c + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy (MV_3 _ as1 bs1 cs1) (MV_3 _ as2 bs2 cs2) + = do + M.basicUnsafeCopy as1 as2 + M.basicUnsafeCopy bs1 bs2 + M.basicUnsafeCopy cs1 cs2 + {-# INLINE basicUnsafeMove #-} + basicUnsafeMove (MV_3 _ as1 bs1 cs1) (MV_3 _ as2 bs2 cs2) + = do + M.basicUnsafeMove as1 as2 + M.basicUnsafeMove bs1 bs2 + M.basicUnsafeMove cs1 cs2 + {-# INLINE basicUnsafeGrow #-} + basicUnsafeGrow (MV_3 n_ as bs cs) m_ + = do + as' <- M.basicUnsafeGrow as m_ + bs' <- M.basicUnsafeGrow bs m_ + cs' <- M.basicUnsafeGrow cs m_ + return $ MV_3 (m_+n_) as' bs' cs' +instance (Unbox a, + Unbox b, + Unbox c) => G.Vector Vector (a, b, c) where + {-# INLINE basicUnsafeFreeze #-} + basicUnsafeFreeze (MV_3 n_ as bs cs) + = do + as' <- G.basicUnsafeFreeze as + bs' <- G.basicUnsafeFreeze bs + cs' <- G.basicUnsafeFreeze cs + return $ V_3 n_ as' bs' cs' + {-# INLINE basicUnsafeThaw #-} + basicUnsafeThaw (V_3 n_ as bs cs) + = do + as' <- G.basicUnsafeThaw as + bs' <- G.basicUnsafeThaw bs + cs' <- G.basicUnsafeThaw cs + return $ MV_3 n_ as' bs' cs' + {-# INLINE basicLength #-} + basicLength (V_3 n_ _ _ _) = n_ + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice i_ m_ (V_3 _ as bs cs) + = V_3 m_ (G.basicUnsafeSlice i_ m_ as) + (G.basicUnsafeSlice i_ m_ bs) + (G.basicUnsafeSlice i_ m_ cs) + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeIndexM (V_3 _ as bs cs) i_ + = do + a <- G.basicUnsafeIndexM as i_ + b <- G.basicUnsafeIndexM bs i_ + c <- G.basicUnsafeIndexM cs i_ + return (a, b, c) + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy (MV_3 _ as1 bs1 cs1) (V_3 _ as2 bs2 cs2) + = do + G.basicUnsafeCopy as1 as2 + G.basicUnsafeCopy bs1 bs2 + G.basicUnsafeCopy cs1 cs2 + {-# INLINE elemseq #-} + elemseq _ (a, b, c) + = G.elemseq (undefined :: Vector a) a + . G.elemseq (undefined :: Vector b) b + . G.elemseq (undefined :: Vector c) c +#endif +#ifdef DEFINE_MUTABLE +-- | /O(1)/ Zip 3 vectors +zip3 :: (Unbox a, Unbox b, Unbox c) => MVector s a -> + MVector s b -> + MVector s c -> MVector s (a, b, c) +{-# INLINE_FUSED zip3 #-} +zip3 as bs cs = MV_3 len (unsafeSlice 0 len as) + (unsafeSlice 0 len bs) + (unsafeSlice 0 len cs) + where + len = length as `delayed_min` length bs `delayed_min` length cs +-- | /O(1)/ Unzip 3 vectors +unzip3 :: (Unbox a, + Unbox b, + Unbox c) => MVector s (a, b, c) -> (MVector s a, + MVector s b, + MVector s c) +{-# INLINE unzip3 #-} +unzip3 (MV_3 _ as bs cs) = (as, bs, cs) +#endif +#ifdef DEFINE_IMMUTABLE +-- | /O(1)/ Zip 3 vectors +zip3 :: (Unbox a, Unbox b, Unbox c) => Vector a -> + Vector b -> + Vector c -> Vector (a, b, c) +{-# INLINE_FUSED zip3 #-} +zip3 as bs cs = V_3 len (unsafeSlice 0 len as) + (unsafeSlice 0 len bs) + (unsafeSlice 0 len cs) + where + len = length as `delayed_min` length bs `delayed_min` length cs +{-# RULES "stream/zip3 [Vector.Unboxed]" forall as bs cs . + G.stream (zip3 as bs cs) = Bundle.zipWith3 (, ,) (G.stream as) + (G.stream bs) + (G.stream cs) #-} + +-- | /O(1)/ Unzip 3 vectors +unzip3 :: (Unbox a, + Unbox b, + Unbox c) => Vector (a, b, c) -> (Vector a, Vector b, Vector c) +{-# INLINE unzip3 #-} +unzip3 (V_3 _ as bs cs) = (as, bs, cs) +#endif +#ifdef DEFINE_INSTANCES +data instance MVector s (a, b, c, d) + = MV_4 {-# UNPACK #-} !Int !(MVector s a) + !(MVector s b) + !(MVector s c) + !(MVector s d) +data instance Vector (a, b, c, d) + = V_4 {-# UNPACK #-} !Int !(Vector a) + !(Vector b) + !(Vector c) + !(Vector d) +instance (Unbox a, Unbox b, Unbox c, Unbox d) => Unbox (a, b, c, d) +instance (Unbox a, + Unbox b, + Unbox c, + Unbox d) => M.MVector MVector (a, b, c, d) where + {-# INLINE basicLength #-} + basicLength (MV_4 n_ _ _ _ _) = n_ + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice i_ m_ (MV_4 _ as bs cs ds) + = MV_4 m_ (M.basicUnsafeSlice i_ m_ as) + (M.basicUnsafeSlice i_ m_ bs) + (M.basicUnsafeSlice i_ m_ cs) + (M.basicUnsafeSlice i_ m_ ds) + {-# INLINE basicOverlaps #-} + basicOverlaps (MV_4 _ as1 bs1 cs1 ds1) (MV_4 _ as2 bs2 cs2 ds2) + = M.basicOverlaps as1 as2 + || M.basicOverlaps bs1 bs2 + || M.basicOverlaps cs1 cs2 + || M.basicOverlaps ds1 ds2 + {-# INLINE basicUnsafeNew #-} + basicUnsafeNew n_ + = do + as <- M.basicUnsafeNew n_ + bs <- M.basicUnsafeNew n_ + cs <- M.basicUnsafeNew n_ + ds <- M.basicUnsafeNew n_ + return $ MV_4 n_ as bs cs ds + {-# INLINE basicInitialize #-} + basicInitialize (MV_4 _ as bs cs ds) + = do + M.basicInitialize as + M.basicInitialize bs + M.basicInitialize cs + M.basicInitialize ds + {-# INLINE basicUnsafeReplicate #-} + basicUnsafeReplicate n_ (a, b, c, d) + = do + as <- M.basicUnsafeReplicate n_ a + bs <- M.basicUnsafeReplicate n_ b + cs <- M.basicUnsafeReplicate n_ c + ds <- M.basicUnsafeReplicate n_ d + return $ MV_4 n_ as bs cs ds + {-# INLINE basicUnsafeRead #-} + basicUnsafeRead (MV_4 _ as bs cs ds) i_ + = do + a <- M.basicUnsafeRead as i_ + b <- M.basicUnsafeRead bs i_ + c <- M.basicUnsafeRead cs i_ + d <- M.basicUnsafeRead ds i_ + return (a, b, c, d) + {-# INLINE basicUnsafeWrite #-} + basicUnsafeWrite (MV_4 _ as bs cs ds) i_ (a, b, c, d) + = do + M.basicUnsafeWrite as i_ a + M.basicUnsafeWrite bs i_ b + M.basicUnsafeWrite cs i_ c + M.basicUnsafeWrite ds i_ d + {-# INLINE basicClear #-} + basicClear (MV_4 _ as bs cs ds) + = do + M.basicClear as + M.basicClear bs + M.basicClear cs + M.basicClear ds + {-# INLINE basicSet #-} + basicSet (MV_4 _ as bs cs ds) (a, b, c, d) + = do + M.basicSet as a + M.basicSet bs b + M.basicSet cs c + M.basicSet ds d + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy (MV_4 _ as1 bs1 cs1 ds1) (MV_4 _ as2 + bs2 + cs2 + ds2) + = do + M.basicUnsafeCopy as1 as2 + M.basicUnsafeCopy bs1 bs2 + M.basicUnsafeCopy cs1 cs2 + M.basicUnsafeCopy ds1 ds2 + {-# INLINE basicUnsafeMove #-} + basicUnsafeMove (MV_4 _ as1 bs1 cs1 ds1) (MV_4 _ as2 + bs2 + cs2 + ds2) + = do + M.basicUnsafeMove as1 as2 + M.basicUnsafeMove bs1 bs2 + M.basicUnsafeMove cs1 cs2 + M.basicUnsafeMove ds1 ds2 + {-# INLINE basicUnsafeGrow #-} + basicUnsafeGrow (MV_4 n_ as bs cs ds) m_ + = do + as' <- M.basicUnsafeGrow as m_ + bs' <- M.basicUnsafeGrow bs m_ + cs' <- M.basicUnsafeGrow cs m_ + ds' <- M.basicUnsafeGrow ds m_ + return $ MV_4 (m_+n_) as' bs' cs' ds' +instance (Unbox a, + Unbox b, + Unbox c, + Unbox d) => G.Vector Vector (a, b, c, d) where + {-# INLINE basicUnsafeFreeze #-} + basicUnsafeFreeze (MV_4 n_ as bs cs ds) + = do + as' <- G.basicUnsafeFreeze as + bs' <- G.basicUnsafeFreeze bs + cs' <- G.basicUnsafeFreeze cs + ds' <- G.basicUnsafeFreeze ds + return $ V_4 n_ as' bs' cs' ds' + {-# INLINE basicUnsafeThaw #-} + basicUnsafeThaw (V_4 n_ as bs cs ds) + = do + as' <- G.basicUnsafeThaw as + bs' <- G.basicUnsafeThaw bs + cs' <- G.basicUnsafeThaw cs + ds' <- G.basicUnsafeThaw ds + return $ MV_4 n_ as' bs' cs' ds' + {-# INLINE basicLength #-} + basicLength (V_4 n_ _ _ _ _) = n_ + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice i_ m_ (V_4 _ as bs cs ds) + = V_4 m_ (G.basicUnsafeSlice i_ m_ as) + (G.basicUnsafeSlice i_ m_ bs) + (G.basicUnsafeSlice i_ m_ cs) + (G.basicUnsafeSlice i_ m_ ds) + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeIndexM (V_4 _ as bs cs ds) i_ + = do + a <- G.basicUnsafeIndexM as i_ + b <- G.basicUnsafeIndexM bs i_ + c <- G.basicUnsafeIndexM cs i_ + d <- G.basicUnsafeIndexM ds i_ + return (a, b, c, d) + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy (MV_4 _ as1 bs1 cs1 ds1) (V_4 _ as2 + bs2 + cs2 + ds2) + = do + G.basicUnsafeCopy as1 as2 + G.basicUnsafeCopy bs1 bs2 + G.basicUnsafeCopy cs1 cs2 + G.basicUnsafeCopy ds1 ds2 + {-# INLINE elemseq #-} + elemseq _ (a, b, c, d) + = G.elemseq (undefined :: Vector a) a + . G.elemseq (undefined :: Vector b) b + . G.elemseq (undefined :: Vector c) c + . G.elemseq (undefined :: Vector d) d +#endif +#ifdef DEFINE_MUTABLE +-- | /O(1)/ Zip 4 vectors +zip4 :: (Unbox a, Unbox b, Unbox c, Unbox d) => MVector s a -> + MVector s b -> + MVector s c -> + MVector s d -> MVector s (a, b, c, d) +{-# INLINE_FUSED zip4 #-} +zip4 as bs cs ds = MV_4 len (unsafeSlice 0 len as) + (unsafeSlice 0 len bs) + (unsafeSlice 0 len cs) + (unsafeSlice 0 len ds) + where + len = length as `delayed_min` + length bs `delayed_min` + length cs `delayed_min` + length ds +-- | /O(1)/ Unzip 4 vectors +unzip4 :: (Unbox a, + Unbox b, + Unbox c, + Unbox d) => MVector s (a, b, c, d) -> (MVector s a, + MVector s b, + MVector s c, + MVector s d) +{-# INLINE unzip4 #-} +unzip4 (MV_4 _ as bs cs ds) = (as, bs, cs, ds) +#endif +#ifdef DEFINE_IMMUTABLE +-- | /O(1)/ Zip 4 vectors +zip4 :: (Unbox a, Unbox b, Unbox c, Unbox d) => Vector a -> + Vector b -> + Vector c -> + Vector d -> Vector (a, b, c, d) +{-# INLINE_FUSED zip4 #-} +zip4 as bs cs ds = V_4 len (unsafeSlice 0 len as) + (unsafeSlice 0 len bs) + (unsafeSlice 0 len cs) + (unsafeSlice 0 len ds) + where + len = length as `delayed_min` + length bs `delayed_min` + length cs `delayed_min` + length ds +{-# RULES "stream/zip4 [Vector.Unboxed]" forall as bs cs ds . + G.stream (zip4 as bs cs ds) = Bundle.zipWith4 (, , ,) (G.stream as) + (G.stream bs) + (G.stream cs) + (G.stream ds) #-} + +-- | /O(1)/ Unzip 4 vectors +unzip4 :: (Unbox a, + Unbox b, + Unbox c, + Unbox d) => Vector (a, b, c, d) -> (Vector a, + Vector b, + Vector c, + Vector d) +{-# INLINE unzip4 #-} +unzip4 (V_4 _ as bs cs ds) = (as, bs, cs, ds) +#endif +#ifdef DEFINE_INSTANCES +data instance MVector s (a, b, c, d, e) + = MV_5 {-# UNPACK #-} !Int !(MVector s a) + !(MVector s b) + !(MVector s c) + !(MVector s d) + !(MVector s e) +data instance Vector (a, b, c, d, e) + = V_5 {-# UNPACK #-} !Int !(Vector a) + !(Vector b) + !(Vector c) + !(Vector d) + !(Vector e) +instance (Unbox a, + Unbox b, + Unbox c, + Unbox d, + Unbox e) => Unbox (a, b, c, d, e) +instance (Unbox a, + Unbox b, + Unbox c, + Unbox d, + Unbox e) => M.MVector MVector (a, b, c, d, e) where + {-# INLINE basicLength #-} + basicLength (MV_5 n_ _ _ _ _ _) = n_ + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice i_ m_ (MV_5 _ as bs cs ds es) + = MV_5 m_ (M.basicUnsafeSlice i_ m_ as) + (M.basicUnsafeSlice i_ m_ bs) + (M.basicUnsafeSlice i_ m_ cs) + (M.basicUnsafeSlice i_ m_ ds) + (M.basicUnsafeSlice i_ m_ es) + {-# INLINE basicOverlaps #-} + basicOverlaps (MV_5 _ as1 bs1 cs1 ds1 es1) (MV_5 _ as2 + bs2 + cs2 + ds2 + es2) + = M.basicOverlaps as1 as2 + || M.basicOverlaps bs1 bs2 + || M.basicOverlaps cs1 cs2 + || M.basicOverlaps ds1 ds2 + || M.basicOverlaps es1 es2 + {-# INLINE basicUnsafeNew #-} + basicUnsafeNew n_ + = do + as <- M.basicUnsafeNew n_ + bs <- M.basicUnsafeNew n_ + cs <- M.basicUnsafeNew n_ + ds <- M.basicUnsafeNew n_ + es <- M.basicUnsafeNew n_ + return $ MV_5 n_ as bs cs ds es + {-# INLINE basicInitialize #-} + basicInitialize (MV_5 _ as bs cs ds es) + = do + M.basicInitialize as + M.basicInitialize bs + M.basicInitialize cs + M.basicInitialize ds + M.basicInitialize es + {-# INLINE basicUnsafeReplicate #-} + basicUnsafeReplicate n_ (a, b, c, d, e) + = do + as <- M.basicUnsafeReplicate n_ a + bs <- M.basicUnsafeReplicate n_ b + cs <- M.basicUnsafeReplicate n_ c + ds <- M.basicUnsafeReplicate n_ d + es <- M.basicUnsafeReplicate n_ e + return $ MV_5 n_ as bs cs ds es + {-# INLINE basicUnsafeRead #-} + basicUnsafeRead (MV_5 _ as bs cs ds es) i_ + = do + a <- M.basicUnsafeRead as i_ + b <- M.basicUnsafeRead bs i_ + c <- M.basicUnsafeRead cs i_ + d <- M.basicUnsafeRead ds i_ + e <- M.basicUnsafeRead es i_ + return (a, b, c, d, e) + {-# INLINE basicUnsafeWrite #-} + basicUnsafeWrite (MV_5 _ as bs cs ds es) i_ (a, b, c, d, e) + = do + M.basicUnsafeWrite as i_ a + M.basicUnsafeWrite bs i_ b + M.basicUnsafeWrite cs i_ c + M.basicUnsafeWrite ds i_ d + M.basicUnsafeWrite es i_ e + {-# INLINE basicClear #-} + basicClear (MV_5 _ as bs cs ds es) + = do + M.basicClear as + M.basicClear bs + M.basicClear cs + M.basicClear ds + M.basicClear es + {-# INLINE basicSet #-} + basicSet (MV_5 _ as bs cs ds es) (a, b, c, d, e) + = do + M.basicSet as a + M.basicSet bs b + M.basicSet cs c + M.basicSet ds d + M.basicSet es e + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy (MV_5 _ as1 bs1 cs1 ds1 es1) (MV_5 _ as2 + bs2 + cs2 + ds2 + es2) + = do + M.basicUnsafeCopy as1 as2 + M.basicUnsafeCopy bs1 bs2 + M.basicUnsafeCopy cs1 cs2 + M.basicUnsafeCopy ds1 ds2 + M.basicUnsafeCopy es1 es2 + {-# INLINE basicUnsafeMove #-} + basicUnsafeMove (MV_5 _ as1 bs1 cs1 ds1 es1) (MV_5 _ as2 + bs2 + cs2 + ds2 + es2) + = do + M.basicUnsafeMove as1 as2 + M.basicUnsafeMove bs1 bs2 + M.basicUnsafeMove cs1 cs2 + M.basicUnsafeMove ds1 ds2 + M.basicUnsafeMove es1 es2 + {-# INLINE basicUnsafeGrow #-} + basicUnsafeGrow (MV_5 n_ as bs cs ds es) m_ + = do + as' <- M.basicUnsafeGrow as m_ + bs' <- M.basicUnsafeGrow bs m_ + cs' <- M.basicUnsafeGrow cs m_ + ds' <- M.basicUnsafeGrow ds m_ + es' <- M.basicUnsafeGrow es m_ + return $ MV_5 (m_+n_) as' bs' cs' ds' es' +instance (Unbox a, + Unbox b, + Unbox c, + Unbox d, + Unbox e) => G.Vector Vector (a, b, c, d, e) where + {-# INLINE basicUnsafeFreeze #-} + basicUnsafeFreeze (MV_5 n_ as bs cs ds es) + = do + as' <- G.basicUnsafeFreeze as + bs' <- G.basicUnsafeFreeze bs + cs' <- G.basicUnsafeFreeze cs + ds' <- G.basicUnsafeFreeze ds + es' <- G.basicUnsafeFreeze es + return $ V_5 n_ as' bs' cs' ds' es' + {-# INLINE basicUnsafeThaw #-} + basicUnsafeThaw (V_5 n_ as bs cs ds es) + = do + as' <- G.basicUnsafeThaw as + bs' <- G.basicUnsafeThaw bs + cs' <- G.basicUnsafeThaw cs + ds' <- G.basicUnsafeThaw ds + es' <- G.basicUnsafeThaw es + return $ MV_5 n_ as' bs' cs' ds' es' + {-# INLINE basicLength #-} + basicLength (V_5 n_ _ _ _ _ _) = n_ + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice i_ m_ (V_5 _ as bs cs ds es) + = V_5 m_ (G.basicUnsafeSlice i_ m_ as) + (G.basicUnsafeSlice i_ m_ bs) + (G.basicUnsafeSlice i_ m_ cs) + (G.basicUnsafeSlice i_ m_ ds) + (G.basicUnsafeSlice i_ m_ es) + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeIndexM (V_5 _ as bs cs ds es) i_ + = do + a <- G.basicUnsafeIndexM as i_ + b <- G.basicUnsafeIndexM bs i_ + c <- G.basicUnsafeIndexM cs i_ + d <- G.basicUnsafeIndexM ds i_ + e <- G.basicUnsafeIndexM es i_ + return (a, b, c, d, e) + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy (MV_5 _ as1 bs1 cs1 ds1 es1) (V_5 _ as2 + bs2 + cs2 + ds2 + es2) + = do + G.basicUnsafeCopy as1 as2 + G.basicUnsafeCopy bs1 bs2 + G.basicUnsafeCopy cs1 cs2 + G.basicUnsafeCopy ds1 ds2 + G.basicUnsafeCopy es1 es2 + {-# INLINE elemseq #-} + elemseq _ (a, b, c, d, e) + = G.elemseq (undefined :: Vector a) a + . G.elemseq (undefined :: Vector b) b + . G.elemseq (undefined :: Vector c) c + . G.elemseq (undefined :: Vector d) d + . G.elemseq (undefined :: Vector e) e +#endif +#ifdef DEFINE_MUTABLE +-- | /O(1)/ Zip 5 vectors +zip5 :: (Unbox a, + Unbox b, + Unbox c, + Unbox d, + Unbox e) => MVector s a -> + MVector s b -> + MVector s c -> + MVector s d -> + MVector s e -> MVector s (a, b, c, d, e) +{-# INLINE_FUSED zip5 #-} +zip5 as bs cs ds es = MV_5 len (unsafeSlice 0 len as) + (unsafeSlice 0 len bs) + (unsafeSlice 0 len cs) + (unsafeSlice 0 len ds) + (unsafeSlice 0 len es) + where + len = length as `delayed_min` + length bs `delayed_min` + length cs `delayed_min` + length ds `delayed_min` + length es +-- | /O(1)/ Unzip 5 vectors +unzip5 :: (Unbox a, + Unbox b, + Unbox c, + Unbox d, + Unbox e) => MVector s (a, b, c, d, e) -> (MVector s a, + MVector s b, + MVector s c, + MVector s d, + MVector s e) +{-# INLINE unzip5 #-} +unzip5 (MV_5 _ as bs cs ds es) = (as, bs, cs, ds, es) +#endif +#ifdef DEFINE_IMMUTABLE +-- | /O(1)/ Zip 5 vectors +zip5 :: (Unbox a, + Unbox b, + Unbox c, + Unbox d, + Unbox e) => Vector a -> + Vector b -> + Vector c -> + Vector d -> + Vector e -> Vector (a, b, c, d, e) +{-# INLINE_FUSED zip5 #-} +zip5 as bs cs ds es = V_5 len (unsafeSlice 0 len as) + (unsafeSlice 0 len bs) + (unsafeSlice 0 len cs) + (unsafeSlice 0 len ds) + (unsafeSlice 0 len es) + where + len = length as `delayed_min` + length bs `delayed_min` + length cs `delayed_min` + length ds `delayed_min` + length es +{-# RULES "stream/zip5 [Vector.Unboxed]" forall as bs cs ds es . + G.stream (zip5 as + bs + cs + ds + es) = Bundle.zipWith5 (, , , ,) (G.stream as) + (G.stream bs) + (G.stream cs) + (G.stream ds) + (G.stream es) #-} + +-- | /O(1)/ Unzip 5 vectors +unzip5 :: (Unbox a, + Unbox b, + Unbox c, + Unbox d, + Unbox e) => Vector (a, b, c, d, e) -> (Vector a, + Vector b, + Vector c, + Vector d, + Vector e) +{-# INLINE unzip5 #-} +unzip5 (V_5 _ as bs cs ds es) = (as, bs, cs, ds, es) +#endif +#ifdef DEFINE_INSTANCES +data instance MVector s (a, b, c, d, e, f) + = MV_6 {-# UNPACK #-} !Int !(MVector s a) + !(MVector s b) + !(MVector s c) + !(MVector s d) + !(MVector s e) + !(MVector s f) +data instance Vector (a, b, c, d, e, f) + = V_6 {-# UNPACK #-} !Int !(Vector a) + !(Vector b) + !(Vector c) + !(Vector d) + !(Vector e) + !(Vector f) +instance (Unbox a, + Unbox b, + Unbox c, + Unbox d, + Unbox e, + Unbox f) => Unbox (a, b, c, d, e, f) +instance (Unbox a, + Unbox b, + Unbox c, + Unbox d, + Unbox e, + Unbox f) => M.MVector MVector (a, b, c, d, e, f) where + {-# INLINE basicLength #-} + basicLength (MV_6 n_ _ _ _ _ _ _) = n_ + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice i_ m_ (MV_6 _ as bs cs ds es fs) + = MV_6 m_ (M.basicUnsafeSlice i_ m_ as) + (M.basicUnsafeSlice i_ m_ bs) + (M.basicUnsafeSlice i_ m_ cs) + (M.basicUnsafeSlice i_ m_ ds) + (M.basicUnsafeSlice i_ m_ es) + (M.basicUnsafeSlice i_ m_ fs) + {-# INLINE basicOverlaps #-} + basicOverlaps (MV_6 _ as1 bs1 cs1 ds1 es1 fs1) (MV_6 _ as2 + bs2 + cs2 + ds2 + es2 + fs2) + = M.basicOverlaps as1 as2 + || M.basicOverlaps bs1 bs2 + || M.basicOverlaps cs1 cs2 + || M.basicOverlaps ds1 ds2 + || M.basicOverlaps es1 es2 + || M.basicOverlaps fs1 fs2 + {-# INLINE basicUnsafeNew #-} + basicUnsafeNew n_ + = do + as <- M.basicUnsafeNew n_ + bs <- M.basicUnsafeNew n_ + cs <- M.basicUnsafeNew n_ + ds <- M.basicUnsafeNew n_ + es <- M.basicUnsafeNew n_ + fs <- M.basicUnsafeNew n_ + return $ MV_6 n_ as bs cs ds es fs + {-# INLINE basicInitialize #-} + basicInitialize (MV_6 _ as bs cs ds es fs) + = do + M.basicInitialize as + M.basicInitialize bs + M.basicInitialize cs + M.basicInitialize ds + M.basicInitialize es + M.basicInitialize fs + {-# INLINE basicUnsafeReplicate #-} + basicUnsafeReplicate n_ (a, b, c, d, e, f) + = do + as <- M.basicUnsafeReplicate n_ a + bs <- M.basicUnsafeReplicate n_ b + cs <- M.basicUnsafeReplicate n_ c + ds <- M.basicUnsafeReplicate n_ d + es <- M.basicUnsafeReplicate n_ e + fs <- M.basicUnsafeReplicate n_ f + return $ MV_6 n_ as bs cs ds es fs + {-# INLINE basicUnsafeRead #-} + basicUnsafeRead (MV_6 _ as bs cs ds es fs) i_ + = do + a <- M.basicUnsafeRead as i_ + b <- M.basicUnsafeRead bs i_ + c <- M.basicUnsafeRead cs i_ + d <- M.basicUnsafeRead ds i_ + e <- M.basicUnsafeRead es i_ + f <- M.basicUnsafeRead fs i_ + return (a, b, c, d, e, f) + {-# INLINE basicUnsafeWrite #-} + basicUnsafeWrite (MV_6 _ as bs cs ds es fs) i_ (a, b, c, d, e, f) + = do + M.basicUnsafeWrite as i_ a + M.basicUnsafeWrite bs i_ b + M.basicUnsafeWrite cs i_ c + M.basicUnsafeWrite ds i_ d + M.basicUnsafeWrite es i_ e + M.basicUnsafeWrite fs i_ f + {-# INLINE basicClear #-} + basicClear (MV_6 _ as bs cs ds es fs) + = do + M.basicClear as + M.basicClear bs + M.basicClear cs + M.basicClear ds + M.basicClear es + M.basicClear fs + {-# INLINE basicSet #-} + basicSet (MV_6 _ as bs cs ds es fs) (a, b, c, d, e, f) + = do + M.basicSet as a + M.basicSet bs b + M.basicSet cs c + M.basicSet ds d + M.basicSet es e + M.basicSet fs f + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy (MV_6 _ as1 bs1 cs1 ds1 es1 fs1) (MV_6 _ as2 + bs2 + cs2 + ds2 + es2 + fs2) + = do + M.basicUnsafeCopy as1 as2 + M.basicUnsafeCopy bs1 bs2 + M.basicUnsafeCopy cs1 cs2 + M.basicUnsafeCopy ds1 ds2 + M.basicUnsafeCopy es1 es2 + M.basicUnsafeCopy fs1 fs2 + {-# INLINE basicUnsafeMove #-} + basicUnsafeMove (MV_6 _ as1 bs1 cs1 ds1 es1 fs1) (MV_6 _ as2 + bs2 + cs2 + ds2 + es2 + fs2) + = do + M.basicUnsafeMove as1 as2 + M.basicUnsafeMove bs1 bs2 + M.basicUnsafeMove cs1 cs2 + M.basicUnsafeMove ds1 ds2 + M.basicUnsafeMove es1 es2 + M.basicUnsafeMove fs1 fs2 + {-# INLINE basicUnsafeGrow #-} + basicUnsafeGrow (MV_6 n_ as bs cs ds es fs) m_ + = do + as' <- M.basicUnsafeGrow as m_ + bs' <- M.basicUnsafeGrow bs m_ + cs' <- M.basicUnsafeGrow cs m_ + ds' <- M.basicUnsafeGrow ds m_ + es' <- M.basicUnsafeGrow es m_ + fs' <- M.basicUnsafeGrow fs m_ + return $ MV_6 (m_+n_) as' bs' cs' ds' es' fs' +instance (Unbox a, + Unbox b, + Unbox c, + Unbox d, + Unbox e, + Unbox f) => G.Vector Vector (a, b, c, d, e, f) where + {-# INLINE basicUnsafeFreeze #-} + basicUnsafeFreeze (MV_6 n_ as bs cs ds es fs) + = do + as' <- G.basicUnsafeFreeze as + bs' <- G.basicUnsafeFreeze bs + cs' <- G.basicUnsafeFreeze cs + ds' <- G.basicUnsafeFreeze ds + es' <- G.basicUnsafeFreeze es + fs' <- G.basicUnsafeFreeze fs + return $ V_6 n_ as' bs' cs' ds' es' fs' + {-# INLINE basicUnsafeThaw #-} + basicUnsafeThaw (V_6 n_ as bs cs ds es fs) + = do + as' <- G.basicUnsafeThaw as + bs' <- G.basicUnsafeThaw bs + cs' <- G.basicUnsafeThaw cs + ds' <- G.basicUnsafeThaw ds + es' <- G.basicUnsafeThaw es + fs' <- G.basicUnsafeThaw fs + return $ MV_6 n_ as' bs' cs' ds' es' fs' + {-# INLINE basicLength #-} + basicLength (V_6 n_ _ _ _ _ _ _) = n_ + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice i_ m_ (V_6 _ as bs cs ds es fs) + = V_6 m_ (G.basicUnsafeSlice i_ m_ as) + (G.basicUnsafeSlice i_ m_ bs) + (G.basicUnsafeSlice i_ m_ cs) + (G.basicUnsafeSlice i_ m_ ds) + (G.basicUnsafeSlice i_ m_ es) + (G.basicUnsafeSlice i_ m_ fs) + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeIndexM (V_6 _ as bs cs ds es fs) i_ + = do + a <- G.basicUnsafeIndexM as i_ + b <- G.basicUnsafeIndexM bs i_ + c <- G.basicUnsafeIndexM cs i_ + d <- G.basicUnsafeIndexM ds i_ + e <- G.basicUnsafeIndexM es i_ + f <- G.basicUnsafeIndexM fs i_ + return (a, b, c, d, e, f) + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy (MV_6 _ as1 bs1 cs1 ds1 es1 fs1) (V_6 _ as2 + bs2 + cs2 + ds2 + es2 + fs2) + = do + G.basicUnsafeCopy as1 as2 + G.basicUnsafeCopy bs1 bs2 + G.basicUnsafeCopy cs1 cs2 + G.basicUnsafeCopy ds1 ds2 + G.basicUnsafeCopy es1 es2 + G.basicUnsafeCopy fs1 fs2 + {-# INLINE elemseq #-} + elemseq _ (a, b, c, d, e, f) + = G.elemseq (undefined :: Vector a) a + . G.elemseq (undefined :: Vector b) b + . G.elemseq (undefined :: Vector c) c + . G.elemseq (undefined :: Vector d) d + . G.elemseq (undefined :: Vector e) e + . G.elemseq (undefined :: Vector f) f +#endif +#ifdef DEFINE_MUTABLE +-- | /O(1)/ Zip 6 vectors +zip6 :: (Unbox a, + Unbox b, + Unbox c, + Unbox d, + Unbox e, + Unbox f) => MVector s a -> + MVector s b -> + MVector s c -> + MVector s d -> + MVector s e -> + MVector s f -> MVector s (a, b, c, d, e, f) +{-# INLINE_FUSED zip6 #-} +zip6 as bs cs ds es fs = MV_6 len (unsafeSlice 0 len as) + (unsafeSlice 0 len bs) + (unsafeSlice 0 len cs) + (unsafeSlice 0 len ds) + (unsafeSlice 0 len es) + (unsafeSlice 0 len fs) + where + len = length as `delayed_min` + length bs `delayed_min` + length cs `delayed_min` + length ds `delayed_min` + length es `delayed_min` + length fs +-- | /O(1)/ Unzip 6 vectors +unzip6 :: (Unbox a, + Unbox b, + Unbox c, + Unbox d, + Unbox e, + Unbox f) => MVector s (a, b, c, d, e, f) -> (MVector s a, + MVector s b, + MVector s c, + MVector s d, + MVector s e, + MVector s f) +{-# INLINE unzip6 #-} +unzip6 (MV_6 _ as bs cs ds es fs) = (as, bs, cs, ds, es, fs) +#endif +#ifdef DEFINE_IMMUTABLE +-- | /O(1)/ Zip 6 vectors +zip6 :: (Unbox a, + Unbox b, + Unbox c, + Unbox d, + Unbox e, + Unbox f) => Vector a -> + Vector b -> + Vector c -> + Vector d -> + Vector e -> + Vector f -> Vector (a, b, c, d, e, f) +{-# INLINE_FUSED zip6 #-} +zip6 as bs cs ds es fs = V_6 len (unsafeSlice 0 len as) + (unsafeSlice 0 len bs) + (unsafeSlice 0 len cs) + (unsafeSlice 0 len ds) + (unsafeSlice 0 len es) + (unsafeSlice 0 len fs) + where + len = length as `delayed_min` + length bs `delayed_min` + length cs `delayed_min` + length ds `delayed_min` + length es `delayed_min` + length fs +{-# RULES "stream/zip6 [Vector.Unboxed]" forall as bs cs ds es fs . + G.stream (zip6 as + bs + cs + ds + es + fs) = Bundle.zipWith6 (, , , , ,) (G.stream as) + (G.stream bs) + (G.stream cs) + (G.stream ds) + (G.stream es) + (G.stream fs) #-} + +-- | /O(1)/ Unzip 6 vectors +unzip6 :: (Unbox a, + Unbox b, + Unbox c, + Unbox d, + Unbox e, + Unbox f) => Vector (a, b, c, d, e, f) -> (Vector a, + Vector b, + Vector c, + Vector d, + Vector e, + Vector f) +{-# INLINE unzip6 #-} +unzip6 (V_6 _ as bs cs ds es fs) = (as, bs, cs, ds, es, fs) +#endif diff --git a/third_party/bazel/rules_haskell/examples/vector/tests/Boilerplater.hs b/third_party/bazel/rules_haskell/examples/vector/tests/Boilerplater.hs new file mode 100644 index 000000000000..5506209ebc01 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/tests/Boilerplater.hs @@ -0,0 +1,27 @@ +module Boilerplater where + +import Test.Framework.Providers.QuickCheck2 + +import Language.Haskell.TH + + +testProperties :: [Name] -> Q Exp +testProperties nms = fmap ListE $ sequence [[| testProperty $(stringE prop_name) $(varE nm) |] + | nm <- nms + , Just prop_name <- [stripPrefix_maybe "prop_" (nameBase nm)]] + +-- This nice clean solution doesn't quite work since I need to use lexically-scoped type +-- variables, which aren't supported by Template Haskell. Argh! +-- testProperties :: Q [Dec] -> Q Exp +-- testProperties mdecs = do +-- decs <- mdecs +-- property_exprs <- sequence [[| testProperty "$prop_name" $(return $ VarE nm) |] +-- | FunD nm _clauses <- decs +-- , Just prop_name <- [stripPrefix_maybe "prop_" (nameBase nm)]] +-- return $ LetE decs (ListE property_exprs) + +stripPrefix_maybe :: String -> String -> Maybe String +stripPrefix_maybe prefix what + | what_start == prefix = Just what_end + | otherwise = Nothing + where (what_start, what_end) = splitAt (length prefix) what diff --git a/third_party/bazel/rules_haskell/examples/vector/tests/LICENSE b/third_party/bazel/rules_haskell/examples/vector/tests/LICENSE new file mode 100644 index 000000000000..43c0cee637be --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/tests/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2009, Max Bolingbroke and Roman Leshchinskiy +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. + diff --git a/third_party/bazel/rules_haskell/examples/vector/tests/Main.hs b/third_party/bazel/rules_haskell/examples/vector/tests/Main.hs new file mode 100644 index 000000000000..6642888323fd --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/tests/Main.hs @@ -0,0 +1,15 @@ +module Main (main) where + +import qualified Tests.Vector +import qualified Tests.Vector.UnitTests +import qualified Tests.Bundle +import qualified Tests.Move + +import Test.Framework (defaultMain) + +main :: IO () +main = defaultMain $ Tests.Bundle.tests + ++ Tests.Vector.tests + ++ Tests.Vector.UnitTests.tests + ++ Tests.Move.tests + diff --git a/third_party/bazel/rules_haskell/examples/vector/tests/Setup.hs b/third_party/bazel/rules_haskell/examples/vector/tests/Setup.hs new file mode 100644 index 000000000000..200a2e51d0b4 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/tests/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Bundle.hs b/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Bundle.hs new file mode 100644 index 000000000000..09368a199971 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Bundle.hs @@ -0,0 +1,163 @@ +module Tests.Bundle ( tests ) where + +import Boilerplater +import Utilities + +import qualified Data.Vector.Fusion.Bundle as S + +import Test.QuickCheck + +import Test.Framework +import Test.Framework.Providers.QuickCheck2 + +import Text.Show.Functions () +import Data.List (foldl', foldl1', unfoldr, find, findIndex) +import System.Random (Random) + +#define COMMON_CONTEXT(a) \ + VANILLA_CONTEXT(a) + +#define VANILLA_CONTEXT(a) \ + Eq a, Show a, Arbitrary a, CoArbitrary a, TestData a, Model a ~ a, EqTest a ~ Property + +testSanity :: forall v a. (COMMON_CONTEXT(a)) => S.Bundle v a -> [Test] +testSanity _ = [ + testProperty "fromList.toList == id" prop_fromList_toList, + testProperty "toList.fromList == id" prop_toList_fromList + ] + where + prop_fromList_toList :: P (S.Bundle v a -> S.Bundle v a) + = (S.fromList . S.toList) `eq` id + prop_toList_fromList :: P ([a] -> [a]) + = (S.toList . (S.fromList :: [a] -> S.Bundle v a)) `eq` id + +testPolymorphicFunctions :: forall v a. (COMMON_CONTEXT(a)) => S.Bundle v a -> [Test] +testPolymorphicFunctions _ = $(testProperties [ + 'prop_eq, + + 'prop_length, 'prop_null, + + 'prop_empty, 'prop_singleton, 'prop_replicate, + 'prop_cons, 'prop_snoc, 'prop_append, + + 'prop_head, 'prop_last, 'prop_index, + + 'prop_extract, 'prop_init, 'prop_tail, 'prop_take, 'prop_drop, + + 'prop_map, 'prop_zipWith, 'prop_zipWith3, + 'prop_filter, 'prop_takeWhile, 'prop_dropWhile, + + 'prop_elem, 'prop_notElem, + 'prop_find, 'prop_findIndex, + + 'prop_foldl, 'prop_foldl1, 'prop_foldl', 'prop_foldl1', + 'prop_foldr, 'prop_foldr1, + + 'prop_prescanl, 'prop_prescanl', + 'prop_postscanl, 'prop_postscanl', + 'prop_scanl, 'prop_scanl', 'prop_scanl1, 'prop_scanl1', + + 'prop_concatMap, + 'prop_unfoldr + ]) + where + -- Prelude + prop_eq :: P (S.Bundle v a -> S.Bundle v a -> Bool) = (==) `eq` (==) + + prop_length :: P (S.Bundle v a -> Int) = S.length `eq` length + prop_null :: P (S.Bundle v a -> Bool) = S.null `eq` null + prop_empty :: P (S.Bundle v a) = S.empty `eq` [] + prop_singleton :: P (a -> S.Bundle v a) = S.singleton `eq` singleton + prop_replicate :: P (Int -> a -> S.Bundle v a) + = (\n _ -> n < 1000) ===> S.replicate `eq` replicate + prop_cons :: P (a -> S.Bundle v a -> S.Bundle v a) = S.cons `eq` (:) + prop_snoc :: P (S.Bundle v a -> a -> S.Bundle v a) = S.snoc `eq` snoc + prop_append :: P (S.Bundle v a -> S.Bundle v a -> S.Bundle v a) = (S.++) `eq` (++) + + prop_head :: P (S.Bundle v a -> a) = not . S.null ===> S.head `eq` head + prop_last :: P (S.Bundle v a -> a) = not . S.null ===> S.last `eq` last + prop_index = \xs -> + not (S.null xs) ==> + forAll (choose (0, S.length xs-1)) $ \i -> + unP prop xs i + where + prop :: P (S.Bundle v a -> Int -> a) = (S.!!) `eq` (!!) + + prop_extract = \xs -> + forAll (choose (0, S.length xs)) $ \i -> + forAll (choose (0, S.length xs - i)) $ \n -> + unP prop i n xs + where + prop :: P (Int -> Int -> S.Bundle v a -> S.Bundle v a) = S.slice `eq` slice + + prop_tail :: P (S.Bundle v a -> S.Bundle v a) = not . S.null ===> S.tail `eq` tail + prop_init :: P (S.Bundle v a -> S.Bundle v a) = not . S.null ===> S.init `eq` init + prop_take :: P (Int -> S.Bundle v a -> S.Bundle v a) = S.take `eq` take + prop_drop :: P (Int -> S.Bundle v a -> S.Bundle v a) = S.drop `eq` drop + + prop_map :: P ((a -> a) -> S.Bundle v a -> S.Bundle v a) = S.map `eq` map + prop_zipWith :: P ((a -> a -> a) -> S.Bundle v a -> S.Bundle v a -> S.Bundle v a) = S.zipWith `eq` zipWith + prop_zipWith3 :: P ((a -> a -> a -> a) -> S.Bundle v a -> S.Bundle v a -> S.Bundle v a -> S.Bundle v a) + = S.zipWith3 `eq` zipWith3 + + prop_filter :: P ((a -> Bool) -> S.Bundle v a -> S.Bundle v a) = S.filter `eq` filter + prop_takeWhile :: P ((a -> Bool) -> S.Bundle v a -> S.Bundle v a) = S.takeWhile `eq` takeWhile + prop_dropWhile :: P ((a -> Bool) -> S.Bundle v a -> S.Bundle v a) = S.dropWhile `eq` dropWhile + + prop_elem :: P (a -> S.Bundle v a -> Bool) = S.elem `eq` elem + prop_notElem :: P (a -> S.Bundle v a -> Bool) = S.notElem `eq` notElem + prop_find :: P ((a -> Bool) -> S.Bundle v a -> Maybe a) = S.find `eq` find + prop_findIndex :: P ((a -> Bool) -> S.Bundle v a -> Maybe Int) + = S.findIndex `eq` findIndex + + prop_foldl :: P ((a -> a -> a) -> a -> S.Bundle v a -> a) = S.foldl `eq` foldl + prop_foldl1 :: P ((a -> a -> a) -> S.Bundle v a -> a) = notNullS2 ===> + S.foldl1 `eq` foldl1 + prop_foldl' :: P ((a -> a -> a) -> a -> S.Bundle v a -> a) = S.foldl' `eq` foldl' + prop_foldl1' :: P ((a -> a -> a) -> S.Bundle v a -> a) = notNullS2 ===> + S.foldl1' `eq` foldl1' + prop_foldr :: P ((a -> a -> a) -> a -> S.Bundle v a -> a) = S.foldr `eq` foldr + prop_foldr1 :: P ((a -> a -> a) -> S.Bundle v a -> a) = notNullS2 ===> + S.foldr1 `eq` foldr1 + + prop_prescanl :: P ((a -> a -> a) -> a -> S.Bundle v a -> S.Bundle v a) + = S.prescanl `eq` prescanl + prop_prescanl' :: P ((a -> a -> a) -> a -> S.Bundle v a -> S.Bundle v a) + = S.prescanl' `eq` prescanl + prop_postscanl :: P ((a -> a -> a) -> a -> S.Bundle v a -> S.Bundle v a) + = S.postscanl `eq` postscanl + prop_postscanl' :: P ((a -> a -> a) -> a -> S.Bundle v a -> S.Bundle v a) + = S.postscanl' `eq` postscanl + prop_scanl :: P ((a -> a -> a) -> a -> S.Bundle v a -> S.Bundle v a) + = S.scanl `eq` scanl + prop_scanl' :: P ((a -> a -> a) -> a -> S.Bundle v a -> S.Bundle v a) + = S.scanl' `eq` scanl + prop_scanl1 :: P ((a -> a -> a) -> S.Bundle v a -> S.Bundle v a) = notNullS2 ===> + S.scanl1 `eq` scanl1 + prop_scanl1' :: P ((a -> a -> a) -> S.Bundle v a -> S.Bundle v a) = notNullS2 ===> + S.scanl1' `eq` scanl1 + + prop_concatMap = forAll arbitrary $ \xs -> + forAll (sized (\n -> resize (n `div` S.length xs) arbitrary)) $ \f -> unP prop f xs + where + prop :: P ((a -> S.Bundle v a) -> S.Bundle v a -> S.Bundle v a) = S.concatMap `eq` concatMap + + limitUnfolds f (theirs, ours) | ours >= 0 + , Just (out, theirs') <- f theirs = Just (out, (theirs', ours - 1)) + | otherwise = Nothing + prop_unfoldr :: P (Int -> (Int -> Maybe (a,Int)) -> Int -> S.Bundle v a) + = (\n f a -> S.unfoldr (limitUnfolds f) (a, n)) + `eq` (\n f a -> unfoldr (limitUnfolds f) (a, n)) + +testBoolFunctions :: forall v. S.Bundle v Bool -> [Test] +testBoolFunctions _ = $(testProperties ['prop_and, 'prop_or ]) + where + prop_and :: P (S.Bundle v Bool -> Bool) = S.and `eq` and + prop_or :: P (S.Bundle v Bool -> Bool) = S.or `eq` or + +testBundleFunctions = testSanity (undefined :: S.Bundle v Int) + ++ testPolymorphicFunctions (undefined :: S.Bundle v Int) + ++ testBoolFunctions (undefined :: S.Bundle v Bool) + +tests = [ testGroup "Data.Vector.Fusion.Bundle" testBundleFunctions ] + diff --git a/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Move.hs b/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Move.hs new file mode 100644 index 000000000000..60ea8d334600 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Move.hs @@ -0,0 +1,49 @@ +module Tests.Move (tests) where + +import Test.QuickCheck +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck.Property (Property(..)) + +import Utilities () + +import Control.Monad (replicateM) +import Control.Monad.ST (runST) +import Data.List (sort,permutations) + +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Generic.Mutable as M + +import qualified Data.Vector as V +import qualified Data.Vector.Primitive as P +import qualified Data.Vector.Storable as S +import qualified Data.Vector.Unboxed as U + +basicMove :: G.Vector v a => v a -> Int -> Int -> Int -> v a +basicMove v dstOff srcOff len + | len > 0 = G.modify (\ mv -> G.copy (M.slice dstOff len mv) (G.slice srcOff len v)) v + | otherwise = v + +testMove :: (G.Vector v a, Show (v a), Eq (v a)) => v a -> Property +testMove v = G.length v > 0 ==> (MkProperty $ do + dstOff <- choose (0, G.length v - 1) + srcOff <- choose (0, G.length v - 1) + len <- choose (1, G.length v - max dstOff srcOff) + expected <- return $ basicMove v dstOff srcOff len + actual <- return $ G.modify (\ mv -> M.move (M.slice dstOff len mv) (M.slice srcOff len mv)) v + unProperty $ counterexample ("Move: " ++ show (v, dstOff, srcOff, len)) (expected == actual)) + +checkPermutations :: Int -> Bool +checkPermutations n = runST $ do + vec <- U.thaw (U.fromList [1..n]) + res <- replicateM (product [1..n]) $ M.nextPermutation vec >> U.freeze vec >>= return . U.toList + return $! ([1..n] : res) == sort (permutations [1..n]) ++ [[n,n-1..1]] + +testPermutations :: Bool +testPermutations = all checkPermutations [1..7] + +tests = + [testProperty "Data.Vector.Mutable (Move)" (testMove :: V.Vector Int -> Property), + testProperty "Data.Vector.Primitive.Mutable (Move)" (testMove :: P.Vector Int -> Property), + testProperty "Data.Vector.Unboxed.Mutable (Move)" (testMove :: U.Vector Int -> Property), + testProperty "Data.Vector.Storable.Mutable (Move)" (testMove :: S.Vector Int -> Property), + testProperty "Data.Vector.Generic.Mutable (nextPermutation)" testPermutations] diff --git a/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Vector.hs b/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Vector.hs new file mode 100644 index 000000000000..46569d909549 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Vector.hs @@ -0,0 +1,706 @@ +{-# LANGUAGE ConstraintKinds #-} +module Tests.Vector (tests) where + +import Boilerplater +import Utilities as Util + +import Data.Functor.Identity +import qualified Data.Traversable as T (Traversable(..)) +import Data.Foldable (Foldable(foldMap)) + +import qualified Data.Vector.Generic as V +import qualified Data.Vector +import qualified Data.Vector.Primitive +import qualified Data.Vector.Storable +import qualified Data.Vector.Unboxed +import qualified Data.Vector.Fusion.Bundle as S + +import Test.QuickCheck + +import Test.Framework +import Test.Framework.Providers.QuickCheck2 + +import Text.Show.Functions () +import Data.List +import Data.Monoid +import qualified Control.Applicative as Applicative +import System.Random (Random) + +import Data.Functor.Identity +import Control.Monad.Trans.Writer + +import Control.Monad.Zip + +type CommonContext a v = (VanillaContext a, VectorContext a v) +type VanillaContext a = ( Eq a , Show a, Arbitrary a, CoArbitrary a + , TestData a, Model a ~ a, EqTest a ~ Property) +type VectorContext a v = ( Eq (v a), Show (v a), Arbitrary (v a), CoArbitrary (v a) + , TestData (v a), Model (v a) ~ [a], EqTest (v a) ~ Property, V.Vector v a) + +-- TODO: implement Vector equivalents of list functions for some of the commented out properties + +-- TODO: test and implement some of these other Prelude functions: +-- mapM * +-- mapM_ * +-- sequence +-- sequence_ +-- sum * +-- product * +-- scanl * +-- scanl1 * +-- scanr * +-- scanr1 * +-- lookup * +-- lines +-- words +-- unlines +-- unwords +-- NB: this is an exhaustive list of all Prelude list functions that make sense for vectors. +-- Ones with *s are the most plausible candidates. + +-- TODO: add tests for the other extra functions +-- IVector exports still needing tests: +-- copy, +-- slice, +-- (//), update, bpermute, +-- prescanl, prescanl', +-- new, +-- unsafeSlice, unsafeIndex, +-- vlength, vnew + +-- TODO: test non-IVector stuff? + +#if !MIN_VERSION_base(4,7,0) +instance Foldable ((,) a) where + foldMap f (_, b) = f b + +instance T.Traversable ((,) a) where + traverse f (a, b) = fmap ((,) a) $ f b +#endif + +testSanity :: forall a v. (CommonContext a v) => v a -> [Test] +testSanity _ = [ + testProperty "fromList.toList == id" prop_fromList_toList, + testProperty "toList.fromList == id" prop_toList_fromList, + testProperty "unstream.stream == id" prop_unstream_stream, + testProperty "stream.unstream == id" prop_stream_unstream + ] + where + prop_fromList_toList (v :: v a) = (V.fromList . V.toList) v == v + prop_toList_fromList (l :: [a]) = ((V.toList :: v a -> [a]) . V.fromList) l == l + prop_unstream_stream (v :: v a) = (V.unstream . V.stream) v == v + prop_stream_unstream (s :: S.Bundle v a) = ((V.stream :: v a -> S.Bundle v a) . V.unstream) s == s + +testPolymorphicFunctions :: forall a v. (CommonContext a v, VectorContext Int v) => v a -> [Test] +testPolymorphicFunctions _ = $(testProperties [ + 'prop_eq, + + -- Length information + 'prop_length, 'prop_null, + + -- Indexing (FIXME) + 'prop_index, 'prop_safeIndex, 'prop_head, 'prop_last, + 'prop_unsafeIndex, 'prop_unsafeHead, 'prop_unsafeLast, + + -- Monadic indexing (FIXME) + {- 'prop_indexM, 'prop_headM, 'prop_lastM, + 'prop_unsafeIndexM, 'prop_unsafeHeadM, 'prop_unsafeLastM, -} + + -- Subvectors (FIXME) + 'prop_slice, 'prop_init, 'prop_tail, 'prop_take, 'prop_drop, + 'prop_splitAt, + {- 'prop_unsafeSlice, 'prop_unsafeInit, 'prop_unsafeTail, + 'prop_unsafeTake, 'prop_unsafeDrop, -} + + -- Initialisation (FIXME) + 'prop_empty, 'prop_singleton, 'prop_replicate, + 'prop_generate, 'prop_iterateN, 'prop_iterateNM, + + -- Monadic initialisation (FIXME) + 'prop_createT, + {- 'prop_replicateM, 'prop_generateM, 'prop_create, -} + + -- Unfolding + 'prop_unfoldr, 'prop_unfoldrN, 'prop_unfoldrM, 'prop_unfoldrNM, + 'prop_constructN, 'prop_constructrN, + + -- Enumeration? (FIXME?) + + -- Concatenation (FIXME) + 'prop_cons, 'prop_snoc, 'prop_append, + 'prop_concat, + + -- Restricting memory usage + 'prop_force, + + + -- Bulk updates (FIXME) + 'prop_upd, + {- 'prop_update, 'prop_update_, + 'prop_unsafeUpd, 'prop_unsafeUpdate, 'prop_unsafeUpdate_, -} + + -- Accumulations (FIXME) + 'prop_accum, + {- 'prop_accumulate, 'prop_accumulate_, + 'prop_unsafeAccum, 'prop_unsafeAccumulate, 'prop_unsafeAccumulate_, -} + + -- Permutations + 'prop_reverse, 'prop_backpermute, + {- 'prop_unsafeBackpermute, -} + + -- Elementwise indexing + {- 'prop_indexed, -} + + -- Mapping + 'prop_map, 'prop_imap, 'prop_concatMap, + + -- Monadic mapping + {- 'prop_mapM, 'prop_mapM_, 'prop_forM, 'prop_forM_, -} + 'prop_imapM, 'prop_imapM_, + + -- Zipping + 'prop_zipWith, 'prop_zipWith3, {- ... -} + 'prop_izipWith, 'prop_izipWith3, {- ... -} + 'prop_izipWithM, 'prop_izipWithM_, + {- 'prop_zip, ... -} + + -- Monadic zipping + {- 'prop_zipWithM, 'prop_zipWithM_, -} + + -- Unzipping + {- 'prop_unzip, ... -} + + -- Filtering + 'prop_filter, 'prop_ifilter, {- prop_filterM, -} + 'prop_uniq, + 'prop_mapMaybe, 'prop_imapMaybe, + 'prop_takeWhile, 'prop_dropWhile, + + -- Paritioning + 'prop_partition, {- 'prop_unstablePartition, -} + 'prop_span, 'prop_break, + + -- Searching + 'prop_elem, 'prop_notElem, + 'prop_find, 'prop_findIndex, 'prop_findIndices, + 'prop_elemIndex, 'prop_elemIndices, + + -- Folding + 'prop_foldl, 'prop_foldl1, 'prop_foldl', 'prop_foldl1', + 'prop_foldr, 'prop_foldr1, 'prop_foldr', 'prop_foldr1', + 'prop_ifoldl, 'prop_ifoldl', 'prop_ifoldr, 'prop_ifoldr', + 'prop_ifoldM, 'prop_ifoldM', 'prop_ifoldM_, 'prop_ifoldM'_, + + -- Specialised folds + 'prop_all, 'prop_any, + {- 'prop_maximumBy, 'prop_minimumBy, + 'prop_maxIndexBy, 'prop_minIndexBy, -} + + -- Monadic folds + {- ... -} + + -- Monadic sequencing + {- ... -} + + -- Scans + 'prop_prescanl, 'prop_prescanl', + 'prop_postscanl, 'prop_postscanl', + 'prop_scanl, 'prop_scanl', 'prop_scanl1, 'prop_scanl1', + 'prop_iscanl, 'prop_iscanl', + + 'prop_prescanr, 'prop_prescanr', + 'prop_postscanr, 'prop_postscanr', + 'prop_scanr, 'prop_scanr', 'prop_scanr1, 'prop_scanr1', + 'prop_iscanr, 'prop_iscanr' + ]) + where + -- Prelude + prop_eq :: P (v a -> v a -> Bool) = (==) `eq` (==) + + prop_length :: P (v a -> Int) = V.length `eq` length + prop_null :: P (v a -> Bool) = V.null `eq` null + + prop_empty :: P (v a) = V.empty `eq` [] + prop_singleton :: P (a -> v a) = V.singleton `eq` singleton + prop_replicate :: P (Int -> a -> v a) + = (\n _ -> n < 1000) ===> V.replicate `eq` replicate + prop_cons :: P (a -> v a -> v a) = V.cons `eq` (:) + prop_snoc :: P (v a -> a -> v a) = V.snoc `eq` snoc + prop_append :: P (v a -> v a -> v a) = (V.++) `eq` (++) + prop_concat :: P ([v a] -> v a) = V.concat `eq` concat + prop_force :: P (v a -> v a) = V.force `eq` id + prop_generate :: P (Int -> (Int -> a) -> v a) + = (\n _ -> n < 1000) ===> V.generate `eq` Util.generate + prop_iterateN :: P (Int -> (a -> a) -> a -> v a) + = (\n _ _ -> n < 1000) ===> V.iterateN `eq` (\n f -> take n . iterate f) + prop_iterateNM :: P (Int -> (a -> Writer [Int] a) -> a -> Writer [Int] (v a)) + = (\n _ _ -> n < 1000) ===> V.iterateNM `eq` Util.iterateNM + prop_createT :: P ((a, v a) -> (a, v a)) + prop_createT = (\v -> V.createT (T.mapM V.thaw v)) `eq` id + + prop_head :: P (v a -> a) = not . V.null ===> V.head `eq` head + prop_last :: P (v a -> a) = not . V.null ===> V.last `eq` last + prop_index = \xs -> + not (V.null xs) ==> + forAll (choose (0, V.length xs-1)) $ \i -> + unP prop xs i + where + prop :: P (v a -> Int -> a) = (V.!) `eq` (!!) + prop_safeIndex :: P (v a -> Int -> Maybe a) = (V.!?) `eq` fn + where + fn xs i = case drop i xs of + x:_ | i >= 0 -> Just x + _ -> Nothing + prop_unsafeHead :: P (v a -> a) = not . V.null ===> V.unsafeHead `eq` head + prop_unsafeLast :: P (v a -> a) = not . V.null ===> V.unsafeLast `eq` last + prop_unsafeIndex = \xs -> + not (V.null xs) ==> + forAll (choose (0, V.length xs-1)) $ \i -> + unP prop xs i + where + prop :: P (v a -> Int -> a) = V.unsafeIndex `eq` (!!) + + prop_slice = \xs -> + forAll (choose (0, V.length xs)) $ \i -> + forAll (choose (0, V.length xs - i)) $ \n -> + unP prop i n xs + where + prop :: P (Int -> Int -> v a -> v a) = V.slice `eq` slice + + prop_tail :: P (v a -> v a) = not . V.null ===> V.tail `eq` tail + prop_init :: P (v a -> v a) = not . V.null ===> V.init `eq` init + prop_take :: P (Int -> v a -> v a) = V.take `eq` take + prop_drop :: P (Int -> v a -> v a) = V.drop `eq` drop + prop_splitAt :: P (Int -> v a -> (v a, v a)) = V.splitAt `eq` splitAt + + prop_accum = \f xs -> + forAll (index_value_pairs (V.length xs)) $ \ps -> + unP prop f xs ps + where + prop :: P ((a -> a -> a) -> v a -> [(Int,a)] -> v a) + = V.accum `eq` accum + + prop_upd = \xs -> + forAll (index_value_pairs (V.length xs)) $ \ps -> + unP prop xs ps + where + prop :: P (v a -> [(Int,a)] -> v a) = (V.//) `eq` (//) + + prop_backpermute = \xs -> + forAll (indices (V.length xs)) $ \is -> + unP prop xs (V.fromList is) + where + prop :: P (v a -> v Int -> v a) = V.backpermute `eq` backpermute + + prop_reverse :: P (v a -> v a) = V.reverse `eq` reverse + + prop_map :: P ((a -> a) -> v a -> v a) = V.map `eq` map + prop_zipWith :: P ((a -> a -> a) -> v a -> v a -> v a) = V.zipWith `eq` zipWith + prop_zipWith3 :: P ((a -> a -> a -> a) -> v a -> v a -> v a -> v a) + = V.zipWith3 `eq` zipWith3 + prop_imap :: P ((Int -> a -> a) -> v a -> v a) = V.imap `eq` imap + prop_imapM :: P ((Int -> a -> Identity a) -> v a -> Identity (v a)) + = V.imapM `eq` imapM + prop_imapM_ :: P ((Int -> a -> Writer [a] ()) -> v a -> Writer [a] ()) + = V.imapM_ `eq` imapM_ + prop_izipWith :: P ((Int -> a -> a -> a) -> v a -> v a -> v a) = V.izipWith `eq` izipWith + prop_izipWithM :: P ((Int -> a -> a -> Identity a) -> v a -> v a -> Identity (v a)) + = V.izipWithM `eq` izipWithM + prop_izipWithM_ :: P ((Int -> a -> a -> Writer [a] ()) -> v a -> v a -> Writer [a] ()) + = V.izipWithM_ `eq` izipWithM_ + prop_izipWith3 :: P ((Int -> a -> a -> a -> a) -> v a -> v a -> v a -> v a) + = V.izipWith3 `eq` izipWith3 + + prop_filter :: P ((a -> Bool) -> v a -> v a) = V.filter `eq` filter + prop_ifilter :: P ((Int -> a -> Bool) -> v a -> v a) = V.ifilter `eq` ifilter + prop_mapMaybe :: P ((a -> Maybe a) -> v a -> v a) = V.mapMaybe `eq` mapMaybe + prop_imapMaybe :: P ((Int -> a -> Maybe a) -> v a -> v a) = V.imapMaybe `eq` imapMaybe + prop_takeWhile :: P ((a -> Bool) -> v a -> v a) = V.takeWhile `eq` takeWhile + prop_dropWhile :: P ((a -> Bool) -> v a -> v a) = V.dropWhile `eq` dropWhile + prop_partition :: P ((a -> Bool) -> v a -> (v a, v a)) + = V.partition `eq` partition + prop_span :: P ((a -> Bool) -> v a -> (v a, v a)) = V.span `eq` span + prop_break :: P ((a -> Bool) -> v a -> (v a, v a)) = V.break `eq` break + + prop_elem :: P (a -> v a -> Bool) = V.elem `eq` elem + prop_notElem :: P (a -> v a -> Bool) = V.notElem `eq` notElem + prop_find :: P ((a -> Bool) -> v a -> Maybe a) = V.find `eq` find + prop_findIndex :: P ((a -> Bool) -> v a -> Maybe Int) + = V.findIndex `eq` findIndex + prop_findIndices :: P ((a -> Bool) -> v a -> v Int) + = V.findIndices `eq` findIndices + prop_elemIndex :: P (a -> v a -> Maybe Int) = V.elemIndex `eq` elemIndex + prop_elemIndices :: P (a -> v a -> v Int) = V.elemIndices `eq` elemIndices + + prop_foldl :: P ((a -> a -> a) -> a -> v a -> a) = V.foldl `eq` foldl + prop_foldl1 :: P ((a -> a -> a) -> v a -> a) = notNull2 ===> + V.foldl1 `eq` foldl1 + prop_foldl' :: P ((a -> a -> a) -> a -> v a -> a) = V.foldl' `eq` foldl' + prop_foldl1' :: P ((a -> a -> a) -> v a -> a) = notNull2 ===> + V.foldl1' `eq` foldl1' + prop_foldr :: P ((a -> a -> a) -> a -> v a -> a) = V.foldr `eq` foldr + prop_foldr1 :: P ((a -> a -> a) -> v a -> a) = notNull2 ===> + V.foldr1 `eq` foldr1 + prop_foldr' :: P ((a -> a -> a) -> a -> v a -> a) = V.foldr' `eq` foldr + prop_foldr1' :: P ((a -> a -> a) -> v a -> a) = notNull2 ===> + V.foldr1' `eq` foldr1 + prop_ifoldl :: P ((a -> Int -> a -> a) -> a -> v a -> a) + = V.ifoldl `eq` ifoldl + prop_ifoldl' :: P ((a -> Int -> a -> a) -> a -> v a -> a) + = V.ifoldl' `eq` ifoldl + prop_ifoldr :: P ((Int -> a -> a -> a) -> a -> v a -> a) + = V.ifoldr `eq` ifoldr + prop_ifoldr' :: P ((Int -> a -> a -> a) -> a -> v a -> a) + = V.ifoldr' `eq` ifoldr + prop_ifoldM :: P ((a -> Int -> a -> Identity a) -> a -> v a -> Identity a) + = V.ifoldM `eq` ifoldM + prop_ifoldM' :: P ((a -> Int -> a -> Identity a) -> a -> v a -> Identity a) + = V.ifoldM' `eq` ifoldM + prop_ifoldM_ :: P ((() -> Int -> a -> Writer [a] ()) -> () -> v a -> Writer [a] ()) + = V.ifoldM_ `eq` ifoldM_ + prop_ifoldM'_ :: P ((() -> Int -> a -> Writer [a] ()) -> () -> v a -> Writer [a] ()) + = V.ifoldM'_ `eq` ifoldM_ + + prop_all :: P ((a -> Bool) -> v a -> Bool) = V.all `eq` all + prop_any :: P ((a -> Bool) -> v a -> Bool) = V.any `eq` any + + prop_prescanl :: P ((a -> a -> a) -> a -> v a -> v a) + = V.prescanl `eq` prescanl + prop_prescanl' :: P ((a -> a -> a) -> a -> v a -> v a) + = V.prescanl' `eq` prescanl + prop_postscanl :: P ((a -> a -> a) -> a -> v a -> v a) + = V.postscanl `eq` postscanl + prop_postscanl' :: P ((a -> a -> a) -> a -> v a -> v a) + = V.postscanl' `eq` postscanl + prop_scanl :: P ((a -> a -> a) -> a -> v a -> v a) + = V.scanl `eq` scanl + prop_scanl' :: P ((a -> a -> a) -> a -> v a -> v a) + = V.scanl' `eq` scanl + prop_scanl1 :: P ((a -> a -> a) -> v a -> v a) = notNull2 ===> + V.scanl1 `eq` scanl1 + prop_scanl1' :: P ((a -> a -> a) -> v a -> v a) = notNull2 ===> + V.scanl1' `eq` scanl1 + prop_iscanl :: P ((Int -> a -> a -> a) -> a -> v a -> v a) + = V.iscanl `eq` iscanl + prop_iscanl' :: P ((Int -> a -> a -> a) -> a -> v a -> v a) + = V.iscanl' `eq` iscanl + + prop_prescanr :: P ((a -> a -> a) -> a -> v a -> v a) + = V.prescanr `eq` prescanr + prop_prescanr' :: P ((a -> a -> a) -> a -> v a -> v a) + = V.prescanr' `eq` prescanr + prop_postscanr :: P ((a -> a -> a) -> a -> v a -> v a) + = V.postscanr `eq` postscanr + prop_postscanr' :: P ((a -> a -> a) -> a -> v a -> v a) + = V.postscanr' `eq` postscanr + prop_scanr :: P ((a -> a -> a) -> a -> v a -> v a) + = V.scanr `eq` scanr + prop_scanr' :: P ((a -> a -> a) -> a -> v a -> v a) + = V.scanr' `eq` scanr + prop_iscanr :: P ((Int -> a -> a -> a) -> a -> v a -> v a) + = V.iscanr `eq` iscanr + prop_iscanr' :: P ((Int -> a -> a -> a) -> a -> v a -> v a) + = V.iscanr' `eq` iscanr + prop_scanr1 :: P ((a -> a -> a) -> v a -> v a) = notNull2 ===> + V.scanr1 `eq` scanr1 + prop_scanr1' :: P ((a -> a -> a) -> v a -> v a) = notNull2 ===> + V.scanr1' `eq` scanr1 + + prop_concatMap = forAll arbitrary $ \xs -> + forAll (sized (\n -> resize (n `div` V.length xs) arbitrary)) $ \f -> unP prop f xs + where + prop :: P ((a -> v a) -> v a -> v a) = V.concatMap `eq` concatMap + + prop_uniq :: P (v a -> v a) + = V.uniq `eq` (map head . group) + --prop_span = (V.span :: (a -> Bool) -> v a -> (v a, v a)) `eq2` span + --prop_break = (V.break :: (a -> Bool) -> v a -> (v a, v a)) `eq2` break + --prop_splitAt = (V.splitAt :: Int -> v a -> (v a, v a)) `eq2` splitAt + --prop_all = (V.all :: (a -> Bool) -> v a -> Bool) `eq2` all + --prop_any = (V.any :: (a -> Bool) -> v a -> Bool) `eq2` any + + -- Data.List + --prop_findIndices = V.findIndices `eq2` (findIndices :: (a -> Bool) -> v a -> v Int) + --prop_isPrefixOf = V.isPrefixOf `eq2` (isPrefixOf :: v a -> v a -> Bool) + --prop_elemIndex = V.elemIndex `eq2` (elemIndex :: a -> v a -> Maybe Int) + --prop_elemIndices = V.elemIndices `eq2` (elemIndices :: a -> v a -> v Int) + -- + --prop_mapAccumL = eq3 + -- (V.mapAccumL :: (X -> W -> (X,W)) -> X -> B -> (X, B)) + -- ( mapAccumL :: (X -> W -> (X,W)) -> X -> [W] -> (X, [W])) + -- + --prop_mapAccumR = eq3 + -- (V.mapAccumR :: (X -> W -> (X,W)) -> X -> B -> (X, B)) + -- ( mapAccumR :: (X -> W -> (X,W)) -> X -> [W] -> (X, [W])) + + -- Because the vectors are strict, we need to be totally sure that the unfold eventually terminates. This + -- is achieved by injecting our own bit of state into the unfold - the maximum number of unfolds allowed. + limitUnfolds f (theirs, ours) + | ours > 0 + , Just (out, theirs') <- f theirs = Just (out, (theirs', ours - 1)) + | otherwise = Nothing + limitUnfoldsM f (theirs, ours) + | ours > 0 = do r <- f theirs + return $ (\(a,b) -> (a,(b,ours - 1))) `fmap` r + | otherwise = return Nothing + + + prop_unfoldr :: P (Int -> (Int -> Maybe (a,Int)) -> Int -> v a) + = (\n f a -> V.unfoldr (limitUnfolds f) (a, n)) + `eq` (\n f a -> unfoldr (limitUnfolds f) (a, n)) + prop_unfoldrN :: P (Int -> (Int -> Maybe (a,Int)) -> Int -> v a) + = V.unfoldrN `eq` (\n f a -> unfoldr (limitUnfolds f) (a, n)) + prop_unfoldrM :: P (Int -> (Int -> Writer [Int] (Maybe (a,Int))) -> Int -> Writer [Int] (v a)) + = (\n f a -> V.unfoldrM (limitUnfoldsM f) (a,n)) + `eq` (\n f a -> Util.unfoldrM (limitUnfoldsM f) (a, n)) + prop_unfoldrNM :: P (Int -> (Int -> Writer [Int] (Maybe (a,Int))) -> Int -> Writer [Int] (v a)) + = V.unfoldrNM `eq` (\n f a -> Util.unfoldrM (limitUnfoldsM f) (a, n)) + + prop_constructN = \f -> forAll (choose (0,20)) $ \n -> unP prop n f + where + prop :: P (Int -> (v a -> a) -> v a) = V.constructN `eq` constructN [] + + constructN xs 0 _ = xs + constructN xs n f = constructN (xs ++ [f xs]) (n-1) f + + prop_constructrN = \f -> forAll (choose (0,20)) $ \n -> unP prop n f + where + prop :: P (Int -> (v a -> a) -> v a) = V.constructrN `eq` constructrN [] + + constructrN xs 0 _ = xs + constructrN xs n f = constructrN (f xs : xs) (n-1) f + +testTuplyFunctions:: forall a v. (CommonContext a v, VectorContext (a, a) v, VectorContext (a, a, a) v) => v a -> [Test] +testTuplyFunctions _ = $(testProperties [ 'prop_zip, 'prop_zip3 + , 'prop_unzip, 'prop_unzip3 + , 'prop_mzip, 'prop_munzip + ]) + where + prop_zip :: P (v a -> v a -> v (a, a)) = V.zip `eq` zip + prop_zip3 :: P (v a -> v a -> v a -> v (a, a, a)) = V.zip3 `eq` zip3 + prop_unzip :: P (v (a, a) -> (v a, v a)) = V.unzip `eq` unzip + prop_unzip3 :: P (v (a, a, a) -> (v a, v a, v a)) = V.unzip3 `eq` unzip3 + prop_mzip :: P (Data.Vector.Vector a -> Data.Vector.Vector a -> Data.Vector.Vector (a, a)) + = mzip `eq` zip + prop_munzip :: P (Data.Vector.Vector (a, a) -> (Data.Vector.Vector a, Data.Vector.Vector a)) + = munzip `eq` unzip + +testOrdFunctions :: forall a v. (CommonContext a v, Ord a, Ord (v a)) => v a -> [Test] +testOrdFunctions _ = $(testProperties + ['prop_compare, + 'prop_maximum, 'prop_minimum, + 'prop_minIndex, 'prop_maxIndex ]) + where + prop_compare :: P (v a -> v a -> Ordering) = compare `eq` compare + prop_maximum :: P (v a -> a) = not . V.null ===> V.maximum `eq` maximum + prop_minimum :: P (v a -> a) = not . V.null ===> V.minimum `eq` minimum + prop_minIndex :: P (v a -> Int) = not . V.null ===> V.minIndex `eq` minIndex + prop_maxIndex :: P (v a -> Int) = not . V.null ===> V.maxIndex `eq` maxIndex + +testEnumFunctions :: forall a v. (CommonContext a v, Enum a, Ord a, Num a, Random a) => v a -> [Test] +testEnumFunctions _ = $(testProperties + [ 'prop_enumFromN, 'prop_enumFromThenN, + 'prop_enumFromTo, 'prop_enumFromThenTo]) + where + prop_enumFromN :: P (a -> Int -> v a) + = (\_ n -> n < 1000) + ===> V.enumFromN `eq` (\x n -> take n $ scanl (+) x $ repeat 1) + + prop_enumFromThenN :: P (a -> a -> Int -> v a) + = (\_ _ n -> n < 1000) + ===> V.enumFromStepN `eq` (\x y n -> take n $ scanl (+) x $ repeat y) + + prop_enumFromTo = \m -> + forAll (choose (-2,100)) $ \n -> + unP prop m (m+n) + where + prop :: P (a -> a -> v a) = V.enumFromTo `eq` enumFromTo + + prop_enumFromThenTo = \i j -> + j /= i ==> + forAll (choose (ks i j)) $ \k -> + unP prop i j k + where + prop :: P (a -> a -> a -> v a) = V.enumFromThenTo `eq` enumFromThenTo + + ks i j | j < i = (i-d*100, i+d*2) + | otherwise = (i-d*2, i+d*100) + where + d = abs (j-i) + +testMonoidFunctions :: forall a v. (CommonContext a v, Monoid (v a)) => v a -> [Test] +testMonoidFunctions _ = $(testProperties + [ 'prop_mempty, 'prop_mappend, 'prop_mconcat ]) + where + prop_mempty :: P (v a) = mempty `eq` mempty + prop_mappend :: P (v a -> v a -> v a) = mappend `eq` mappend + prop_mconcat :: P ([v a] -> v a) = mconcat `eq` mconcat + +testFunctorFunctions :: forall a v. (CommonContext a v, Functor v) => v a -> [Test] +testFunctorFunctions _ = $(testProperties + [ 'prop_fmap ]) + where + prop_fmap :: P ((a -> a) -> v a -> v a) = fmap `eq` fmap + +testMonadFunctions :: forall a v. (CommonContext a v, Monad v) => v a -> [Test] +testMonadFunctions _ = $(testProperties + [ 'prop_return, 'prop_bind ]) + where + prop_return :: P (a -> v a) = return `eq` return + prop_bind :: P (v a -> (a -> v a) -> v a) = (>>=) `eq` (>>=) + +testApplicativeFunctions :: forall a v. (CommonContext a v, V.Vector v (a -> a), Applicative.Applicative v) => v a -> [Test] +testApplicativeFunctions _ = $(testProperties + [ 'prop_applicative_pure, 'prop_applicative_appl ]) + where + prop_applicative_pure :: P (a -> v a) + = Applicative.pure `eq` Applicative.pure + prop_applicative_appl :: [a -> a] -> P (v a -> v a) + = \fs -> (Applicative.<*>) (V.fromList fs) `eq` (Applicative.<*>) fs + +testAlternativeFunctions :: forall a v. (CommonContext a v, Applicative.Alternative v) => v a -> [Test] +testAlternativeFunctions _ = $(testProperties + [ 'prop_alternative_empty, 'prop_alternative_or ]) + where + prop_alternative_empty :: P (v a) = Applicative.empty `eq` Applicative.empty + prop_alternative_or :: P (v a -> v a -> v a) + = (Applicative.<|>) `eq` (Applicative.<|>) + +testBoolFunctions :: forall v. (CommonContext Bool v) => v Bool -> [Test] +testBoolFunctions _ = $(testProperties ['prop_and, 'prop_or]) + where + prop_and :: P (v Bool -> Bool) = V.and `eq` and + prop_or :: P (v Bool -> Bool) = V.or `eq` or + +testNumFunctions :: forall a v. (CommonContext a v, Num a) => v a -> [Test] +testNumFunctions _ = $(testProperties ['prop_sum, 'prop_product]) + where + prop_sum :: P (v a -> a) = V.sum `eq` sum + prop_product :: P (v a -> a) = V.product `eq` product + +testNestedVectorFunctions :: forall a v. (CommonContext a v) => v a -> [Test] +testNestedVectorFunctions _ = $(testProperties []) + where + -- Prelude + --prop_concat = (V.concat :: [v a] -> v a) `eq1` concat + + -- Data.List + --prop_transpose = V.transpose `eq1` (transpose :: [v a] -> [v a]) + --prop_group = V.group `eq1` (group :: v a -> [v a]) + --prop_inits = V.inits `eq1` (inits :: v a -> [v a]) + --prop_tails = V.tails `eq1` (tails :: v a -> [v a]) + +testGeneralBoxedVector :: forall a. (CommonContext a Data.Vector.Vector, Ord a) => Data.Vector.Vector a -> [Test] +testGeneralBoxedVector dummy = concatMap ($ dummy) [ + testSanity, + testPolymorphicFunctions, + testOrdFunctions, + testTuplyFunctions, + testNestedVectorFunctions, + testMonoidFunctions, + testFunctorFunctions, + testMonadFunctions, + testApplicativeFunctions, + testAlternativeFunctions + ] + +testBoolBoxedVector dummy = concatMap ($ dummy) + [ + testGeneralBoxedVector + , testBoolFunctions + ] + +testNumericBoxedVector :: forall a. (CommonContext a Data.Vector.Vector, Ord a, Num a, Enum a, Random a) => Data.Vector.Vector a -> [Test] +testNumericBoxedVector dummy = concatMap ($ dummy) + [ + testGeneralBoxedVector + , testNumFunctions + , testEnumFunctions + ] + + +testGeneralPrimitiveVector :: forall a. (CommonContext a Data.Vector.Primitive.Vector, Data.Vector.Primitive.Prim a, Ord a) => Data.Vector.Primitive.Vector a -> [Test] +testGeneralPrimitiveVector dummy = concatMap ($ dummy) [ + testSanity, + testPolymorphicFunctions, + testOrdFunctions, + testMonoidFunctions + ] + +testNumericPrimitiveVector :: forall a. (CommonContext a Data.Vector.Primitive.Vector, Data.Vector.Primitive.Prim a, Ord a, Num a, Enum a, Random a) => Data.Vector.Primitive.Vector a -> [Test] +testNumericPrimitiveVector dummy = concatMap ($ dummy) + [ + testGeneralPrimitiveVector + , testNumFunctions + , testEnumFunctions + ] + + +testGeneralStorableVector :: forall a. (CommonContext a Data.Vector.Storable.Vector, Data.Vector.Storable.Storable a, Ord a) => Data.Vector.Storable.Vector a -> [Test] +testGeneralStorableVector dummy = concatMap ($ dummy) [ + testSanity, + testPolymorphicFunctions, + testOrdFunctions, + testMonoidFunctions + ] + +testNumericStorableVector :: forall a. (CommonContext a Data.Vector.Storable.Vector, Data.Vector.Storable.Storable a, Ord a, Num a, Enum a, Random a) => Data.Vector.Storable.Vector a -> [Test] +testNumericStorableVector dummy = concatMap ($ dummy) + [ + testGeneralStorableVector + , testNumFunctions + , testEnumFunctions + ] + + +testGeneralUnboxedVector :: forall a. (CommonContext a Data.Vector.Unboxed.Vector, Data.Vector.Unboxed.Unbox a, Ord a) => Data.Vector.Unboxed.Vector a -> [Test] +testGeneralUnboxedVector dummy = concatMap ($ dummy) [ + testSanity, + testPolymorphicFunctions, + testOrdFunctions, + testMonoidFunctions + ] + +testUnitUnboxedVector dummy = concatMap ($ dummy) + [ + testGeneralUnboxedVector + ] + +testBoolUnboxedVector dummy = concatMap ($ dummy) + [ + testGeneralUnboxedVector + , testBoolFunctions + ] + +testNumericUnboxedVector :: forall a. (CommonContext a Data.Vector.Unboxed.Vector, Data.Vector.Unboxed.Unbox a, Ord a, Num a, Enum a, Random a) => Data.Vector.Unboxed.Vector a -> [Test] +testNumericUnboxedVector dummy = concatMap ($ dummy) + [ + testGeneralUnboxedVector + , testNumFunctions + , testEnumFunctions + ] + +testTupleUnboxedVector :: forall a. (CommonContext a Data.Vector.Unboxed.Vector, Data.Vector.Unboxed.Unbox a, Ord a) => Data.Vector.Unboxed.Vector a -> [Test] +testTupleUnboxedVector dummy = concatMap ($ dummy) + [ + testGeneralUnboxedVector + ] + +tests = [ + testGroup "Data.Vector.Vector (Bool)" (testBoolBoxedVector (undefined :: Data.Vector.Vector Bool)), + testGroup "Data.Vector.Vector (Int)" (testNumericBoxedVector (undefined :: Data.Vector.Vector Int)), + + testGroup "Data.Vector.Primitive.Vector (Int)" (testNumericPrimitiveVector (undefined :: Data.Vector.Primitive.Vector Int)), + testGroup "Data.Vector.Primitive.Vector (Double)" (testNumericPrimitiveVector (undefined :: Data.Vector.Primitive.Vector Double)), + + testGroup "Data.Vector.Storable.Vector (Int)" (testNumericStorableVector (undefined :: Data.Vector.Storable.Vector Int)), + testGroup "Data.Vector.Storable.Vector (Double)" (testNumericStorableVector (undefined :: Data.Vector.Storable.Vector Double)), + + testGroup "Data.Vector.Unboxed.Vector ()" (testUnitUnboxedVector (undefined :: Data.Vector.Unboxed.Vector ())), + testGroup "Data.Vector.Unboxed.Vector (Bool)" (testBoolUnboxedVector (undefined :: Data.Vector.Unboxed.Vector Bool)), + testGroup "Data.Vector.Unboxed.Vector (Int)" (testNumericUnboxedVector (undefined :: Data.Vector.Unboxed.Vector Int)), + testGroup "Data.Vector.Unboxed.Vector (Double)" (testNumericUnboxedVector (undefined :: Data.Vector.Unboxed.Vector Double)), + testGroup "Data.Vector.Unboxed.Vector (Int,Bool)" (testTupleUnboxedVector (undefined :: Data.Vector.Unboxed.Vector (Int,Bool))), + testGroup "Data.Vector.Unboxed.Vector (Int,Bool,Int)" (testTupleUnboxedVector (undefined :: Data.Vector.Unboxed.Vector (Int,Bool,Int))) + + ] diff --git a/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Vector/UnitTests.hs b/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Vector/UnitTests.hs new file mode 100644 index 000000000000..5827640d8438 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Vector/UnitTests.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Tests.Vector.UnitTests (tests) where + +import Control.Applicative as Applicative +import qualified Data.Vector.Storable as Storable +import Foreign.Ptr +import Foreign.Storable +import Text.Printf + +import Test.Framework +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, assertBool) + +newtype Aligned a = Aligned { getAligned :: a } + +instance (Storable a) => Storable (Aligned a) where + sizeOf _ = sizeOf (undefined :: a) + alignment _ = 128 + peek ptr = Aligned Applicative.<$> peek (castPtr ptr) + poke ptr = poke (castPtr ptr) . getAligned + +checkAddressAlignment :: forall a. (Storable a) => Storable.Vector a -> Assertion +checkAddressAlignment xs = Storable.unsafeWith xs $ \ptr -> do + let ptr' = ptrToWordPtr ptr + msg = printf "Expected pointer with alignment %d but got 0x%08x" (toInteger align) (toInteger ptr') + align :: WordPtr + align = fromIntegral $ alignment dummy + assertBool msg $ (ptr' `mod` align) == 0 + where + dummy :: a + dummy = undefined + +tests :: [Test] +tests = + [ testGroup "Data.Vector.Storable.Vector Alignment" + [ testCase "Aligned Double" $ + checkAddressAlignment alignedDoubleVec + , testCase "Aligned Int" $ + checkAddressAlignment alignedIntVec + ] + ] + +alignedDoubleVec :: Storable.Vector (Aligned Double) +alignedDoubleVec = Storable.fromList $ map Aligned [1, 2, 3, 4, 5] + +alignedIntVec :: Storable.Vector (Aligned Int) +alignedIntVec = Storable.fromList $ map Aligned [1, 2, 3, 4, 5] diff --git a/third_party/bazel/rules_haskell/examples/vector/tests/Utilities.hs b/third_party/bazel/rules_haskell/examples/vector/tests/Utilities.hs new file mode 100644 index 000000000000..86a4f2c32462 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/tests/Utilities.hs @@ -0,0 +1,350 @@ +{-# LANGUAGE FlexibleInstances, GADTs #-} +module Utilities where + +import Test.QuickCheck + +import qualified Data.Vector as DV +import qualified Data.Vector.Generic as DVG +import qualified Data.Vector.Primitive as DVP +import qualified Data.Vector.Storable as DVS +import qualified Data.Vector.Unboxed as DVU +import qualified Data.Vector.Fusion.Bundle as S + +import Control.Monad (foldM, foldM_, zipWithM, zipWithM_) +import Control.Monad.Trans.Writer +import Data.Function (on) +import Data.Functor.Identity +import Data.List ( sortBy ) +import Data.Monoid +import Data.Maybe (catMaybes) + +instance Show a => Show (S.Bundle v a) where + show s = "Data.Vector.Fusion.Bundle.fromList " ++ show (S.toList s) + + +instance Arbitrary a => Arbitrary (DV.Vector a) where + arbitrary = fmap DV.fromList arbitrary + +instance CoArbitrary a => CoArbitrary (DV.Vector a) where + coarbitrary = coarbitrary . DV.toList + +instance (Arbitrary a, DVP.Prim a) => Arbitrary (DVP.Vector a) where + arbitrary = fmap DVP.fromList arbitrary + +instance (CoArbitrary a, DVP.Prim a) => CoArbitrary (DVP.Vector a) where + coarbitrary = coarbitrary . DVP.toList + +instance (Arbitrary a, DVS.Storable a) => Arbitrary (DVS.Vector a) where + arbitrary = fmap DVS.fromList arbitrary + +instance (CoArbitrary a, DVS.Storable a) => CoArbitrary (DVS.Vector a) where + coarbitrary = coarbitrary . DVS.toList + +instance (Arbitrary a, DVU.Unbox a) => Arbitrary (DVU.Vector a) where + arbitrary = fmap DVU.fromList arbitrary + +instance (CoArbitrary a, DVU.Unbox a) => CoArbitrary (DVU.Vector a) where + coarbitrary = coarbitrary . DVU.toList + +instance Arbitrary a => Arbitrary (S.Bundle v a) where + arbitrary = fmap S.fromList arbitrary + +instance CoArbitrary a => CoArbitrary (S.Bundle v a) where + coarbitrary = coarbitrary . S.toList + +instance (Arbitrary a, Arbitrary b) => Arbitrary (Writer a b) where + arbitrary = do b <- arbitrary + a <- arbitrary + return $ writer (b,a) + +instance CoArbitrary a => CoArbitrary (Writer a ()) where + coarbitrary = coarbitrary . runWriter + +class (Testable (EqTest a), Conclusion (EqTest a)) => TestData a where + type Model a + model :: a -> Model a + unmodel :: Model a -> a + + type EqTest a + equal :: a -> a -> EqTest a + +instance Eq a => TestData (S.Bundle v a) where + type Model (S.Bundle v a) = [a] + model = S.toList + unmodel = S.fromList + + type EqTest (S.Bundle v a) = Property + equal x y = property (x == y) + +instance Eq a => TestData (DV.Vector a) where + type Model (DV.Vector a) = [a] + model = DV.toList + unmodel = DV.fromList + + type EqTest (DV.Vector a) = Property + equal x y = property (x == y) + +instance (Eq a, DVP.Prim a) => TestData (DVP.Vector a) where + type Model (DVP.Vector a) = [a] + model = DVP.toList + unmodel = DVP.fromList + + type EqTest (DVP.Vector a) = Property + equal x y = property (x == y) + +instance (Eq a, DVS.Storable a) => TestData (DVS.Vector a) where + type Model (DVS.Vector a) = [a] + model = DVS.toList + unmodel = DVS.fromList + + type EqTest (DVS.Vector a) = Property + equal x y = property (x == y) + +instance (Eq a, DVU.Unbox a) => TestData (DVU.Vector a) where + type Model (DVU.Vector a) = [a] + model = DVU.toList + unmodel = DVU.fromList + + type EqTest (DVU.Vector a) = Property + equal x y = property (x == y) + +#define id_TestData(ty) \ +instance TestData ty where { \ + type Model ty = ty; \ + model = id; \ + unmodel = id; \ + \ + type EqTest ty = Property; \ + equal x y = property (x == y) } + +id_TestData(()) +id_TestData(Bool) +id_TestData(Int) +id_TestData(Float) +id_TestData(Double) +id_TestData(Ordering) + +-- Functorish models +-- All of these need UndecidableInstances although they are actually well founded. Oh well. +instance (Eq a, TestData a) => TestData (Maybe a) where + type Model (Maybe a) = Maybe (Model a) + model = fmap model + unmodel = fmap unmodel + + type EqTest (Maybe a) = Property + equal x y = property (x == y) + +instance (Eq a, TestData a) => TestData [a] where + type Model [a] = [Model a] + model = fmap model + unmodel = fmap unmodel + + type EqTest [a] = Property + equal x y = property (x == y) + +instance (Eq a, TestData a) => TestData (Identity a) where + type Model (Identity a) = Identity (Model a) + model = fmap model + unmodel = fmap unmodel + + type EqTest (Identity a) = Property + equal = (property .) . on (==) runIdentity + +instance (Eq a, TestData a, Eq b, TestData b, Monoid a) => TestData (Writer a b) where + type Model (Writer a b) = Writer (Model a) (Model b) + model = mapWriter model + unmodel = mapWriter unmodel + + type EqTest (Writer a b) = Property + equal = (property .) . on (==) runWriter + +instance (Eq a, Eq b, TestData a, TestData b) => TestData (a,b) where + type Model (a,b) = (Model a, Model b) + model (a,b) = (model a, model b) + unmodel (a,b) = (unmodel a, unmodel b) + + type EqTest (a,b) = Property + equal x y = property (x == y) + +instance (Eq a, Eq b, Eq c, TestData a, TestData b, TestData c) => TestData (a,b,c) where + type Model (a,b,c) = (Model a, Model b, Model c) + model (a,b,c) = (model a, model b, model c) + unmodel (a,b,c) = (unmodel a, unmodel b, unmodel c) + + type EqTest (a,b,c) = Property + equal x y = property (x == y) + +instance (Arbitrary a, Show a, TestData a, TestData b) => TestData (a -> b) where + type Model (a -> b) = Model a -> Model b + model f = model . f . unmodel + unmodel f = unmodel . f . model + + type EqTest (a -> b) = a -> EqTest b + equal f g x = equal (f x) (g x) + +newtype P a = P { unP :: EqTest a } + +instance TestData a => Testable (P a) where + property (P a) = property a + +infix 4 `eq` +eq :: TestData a => a -> Model a -> P a +eq x y = P (equal x (unmodel y)) + +class Conclusion p where + type Predicate p + + predicate :: Predicate p -> p -> p + +instance Conclusion Property where + type Predicate Property = Bool + + predicate = (==>) + +instance Conclusion p => Conclusion (a -> p) where + type Predicate (a -> p) = a -> Predicate p + + predicate f p = \x -> predicate (f x) (p x) + +infixr 0 ===> +(===>) :: TestData a => Predicate (EqTest a) -> P a -> P a +p ===> P a = P (predicate p a) + +notNull2 _ xs = not $ DVG.null xs +notNullS2 _ s = not $ S.null s + +-- Generators +index_value_pairs :: Arbitrary a => Int -> Gen [(Int,a)] +index_value_pairs 0 = return [] +index_value_pairs m = sized $ \n -> + do + len <- choose (0,n) + is <- sequence [choose (0,m-1) | i <- [1..len]] + xs <- vector len + return $ zip is xs + +indices :: Int -> Gen [Int] +indices 0 = return [] +indices m = sized $ \n -> + do + len <- choose (0,n) + sequence [choose (0,m-1) | i <- [1..len]] + + +-- Additional list functions +singleton x = [x] +snoc xs x = xs ++ [x] +generate n f = [f i | i <- [0 .. n-1]] +slice i n xs = take n (drop i xs) +backpermute xs is = map (xs!!) is +prescanl f z = init . scanl f z +postscanl f z = tail . scanl f z +prescanr f z = tail . scanr f z +postscanr f z = init . scanr f z + +accum :: (a -> b -> a) -> [a] -> [(Int,b)] -> [a] +accum f xs ps = go xs ps' 0 + where + ps' = sortBy (\p q -> compare (fst p) (fst q)) ps + + go (x:xs) ((i,y) : ps) j + | i == j = go (f x y : xs) ps j + go (x:xs) ps j = x : go xs ps (j+1) + go [] _ _ = [] + +(//) :: [a] -> [(Int, a)] -> [a] +xs // ps = go xs ps' 0 + where + ps' = sortBy (\p q -> compare (fst p) (fst q)) ps + + go (x:xs) ((i,y) : ps) j + | i == j = go (y:xs) ps j + go (x:xs) ps j = x : go xs ps (j+1) + go [] _ _ = [] + + +withIndexFirst m f = m (uncurry f) . zip [0..] + +imap :: (Int -> a -> a) -> [a] -> [a] +imap = withIndexFirst map + +imapM :: Monad m => (Int -> a -> m a) -> [a] -> m [a] +imapM = withIndexFirst mapM + +imapM_ :: Monad m => (Int -> a -> m b) -> [a] -> m () +imapM_ = withIndexFirst mapM_ + +izipWith :: (Int -> a -> a -> a) -> [a] -> [a] -> [a] +izipWith = withIndexFirst zipWith + +izipWithM :: Monad m => (Int -> a -> a -> m a) -> [a] -> [a] -> m [a] +izipWithM = withIndexFirst zipWithM + +izipWithM_ :: Monad m => (Int -> a -> a -> m b) -> [a] -> [a] -> m () +izipWithM_ = withIndexFirst zipWithM_ + +izipWith3 :: (Int -> a -> a -> a -> a) -> [a] -> [a] -> [a] -> [a] +izipWith3 = withIndexFirst zipWith3 + +ifilter :: (Int -> a -> Bool) -> [a] -> [a] +ifilter f = map snd . withIndexFirst filter f + +mapMaybe :: (a -> Maybe b) -> [a] -> [b] +mapMaybe f = catMaybes . map f + +imapMaybe :: (Int -> a -> Maybe b) -> [a] -> [b] +imapMaybe f = catMaybes . withIndexFirst map f + +indexedLeftFold fld f z = fld (uncurry . f) z . zip [0..] + +ifoldl :: (a -> Int -> a -> a) -> a -> [a] -> a +ifoldl = indexedLeftFold foldl + +iscanl :: (Int -> a -> b -> a) -> a -> [b] -> [a] +iscanl f z = scanl (\a (i, b) -> f i a b) z . zip [0..] + +iscanr :: (Int -> a -> b -> b) -> b -> [a] -> [b] +iscanr f z = scanr (uncurry f) z . zip [0..] + +ifoldr :: (Int -> a -> b -> b) -> b -> [a] -> b +ifoldr f z = foldr (uncurry f) z . zip [0..] + +ifoldM :: Monad m => (a -> Int -> a -> m a) -> a -> [a] -> m a +ifoldM = indexedLeftFold foldM + +ifoldM_ :: Monad m => (b -> Int -> a -> m b) -> b -> [a] -> m () +ifoldM_ = indexedLeftFold foldM_ + +minIndex :: Ord a => [a] -> Int +minIndex = fst . foldr1 imin . zip [0..] + where + imin (i,x) (j,y) | x <= y = (i,x) + | otherwise = (j,y) + +maxIndex :: Ord a => [a] -> Int +maxIndex = fst . foldr1 imax . zip [0..] + where + imax (i,x) (j,y) | x >= y = (i,x) + | otherwise = (j,y) + +iterateNM :: Monad m => Int -> (a -> m a) -> a -> m [a] +iterateNM n f x + | n <= 0 = return [] + | n == 1 = return [x] + | otherwise = do x' <- f x + xs <- iterateNM (n-1) f x' + return (x : xs) + +unfoldrM :: Monad m => (b -> m (Maybe (a,b))) -> b -> m [a] +unfoldrM step b0 = do + r <- step b0 + case r of + Nothing -> return [] + Just (a,b) -> do as <- unfoldrM step b + return (a : as) + + +limitUnfolds f (theirs, ours) + | ours >= 0 + , Just (out, theirs') <- f theirs = Just (out, (theirs', ours - 1)) + | otherwise = Nothing diff --git a/third_party/bazel/rules_haskell/examples/vector/vector.cabal b/third_party/bazel/rules_haskell/examples/vector/vector.cabal new file mode 100644 index 000000000000..013d522b2cb4 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/vector.cabal @@ -0,0 +1,251 @@ +Name: vector +Version: 0.12.0.1 +x-revision: 2 +-- don't forget to update the changelog file! +License: BSD3 +License-File: LICENSE +Author: Roman Leshchinskiy <rl@cse.unsw.edu.au> +Maintainer: Haskell Libraries Team <libraries@haskell.org> +Copyright: (c) Roman Leshchinskiy 2008-2012 +Homepage: https://github.com/haskell/vector +Bug-Reports: https://github.com/haskell/vector/issues +Category: Data, Data Structures +Synopsis: Efficient Arrays +Description: + . + An efficient implementation of Int-indexed arrays (both mutable + and immutable), with a powerful loop optimisation framework . + . + It is structured as follows: + . + ["Data.Vector"] Boxed vectors of arbitrary types. + . + ["Data.Vector.Unboxed"] Unboxed vectors with an adaptive + representation based on data type families. + . + ["Data.Vector.Storable"] Unboxed vectors of 'Storable' types. + . + ["Data.Vector.Primitive"] Unboxed vectors of primitive types as + defined by the @primitive@ package. "Data.Vector.Unboxed" is more + flexible at no performance cost. + . + ["Data.Vector.Generic"] Generic interface to the vector types. + . + There is also a (draft) tutorial on common uses of vector. + . + * <http://haskell.org/haskellwiki/Numeric_Haskell:_A_Vector_Tutorial> + +Tested-With: + GHC == 7.4.2, + GHC == 7.6.3, + GHC == 7.8.4, + GHC == 7.10.3, + GHC == 8.0.1 + +Cabal-Version: >=1.10 +Build-Type: Simple + +Extra-Source-Files: + changelog + README.md + tests/LICENSE + tests/Setup.hs + tests/Main.hs + benchmarks/vector-benchmarks.cabal + benchmarks/LICENSE + benchmarks/Setup.hs + benchmarks/Main.hs + benchmarks/Algo/AwShCC.hs + benchmarks/Algo/HybCC.hs + benchmarks/Algo/Leaffix.hs + benchmarks/Algo/ListRank.hs + benchmarks/Algo/Quickhull.hs + benchmarks/Algo/Rootfix.hs + benchmarks/Algo/Spectral.hs + benchmarks/Algo/Tridiag.hs + benchmarks/TestData/Graph.hs + benchmarks/TestData/ParenTree.hs + benchmarks/TestData/Random.hs + changelog + internal/GenUnboxTuple.hs + internal/unbox-tuple-instances + +Flag BoundsChecks + Description: Enable bounds checking + Default: True + Manual: True + +Flag UnsafeChecks + Description: Enable bounds checking in unsafe operations at the cost of a + significant performance penalty + Default: False + Manual: True + +Flag InternalChecks + Description: Enable internal consistency checks at the cost of a + significant performance penalty + Default: False + Manual: True + +Flag Wall + Description: Enable all -Wall warnings + Default: False + Manual: True + +Library + Default-Language: Haskell2010 + Other-Extensions: + BangPatterns + CPP + DeriveDataTypeable + ExistentialQuantification + FlexibleContexts + FlexibleInstances + GADTs + KindSignatures + MagicHash + MultiParamTypeClasses + Rank2Types + ScopedTypeVariables + StandaloneDeriving + TypeFamilies + + Exposed-Modules: + Data.Vector.Internal.Check + + Data.Vector.Fusion.Util + Data.Vector.Fusion.Stream.Monadic + Data.Vector.Fusion.Bundle.Size + Data.Vector.Fusion.Bundle.Monadic + Data.Vector.Fusion.Bundle + + Data.Vector.Generic.Mutable.Base + Data.Vector.Generic.Mutable + Data.Vector.Generic.Base + Data.Vector.Generic.New + Data.Vector.Generic + + Data.Vector.Primitive.Mutable + Data.Vector.Primitive + + Data.Vector.Storable.Internal + Data.Vector.Storable.Mutable + Data.Vector.Storable + + Data.Vector.Unboxed.Base + Data.Vector.Unboxed.Mutable + Data.Vector.Unboxed + + Data.Vector.Mutable + Data.Vector + + Include-Dirs: + include, internal + + Install-Includes: + vector.h + + Build-Depends: base >= 4.5 && < 4.12 + , primitive >= 0.5.0.1 && < 0.7 + , ghc-prim >= 0.2 && < 0.6 + , deepseq >= 1.1 && < 1.5 + if !impl(ghc > 8.0) + Build-Depends: semigroups >= 0.18 && < 0.19 + + Ghc-Options: -O2 -Wall + + if !flag(Wall) + Ghc-Options: -fno-warn-orphans + + if impl(ghc >= 8.0) && impl(ghc < 8.1) + Ghc-Options: -Wno-redundant-constraints + + if flag(BoundsChecks) + cpp-options: -DVECTOR_BOUNDS_CHECKS + + if flag(UnsafeChecks) + cpp-options: -DVECTOR_UNSAFE_CHECKS + + if flag(InternalChecks) + cpp-options: -DVECTOR_INTERNAL_CHECKS + +source-repository head + type: git + location: https://github.com/haskell/vector.git + + + +test-suite vector-tests-O0 + Default-Language: Haskell2010 + type: exitcode-stdio-1.0 + Main-Is: Main.hs + + other-modules: Boilerplater + Tests.Bundle + Tests.Move + Tests.Vector + Tests.Vector.UnitTests + Utilities + + hs-source-dirs: tests + Build-Depends: base >= 4.5 && < 5, template-haskell, vector, + random, + QuickCheck >= 2.9 && < 2.10 , HUnit, test-framework, + test-framework-hunit, test-framework-quickcheck2, + transformers >= 0.2.0.0 + + default-extensions: CPP, + ScopedTypeVariables, + PatternGuards, + MultiParamTypeClasses, + FlexibleContexts, + Rank2Types, + TypeSynonymInstances, + TypeFamilies, + TemplateHaskell + + Ghc-Options: -O0 + Ghc-Options: -Wall + + if !flag(Wall) + Ghc-Options: -fno-warn-orphans -fno-warn-missing-signatures + if impl(ghc >= 8.0) && impl( ghc < 8.1) + Ghc-Options: -Wno-redundant-constraints + + +test-suite vector-tests-O2 + Default-Language: Haskell2010 + type: exitcode-stdio-1.0 + Main-Is: Main.hs + + other-modules: Boilerplater + Tests.Bundle + Tests.Move + Tests.Vector + Tests.Vector.UnitTests + Utilities + + hs-source-dirs: tests + Build-Depends: base >= 4.5 && < 5, template-haskell, vector, + random, + QuickCheck >= 2.9 && < 2.10 , HUnit, test-framework, + test-framework-hunit, test-framework-quickcheck2, + transformers >= 0.2.0.0 + + default-extensions: CPP, + ScopedTypeVariables, + PatternGuards, + MultiParamTypeClasses, + FlexibleContexts, + Rank2Types, + TypeSynonymInstances, + TypeFamilies, + TemplateHaskell + + Ghc-Options: -O2 -Wall + + if !flag(Wall) + Ghc-Options: -fno-warn-orphans -fno-warn-missing-signatures + if impl(ghc >= 8.0) && impl(ghc < 8.1) + Ghc-Options: -Wno-redundant-constraints + diff --git a/third_party/bazel/rules_haskell/haskell/BUILD.bazel b/third_party/bazel/rules_haskell/haskell/BUILD.bazel new file mode 100644 index 000000000000..a51dc5af1191 --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/BUILD.bazel @@ -0,0 +1,46 @@ +exports_files( + glob(["*.bzl"]) + [ + "assets/ghci_script", + "private/ghci_repl_wrapper.sh", + "private/haddock_wrapper.sh.tpl", + "private/coverage_wrapper.sh.tpl", + "private/osx_cc_wrapper.sh.tpl", + ], +) + +# to make functions visible to unit tests +exports_files( + ["private/actions/link.bzl"], + visibility = ["//tests/unit-tests:__pkg__"], +) + +py_binary( + name = "ls_modules", + srcs = ["private/ls_modules.py"], + visibility = ["//visibility:public"], +) + +py_binary( + name = "version_macros", + srcs = ["private/version_macros.py"], + visibility = ["//visibility:public"], +) + +# generate the _GHC_BINDISTS dict +py_binary( + name = "gen-ghc-bindist", + srcs = [":gen_ghc_bindist.py"], + main = ":gen_ghc_bindist.py", + visibility = ["//visibility:public"], +) + +# toolchains must have a valid toolchain_type from bazel 0.21 +toolchain_type( + name = "toolchain", + visibility = ["//visibility:public"], +) + +toolchain_type( + name = "doctest-toolchain", + visibility = ["//visibility:public"], +) diff --git a/third_party/bazel/rules_haskell/haskell/CROSSTOOL.windows b/third_party/bazel/rules_haskell/haskell/CROSSTOOL.windows new file mode 100644 index 000000000000..ae167769581e --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/CROSSTOOL.windows @@ -0,0 +1,49 @@ +major_version: "local" +minor_version: "" + +toolchain { + toolchain_identifier: "ghc_windows_mingw64" + abi_version: "local" + abi_libc_version: "local" + builtin_sysroot: "" + compiler: "ghc-mingw-gcc" + host_system_name: "local" + needsPic: false + target_libc: "mingw" + target_cpu: "x64_windows" + target_system_name: "local" + + artifact_name_pattern { + category_name: 'executable' + prefix: '' + extension: '.exe' + } + + tool_path { name: "ar" path: "mingw/bin/ar" } + tool_path { name: "compat-ld" path: "mingw/bin/ld" } + tool_path { name: "cpp" path: "mingw/bin/cpp" } + tool_path { name: "dwp" path: "mingw/bin/dwp" } + tool_path { name: "gcc" path: "mingw/bin/gcc" } + tool_path { name: "gcov" path: "mingw/bin/gcov" } + tool_path { name: "ld" path: "mingw/bin/ld" } + tool_path { name: "nm" path: "mingw/bin/nm" } + tool_path { name: "objcopy" path: "mingw/bin/objcopy" } + tool_path { name: "objdump" path: "mingw/bin/objdump" } + tool_path { name: "strip" path: "mingw/bin/strip" } + cxx_builtin_include_directory: "mingw" + cxx_flag: "-std=gnu++0x" + + # Needed to prevent Bazel from complaining about undeclared inclusions of + # MingW headers. + # + # See: https://github.com/bazelbuild/bazel/issues/4605 + unfiltered_cxx_flag: "-no-canonical-prefixes" + unfiltered_cxx_flag: "-fno-canonical-system-headers" + + linker_flag: "-lstdc++" + objcopy_embed_flag: "-I" + objcopy_embed_flag: "binary" + feature { name: "targets_windows" implies: "copy_dynamic_libraries_to_binary" enabled: true } + feature { name: "copy_dynamic_libraries_to_binary" } + linking_mode_flags { mode: DYNAMIC } +} diff --git a/third_party/bazel/rules_haskell/haskell/assets/ghc_8_6_2_win_base.patch b/third_party/bazel/rules_haskell/haskell/assets/ghc_8_6_2_win_base.patch new file mode 100644 index 000000000000..9e47363f25dc --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/assets/ghc_8_6_2_win_base.patch @@ -0,0 +1,11 @@ +--- lib/package.conf.d/base-4.12.0.0.conf 2019-03-19 18:04:35.186653529 +0100 ++++ lib/package.conf.d/base-4.12.0.0.conf 2019-03-19 18:04:48.958873769 +0100 +@@ -79,7 +79,7 @@ + data-dir: $topdir\x86_64-windows-ghc-8.6.2\base-4.12.0.0 + hs-libraries: HSbase-4.12.0.0 + extra-libraries: +- wsock32 user32 shell32 msvcrt mingw32 mingwex ++ wsock32 user32 shell32 msvcrt mingw32 mingwex shlwapi + include-dirs: $topdir\base-4.12.0.0\include + includes: + HsBase.h diff --git a/third_party/bazel/rules_haskell/haskell/assets/ghc_8_6_4_win_base.patch b/third_party/bazel/rules_haskell/haskell/assets/ghc_8_6_4_win_base.patch new file mode 100644 index 000000000000..9fe008ebb784 --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/assets/ghc_8_6_4_win_base.patch @@ -0,0 +1,11 @@ +--- lib/package.conf.d/base-4.12.0.0.conf 2019-03-20 12:24:30.857292020 +0100 ++++ lib/package.conf.d/base-4.12.0.0.conf 2019-03-20 12:24:44.637400564 +0100 +@@ -79,7 +79,7 @@ + data-dir: $topdir\x86_64-windows-ghc-8.6.4\base-4.12.0.0 + hs-libraries: HSbase-4.12.0.0 + extra-libraries: +- wsock32 user32 shell32 msvcrt mingw32 mingwex ++ wsock32 user32 shell32 msvcrt mingw32 mingwex shlwapi + include-dirs: $topdir\base-4.12.0.0\include + includes: + HsBase.h diff --git a/third_party/bazel/rules_haskell/haskell/assets/ghci_script b/third_party/bazel/rules_haskell/haskell/assets/ghci_script new file mode 100644 index 000000000000..ddf9e7917482 --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/assets/ghci_script @@ -0,0 +1,39 @@ +:add {ADD_SOURCES} +:module + System.IO GHC.IO.Handle Control.Exception System.Directory +import qualified GHC.IO.Handle as Handle +import qualified System.IO as IO +import qualified System.Directory as Dir +rules_haskell_stdout_dupe <- Handle.hDuplicate IO.stdout +:{ +(rules_haskell_stdout_copy_file, rules_haskell_stdout_copy_h) <- do + rules_haskell_tmp_dir <- Dir.getTemporaryDirectory Prelude.>>= Dir.canonicalizePath + (rules_haskell_fn, rules_haskell_h) <- IO.openTempFile rules_haskell_tmp_dir "rules-haskell-ghci-repl" + Handle.hDuplicateTo rules_haskell_h IO.stdout + Prelude.return (rules_haskell_fn, rules_haskell_h) +:} +:show modules +:{ +rules_haskell_loaded_modules <- do + Handle.hClose rules_haskell_stdout_copy_h + -- I had to do it like this because flushing and then searching in the + -- stream at offset 0 did not work (no data is there, although the + -- corresponding file certainly contained it after flushing). Couldn't + -- figure this one out, so we first close the file and then read from it. + rules_haskell_h <- IO.openFile rules_haskell_stdout_copy_file IO.ReadMode + rules_haskell_xs <- Handle.hGetContents rules_haskell_h + Dir.removeFile rules_haskell_stdout_copy_file + Prelude.return Prelude.$ Prelude.takeWhile (Prelude./= ' ') Prelude.<$> Prelude.lines rules_haskell_xs +:} +hDuplicateTo rules_haskell_stdout_dupe IO.stdout +:{ +let rules_haskell_add_loaded_modules _ = + Prelude.return Prelude.$ ":module + " Prelude.++ + Data.List.intercalate " " (("*" Prelude.++) Prelude.<$> rules_haskell_loaded_modules) +:} +:module - System.IO GHC.IO.Handle Control.Exception System.Directory +:def rules_haskell_add_loaded_modules rules_haskell_add_loaded_modules +:rules_haskell_add_loaded_modules +:undef rules_haskell_add_loaded_modules +-- reload modules to drop the rules_haskell* definitions +:reload +{COMMANDS} diff --git a/third_party/bazel/rules_haskell/haskell/c2hs.bzl b/third_party/bazel/rules_haskell/haskell/c2hs.bzl new file mode 100644 index 000000000000..5dcf4a2cf31d --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/c2hs.bzl @@ -0,0 +1,183 @@ +"""Support for c2hs""" + +load("@bazel_skylib//lib:paths.bzl", "paths") +load( + "@io_tweag_rules_haskell//haskell:providers.bzl", + "C2hsLibraryInfo", + "HaskellInfo", +) +load(":cc.bzl", "cc_interop_info") +load(":private/context.bzl", "haskell_context") +load(":private/dependencies.bzl", "gather_dep_info") +load( + ":private/path_utils.bzl", + "declare_compiled", + "target_unique_name", +) +load(":private/set.bzl", "set") +load(":private/version_macros.bzl", "version_macro_includes") + +def _c2hs_library_impl(ctx): + hs = haskell_context(ctx) + + cc = cc_interop_info(ctx) + args = hs.actions.args() + c2hs = ctx.toolchains["@io_tweag_rules_haskell//haskell/c2hs:toolchain"].c2hs + + if len(ctx.files.srcs) != 1: + fail("srcs field should contain exactly one file.") + chs_file = ctx.files.srcs[0] + + # Output a Haskell source file. + chs_dir_raw = target_unique_name(hs, "chs") + hs_file = declare_compiled(hs, chs_file, ".hs", directory = chs_dir_raw) + chi_file = declare_compiled(hs, chs_file, ".chi", directory = chs_dir_raw) + args.add_all([chs_file.path, "-o", hs_file.path]) + + args.add("-C-E") + args.add_all(["--cpp", cc.tools.cpp]) + args.add("-C-includeghcplatform.h") + args.add("-C-includeghcversion.h") + args.add_all(["-C" + x for x in cc.cpp_flags]) + args.add_all(["-C" + x for x in cc.include_args]) + + dep_chi_files = [ + dep[C2hsLibraryInfo].chi_file + for dep in ctx.attr.deps + if C2hsLibraryInfo in dep + ] + + chi_includes = [ + "-i" + dep[C2hsLibraryInfo].import_dir + for dep in ctx.attr.deps + if C2hsLibraryInfo in dep + ] + args.add_all(chi_includes) + + version_macro_headers = set.empty() + if ctx.attr.version: + dep_info = gather_dep_info(ctx, ctx.attr.deps) + (version_macro_headers, version_macro_flags) = version_macro_includes(dep_info) + args.add_all(["-C" + x for x in version_macro_flags]) + + hs.actions.run_shell( + inputs = depset(transitive = [ + depset(cc.hdrs), + depset([hs.tools.ghc, c2hs, chs_file]), + depset(dep_chi_files), + depset(cc.files), + set.to_depset(version_macro_headers), + ]), + outputs = [hs_file, chi_file], + command = """ + # Include libdir in include path just like hsc2hs does. + libdir=$({ghc} --print-libdir) + {c2hs} -C-I$libdir/include "$@" + """.format( + ghc = hs.tools.ghc.path, + c2hs = c2hs.path, + ), + mnemonic = "HaskellC2Hs", + arguments = [args], + env = hs.env, + ) + + idir = paths.join( + hs.bin_dir.path, + hs.label.workspace_root, + hs.label.package, + chs_dir_raw, + ) + + return [ + DefaultInfo(files = depset([hs_file])), + C2hsLibraryInfo( + chi_file = chi_file, + import_dir = idir, + ), + ] + +c2hs_library = rule( + _c2hs_library_impl, + attrs = { + "deps": attr.label_list(), + "srcs": attr.label_list(allow_files = [".chs"]), + "src_strip_prefix": attr.string( + doc = "Directory in which module hierarchy starts.", + ), + "version": attr.string( + doc = "Executable version. If this is specified, CPP version macros will be generated for this build.", + ), + "_cc_toolchain": attr.label( + default = Label("@bazel_tools//tools/cpp:current_cc_toolchain"), + ), + }, + toolchains = [ + "@io_tweag_rules_haskell//haskell:toolchain", + "@io_tweag_rules_haskell//haskell/c2hs:toolchain", + ], +) + +def _c2hs_toolchain_impl(ctx): + return [ + platform_common.ToolchainInfo( + name = ctx.label.name, + c2hs = ctx.file.c2hs, + ), + ] + +_c2hs_toolchain = rule( + _c2hs_toolchain_impl, + attrs = { + "c2hs": attr.label( + doc = "The c2hs executable.", + mandatory = True, + allow_single_file = True, + ), + }, +) + +def c2hs_toolchain(name, c2hs, **kwargs): + """Declare a Haskell c2hs toolchain. + + You need at least one of these declared somewhere in your `BUILD` + files for the `chs_library` rule to work. Once declared, you then + need to *register* the toolchain using `register_toolchains` in + your `WORKSPACE` file (see example below). + + Example: + + In a `BUILD` file: + + ```bzl + c2hs_toolchain( + name = "c2hs", + c2hs = "@c2hs//:bin", + ) + ``` + + where `@c2hs` is an external repository defined in the + `WORKSPACE`, e.g. using: + + ```bzl + nixpkgs_package( + name = "c2hs", + attribute_path = "haskell.packages.ghc822.c2hs", + ) + + register_toolchains("//:c2hs") + ``` + """ + impl_name = name + "-impl" + _c2hs_toolchain( + name = impl_name, + c2hs = c2hs, + visibility = ["//visibility:public"], + **kwargs + ) + + native.toolchain( + name = name, + toolchain_type = "@io_tweag_rules_haskell//haskell/c2hs:toolchain", + toolchain = ":" + impl_name, + ) diff --git a/third_party/bazel/rules_haskell/haskell/c2hs/BUILD.bazel b/third_party/bazel/rules_haskell/haskell/c2hs/BUILD.bazel new file mode 100644 index 000000000000..17305e6e3761 --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/c2hs/BUILD.bazel @@ -0,0 +1,4 @@ +toolchain_type( + name = "toolchain", + visibility = ["//visibility:public"], +) diff --git a/third_party/bazel/rules_haskell/haskell/cc.bzl b/third_party/bazel/rules_haskell/haskell/cc.bzl new file mode 100644 index 000000000000..1ec803764aab --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/cc.bzl @@ -0,0 +1,353 @@ +"""Interop with cc_* rules + +These rules are deprecated. +""" + +load("@bazel_tools//tools/cpp:toolchain_utils.bzl", "find_cpp_toolchain") +load( + "@bazel_tools//tools/build_defs/cc:action_names.bzl", + "CPP_LINK_DYNAMIC_LIBRARY_ACTION_NAME", + "C_COMPILE_ACTION_NAME", +) +load(":private/path_utils.bzl", "ln") +load("@bazel_skylib//lib:paths.bzl", "paths") +load(":private/set.bzl", "set") +load( + "@io_tweag_rules_haskell//haskell:providers.bzl", + "HaskellInfo", +) + +CcInteropInfo = provider( + doc = "Information needed for interop with cc rules.", + fields = { + "tools": "Tools from the CC toolchain", + # See the following for why this is needed: + # https://stackoverflow.com/questions/52769846/custom-c-rule-with-the-cc-common-api + "files": "Files for all tools (input to any action that uses tools)", + "hdrs": "CC headers", + "cpp_flags": "Preprocessor flags", + "compiler_flags": "Flags for compilation", + "linker_flags": "Flags to forward to the linker", + "include_args": "Extra include dirs", + }, +) + +def cc_interop_info(ctx): + """Gather information from any CC dependencies. + + *Internal function - do not use.* + + Args: + ctx: Rule context. + + Returns: + CcInteropInfo: Information needed for CC interop. + """ + ccs = [dep[CcInfo] for dep in ctx.attr.deps if CcInfo in dep and HaskellInfo not in dep] + + hdrs = [] + include_args = [] + cpp_flags = [] + for cc in ccs: + cc_ctx = cc.compilation_context + hdrs.append(cc_ctx.headers) + include_args.extend(["-I" + include for include in cc_ctx.includes]) + cpp_flags.extend( + [ + "-D" + define + for define in cc_ctx.defines + ] + [ + f + for include in cc_ctx.quote_includes + for f in ["-iquote", include] + ] + [ + f + for include in cc_ctx.system_includes + for f in ["-isystem", include] + ], + ) + + hdrs = depset(transitive = hdrs) + + # XXX Workaround https://github.com/bazelbuild/bazel/issues/6874. + # Should be find_cpp_toolchain() instead. + cc_toolchain = ctx.attr._cc_toolchain[cc_common.CcToolchainInfo] + feature_configuration = cc_common.configure_features( + cc_toolchain = cc_toolchain, + requested_features = ctx.features, + unsupported_features = ctx.disabled_features, + ) + compile_variables = cc_common.create_compile_variables( + feature_configuration = feature_configuration, + cc_toolchain = cc_toolchain, + ) + compiler_flags = cc_common.get_memory_inefficient_command_line( + feature_configuration = feature_configuration, + action_name = C_COMPILE_ACTION_NAME, + variables = compile_variables, + ) + link_variables = cc_common.create_link_variables( + feature_configuration = feature_configuration, + cc_toolchain = cc_toolchain, + is_linking_dynamic_library = False, + is_static_linking_mode = True, + ) + linker_flags = cc_common.get_memory_inefficient_command_line( + feature_configuration = feature_configuration, + action_name = CPP_LINK_DYNAMIC_LIBRARY_ACTION_NAME, + variables = link_variables, + ) + + # Generate cc wrapper script on Darwin that adjusts load commands. + hs_toolchain = ctx.toolchains["@io_tweag_rules_haskell//haskell:toolchain"] + if hs_toolchain.is_darwin: + cc_wrapper = ctx.actions.declare_file("osx_cc_wrapper") + cc = cc_wrapper.path + ctx.actions.expand_template( + template = hs_toolchain.osx_cc_wrapper_tpl, + output = cc_wrapper, + substitutions = { + "%{cc}": cc_toolchain.compiler_executable(), + }, + ) + cc_files = ctx.files._cc_toolchain + [ + cc_wrapper, + ] + else: + cc = cc_toolchain.compiler_executable() + cc_files = ctx.files._cc_toolchain + + # XXX Workaround https://github.com/bazelbuild/bazel/issues/6876. + linker_flags = [flag for flag in linker_flags if flag not in ["-shared"]] + + tools = { + "ar": cc_toolchain.ar_executable(), + "cc": cc, + "ld": cc_toolchain.ld_executable(), + "cpp": cc_toolchain.preprocessor_executable(), + "nm": cc_toolchain.nm_executable(), + } + + # If running on darwin but XCode is not installed (i.e., only the Command + # Line Tools are available), then Bazel will make ar_executable point to + # "/usr/bin/libtool". Since we call ar directly, override it. + # TODO: remove this if Bazel fixes its behavior. + # Upstream ticket: https://github.com/bazelbuild/bazel/issues/5127. + if tools["ar"].find("libtool") >= 0: + tools["ar"] = "/usr/bin/ar" + + return CcInteropInfo( + tools = struct(**tools), + files = cc_files, + hdrs = hdrs.to_list(), + cpp_flags = cpp_flags, + include_args = include_args, + compiler_flags = compiler_flags, + # XXX this might not be the right set of flags for all situations, + # but this will anyways all be replaced (once implemented) by + # https://github.com/bazelbuild/bazel/issues/4571. + linker_flags = linker_flags, + ) + +def _cc_import_impl(ctx): + strip_prefix = ctx.attr.strip_include_prefix + + # cc_library's strip_include_prefix attribute accepts both absolute and + # relative paths. For simplicity we currently only implement absolute + # paths. + if strip_prefix.startswith("/"): + prefix = strip_prefix[1:] + else: + prefix = paths.join(ctx.label.workspace_root, ctx.label.package, strip_prefix) + + roots = set.empty() + for f in ctx.files.hdrs: + # If it's a generated file, strip off the bin or genfiles prefix. + path = f.path + if path.startswith(ctx.bin_dir.path): + path = paths.relativize(path, ctx.bin_dir.path) + elif path.startswith(ctx.genfiles_dir.path): + path = paths.relativize(path, ctx.genfiles_dir.path) + + if not path.startswith(prefix): + fail("Header {} does not have expected prefix {}".format( + path, + prefix, + )) + roots = set.insert(roots, f.root.path if f.root.path else ".") + + include_directories = [paths.join(root, prefix) for root in set.to_list(roots)] + + cc_toolchain = ctx.attr._cc_toolchain[cc_common.CcToolchainInfo] + feature_configuration = cc_common.configure_features(cc_toolchain = cc_toolchain) + + compilation_context = cc_common.create_compilation_context( + headers = depset(transitive = [l.files for l in ctx.attr.hdrs]), + includes = depset(direct = include_directories), + ) + linking_context = cc_common.create_linking_context( + libraries_to_link = [ + cc_common.create_library_to_link( + actions = ctx.actions, + feature_configuration = feature_configuration, + cc_toolchain = cc_toolchain, + dynamic_library = f, + ) + for f in ctx.attr.shared_library.files + ], + ) + + return [ + CcInfo( + compilation_context = compilation_context, + linking_context = linking_context, + ), + ] + +haskell_cc_import = rule( + _cc_import_impl, + attrs = { + "shared_library": attr.label( + # NOTE We do not list all extensions here because .so libraries may + # have numeric suffixes like foo.so.1.2.3, and if they also have + # SONAME with numeric suffix, matching file must be provided, so this + # attributes must accept libraries with almost arbitrary extensions. + # It would be easier if Skylark supported regexps. + allow_files = True, + doc = """A single precompiled shared library. + +Bazel ensures it is available to the binary that depends on it +during runtime. +""", + ), + "hdrs": attr.label_list( + allow_files = [".h"], + doc = """ + +The list of header files published by this precompiled library to be +directly included by sources in dependent rules. +""", + ), + "strip_include_prefix": attr.string( + doc = """ +The prefix to strip from the paths of the headers of this rule. +When set, the headers in the `hdrs` attribute of this rule are +accessible at their path (relative to the repository) with this +prefix cut off. + +If it's a relative path, it's taken as a package-relative one. If it's an +absolute one, it's understood as a repository-relative path. +""", + ), + "_cc_toolchain": attr.label( + default = Label("@bazel_tools//tools/cpp:current_cc_toolchain"), + ), + }, +) +"""Imports a prebuilt shared library. + +Use this to make `.so`, `.dll`, `.dylib` files residing in external +[external repositories][bazel-ext-repos] available to Haskell rules. + +*This rule is temporary replacement for [cc_import][cc_import] and is +deprecated. Use [cc_library][cc_library] instead as shown in the example.* + +Example: + ```bzl + # Deprecated, use cc_library instead. + # haskell_cc_import(name = "zlib", shared_library = "@zlib//:lib") + + cc_library(name = "zlib", srcs = ["@zlib//:lib"]) + + haskell_import( + name = "base_pkg", + package = "base", + ) + + haskell_binary( + name = "crc32sum", + srcs = ["Main.hs"], + deps = [ + "bazel_pkg", + ":zlib", + ], + ) + ``` + +[bazel-ext-repos]: https://docs.bazel.build/versions/master/external.html +[cc_import]: https://docs.bazel.build/versions/master/be/c-cpp.html#cc_import +[cc_library]: https://docs.bazel.build/versions/master/be/c-cpp.html#cc_library +""" + +def _cc_haskell_import(ctx): + dyn_libs = set.empty() + + if HaskellInfo in ctx.attr.dep: + set.mutable_union(dyn_libs, ctx.attr.dep[HaskellInfo].dynamic_libraries) + else: + fail("{0} has to provide `HaskellInfo`".format(ctx.attr.dep.label.name)) + + return [ + DefaultInfo( + files = set.to_depset(dyn_libs), + default_runfiles = ctx.runfiles( + files = ctx.attr.dep.default_runfiles.files.to_list(), + collect_default = True, + ), + data_runfiles = ctx.runfiles( + files = ctx.attr.dep.data_runfiles.files.to_list(), + collect_data = True, + ), + ), + ] + +cc_haskell_import = rule( + _cc_haskell_import, + attrs = { + "dep": attr.label( + doc = """ +Target providing a `HaskellInfo` such as `haskell_library` or +`haskell_binary`. +""", + ), + }, + toolchains = ["@io_tweag_rules_haskell//haskell:toolchain"], +) +"""Exports a Haskell library as a CC library. + +Given a [haskell_library](#haskell_library) or +[haskell_binary](#haskell_binary) input, outputs the shared object files +produced as well as the object files it depends on directly and +transitively. This is very useful if you want to link in a Haskell shared +library from `cc_library`. + +There is a caveat: this will not provide any shared libraries that +aren't explicitly given to it. This means that if you're using +`prebuilt_dependencies` and relying on GHC to provide those objects, +they will not be present here. You will have to provide those +separately to your `cc_library`. If you're getting +`prebuilt_dependencies` from your toolchain, you will likely want to +extract those and pass them in as well. + +*This rule is deprecated.* + +Example: + ```bzl + haskell_library( + name = "my-lib", + ... + ) + + cc_haskell_import( + name = "my-lib-objects", + dep = ":my-lib", + ) + + cc_library( + name = "my-cc", + srcs = ["main.c", ":my-lib-objects"], + ) + ``` + +[bazel-cpp-sandwich]: https://github.com/bazelbuild/bazel/issues/2163 +""" diff --git a/third_party/bazel/rules_haskell/haskell/doctest.bzl b/third_party/bazel/rules_haskell/haskell/doctest.bzl new file mode 100644 index 000000000000..dec00a5d758f --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/doctest.bzl @@ -0,0 +1,228 @@ +"""Doctest support""" + +load("@bazel_skylib//lib:dicts.bzl", "dicts") +load("@bazel_skylib//lib:paths.bzl", "paths") +load(":private/context.bzl", "haskell_context", "render_env") +load( + ":private/path_utils.bzl", + "get_lib_name", +) +load(":providers.bzl", "get_libs_for_ghc_linker") +load(":private/set.bzl", "set") +load( + "@io_tweag_rules_haskell//haskell:providers.bzl", + "HaskellInfo", + "HaskellLibraryInfo", +) + +def _doctest_toolchain_impl(ctx): + return platform_common.ToolchainInfo( + name = ctx.label.name, + doctest = ctx.files.doctest, + ) + +_doctest_toolchain = rule( + _doctest_toolchain_impl, + attrs = { + "doctest": attr.label( + doc = "Doctest executable", + cfg = "host", + executable = True, + allow_single_file = True, + mandatory = True, + ), + }, +) + +def haskell_doctest_toolchain(name, doctest, **kwargs): + """Declare a toolchain for the `haskell_doctest` rule. + + You need at least one of these declared somewhere in your `BUILD`files + for `haskell_doctest` to work. Once declared, you then need to *register* + the toolchain using `register_toolchains` in your `WORKSPACE` file. + + Example: + + In a `BUILD` file: + + ```bzl + haskell_doctest_toolchain( + name = "doctest", + doctest = "@doctest//:bin", + ) + ``` + And in `WORKSPACE`: + ``` + register_toolchains("//:doctest") + ``` + """ + impl_name = name + "-impl" + _doctest_toolchain( + name = impl_name, + doctest = doctest, + visibility = ["//visibility:public"], + **kwargs + ) + native.toolchain( + name = name, + toolchain_type = "@io_tweag_rules_haskell//haskell:doctest-toolchain", + toolchain = ":" + impl_name, + ) + +def _haskell_doctest_single(target, ctx): + """Doctest a single Haskell `target`. + + Args: + target: Provider(s) of the target to doctest. + ctx: Rule context. + + Returns: + File: the doctest log. + """ + + if HaskellInfo not in target: + return [] + + hs = haskell_context(ctx, ctx.attr) + + hs_info = target[HaskellInfo] + cc_info = target[CcInfo] + lib_info = target[HaskellLibraryInfo] if HaskellLibraryInfo in target else None + + args = ctx.actions.args() + args.add("--no-magic") + + doctest_log = ctx.actions.declare_file( + "doctest-log-" + ctx.label.name + "-" + target.label.name, + ) + + toolchain = ctx.toolchains["@io_tweag_rules_haskell//haskell:doctest-toolchain"] + + # GHC flags we have prepared before. + args.add_all(hs_info.compile_flags) + + # Add any extra flags specified by the user. + args.add_all(ctx.attr.doctest_flags) + + # Direct C library dependencies to link against. + link_ctx = hs_info.cc_dependencies.dynamic_linking + libs_to_link = link_ctx.libraries_to_link.to_list() + + # External libraries. + seen_libs = set.empty() + for lib in libs_to_link: + lib_name = get_lib_name(lib) + if not set.is_member(seen_libs, lib_name): + set.mutable_insert(seen_libs, lib_name) + if hs.toolchain.is_darwin: + args.add_all([ + "-optl-l{0}".format(lib_name), + "-optl-L{0}".format(paths.dirname(lib.path)), + ]) + else: + args.add_all([ + "-l{0}".format(lib_name), + "-L{0}".format(paths.dirname(lib.path)), + ]) + + # Transitive library dependencies for runtime. + (library_deps, ld_library_deps, ghc_env) = get_libs_for_ghc_linker( + hs, + hs_info.transitive_cc_dependencies, + ) + + sources = set.to_list(hs_info.source_files) + + if ctx.attr.modules: + inputs = ctx.attr.modules + else: + inputs = [source.path for source in sources] + + ctx.actions.run_shell( + inputs = depset(transitive = [ + depset(sources), + set.to_depset(hs_info.package_databases), + set.to_depset(hs_info.interface_dirs), + set.to_depset(hs_info.dynamic_libraries), + cc_info.compilation_context.headers, + depset(library_deps), + depset(ld_library_deps), + depset( + toolchain.doctest + + [hs.tools.ghc], + ), + ]), + outputs = [doctest_log], + mnemonic = "HaskellDoctest", + progress_message = "HaskellDoctest {}".format(ctx.label), + command = """ + {env} + {doctest} "$@" {inputs} > {output} 2>&1 || (rc=$? && cat {output} && exit $rc) + """.format( + doctest = toolchain.doctest[0].path, + output = doctest_log.path, + inputs = " ".join(inputs), + # XXX Workaround + # https://github.com/bazelbuild/bazel/issues/5980. + env = render_env(hs.env), + ), + arguments = [args], + # NOTE It looks like we must specify the paths here as well as via -L + # flags because there are at least two different "consumers" of the info + # (ghc and linker?) and they seem to prefer to get it in different ways + # in this case. + env = dicts.add( + ghc_env, + hs.env, + ), + execution_requirements = { + # Prevents a race condition among concurrent doctest tests on Linux. + # + # The reason is that the doctest process uses its own PID to determine the name + # of its working directory. In presence of PID namespacing, this occasionally results + # in multiple concurrent processes attempting to create the same directory. + # See https://github.com/sol/doctest/issues/219 for details. + # + # For some reason, setting "exclusive": "1" does not fix the issue, so we disable + # sandboxing altogether for doctest tests. + "no-sandbox": "1", + }, + ) + return doctest_log + +def _haskell_doctest_impl(ctx): + logs = [] + + for dep in ctx.attr.deps: + logs.append(_haskell_doctest_single(dep, ctx)) + + return DefaultInfo( + files = depset(logs), + ) + +haskell_doctest = rule( + _haskell_doctest_impl, + attrs = { + "deps": attr.label_list( + doc = "List of Haskell targets to lint.", + ), + "doctest_flags": attr.string_list( + doc = "Extra flags to pass to doctest executable.", + ), + "modules": attr.string_list( + doc = """List of names of modules that will be tested. If the list is +omitted, all exposed modules provided by `deps` will be tested. +""", + ), + }, + toolchains = [ + "@io_tweag_rules_haskell//haskell:toolchain", + "@io_tweag_rules_haskell//haskell:doctest-toolchain", + ], +) +"""Run doctest test on targets in `deps`. + +Note that your toolchain must be equipped with `doctest` executable, i.e. +you should specify location of the executable using the `doctest` attribute +of `haskell_doctest_toolchain`. +""" diff --git a/third_party/bazel/rules_haskell/haskell/gen_ghc_bindist.py b/third_party/bazel/rules_haskell/haskell/gen_ghc_bindist.py new file mode 100644 index 000000000000..9e52896eb913 --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/gen_ghc_bindist.py @@ -0,0 +1,152 @@ +#!/usr/bin/env python + +# This is a happy-path tool to download the bindist +# download paths and hashes, for maintainers. +# It uses the hashes provided by download.haskell.org. + +from __future__ import print_function + +import pprint +import sys +import urllib2 + +# All GHC versions we generate. +# `version` is the version number +# `distribution_version` is a corrected name +# (sometimes bindists have errors and are updated by new bindists) +# `ignore_prefixes` is the prefix of files to ignore +# `ignore_suffixes` is the suffix of files to ignore +VERSIONS = [ + { "version": "8.6.5" }, + { "version": "8.6.4" }, + { "version": "8.6.3" }, + { "version": "8.6.2" }, + { "version": "8.4.4" }, + { "version": "8.4.3" }, + { "version": "8.4.2" }, + { "version": "8.4.1" }, + { "version": "8.2.2" }, + { "version": "8.0.2", + "ignore_suffixes": [".patch"] }, + { "version": "7.10.3", + "distribution_version": "7.10.3b", + "ignore_prefixes": ["ghc-7.10.3-", "ghc-7.10.3a-"], + "ignore_suffixes": [".bz2", ".patch" ] } +] + +# All architectures we generate. +# bazel: bazel name +# upstream: download.haskell.org name +ARCHES = [ + { "bazel": "linux_amd64", + "upstream": "x86_64-deb8-linux", }, + { "bazel": "darwin_amd64", + "upstream": "x86_64-apple-darwin" }, + { "bazel": "windows_amd64", + "upstream": "x86_64-unknown-mingw32" }, +] + + +# An url to a bindist tarball. +def link_for_tarball(arch, version): + return "https://downloads.haskell.org/~ghc/{ver}/ghc-{ver}-{arch}.tar.xz".format( + ver = version, + arch = arch, + ) + +# An url to a version's tarball hashsum file. +# The files contain the hashsums for all arches. +def link_for_sha256_file(version): + return "https://downloads.haskell.org/~ghc/{ver}/SHA256SUMS".format( + ver = version + ) + +# Parses the tarball hashsum file for a distribution version. +def parse_sha256_file(content, version, url): + res = {} + errs = [] + for line in content: + # f5763983a26dedd88b65a0b17267359a3981b83a642569b26334423f684f8b8c ./ghc-8.4.3-i386-deb8-linux.tar.xz + (hash, file_) = line.strip().split(" ./") + prefix = "ghc-{ver}-".format(ver = version.get("distribution_version", version['version'])) + suffix = ".tar.xz" + + # filter ignored files + if any([file_.startswith(p) for p in version.get("ignore_prefixes", [])]) \ + or any([file_.endswith(s) for s in version.get("ignore_suffixes", [])]): + continue + + if file_.startswith(prefix) and file_.endswith(suffix): + # i386-deb8-linux + name = file_[len(prefix):-len(suffix)] + res[name] = hash + else: + errs.append("Can't parse the sha256 field for {ver}: {entry}".format( + ver = version['version'], entry = line.strip())) + + if errs: + eprint("Errors parsing file at " + url + ". Either fix or ignore the lines (ignore_suffixes/ignore_prefixes).") + for e in errs: + eprint(e) + exit(1) + + return res + +# Print to stderr. +def eprint(mes): + print(mes, file = sys.stderr) + +# Main. +if __name__ == "__main__": + + # Fetch all hashsum files + # grab : { version: { arch: sha256 } } + grab = {} + for ver in VERSIONS: + eprint("fetching " + ver['version']) + url = link_for_sha256_file(ver['version']) + res = urllib2.urlopen(url) + if res.getcode() != 200: + eprint("download of {} failed with status {}".format(url, res.getcode())) + sys.exit(1) + else: + grab[ver['version']] = parse_sha256_file(res, ver, url) + + # check whether any version is missing arches we need + # errs : { version: set(missing_arches) } + errs = {} + for ver, hashes in grab.items(): + real_arches = frozenset(hashes.keys()) + needed_arches = frozenset([a['upstream'] for a in ARCHES]) + missing_arches = needed_arches.difference(real_arches) + if missing_arches: + errs[ver] = missing_arches + if errs: + for ver, missing in errs.items(): + eprint("version {ver} is missing hashes for required architectures {arches}".format( + ver = ver, + arches = missing)) + + # fetch the arches we need and create the GHC_BINDISTS dict + # ghc_bindists : { version: { bazel_arch: (tarball_url, sha256_hash) } } + ghc_bindists = {} + for ver, hashes in grab.items(): + # { bazel_arch: (tarball_url, sha256_hash) } + arch_dists = {} + for arch in ARCHES: + hashes[arch['upstream']] + arch_dists[arch['bazel']] = ( + link_for_tarball(arch['upstream'], ver), + hashes[arch['upstream']] + ) + ghc_bindists[ver] = arch_dists + + # Print to stdout. Be aware that you can't `> foo.bzl`, + # because that truncates the source file which is needed + # for bazel to run in the first place. + print(""" \ +# Generated with `bazel run @io_tweag_rules_haskell//haskell:gen-ghc-bindist | sponge haskell/private/ghc_bindist_generated.bzl` +# To add a version or architecture, edit the constants in haskell/gen_ghc_bindist.py +GHC_BINDIST = \\""") + pprint.pprint(ghc_bindists) + diff --git a/third_party/bazel/rules_haskell/haskell/ghc.BUILD b/third_party/bazel/rules_haskell/haskell/ghc.BUILD new file mode 100644 index 000000000000..67a42b0817ed --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/ghc.BUILD @@ -0,0 +1,83 @@ +package(default_visibility = ["//visibility:public"]) + +filegroup( + name = "bin", + srcs = glob(["bin/*"]), +) + +cc_library( + name = "threaded-rts", + srcs = glob( + ["lib/ghc-*/rts/libHSrts_thr-ghc*." + ext for ext in [ + "so", + "dylib", + ]] + + # dependency of `libHSrts_thr_ghc*` + # globbing on the `so` version to stay working when they update + [ + "lib/ghc-*/rts/libffi.so.*", + ], + ), + hdrs = glob(["lib/ghc-*/include/**/*.h"]), + strip_include_prefix = glob( + ["lib/ghc-*/include"], + exclude_directories = 0, + )[0], +) + +# TODO: detect this more automatically. +cc_library( + name = "unix-includes", + hdrs = glob(["lib/ghc-*/unix-*/include/*.h"]), + includes = glob( + ["lib/ghc-*/unix-*/include"], + exclude_directories = 0, + ), +) + +# This is needed for Hazel targets. +cc_library( + name = "rts-headers", + hdrs = glob([ + "lib/ghc-*/include/**/*.h", + "lib/include/**/*.h", + ]), + includes = glob( + [ + "lib/ghc-*/include", + "lib/include", + ], + exclude_directories = 0, + ), +) + +# Expose embedded MinGW toolchain when on Windows. + +filegroup( + name = "empty", + srcs = [], +) + +cc_toolchain_suite( + name = "toolchain", + toolchains = { + "x64_windows": ":cc-compiler-mingw64", + "x64_windows|ghc-mingw-gcc": ":cc-compiler-mingw64", + }, +) + +# Keep in sync with @bazel_tools//cpp:cc-compiler-x64_windows definition. +cc_toolchain( + name = "cc-compiler-mingw64", + all_files = ":empty", + ar_files = ":empty", + as_files = ":empty", + compiler_files = ":empty", + cpu = "x64_windows", + dwp_files = ":empty", + linker_files = ":empty", + objcopy_files = ":empty", + strip_files = ":empty", + supports_param_files = 0, + toolchain_identifier = "ghc_windows_mingw64", +) diff --git a/third_party/bazel/rules_haskell/haskell/ghc_bindist.bzl b/third_party/bazel/rules_haskell/haskell/ghc_bindist.bzl new file mode 100644 index 000000000000..3a448675e9d0 --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/ghc_bindist.bzl @@ -0,0 +1,408 @@ +"""Workspace rules (GHC binary distributions)""" + +_GHC_DEFAULT_VERSION = "8.4.4" + +# Generated with `bazel run @io_tweag_rules_haskell//haskell:gen-ghc-bindist` +# To add a version or architecture, edit the constants in haskell/gen_ghc_bindist.py, +# regenerate the dict and copy it here. +# Weโd like to put this dict into its own file, +# but that triggers a bug in Skydoc unfortunately. +GHC_BINDIST = \ + { + "7.10.3": { + "darwin_amd64": ( + "https://downloads.haskell.org/~ghc/7.10.3/ghc-7.10.3-x86_64-apple-darwin.tar.xz", + "b7cad2ea7badb7006621105fbf24b4bd364d2e51c1a75661978d9280d68e83a8", + ), + "linux_amd64": ( + "https://downloads.haskell.org/~ghc/7.10.3/ghc-7.10.3-x86_64-deb8-linux.tar.xz", + "804c75c4635353bf987c1ca120b8531c7bb4957c5b84d29c7adc4894b6fd579d", + ), + "windows_amd64": ( + "https://downloads.haskell.org/~ghc/7.10.3/ghc-7.10.3-x86_64-unknown-mingw32.tar.xz", + "cc7987ca7ffcd8fc8b999ed8f7408300cd9fef156032338fd57d63f577532b81", + ), + }, + "8.0.2": { + "darwin_amd64": ( + "https://downloads.haskell.org/~ghc/8.0.2/ghc-8.0.2-x86_64-apple-darwin.tar.xz", + "ff50a2df9f002f33b9f09717ebf5ec5a47906b9b65cc57b1f9849f8b2e06788d", + ), + "linux_amd64": ( + "https://downloads.haskell.org/~ghc/8.0.2/ghc-8.0.2-x86_64-deb8-linux.tar.xz", + "5ee68290db00ca0b79d57bc3a5bdce470de9ce9da0b098a7ce6c504605856c8f", + ), + "windows_amd64": ( + "https://downloads.haskell.org/~ghc/8.0.2/ghc-8.0.2-x86_64-unknown-mingw32.tar.xz", + "8c42c1f4af995205b9816a1e97e2752fe758544c1f5fe77958cdcd319c9c2d53", + ), + }, + "8.2.2": { + "darwin_amd64": ( + "https://downloads.haskell.org/~ghc/8.2.2/ghc-8.2.2-x86_64-apple-darwin.tar.xz", + "f90fcf62f7e0936a6dfc3601cf663729bfe9bbf85097d2d75f0a16f8c2e95c27", + ), + "linux_amd64": ( + "https://downloads.haskell.org/~ghc/8.2.2/ghc-8.2.2-x86_64-deb8-linux.tar.xz", + "48e205c62b9dc1ccf6739a4bc15a71e56dde2f891a9d786a1b115f0286111b2a", + ), + "windows_amd64": ( + "https://downloads.haskell.org/~ghc/8.2.2/ghc-8.2.2-x86_64-unknown-mingw32.tar.xz", + "1e033df2092aa546e763e7be63167720b32df64f76673ea1ce7ae7c9f564b223", + ), + }, + "8.4.1": { + "darwin_amd64": ( + "https://downloads.haskell.org/~ghc/8.4.1/ghc-8.4.1-x86_64-apple-darwin.tar.xz", + "d774e39f3a0105843efd06709b214ee332c30203e6c5902dd6ed45e36285f9b7", + ), + "linux_amd64": ( + "https://downloads.haskell.org/~ghc/8.4.1/ghc-8.4.1-x86_64-deb8-linux.tar.xz", + "427c77a934b30c3f1de992c38c072afb4323fe6fb30dbac919ca8cb6ae98fbd9", + ), + "windows_amd64": ( + "https://downloads.haskell.org/~ghc/8.4.1/ghc-8.4.1-x86_64-unknown-mingw32.tar.xz", + "328b013fc651d34e075019107e58bb6c8a578f0155cf3ad4557e6f2661b03131", + ), + }, + "8.4.2": { + "darwin_amd64": ( + "https://downloads.haskell.org/~ghc/8.4.2/ghc-8.4.2-x86_64-apple-darwin.tar.xz", + "87469222042b9ac23f9db216a8d4e5107297bdbbb99df71eb4d9e7208455def2", + ), + "linux_amd64": ( + "https://downloads.haskell.org/~ghc/8.4.2/ghc-8.4.2-x86_64-deb8-linux.tar.xz", + "246f66eb56f4ad0f1c7755502cfc8f9972f2d067dede17e151f6f479c1f76fbd", + ), + "windows_amd64": ( + "https://downloads.haskell.org/~ghc/8.4.2/ghc-8.4.2-x86_64-unknown-mingw32.tar.xz", + "797634aa9812fc6b2084a24ddb4fde44fa83a2f59daea82e0af81ca3dd323fde", + ), + }, + "8.4.3": { + "darwin_amd64": ( + "https://downloads.haskell.org/~ghc/8.4.3/ghc-8.4.3-x86_64-apple-darwin.tar.xz", + "af0b455f6c46b9802b4b48dad996619cfa27cc6e2bf2ce5532387b4a8c00aa64", + ), + "linux_amd64": ( + "https://downloads.haskell.org/~ghc/8.4.3/ghc-8.4.3-x86_64-deb8-linux.tar.xz", + "30a402c6d4754a6c020e0547f19ae3ac42e907e35349aa932d347f73e421a8e2", + ), + "windows_amd64": ( + "https://downloads.haskell.org/~ghc/8.4.3/ghc-8.4.3-x86_64-unknown-mingw32.tar.xz", + "8a83cfbf9ae84de0443c39c93b931693bdf2a6d4bf163ffb41855f80f4bf883e", + ), + }, + "8.4.4": { + "darwin_amd64": ( + "https://downloads.haskell.org/~ghc/8.4.4/ghc-8.4.4-x86_64-apple-darwin.tar.xz", + "28dc89ebd231335337c656f4c5ead2ae2a1acc166aafe74a14f084393c5ef03a", + ), + "linux_amd64": ( + "https://downloads.haskell.org/~ghc/8.4.4/ghc-8.4.4-x86_64-deb8-linux.tar.xz", + "4c2a8857f76b7f3e34ecba0b51015d5cb8b767fe5377a7ec477abde10705ab1a", + ), + "windows_amd64": ( + "https://downloads.haskell.org/~ghc/8.4.4/ghc-8.4.4-x86_64-unknown-mingw32.tar.xz", + "da29dbb0f1199611c7d5bb7b0dd6a7426ca98f67dfd6da1526b033cd3830dc05", + ), + }, + "8.6.2": { + "darwin_amd64": ( + "https://downloads.haskell.org/~ghc/8.6.2/ghc-8.6.2-x86_64-apple-darwin.tar.xz", + "8ec46a25872226dd7e5cf7271e3f3450c05f32144b96e6b9cb44cc4079db50dc", + ), + "linux_amd64": ( + "https://downloads.haskell.org/~ghc/8.6.2/ghc-8.6.2-x86_64-deb8-linux.tar.xz", + "13f96e8b83bb5bb60f955786ff9085744c24927a33be8a17773f84c7c248533a", + ), + "windows_amd64": ( + "https://downloads.haskell.org/~ghc/8.6.2/ghc-8.6.2-x86_64-unknown-mingw32.tar.xz", + "9a398e133cab09ff2610834337355d4e26c35e0665403fb9ff8db79315f74d3d", + ), + }, + "8.6.3": { + "darwin_amd64": ( + "https://downloads.haskell.org/~ghc/8.6.3/ghc-8.6.3-x86_64-apple-darwin.tar.xz", + "79d069a1a7d74cfdd7ac2a2711c45d3ddc6265b988a0cefa342714b24f997fc1", + ), + "linux_amd64": ( + "https://downloads.haskell.org/~ghc/8.6.3/ghc-8.6.3-x86_64-deb8-linux.tar.xz", + "291ca565374f4d51cc311488581f3279d3167a064fabfd4a6722fe2bd4532fd5", + ), + "windows_amd64": ( + "https://downloads.haskell.org/~ghc/8.6.3/ghc-8.6.3-x86_64-unknown-mingw32.tar.xz", + "2fec383904e5fa79413e9afd328faf9bc700006c8c3d4bcdd8d4f2ccf0f7fa2a", + ), + }, + "8.6.4": { + "darwin_amd64": ( + "https://downloads.haskell.org/~ghc/8.6.4/ghc-8.6.4-x86_64-apple-darwin.tar.xz", + "cccb58f142fe41b601d73690809f6089f7715b6a50a09aa3d0104176ab4db09e", + ), + "linux_amd64": ( + "https://downloads.haskell.org/~ghc/8.6.4/ghc-8.6.4-x86_64-deb8-linux.tar.xz", + "34ef5fc8ddf2fc32a027180bea5b1c8a81ea840c87faace2977a572188d4b42d", + ), + "windows_amd64": ( + "https://downloads.haskell.org/~ghc/8.6.4/ghc-8.6.4-x86_64-unknown-mingw32.tar.xz", + "e8d021b7a90772fc559862079da20538498d991956d7557b468ca19ddda22a08", + ), + }, + "8.6.5": { + "darwin_amd64": ( + "https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-apple-darwin.tar.xz", + "dfc1bdb1d303a87a8552aa17f5b080e61351f2823c2b99071ec23d0837422169", + ), + "linux_amd64": ( + "https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-deb8-linux.tar.xz", + "c419fd0aa9065fe4d2eb9a248e323860c696ddf3859749ca96a84938aee49107", + ), + "windows_amd64": ( + "https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-unknown-mingw32.tar.xz", + "457024c6ea43bdce340af428d86319931f267089398b859b00efdfe2fd4ce93f", + ), + }, + } + +def _execute_fail_loudly(ctx, args): + """Execute a command and fail loudly if it fails. + + Args: + ctx: Repository rule context. + args: Command and its arguments. + """ + eresult = ctx.execute(args, quiet = False) + if eresult.return_code != 0: + fail("{0} failed, aborting creation of GHC bindist".format(" ".join(args))) + +load("@bazel_tools//tools/build_defs/repo:utils.bzl", "patch") + +def _ghc_bindist_impl(ctx): + # Avoid rule restart by resolving these labels early. See + # https://github.com/bazelbuild/bazel/blob/master/tools/cpp/lib_cc_configure.bzl#L17. + ghc_build = ctx.path(Label("//haskell:ghc.BUILD")) + crosstool_windows = ctx.path(Label("//haskell:CROSSTOOL.windows")) + + version = ctx.attr.version + target = ctx.attr.target + os, _, arch = target.partition("_") + + if GHC_BINDIST[version].get(target) == None: + fail("Operating system {0} does not have a bindist for GHC version {1}".format(ctx.os.name, ctx.attr.version)) + else: + url, sha256 = GHC_BINDIST[version][target] + + bindist_dir = ctx.path(".") # repo path + + ctx.download_and_extract( + url = url, + output = ".", + sha256 = sha256, + type = "tar.xz", + stripPrefix = "ghc-" + version, + ) + + # We apply some patches, if needed. + patch(ctx) + + # As the patches may touch the package DB we regenerate the cache. + if len(ctx.attr.patches) > 0: + _execute_fail_loudly(ctx, ["./bin/ghc-pkg", "recache"]) + + # On Windows the bindist already contains the built executables + if os != "windows": + _execute_fail_loudly(ctx, ["sed", "-i", "s/RelocatableBuild = NO/RelocatableBuild = YES/", "mk/config.mk.in"]) + _execute_fail_loudly(ctx, ["./configure", "--prefix", bindist_dir.realpath]) + _execute_fail_loudly(ctx, ["make", "install"]) + ctx.file("patch_bins", executable = True, content = """#!/usr/bin/env bash +grep -lZ {bindist_dir} bin/* | xargs -0 --verbose \\ + sed -i \\ + -e '2iDISTDIR="$( dirname "$(resolved="$0"; while tmp="$(readlink "$resolved")"; do resolved="$tmp"; done; echo "$resolved")" )/.."' \\ + -e 's:{bindist_dir}:$DISTDIR:' +""".format( + bindist_dir = bindist_dir.realpath, + )) + _execute_fail_loudly(ctx, ["./patch_bins"]) + + ctx.template( + "BUILD", + ghc_build, + executable = False, + ) + ctx.template("CROSSTOOL", crosstool_windows, executable = False) + ctx.file("WORKSPACE") + +_ghc_bindist = repository_rule( + _ghc_bindist_impl, + local = False, + attrs = { + "version": attr.string( + default = _GHC_DEFAULT_VERSION, + values = GHC_BINDIST.keys(), + doc = "The desired GHC version", + ), + "target": attr.string(), + "patches": attr.label_list( + default = [], + doc = + "A list of files that are to be applied as patches afer " + + "extracting the archive.", + ), + "patch_tool": attr.string( + default = "patch", + doc = "The patch(1) utility to use.", + ), + "patch_args": attr.string_list( + default = ["-p0"], + doc = "The arguments given to the patch tool", + ), + "patch_cmds": attr.string_list( + default = [], + doc = "Sequence of commands to be applied after patches are applied.", + ), + }, +) + +def _ghc_bindist_toolchain_impl(ctx): + os, _, arch = ctx.attr.target.partition("_") + exec_constraints = [{ + "darwin": "@bazel_tools//platforms:osx", + "linux": "@bazel_tools//platforms:linux", + "windows": "@bazel_tools//platforms:windows", + }.get(os)] + target_constraints = exec_constraints + ctx.file( + "BUILD", + executable = False, + content = """ +load("@io_tweag_rules_haskell//haskell:toolchain.bzl", "haskell_toolchain") + +haskell_toolchain( + name = "toolchain", + tools = ["{tools}"], + version = "{version}", + compiler_flags = {compiler_flags}, + haddock_flags = {haddock_flags}, + repl_ghci_args = {repl_ghci_args}, + exec_compatible_with = {exec_constraints}, + target_compatible_with = {target_constraints}, +) + """.format( + tools = "@{}//:bin".format(ctx.attr.bindist_name), + version = ctx.attr.version, + compiler_flags = ctx.attr.compiler_flags, + haddock_flags = ctx.attr.haddock_flags, + repl_ghci_args = ctx.attr.repl_ghci_args, + exec_constraints = exec_constraints, + target_constraints = target_constraints, + ), + ) + +_ghc_bindist_toolchain = repository_rule( + _ghc_bindist_toolchain_impl, + local = False, + attrs = { + "bindist_name": attr.string(), + "version": attr.string(), + "compiler_flags": attr.string_list(), + "haddock_flags": attr.string_list(), + "repl_ghci_args": attr.string_list(), + "target": attr.string(), + }, +) + +def ghc_bindist( + name, + version, + target, + compiler_flags = None, + haddock_flags = None, + repl_ghci_args = None): + """Create a new repository from binary distributions of GHC. The + repository exports two targets: + + * a `bin` filegroup containing all GHC commands, + * a `threaded-rts` CC library. + + These targets are unpacked from a binary distribution specific to your + platform. Only the platforms that have a "binary package" on the GHC + [download page](https://www.haskell.org/ghc/) are supported. + + Example: + In `WORKSPACE` file: + + ```bzl + load("@io_tweag_rules_haskell//haskell:haskell.bzl", "ghc_bindist") + + # This repository rule creates @ghc repository. + ghc_bindist( + name = "ghc", + version = "8.2.2", + ) + ``` + """ + bindist_name = name + toolchain_name = "{}-toolchain".format(name) + + # Recent GHC versions on Windows contain a bug: + # https://gitlab.haskell.org/ghc/ghc/issues/16466 + # We work around this by patching the base configuration. + patches = { + "8.6.2": ["@io_tweag_rules_haskell//haskell:assets/ghc_8_6_2_win_base.patch"], + "8.6.4": ["@io_tweag_rules_haskell//haskell:assets/ghc_8_6_4_win_base.patch"], + }.get(version) if target == "windows_amd64" else None + + extra_attrs = {"patches": patches, "patch_args": ["-p0"]} if patches else {} + + # We want the toolchain definition to be tucked away in a separate + # repository, that way `bazel build //...` will not match it (and + # e.g. build the Windows toolchain even on Linux). At the same + # time, we don't want the definition in the bindist repository, + # because then we need to download the bindist first before we can + # see the toolchain definition. The solution is to add the + # toolchain definition in its own special repository. + _ghc_bindist( + name = bindist_name, + version = version, + target = target, + **extra_attrs + ) + _ghc_bindist_toolchain( + name = toolchain_name, + bindist_name = bindist_name, + version = version, + compiler_flags = compiler_flags, + haddock_flags = haddock_flags, + repl_ghci_args = repl_ghci_args, + target = target, + ) + native.register_toolchains("@{}//:toolchain".format(toolchain_name)) + +def haskell_register_ghc_bindists( + version, + compiler_flags = None, + haddock_flags = None, + repl_ghci_args = None): + """Register GHC binary distributions for all platforms as toolchains. + + Toolchains can be used to compile Haskell code. This function + registers one toolchain for each known binary distribution on all + platforms of the given GHC version. During the build, one + toolchain will be selected based on the host and target platforms + (See [toolchain resolution][toolchain-resolution]). + + [toolchain-resolution]: https://docs.bazel.build/versions/master/toolchains.html#toolchain-resolution + + """ + if not GHC_BINDIST.get(version): + fail("Binary distribution of GHC {} not available.".format(version)) + for target in GHC_BINDIST[version]: + ghc_bindist( + name = "io_tweag_rules_haskell_ghc_{}".format(target), + target = target, + version = version, + compiler_flags = compiler_flags, + haddock_flags = haddock_flags, + repl_ghci_args = repl_ghci_args, + ) diff --git a/third_party/bazel/rules_haskell/haskell/haddock.bzl b/third_party/bazel/rules_haskell/haskell/haddock.bzl new file mode 100644 index 000000000000..2e9d5709ac39 --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/haddock.bzl @@ -0,0 +1,312 @@ +"""Haddock support""" + +load("@bazel_skylib//lib:paths.bzl", "paths") +load( + "@io_tweag_rules_haskell//haskell:providers.bzl", + "HaddockInfo", + "HaskellInfo", + "HaskellLibraryInfo", +) +load(":private/context.bzl", "haskell_context", "render_env") +load(":private/set.bzl", "set") + +def _get_haddock_path(package_id): + """Get path to Haddock file of a package given its id. + + Args: + package_id: string, package id. + + Returns: + string: relative path to haddock file. + """ + return package_id + ".haddock" + +def _haskell_doc_aspect_impl(target, ctx): + if HaskellInfo not in target or HaskellLibraryInfo not in target: + return [] + + # Packages imported via `//haskell:import.bzl%haskell_import` already + # contain an `HaddockInfo` provider, so we just forward it + if HaddockInfo in target: + return [] + + hs = haskell_context(ctx, ctx.rule.attr) + + package_id = target[HaskellLibraryInfo].package_id + html_dir_raw = "doc-{0}".format(package_id) + html_dir = ctx.actions.declare_directory(html_dir_raw) + haddock_file = ctx.actions.declare_file(_get_haddock_path(package_id)) + + # XXX Haddock really wants a version number, so invent one from + # thin air. See https://github.com/haskell/haddock/issues/898. + if target[HaskellLibraryInfo].version: + version = target[HaskellLibraryInfo].version + else: + version = "0" + + args = ctx.actions.args() + args.add("--package-name={0}".format(package_id)) + args.add("--package-version={0}".format(version)) + args.add_all([ + "-D", + haddock_file.path, + "-o", + html_dir.path, + "--html", + "--hoogle", + "--title={0}".format(package_id), + "--hyperlinked-source", + ]) + + transitive_haddocks = {} + transitive_html = {} + + for dep in ctx.rule.attr.deps: + if HaddockInfo in dep: + transitive_haddocks.update(dep[HaddockInfo].transitive_haddocks) + transitive_html.update(dep[HaddockInfo].transitive_html) + + for pid in transitive_haddocks: + args.add("--read-interface=../{0},{1}".format( + pid, + transitive_haddocks[pid].path, + )) + + prebuilt_deps = ctx.actions.args() + for dep in set.to_list(target[HaskellInfo].prebuilt_dependencies): + prebuilt_deps.add(dep.package) + prebuilt_deps.use_param_file(param_file_arg = "%s", use_always = True) + + compile_flags = ctx.actions.args() + for x in target[HaskellInfo].compile_flags: + compile_flags.add_all(["--optghc", x]) + compile_flags.add_all([x.path for x in set.to_list(target[HaskellInfo].source_files)]) + compile_flags.add("-v0") + + # haddock flags should take precedence over ghc args, hence are in + # last position + compile_flags.add_all(hs.toolchain.haddock_flags) + + locale_archive_depset = ( + depset([hs.toolchain.locale_archive]) if hs.toolchain.locale_archive != None else depset() + ) + + # TODO(mboes): we should be able to instantiate this template only + # once per toolchain instance, rather than here. + haddock_wrapper = ctx.actions.declare_file("haddock_wrapper-{}".format(hs.name)) + ctx.actions.expand_template( + template = ctx.file._haddock_wrapper_tpl, + output = haddock_wrapper, + substitutions = { + "%{ghc-pkg}": hs.tools.ghc_pkg.path, + "%{haddock}": hs.tools.haddock.path, + # XXX Workaround + # https://github.com/bazelbuild/bazel/issues/5980. + "%{env}": render_env(hs.env), + }, + is_executable = True, + ) + + # Transitive library dependencies for runtime. + trans_link_ctx = target[HaskellInfo].transitive_cc_dependencies.dynamic_linking + trans_libs = trans_link_ctx.libraries_to_link.to_list() + + ctx.actions.run( + inputs = depset(transitive = [ + set.to_depset(target[HaskellInfo].package_databases), + set.to_depset(target[HaskellInfo].interface_dirs), + set.to_depset(target[HaskellInfo].source_files), + target[HaskellInfo].extra_source_files, + set.to_depset(target[HaskellInfo].dynamic_libraries), + depset(trans_libs), + depset(transitive_haddocks.values()), + depset(transitive_html.values()), + target[CcInfo].compilation_context.headers, + depset([ + hs.tools.ghc_pkg, + hs.tools.haddock, + ]), + locale_archive_depset, + ]), + outputs = [haddock_file, html_dir], + mnemonic = "HaskellHaddock", + progress_message = "HaskellHaddock {}".format(ctx.label), + executable = haddock_wrapper, + arguments = [ + prebuilt_deps, + args, + compile_flags, + ], + use_default_shell_env = True, + ) + + transitive_html.update({package_id: html_dir}) + transitive_haddocks.update({package_id: haddock_file}) + + haddock_info = HaddockInfo( + package_id = package_id, + transitive_html = transitive_html, + transitive_haddocks = transitive_haddocks, + ) + output_files = OutputGroupInfo(default = transitive_html.values()) + + return [haddock_info, output_files] + +haskell_doc_aspect = aspect( + _haskell_doc_aspect_impl, + attrs = { + "_haddock_wrapper_tpl": attr.label( + allow_single_file = True, + default = Label("@io_tweag_rules_haskell//haskell:private/haddock_wrapper.sh.tpl"), + ), + }, + attr_aspects = ["deps"], + toolchains = ["@io_tweag_rules_haskell//haskell:toolchain"], +) + +def _haskell_doc_rule_impl(ctx): + hs = haskell_context(ctx) + + # Reject cases when number of dependencies is 0. + + if not ctx.attr.deps: + fail("haskell_doc needs at least one haskell_library component in deps") + + doc_root_raw = ctx.attr.name + haddock_dict = {} + html_dict_original = {} + all_caches = set.empty() + + for dep in ctx.attr.deps: + if HaddockInfo in dep: + html_dict_original.update(dep[HaddockInfo].transitive_html) + haddock_dict.update(dep[HaddockInfo].transitive_haddocks) + if HaskellInfo in dep: + set.mutable_union( + all_caches, + dep[HaskellInfo].package_databases, + ) + + # Copy docs of Bazel deps into predefined locations under the root doc + # directory. + + html_dict_copied = {} + doc_root_path = "" + + for package_id in html_dict_original: + html_dir = html_dict_original[package_id] + output_dir = ctx.actions.declare_directory( + paths.join( + doc_root_raw, + package_id, + ), + ) + doc_root_path = paths.dirname(output_dir.path) + + html_dict_copied[package_id] = output_dir + + ctx.actions.run_shell( + inputs = [html_dir], + outputs = [output_dir], + command = """ + mkdir -p "{doc_dir}" + # Copy Haddocks of a dependency. + cp -R -L "{html_dir}/." "{target_dir}" + """.format( + doc_dir = doc_root_path, + html_dir = html_dir.path, + target_dir = output_dir.path, + ), + ) + + # Do one more Haddock call to generate the unified index + + index_root_raw = paths.join(doc_root_raw, "index") + index_root = ctx.actions.declare_directory(index_root_raw) + + args = ctx.actions.args() + args.add_all([ + "-o", + index_root.path, + "--title={0}".format(ctx.attr.name), + "--gen-index", + "--gen-contents", + ]) + + if ctx.attr.index_transitive_deps: + # Include all packages in the unified index. + for package_id in html_dict_copied: + args.add("--read-interface=../{0},{1}".format( + package_id, + haddock_dict[package_id].path, + )) + else: + # Include only direct dependencies. + for dep in ctx.attr.deps: + if HaddockInfo in dep: + package_id = dep[HaddockInfo].package_id + args.add("--read-interface=../{0},{1}".format( + package_id, + haddock_dict[package_id].path, + )) + + for cache in set.to_list(all_caches): + args.add("--optghc=-package-db={0}".format(cache.dirname)) + + locale_archive_depset = ( + depset([hs.toolchain.locale_archive]) if hs.toolchain.locale_archive != None else depset() + ) + + ctx.actions.run( + inputs = depset(transitive = [ + set.to_depset(all_caches), + depset(html_dict_copied.values()), + depset(haddock_dict.values()), + locale_archive_depset, + ]), + outputs = [index_root], + mnemonic = "HaskellHaddockIndex", + executable = hs.tools.haddock, + arguments = [args], + ) + + return [DefaultInfo( + files = depset(html_dict_copied.values() + [index_root]), + )] + +haskell_doc = rule( + _haskell_doc_rule_impl, + attrs = { + "deps": attr.label_list( + aspects = [haskell_doc_aspect], + doc = "List of Haskell libraries to generate documentation for.", + ), + "index_transitive_deps": attr.bool( + default = False, + doc = "Whether to include documentation of transitive dependencies in index.", + ), + }, + toolchains = ["@io_tweag_rules_haskell//haskell:toolchain"], +) +"""Create API documentation. + +Builds API documentation (using [Haddock][haddock]) for the given +Haskell libraries. It will automatically build documentation for any +transitive dependencies to allow for cross-package documentation +linking. + +Example: + ```bzl + haskell_library( + name = "my-lib", + ... + ) + + haskell_doc( + name = "my-lib-doc", + deps = [":my-lib"], + ) + ``` + +[haddock]: http://haskell-haddock.readthedocs.io/en/latest/ +""" diff --git a/third_party/bazel/rules_haskell/haskell/haskell.bzl b/third_party/bazel/rules_haskell/haskell/haskell.bzl new file mode 100644 index 000000000000..61994e4aca10 --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/haskell.bzl @@ -0,0 +1,353 @@ +"""Core Haskell rules""" + +load( + ":cc.bzl", + _cc_haskell_import = "cc_haskell_import", + _haskell_cc_import = "haskell_cc_import", +) +load( + ":doctest.bzl", + _haskell_doctest = "haskell_doctest", + _haskell_doctest_toolchain = "haskell_doctest_toolchain", +) +load( + ":ghc_bindist.bzl", + _ghc_bindist = "ghc_bindist", + _haskell_register_ghc_bindists = "haskell_register_ghc_bindists", +) +load( + ":haddock.bzl", + _haskell_doc = "haskell_doc", + _haskell_doc_aspect = "haskell_doc_aspect", +) +load( + ":lint.bzl", + _haskell_lint = "haskell_lint", + _haskell_lint_aspect = "haskell_lint_aspect", +) +load( + ":private/haskell_impl.bzl", + _haskell_binary_impl = "haskell_binary_impl", + _haskell_library_impl = "haskell_library_impl", + _haskell_test_impl = "haskell_test_impl", + _haskell_toolchain_library_impl = "haskell_toolchain_library_impl", +) +load( + ":repl.bzl", + _haskell_repl = "haskell_repl", + _haskell_repl_aspect = "haskell_repl_aspect", +) + +# For re-exports: +load( + ":protobuf.bzl", + _haskell_proto_library = "haskell_proto_library", + _haskell_proto_toolchain = "haskell_proto_toolchain", +) +load( + ":toolchain.bzl", + _haskell_register_toolchains = "haskell_register_toolchains", + _haskell_toolchain = "haskell_toolchain", +) +load( + ":plugins.bzl", + _ghc_plugin = "ghc_plugin", +) + +_haskell_common_attrs = { + "src_strip_prefix": attr.string( + doc = "Directory in which module hierarchy starts.", + ), + "srcs": attr.label_list( + allow_files = [".hs", ".hsc", ".lhs", ".hs-boot", ".lhs-boot", ".h"], + doc = "Haskell source files.", + ), + "extra_srcs": attr.label_list( + allow_files = True, + doc = "Extra (non-Haskell) source files that will be needed at compile time (e.g. by Template Haskell).", + ), + "deps": attr.label_list( + doc = "List of other Haskell libraries to be linked to this target.", + ), + "data": attr.label_list( + doc = "See [Bazel documentation](https://docs.bazel.build/versions/master/be/common-definitions.html#common.data).", + allow_files = True, + ), + "compiler_flags": attr.string_list( + doc = "Flags to pass to Haskell compiler.", + ), + "repl_ghci_args": attr.string_list( + doc = "Arbitrary extra arguments to pass to GHCi. This extends `compiler_flags` and `repl_ghci_args` from the toolchain", + ), + "runcompile_flags": attr.string_list( + doc = "Arbitrary extra arguments to pass to runghc. This extends `compiler_flags` and `repl_ghci_args` from the toolchain", + ), + "plugins": attr.label_list( + doc = "Compiler plugins to use during compilation.", + ), + "_ghci_script": attr.label( + allow_single_file = True, + default = Label("@io_tweag_rules_haskell//haskell:assets/ghci_script"), + ), + "_ghci_repl_wrapper": attr.label( + allow_single_file = True, + default = Label("@io_tweag_rules_haskell//haskell:private/ghci_repl_wrapper.sh"), + ), + "_ls_modules": attr.label( + executable = True, + cfg = "host", + default = Label("@io_tweag_rules_haskell//haskell:ls_modules"), + ), + "_version_macros": attr.label( + executable = True, + cfg = "host", + default = Label("@io_tweag_rules_haskell//haskell:version_macros"), + ), + "_cc_toolchain": attr.label( + default = Label("@bazel_tools//tools/cpp:current_cc_toolchain"), + ), +} + +def _mk_binary_rule(**kwargs): + """Generate a rule that compiles a binary. + + This is useful to create variations of a Haskell binary compilation + rule without having to copy and paste the actual `rule` invocation. + + Args: + **kwargs: Any additional keyword arguments to pass to `rule`. + + Returns: + Rule: Haskell binary compilation rule. + """ + + is_test = kwargs.get("test", False) + + attrs = dict( + _haskell_common_attrs, + linkstatic = attr.bool( + default = True, + doc = "Link dependencies statically wherever possible. Some system libraries may still be linked dynamically, as are libraries for which there is no static library. So the resulting executable will still be dynamically linked, hence only mostly static.", + ), + main_function = attr.string( + default = "Main.main", + doc = """A function with type `IO _`, either the qualified name of a function from any module or the bare name of a function from a `Main` module. It is also possible to give the qualified name of any module exposing a `main` function.""", + ), + version = attr.string( + doc = "Executable version. If this is specified, CPP version macros will be generated for this build.", + ), + ) + + # Tests have an extra fields regarding code coverage. + if is_test: + attrs.update({ + "expected_covered_expressions_percentage": attr.int( + default = -1, + doc = "The expected percentage of expressions covered by testing.", + ), + "expected_uncovered_expression_count": attr.int( + default = -1, + doc = "The expected number of expressions which are not covered by testing.", + ), + "strict_coverage_analysis": attr.bool( + default = False, + doc = "Requires that the coverage metric is matched exactly, even doing better than expected is not allowed.", + ), + "coverage_report_format": attr.string( + default = "text", + doc = """The format to output the coverage report in. Supported values: "text", "html". Default: "text". + Report can be seen in the testlog XML file, or by setting --test_output=all when running bazel coverage. + """, + ), + "experimental_coverage_source_patterns": attr.string_list( + default = ["//..."], + doc = """The path patterns specifying which targets to analyze for test coverage metrics. + + Wild-card targets such as //... or //:all are allowed. The paths must be relative to the workspace, which means they must start with "//". + + Note, this attribute may leave experimental status depending on the outcome of https://github.com/bazelbuild/bazel/issues/7763. + """, + ), + "_coverage_wrapper_template": attr.label( + allow_single_file = True, + default = Label("@io_tweag_rules_haskell//haskell:private/coverage_wrapper.sh.tpl"), + ), + "_bash_runfiles": attr.label( + allow_single_file = True, + default = Label("@bazel_tools//tools/bash/runfiles:runfiles"), + ), + }) + + return rule( + # If _mk_binary_rule was called with test = True, we want to use the test binary implementation + _haskell_test_impl if is_test else _haskell_binary_impl, + executable = True, + attrs = attrs, + outputs = { + "runghc": "%{name}@runghc", + "repl": "%{name}@repl", + "repl_deprecated": "%{name}-repl", + }, + toolchains = [ + "@io_tweag_rules_haskell//haskell:toolchain", + ], + **kwargs + ) + +haskell_test = _mk_binary_rule(test = True) +"""Build a test suite. + +Additionally, it accepts [all common bazel test rule +fields][bazel-test-attrs]. This allows you to influence things like +timeout and resource allocation for the test. + +[bazel-test-attrs]: https://docs.bazel.build/versions/master/be/common-definitions.html#common-attributes-tests +""" + +haskell_binary = _mk_binary_rule() +"""Build an executable from Haskell source. + +Example: + ```bzl + haskell_binary( + name = "hello", + srcs = ["Main.hs", "Other.hs"], + deps = ["//lib:some_lib"] + ) + ``` + +Every `haskell_binary` target also defines an optional REPL target that is +not built by default, but can be built on request. The name of the REPL +target is the same as the name of binary with `"@repl"` added at the end. +For example, the target above also defines `main@repl`. + +You can call the REPL like this (requires Bazel 0.15 or later): + +``` +$ bazel run //:hello@repl +``` + +""" + +haskell_library = rule( + _haskell_library_impl, + attrs = dict( + _haskell_common_attrs, + hidden_modules = attr.string_list( + doc = "Modules that should be unavailable for import by dependencies.", + ), + exports = attr.label_keyed_string_dict( + doc = "A dictionary mapping dependencies to module reexports that should be available for import by dependencies.", + ), + linkstatic = attr.bool( + default = False, + doc = "Create a static library, not both a static and a shared library.", + ), + version = attr.string( + doc = """Library version. Not normally necessary unless to build a library + originally defined as a Cabal package. If this is specified, CPP version macro will be generated.""", + ), + ), + outputs = { + "runghc": "%{name}@runghc", + "repl": "%{name}@repl", + "repl_deprecated": "%{name}-repl", + }, + toolchains = [ + "@io_tweag_rules_haskell//haskell:toolchain", + ], +) +"""Build a library from Haskell source. + +Example: + ```bzl + haskell_library( + name = "hello-lib", + srcs = glob(["src/**/*.hs"]), + src_strip_prefix = "src", + deps = [ + "//hello-sublib:lib", + ], + exports = { + "//hello-sublib:lib": "Lib1 as HelloLib1, Lib2", + }, + ) + ``` + +Every `haskell_library` target also defines an optional REPL target that is +not built by default, but can be built on request. It works the same way as +for `haskell_binary`. +""" + +haskell_toolchain_library = rule( + _haskell_toolchain_library_impl, + attrs = dict( + package = attr.string( + doc = "The name of a GHC package not built by Bazel. Defaults to the name of the rule.", + ), + _version_macros = attr.label( + executable = True, + cfg = "host", + default = Label("@io_tweag_rules_haskell//haskell:version_macros"), + ), + ), + toolchains = [ + "@io_tweag_rules_haskell//haskell:toolchain", + ], +) +"""Import packages that are prebuilt outside of Bazel. + +Example: + ```bzl + haskell_toolchain_library( + name = "base_pkg", + package = "base", + ) + + haskell_library( + name = "hello-lib", + srcs = ["Lib.hs"], + deps = [ + ":base_pkg", + "//hello-sublib:lib", + ], + ) + ``` + +Use this rule to make dependencies that are prebuilt (supplied as part +of the compiler toolchain) available as targets. +""" + +haskell_doc = _haskell_doc + +haskell_doc_aspect = _haskell_doc_aspect + +haskell_lint = _haskell_lint + +haskell_lint_aspect = _haskell_lint_aspect + +haskell_doctest = _haskell_doctest + +haskell_doctest_toolchain = _haskell_doctest_toolchain + +haskell_register_toolchains = _haskell_register_toolchains + +haskell_register_ghc_bindists = _haskell_register_ghc_bindists + +haskell_repl = _haskell_repl + +haskell_repl_aspect = _haskell_repl_aspect + +haskell_toolchain = _haskell_toolchain + +haskell_proto_library = _haskell_proto_library + +haskell_proto_toolchain = _haskell_proto_toolchain + +ghc_bindist = _ghc_bindist + +haskell_cc_import = _haskell_cc_import + +cc_haskell_import = _cc_haskell_import + +ghc_plugin = _ghc_plugin diff --git a/third_party/bazel/rules_haskell/haskell/import.bzl b/third_party/bazel/rules_haskell/haskell/import.bzl new file mode 100644 index 000000000000..a79a9cff7b3d --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/import.bzl @@ -0,0 +1,118 @@ +"""Importing prebuilt packages into bazel""" + +load("@bazel_skylib//lib:paths.bzl", "paths") +load( + "@io_tweag_rules_haskell//haskell:providers.bzl", + "HaddockInfo", + "HaskellInfo", + "HaskellLibraryInfo", + "empty_HaskellCcInfo", +) +load(":private/context.bzl", "haskell_context") +load(":private/path_utils.bzl", "copy_all", "link_forest", "ln") +load(":private/set.bzl", "set") +load(":private/version_macros.bzl", "generate_version_macros") + +def _haskell_import_impl(ctx): + hs = haskell_context(ctx) + + package_cache = ctx.actions.declare_file( + paths.join("package.conf.d", "package.cache"), + ) + + local_package_confs = link_forest( + ctx = ctx, + srcs = ctx.attr.package_confs.files, + sibling = package_cache, + ) + + local_haddock_html = ctx.actions.declare_directory("haddock-html") + copy_all( + ctx = ctx, + srcs = ctx.attr.haddock_html.files, + dest = local_haddock_html, + ) + + ctx.actions.run( + outputs = [package_cache], + inputs = local_package_confs, + mnemonic = "HaskellCreatePackageCache", + executable = hs.tools.ghc_pkg, + arguments = [ + "recache", + "--package-db", + package_cache.dirname, + ], + ) + ln(ctx, package_cache, ctx.outputs.cache) + + dependencies_caches = set.singleton(package_cache) + for dep in ctx.attr.deps: + if HaskellInfo in dep: + set.mutable_union(dependencies_caches, dep[HaskellInfo].package_databases) + + deps_ids = [ + dep[HaskellLibraryInfo].package_id + for dep in ctx.attr.deps + if HaskellLibraryInfo in dep + ] + + version_macros = set.empty() + if ctx.attr.version != None: + version_macros = set.singleton( + generate_version_macros(ctx, hs.name, ctx.attr.version), + ) + + libInfo = HaskellLibraryInfo( + package_id = ctx.attr.package_id, + version = ctx.attr.version, + ) + buildInfo = HaskellInfo( + package_ids = set.from_list([ctx.attr.package_id] + deps_ids), + package_databases = dependencies_caches, + version_macros = version_macros, + import_dirs = [], + source_files = set.empty(), + extra_source_files = set.empty(), + static_libraries = [], + static_libraries_prof = [], + dynamic_libraries = set.empty(), + interface_dirs = set.empty(), + compile_flags = [], + prebuilt_dependencies = set.empty(), + direct_prebuilt_deps = set.empty(), + cc_dependencies = empty_HaskellCcInfo(), + transitive_cc_dependencies = empty_HaskellCcInfo(), + ) + html_files = ctx.attr.haddock_html.files.to_list() + transitive_html = {ctx.attr.package_id: local_haddock_html} if html_files != [] else {} + interface_files = ctx.attr.haddock_interfaces.files.to_list() + transitive_haddocks = {ctx.attr.package_id: interface_files[0]} if interface_files != [] else {} + + haddockInfo = HaddockInfo( + package_id = ctx.attr.package_id, + transitive_html = transitive_html, + transitive_haddocks = transitive_haddocks, + ) + return [buildInfo, libInfo, haddockInfo] + +haskell_import = rule( + _haskell_import_impl, + attrs = dict( + package_id = attr.string(doc = "Workspace unique package identifier"), + deps = attr.label_list(doc = "Haskell dependencies for the package"), + version = attr.string(doc = "Package version."), + haddock_interfaces = attr.label(doc = "List of haddock interfaces"), + haddock_html = attr.label(doc = "List of haddock html dirs"), + package_confs = attr.label(doc = "List of ghc-pkg package.conf files"), + _version_macros = attr.label( + executable = True, + cfg = "host", + default = Label("@io_tweag_rules_haskell//haskell:version_macros"), + ), + ), + outputs = { + "cache": "%{name}-cache", + }, + toolchains = ["@io_tweag_rules_haskell//haskell:toolchain"], +) diff --git a/third_party/bazel/rules_haskell/haskell/lint.bzl b/third_party/bazel/rules_haskell/haskell/lint.bzl new file mode 100644 index 000000000000..1ee7d47a2e11 --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/lint.bzl @@ -0,0 +1,137 @@ +"""Linting""" + +load( + "@io_tweag_rules_haskell//haskell:providers.bzl", + "HaskellInfo", + "HaskellLibraryInfo", + "HaskellLintInfo", +) +load(":private/context.bzl", "haskell_context", "render_env") +load(":private/packages.bzl", "expose_packages", "pkg_info_to_compile_flags") +load( + ":private/path_utils.bzl", + "target_unique_name", +) +load(":providers.bzl", "get_libs_for_ghc_linker") +load(":private/set.bzl", "set") + +def _collect_lint_logs(deps): + lint_logs = set.empty() + for dep in deps: + if HaskellLintInfo in dep: + set.mutable_union(lint_logs, dep[HaskellLintInfo].outputs) + return lint_logs + +def _haskell_lint_rule_impl(ctx): + return [DefaultInfo( + files = set.to_depset(_collect_lint_logs(ctx.attr.deps)), + )] + +def _haskell_lint_aspect_impl(target, ctx): + hs = haskell_context(ctx, ctx.rule.attr) + + if HaskellInfo not in target: + return [] + + hs_info = target[HaskellInfo] + lib_info = target[HaskellLibraryInfo] if HaskellLibraryInfo in target else None + + args = ctx.actions.args() + + args.add_all([ + "-O0", + "-v0", + "-fno-code", + "-Wall", + "-Werror", + "-Wcompat", + "-Wincomplete-record-updates", + "-Wincomplete-uni-patterns", + "-Wredundant-constraints", + "-Wnoncanonical-monad-instances", + "--make", + ]) + + args.add_all(pkg_info_to_compile_flags(expose_packages( + hs_info, + lib_info, + use_direct = False, + use_my_pkg_id = None, + custom_package_databases = None, + version = ctx.rule.attr.version, + ))) + + sources = set.to_list(hs_info.source_files) + + args.add_all(sources) + + lint_log = ctx.actions.declare_file( + target_unique_name(hs, "lint-log"), + ) + + # Transitive library dependencies for runtime. + (library_deps, ld_library_deps, _ghc_env) = get_libs_for_ghc_linker( + hs, + hs_info.transitive_cc_dependencies, + ) + + ctx.actions.run_shell( + inputs = depset(transitive = [ + depset(sources), + set.to_depset(hs_info.package_databases), + set.to_depset(hs_info.interface_dirs), + set.to_depset(hs_info.dynamic_libraries), + depset(library_deps), + depset(ld_library_deps), + depset([hs.tools.ghc]), + ]), + outputs = [lint_log], + mnemonic = "HaskellLint", + progress_message = "HaskellLint {}".format(ctx.label), + command = """ + {env} + {ghc} "$@" > {output} 2>&1 || rc=$? && cat {output} && exit $rc + """.format( + ghc = hs.tools.ghc.path, + output = lint_log.path, + # XXX Workaround + # https://github.com/bazelbuild/bazel/issues/5980. + env = render_env(hs.env), + ), + arguments = [args], + use_default_shell_env = True, + ) + + lint_info = HaskellLintInfo(outputs = set.singleton(lint_log)) + output_files = OutputGroupInfo(default = [lint_log]) + + return [lint_info, output_files] + +haskell_lint_aspect = aspect( + _haskell_lint_aspect_impl, + attr_aspects = ["deps"], + toolchains = ["@io_tweag_rules_haskell//haskell:toolchain"], +) + +haskell_lint = rule( + _haskell_lint_rule_impl, + attrs = { + "deps": attr.label_list( + aspects = [haskell_lint_aspect], + doc = "List of Haskell targets to lint.", + ), + }, + toolchains = ["@io_tweag_rules_haskell//haskell:toolchain"], +) +"""Check source code of targets in `deps` using a restrictive set of GHC +flags. + +The following flags will be used: + +* `-Wall` +* `-Werror` +* `-Wcompat` +* `-Wincomplete-record-updates` +* `-Wincomplete-uni-patterns` +* `-Wredundant-constraints` +""" diff --git a/third_party/bazel/rules_haskell/haskell/nix/default.nix b/third_party/bazel/rules_haskell/haskell/nix/default.nix new file mode 100644 index 000000000000..d32f558625c4 --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/nix/default.nix @@ -0,0 +1,119 @@ +/** + Generate a bazel-friendly nix package containing + - The haskell package itself + - Its documentation + - A bazel file ready to be loaded from the `BUILD` file and containing the + right call to `haskell_import` +*/ +{ runCommand, lib, writeTextDir, symlinkJoin }: +let + /* Generate the BUILD file for the package */ + genBuildFile = + { package_name, package, ghc }: + runCommand "${package_name}-BUILD" { + preferLocalBuild = true; + allowSubstitutes = false; + ghc_pkg = "${ghc}/bin/ghc-pkg --simple-output -v0"; + GHC_PACKAGE_PATH = "${package}/lib/${ghc.name}/package.conf.d"; + inherit package_name; + } '' + query_field () { + $ghc_pkg field ${package_name} "$@" + } + + query_haddock () { + echo -n '[' + for FIELD in $(query_field "$@"); do + echo -n "\"$(echo "$FIELD" | cut -d/ -f5-)*\"," + echo -n "\"$(echo "$FIELD" | cut -d/ -f5-)/*\"," + done + echo -n ']' + } + + query_list () { + echo -n '[' + for FIELD in $(query_field "$@"); do + echo -n '"' + echo -n $(echo "$FIELD" | cut -d/ -f5-) + echo -n '",' + done + echo -n ']' + } + + get_deps () { + echo -n '[' + for DEP in $(query_field depends); do + DEPNAME=$(echo $DEP | sed 's/-[0-9].*//') + # Because of cabal's "internal libraries", we may have a package + # apparently depending on itself, so we have to filter out this + # corner-case (see + # https://github.com/tweag/rules_haskell/pull/442#discussion_r219859467) + if [[ -n $DEPNAME && $DEPNAME != $(query_field name) ]]; then + echo -n "\"@hackage-$DEPNAME\"," + fi + done + echo -n ']' + } + + mkdir -p $out + cat <<EOF > $out/BUILD.bzl + load("@io_tweag_rules_haskell//haskell:import.bzl", haskell_import_new = "haskell_import") + deps_repos = $(get_deps) + + def targets(): + + haskell_import_new( + name = "pkg", + deps = [ dep + "//:pkg" for dep in deps_repos], + package_id = "$(query_field id)", + version = "$(query_field version)", + package_confs = "//:package_conf", + haddock_interfaces = "//:interfaces", + haddock_html = "//:html", + ) + native.filegroup( + name = "html", + srcs = native.glob($(query_haddock haddock-html), exclude_directories=1), + ) + native.filegroup( + name = "interfaces", + srcs = native.glob($(query_haddock haddock-interfaces), exclude_directories=0), + ) + native.filegroup( + name = "bin", + srcs = native.glob(["bin/*"]), + ) + native.filegroup( + name = "package_conf", + srcs = native.glob(["lib*/${ghc.name}/package.conf.d/$(query_field name)*.conf"]), + ) + EOF + ''; + genAllBuilds = pkgSet: + let newSet = + lib.mapAttrs (package_name: package: + let + # Some nix packages are actually `null` because the haskell package is + # bundled with ghc (so it doesn't have a custom derivation of its own). + # For these, we simply pass the ghc derivation instead of theirs. + real_package = if builtins.isNull package then pkgSet.ghc else package; + buildFile = genBuildFile { + inherit (pkgSet) ghc; + inherit package_name; + package = real_package; + }; + in + symlinkJoin { + name = package_name + "-bazel"; + paths = [ real_package (real_package.doc or null) buildFile ]; + } + ) + pkgSet; + in + newSet // { + packageNames = writeTextDir + "all-haskell-packages.bzl" + ("packages =" + builtins.toJSON (builtins.attrNames newSet)); + }; +in +genAllBuilds diff --git a/third_party/bazel/rules_haskell/haskell/nixpkgs.bzl b/third_party/bazel/rules_haskell/haskell/nixpkgs.bzl new file mode 100644 index 000000000000..20d77f72193a --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/nixpkgs.bzl @@ -0,0 +1,354 @@ +"""Workspace rules (Nixpkgs)""" + +load("@bazel_skylib//lib:dicts.bzl", "dicts") +load( + "@io_tweag_rules_nixpkgs//nixpkgs:nixpkgs.bzl", + "nixpkgs_package", +) + +def haskell_nixpkgs_package( + name, + attribute_path, + nix_file_deps = [], + repositories = {}, + build_file_content = None, + build_file = None, + **kwargs): + """Load a single haskell package. + The package is expected to be in the form of the packages generated by + `genBazelBuild.nix` + """ + repositories = dicts.add( + {"bazel_haskell_wrapper": "@io_tweag_rules_haskell//haskell:nix/default.nix"}, + repositories, + ) + + nixpkgs_args = dict( + name = name, + attribute_path = attribute_path, + build_file_content = build_file_content, + nix_file_deps = nix_file_deps + ["@io_tweag_rules_haskell//haskell:nix/default.nix"], + repositories = repositories, + **kwargs + ) + + if build_file_content: + nixpkgs_args["build_file_content"] = build_file_content + elif build_file: + nixpkgs_args["build_file"] = build_file + else: + nixpkgs_args["build_file_content"] = """ +package(default_visibility = ["//visibility:public"]) +load("@io_tweag_rules_haskell//haskell:import.bzl", haskell_import_new = "haskell_import") + +load(":BUILD.bzl", "targets") +targets() +""" + + nixpkgs_package( + **nixpkgs_args + ) + +def _bundle_impl(repository_ctx): + build_file_content = """ +package(default_visibility = ["//visibility:public"]) + """ + for package in repository_ctx.attr.packages: + build_file_content += """ +alias( + name = "{package}", + actual = "@{base_repo}-{package}//:pkg", +) + """.format( + package = package, + base_repo = repository_ctx.attr.base_repository, + ) + repository_ctx.file("BUILD", build_file_content) + +_bundle = repository_rule( + attrs = { + "packages": attr.string_list(), + "base_repository": attr.string(), + }, + implementation = _bundle_impl, +) +""" +Generate an alias from `@base_repo//:package` to `@base_repo-package//:pkg` for +each one of the input package +""" + +def haskell_nixpkgs_packages(name, base_attribute_path, packages, **kwargs): + """Import a set of haskell packages from nixpkgs. + + This takes as input the same arguments as + [nixpkgs_package](https://github.com/tweag/rules_nixpkgs#nixpkgs_package), + expecting the `attribute_path` to resolve to a set of haskell packages + (such as `haskellPackages` or `haskell.packages.ghc822`) preprocessed by + the `genBazelBuild` function. It also takes as input a list of packages to + import (which can be generated by the `gen_packages_list` function). + """ + for package in packages: + haskell_nixpkgs_package( + name = name + "-" + package, + attribute_path = base_attribute_path + "." + package, + **kwargs + ) + _bundle( + name = name, + packages = packages, + base_repository = name, + ) + +def _is_nix_platform(repository_ctx): + return repository_ctx.which("nix-build") != None + +def _gen_imports_impl(repository_ctx): + repository_ctx.file("BUILD", "") + extra_args_raw = "" + for foo, bar in repository_ctx.attr.extra_args.items(): + extra_args_raw += foo + " = " + bar + ", " + bzl_file_content = """ +load("{repo_name}", "packages") +load("@io_tweag_rules_haskell//haskell:nixpkgs.bzl", "haskell_nixpkgs_packages") + +def import_packages(name): + haskell_nixpkgs_packages( + name = name, + packages = packages, + {extra_args_raw} + ) + """.format( + repo_name = repository_ctx.attr.packages_list_file, + extra_args_raw = extra_args_raw, + ) + + # A dummy 'packages.bzl' file with a no-op 'import_packages()' on unsupported platforms + bzl_file_content_unsupported_platform = """ +def import_packages(name): + return + """ + if _is_nix_platform(repository_ctx): + repository_ctx.file("packages.bzl", bzl_file_content) + else: + repository_ctx.file("packages.bzl", bzl_file_content_unsupported_platform) + +_gen_imports_str = repository_rule( + implementation = _gen_imports_impl, + attrs = dict( + packages_list_file = attr.label(doc = "A list containing the list of packages to import"), + # We pass the extra arguments to `haskell_nixpkgs_packages` as strings + # since we can't forward arbitrary arguments in a rule and they will be + # converted to strings anyways. + extra_args = attr.string_dict(doc = "Extra arguments for `haskell_nixpkgs_packages`"), + ), +) +""" +Generate a repository containing a file `packages.bzl` which imports the given +packages list. +""" + +def _gen_imports(name, packages_list_file, extra_args): + """ + A wrapper around `_gen_imports_str` which allows passing an arbitrary set of + `extra_args` instead of a set of strings + """ + extra_args_str = {label: repr(value) for (label, value) in extra_args.items()} + _gen_imports_str( + name = name, + packages_list_file = packages_list_file, + extra_args = extra_args_str, + ) + +def haskell_nixpkgs_packageset(name, base_attribute_path, repositories = {}, **kwargs): + """Import all the available haskell packages. + The arguments are the same as the arguments of ``nixpkgs_package``, except + for the ``base_attribute_path`` which should point to an `haskellPackages` + set in the nix expression + + Example: + + In `haskellPackages.nix`: + + ```nix + with import <nixpkgs> {}; + + let wrapPackages = callPackage <bazel_haskell_wrapper> { }; in + { haskellPackages = wrapPackages haskell.packages.ghc822; } + ``` + + In your `WORKSPACE` + + ```bazel + # Define a nix repository to fetch the packages from + load("@io_tweag_rules_nixpkgs//nixpkgs:nixpkgs.bzl", + "nixpkgs_git_repository") + nixpkgs_git_repository( + name = "nixpkgs", + revision = "9a787af6bc75a19ac9f02077ade58ddc248e674a", + ) + + load("@io_tweag_rules_haskell//haskell:nixpkgs.bzl", + "haskell_nixpkgs_packageset", + + # Generate a list of all the available haskell packages + haskell_nixpkgs_packageset( + name = "hackage-packages", + repositories = {"@nixpkgs": "nixpkgs"}, + nix_file = "//haskellPackages.nix", + base_attribute_path = "haskellPackages", + ) + load("@hackage-packages//:packages.bzl", "import_packages") + import_packages(name = "hackage") + ``` + + Then in your `BUILD` files, you can access to the whole of hackage as + `@hackage//:{your-package-name}` + """ + + repositories = dicts.add( + {"bazel_haskell_wrapper": "@io_tweag_rules_haskell//haskell:nix/default.nix"}, + repositories, + ) + + nixpkgs_package( + name = name + "-packages-list", + attribute_path = base_attribute_path + ".packageNames", + repositories = repositories, + build_file_content = """ +exports_files(["all-haskell-packages.bzl"]) + """, + fail_not_supported = False, + **kwargs + ) + _gen_imports( + name = name, + packages_list_file = "@" + name + "-packages-list//:all-haskell-packages.bzl", + extra_args = dict( + repositories = repositories, + base_attribute_path = base_attribute_path, + **kwargs + ), + ) + +def _ghc_nixpkgs_toolchain_impl(repository_ctx): + # These constraints might look tautological, because they always + # match the host platform if it is the same as the target + # platform. But they are important to state because Bazel + # toolchain resolution prefers other toolchains with more specific + # constraints otherwise. + target_constraints = ["@bazel_tools//platforms:x86_64"] + if repository_ctx.os.name == "linux": + target_constraints.append("@bazel_tools//platforms:linux") + elif repository_ctx.os.name == "mac os x": + target_constraints.append("@bazel_tools//platforms:osx") + exec_constraints = list(target_constraints) + exec_constraints.append("@io_tweag_rules_haskell//haskell/platforms:nixpkgs") + + compiler_flags_select = repository_ctx.attr.compiler_flags_select or {"//conditions:default": []} + locale_archive = repr(repository_ctx.attr.locale_archive or None) + + repository_ctx.file( + "BUILD", + executable = False, + content = """ +load("@io_tweag_rules_haskell//haskell:toolchain.bzl", "haskell_toolchain") + +haskell_toolchain( + name = "toolchain", + tools = ["{tools}"], + version = "{version}", + compiler_flags = {compiler_flags} + {compiler_flags_select}, + haddock_flags = {haddock_flags}, + repl_ghci_args = {repl_ghci_args}, + # On Darwin we don't need a locale archive. It's a Linux-specific + # hack in Nixpkgs. + locale_archive = {locale_archive}, + exec_compatible_with = {exec_constraints}, + target_compatible_with = {target_constraints}, +) + """.format( + tools = "@io_tweag_rules_haskell_ghc-nixpkgs//:bin", + version = repository_ctx.attr.version, + compiler_flags = repository_ctx.attr.compiler_flags, + compiler_flags_select = "select({})".format(compiler_flags_select), + haddock_flags = repository_ctx.attr.haddock_flags, + repl_ghci_args = repository_ctx.attr.repl_ghci_args, + locale_archive = locale_archive, + exec_constraints = exec_constraints, + target_constraints = target_constraints, + ), + ) + +_ghc_nixpkgs_toolchain = repository_rule( + _ghc_nixpkgs_toolchain_impl, + local = False, + attrs = { + # These attributes just forward to haskell_toolchain. + # They are documented there. + "version": attr.string(), + "compiler_flags": attr.string_list(), + "compiler_flags_select": attr.string_list_dict(), + "haddock_flags": attr.string_list(), + "repl_ghci_args": attr.string_list(), + "locale_archive": attr.string(), + }, +) + +def haskell_register_ghc_nixpkgs( + version, + build_file = None, + compiler_flags = None, + compiler_flags_select = None, + haddock_flags = None, + repl_ghci_args = None, + locale_archive = None, + attribute_path = "haskellPackages.ghc", + nix_file = None, + nix_file_deps = [], + repositories = {}): + """Register a package from Nixpkgs as a toolchain. + + Toolchains can be used to compile Haskell code. To have this + toolchain selected during [toolchain + resolution][toolchain-resolution], set a host platform that + includes the `@io_tweag_rules_haskell//haskell/platforms:nixpkgs` + constraint value. + + [toolchain-resolution]: https://docs.bazel.build/versions/master/toolchains.html#toolchain-resolution + + Example: + + ``` + haskell_register_ghc_nixpkgs( + locale_archive = "@glibc_locales//:locale-archive", + atttribute_path = "haskellPackages.ghc", + version = "1.2.3", # The version of GHC + ) + ``` + + Setting the host platform can be done on the command-line like + in the following: + + ``` + --host_platform=@io_tweag_rules_haskell//haskell/platforms:linux_x86_64_nixpkgs + ``` + + """ + haskell_nixpkgs_package( + name = "io_tweag_rules_haskell_ghc-nixpkgs", + attribute_path = attribute_path, + build_file = build_file or "@io_tweag_rules_haskell//haskell:ghc.BUILD", + nix_file = nix_file, + nix_file_deps = nix_file_deps, + repositories = repositories, + ) + _ghc_nixpkgs_toolchain( + name = "io_tweag_rules_haskell_ghc-nixpkgs-toolchain", + version = version, + compiler_flags = compiler_flags, + compiler_flags_select = compiler_flags_select, + haddock_flags = haddock_flags, + repl_ghci_args = repl_ghci_args, + locale_archive = locale_archive, + ) + native.register_toolchains("@io_tweag_rules_haskell_ghc-nixpkgs-toolchain//:toolchain") diff --git a/third_party/bazel/rules_haskell/haskell/platforms/BUILD.bazel b/third_party/bazel/rules_haskell/haskell/platforms/BUILD.bazel new file mode 100644 index 000000000000..6edf86824e27 --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/platforms/BUILD.bazel @@ -0,0 +1,39 @@ +# This file declares constraint values for each platform supported by +# GHC. These rules follow the GHC naming convention, for example, +# //haskell/platform:linux and //haskell/platform:x86_64. See the +# config.guess in any GHC source distribution for possible platforms. +# +# These can be used in select expressions to choose platform-specifc +# sources and dependencies. + +load(":list.bzl", "declare_config_settings") + +declare_config_settings() + +constraint_value( + name = "nixpkgs", + constraint_setting = "@bazel_tools//tools/cpp:cc_compiler", + visibility = ["//visibility:public"], +) + +platform( + name = "linux_x86_64_nixpkgs", + constraint_values = [ + # XXX using the platform names defined here results in a graph + # cycle for some reason. + "@bazel_tools//platforms:x86_64", + "@bazel_tools//platforms:linux", + ":nixpkgs", + ], + visibility = ["//visibility:public"], +) + +platform( + name = "darwin_x86_64_nixpkgs", + constraint_values = [ + "@bazel_tools//platforms:x86_64", + "@bazel_tools//platforms:osx", + ":nixpkgs", + ], + visibility = ["//visibility:public"], +) diff --git a/third_party/bazel/rules_haskell/haskell/platforms/list.bzl b/third_party/bazel/rules_haskell/haskell/platforms/list.bzl new file mode 100644 index 000000000000..d71be41690cc --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/platforms/list.bzl @@ -0,0 +1,44 @@ +OS = { + "aix": None, + "darwin": "@bazel_tools//platforms:osx", + "dragonfly": None, + "freebsd": "@bazel_tools//platforms:freebsd", + "haiku": None, + "hpux": None, + "ios": "@bazel_tools//platforms:ios", + "linux_android": "@bazel_tools//platforms:android", + "linux": "@bazel_tools//platforms:linux", + "mingw32": "@bazel_tools//platforms:windows", + "netbsd": None, + "openbsd": None, + "solaris2": None, +} + +ARCH = { + "aarch64": None, + "alpha": None, + "arm64": "@bazel_tools//platforms:aarch64", + "arm": "@bazel_tools//platforms:arm", + "i386": "@bazel_tools//platforms:x86_32", + "ia64": None, + "powerpc64": None, + "powerpc64le": None, + "powerpc": "@bazel_tools//platforms:ppc", + "rs6000": None, + "sparc": None, + "x86_64": "@bazel_tools//platforms:x86_64", +} + +def declare_config_settings(): + for os, constraint_value in OS.items(): + if constraint_value: + native.config_setting( + name = os, + constraint_values = [constraint_value], + ) + for arch, constraint_value in ARCH.items(): + if constraint_value: + native.config_setting( + name = arch, + constraint_values = [constraint_value], + ) diff --git a/third_party/bazel/rules_haskell/haskell/plugins.bzl b/third_party/bazel/rules_haskell/haskell/plugins.bzl new file mode 100644 index 000000000000..5769eeaf7ef6 --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/plugins.bzl @@ -0,0 +1,64 @@ +load(":providers.bzl", "GhcPluginInfo", "HaskellLibraryInfo") + +def ghc_plugin_impl(ctx): + args = ctx.attr.args + args = [ctx.expand_location(arg, ctx.attr.tools) for arg in args] + args = [ctx.expand_make_variables("args", arg, {}) for arg in args] + + # XXX Ideally we'd resolve tools downstream. + (tool_inputs, tool_input_manifests) = ctx.resolve_tools(tools = ctx.attr.tools) + return [ + GhcPluginInfo( + module = ctx.attr.module, + deps = ctx.attr.deps, + tool_inputs = tool_inputs, + tool_input_manifests = tool_input_manifests, + args = args, + ), + ] + +ghc_plugin = rule( + ghc_plugin_impl, + attrs = { + "module": attr.string( + doc = "Plugin entrypoint.", + ), + "deps": attr.label_list( + doc = "Plugin dependencies. These are compile-time dependencies only.", + providers = [HaskellLibraryInfo], + ), + "args": attr.string_list( + doc = "Plugin options.", + ), + "tools": attr.label_list( + doc = "Tools needed by the plugin when it used.", + ), + }, +) +"""Declare a GHC plugin. + +Example: + ```bzl + haskell_library( + name = "plugin-lib", + srcs = ["Plugin.hs"], + ) + + ghc_plugin( + name = "plugin", + module = "Plugin", + deps = [":plugin-lib"], + ) + + haskell_binary( + name = "some-binary", + srcs = ["Main.hs"], + plugins = [":plugin"], + ``` + +Plugins to use during compilation by GHC are given by the `plugins` +attribute to Haskell rules. Plugins are haskell libraries with some +extra metadata, like the name of the module that acts as the +entrypoint for the plugin and plugin options. + +""" diff --git a/third_party/bazel/rules_haskell/haskell/private/actions/compile.bzl b/third_party/bazel/rules_haskell/haskell/private/actions/compile.bzl new file mode 100644 index 000000000000..530b23a04b0f --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/private/actions/compile.bzl @@ -0,0 +1,563 @@ +"""Actions for compiling Haskell source code""" + +load(":private/packages.bzl", "expose_packages", "pkg_info_to_compile_flags") +load("@bazel_skylib//lib:dicts.bzl", "dicts") +load("@bazel_skylib//lib:paths.bzl", "paths") +load( + ":private/path_utils.bzl", + "declare_compiled", + "module_name", + "target_unique_name", +) +load(":private/pkg_id.bzl", "pkg_id") +load(":private/version_macros.bzl", "version_macro_includes") +load( + ":providers.bzl", + "GhcPluginInfo", + "get_libs_for_ghc_linker", + "merge_HaskellCcInfo", +) +load(":private/set.bzl", "set") + +def _process_hsc_file(hs, cc, hsc_flags, hsc_inputs, hsc_file): + """Process a single hsc file. + + Args: + hs: Haskell context. + cc: CcInteropInfo, information about C dependencies. + hsc_flags: extra flags to pass to hsc2hs + hsc_inputs: extra file inputs for the hsc2hs command + hsc_file: hsc file to process. + + Returns: + (File, string): Haskell source file created by processing hsc_file and + new import directory containing the produced file. + """ + args = hs.actions.args() + + # Output a Haskell source file. + hsc_dir_raw = paths.join("_hsc", hs.name) + hs_out = declare_compiled(hs, hsc_file, ".hs", directory = hsc_dir_raw) + args.add_all([hsc_file.path, "-o", hs_out.path]) + + args.add_all(["-c", cc.tools.cc]) + args.add_all(["-l", cc.tools.cc]) + args.add("-ighcplatform.h") + args.add("-ighcversion.h") + args.add_all(["--cflag=" + f for f in cc.cpp_flags]) + args.add_all(["--cflag=" + f for f in cc.compiler_flags]) + args.add_all(["--cflag=" + f for f in cc.include_args]) + args.add_all(["--lflag=" + f for f in cc.linker_flags]) + args.add_all(hsc_flags) + + # Add an empty PATH variable if not already specified in hs.env. + # Needed to avoid a "Couldn't read PATH" error on Windows. + # + # On Unix platforms, though, we musn't set PATH as it is automatically set up + # by the run action, unless already set in the env parameter. This triggers + # build errors when using GHC bindists on Linux. + if hs.env.get("PATH") == None and hs.toolchain.is_windows: + hs.env["PATH"] = "" + + hs.actions.run( + inputs = depset(transitive = [ + depset(cc.hdrs), + depset([hsc_file]), + depset(cc.files), + depset(hsc_inputs), + ]), + outputs = [hs_out], + mnemonic = "HaskellHsc2hs", + executable = hs.tools.hsc2hs, + arguments = [args], + env = hs.env, + ) + + idir = paths.join( + hs.bin_dir.path, + hs.label.package, + hsc_dir_raw, + ) + + return hs_out, idir + +def _compilation_defaults(hs, cc, java, dep_info, plugin_dep_info, srcs, import_dir_map, extra_srcs, user_compile_flags, with_profiling, my_pkg_id, version, plugins): + """Compute variables common to all compilation targets (binary and library). + + Returns: + struct with the following fields: + args: default argument list + compile_flags: arguments that were used to compile the package + inputs: default inputs + input_manifests: input manifests + outputs: default outputs + objects_dir: object files directory + interfaces_dir: interface files directory + source_files: set of files that contain Haskell modules + extra_source_files: depset of non-Haskell source files + import_dirs: c2hs Import hierarchy roots + env: default environment variables + """ + + compile_flags = [] + + # GHC expects the CC compiler as the assembler, but segregates the + # set of flags to pass to it when used as an assembler. So we have + # to set both -optc and -opta. + cc_args = [ + "-optc" + f + for f in cc.compiler_flags + ] + [ + "-opta" + f + for f in cc.compiler_flags + ] + compile_flags += cc_args + + interface_dir_raw = "_iface_prof" if with_profiling else "_iface" + object_dir_raw = "_obj_prof" if with_profiling else "_obj" + + # Declare file directories. + # + # NOTE: We could have used -outputdir here and a single output + # directory. But keeping interface and object files separate has + # one advantage: if interface files are invariant under + # a particular code change, then we don't need to rebuild + # downstream. + if my_pkg_id: + # If we're compiling a package, put the interfaces inside the + # package directory. + interfaces_dir = hs.actions.declare_directory( + paths.join( + pkg_id.to_string(my_pkg_id), + interface_dir_raw, + ), + ) + else: + interfaces_dir = hs.actions.declare_directory( + paths.join(interface_dir_raw, hs.name), + ) + objects_dir = hs.actions.declare_directory( + paths.join(object_dir_raw, hs.name), + ) + + # Default compiler flags. + compile_flags += hs.toolchain.compiler_flags + compile_flags += user_compile_flags + + # Work around macOS linker limits. This fix has landed in GHC HEAD, but is + # not yet in a release; plus, we still want to support older versions of + # GHC. For details, see: https://phabricator.haskell.org/D4714 + if hs.toolchain.is_darwin: + compile_flags += ["-optl-Wl,-dead_strip_dylibs"] + + compile_flags.extend( + pkg_info_to_compile_flags( + expose_packages( + dep_info, + lib_info = None, + use_direct = True, + use_my_pkg_id = my_pkg_id, + custom_package_databases = None, + version = version, + ), + ), + ) + compile_flags.extend( + pkg_info_to_compile_flags( + expose_packages( + plugin_dep_info, + lib_info = None, + use_direct = True, + use_my_pkg_id = my_pkg_id, + custom_package_databases = None, + version = version, + ), + for_plugin = True, + ), + ) + + header_files = [] + boot_files = [] + source_files = set.empty() + + # Forward all "-D" and "-optP-D" flags to hsc2hs + hsc_flags = [] + hsc_flags += ["--cflag=" + x for x in user_compile_flags if x.startswith("-D")] + hsc_flags += ["--cflag=" + x[len("-optP"):] for x in user_compile_flags if x.startswith("-optP-D")] + + hsc_inputs = [] + if version: + (version_macro_headers, version_macro_flags) = version_macro_includes(dep_info) + hsc_flags += ["--cflag=" + x for x in version_macro_flags] + hsc_inputs += set.to_list(version_macro_headers) + + # Add import hierarchy root. + # Note that this is not perfect, since GHC requires hs-boot files + # to be in the same directory as the corresponding .hs file. Thus + # the two must both have the same root; i.e., both plain files, + # both in bin_dir, or both in genfiles_dir. + + import_dirs = set.from_list([ + hs.src_root, + paths.join(hs.bin_dir.path, hs.src_root), + paths.join(hs.genfiles_dir.path, hs.src_root), + ]) + + for s in srcs: + if s.extension == "h": + header_files.append(s) + elif s.extension == "hsc": + s0, idir = _process_hsc_file(hs, cc, hsc_flags, hsc_inputs, s) + set.mutable_insert(source_files, s0) + set.mutable_insert(import_dirs, idir) + elif s.extension in ["hs-boot", "lhs-boot"]: + boot_files.append(s) + else: + set.mutable_insert(source_files, s) + + if s in import_dir_map: + idir = import_dir_map[s] + set.mutable_insert(import_dirs, idir) + + compile_flags += ["-i{0}".format(d) for d in set.to_list(import_dirs)] + + # Write the -optP flags to a parameter file because they can be very long on Windows + # e.g. 27Kb for grpc-haskell + # Equivalent to: compile_flags += ["-optP" + f for f in cc.cpp_flags] + optp_args_file = hs.actions.declare_file("optp_args_%s" % hs.name) + optp_args = hs.actions.args() + optp_args.add_all(cc.cpp_flags) + optp_args.set_param_file_format("multiline") + hs.actions.write(optp_args_file, optp_args) + compile_flags += ["-optP@" + optp_args_file.path] + + compile_flags += cc.include_args + + locale_archive_depset = ( + depset([hs.toolchain.locale_archive]) if hs.toolchain.locale_archive != None else depset() + ) + + # This is absolutely required otherwise GHC doesn't know what package it's + # creating `Name`s for to put them in Haddock interface files which then + # results in Haddock not being able to find names for linking in + # environment after reading its interface file later. + if my_pkg_id != None: + unit_id_args = [ + "-this-unit-id", + pkg_id.to_string(my_pkg_id), + "-optP-DCURRENT_PACKAGE_KEY=\"{}\"".format(pkg_id.to_string(my_pkg_id)), + ] + compile_flags += unit_id_args + + args = hs.actions.args() + + # Compilation mode. Allow rule-supplied compiler flags to override it. + if hs.mode == "opt": + args.add("-O2") + + args.add("-static") + if with_profiling: + args.add("-prof", "-fexternal-interpreter") + + # Common flags + args.add_all([ + "-v0", + "-no-link", + "-fPIC", + "-hide-all-packages", + # Should never trigger in sandboxed builds, but can be useful + # to debug issues in non-sandboxed builds. + "-Wmissing-home-modules", + ]) + + # Output directories + args.add_all([ + "-odir", + objects_dir.path, + "-hidir", + interfaces_dir.path, + ]) + + # Interface files with profiling have to have the extension "p_hi": + # https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/packages.html#installedpackageinfo-a-package-specification + # otherwise we won't be able to register them with ghc-pkg. + if with_profiling: + args.add_all([ + "-hisuf", + "p_hi", + "-osuf", + "p_o", + ]) + + args.add_all(compile_flags) + + # Plugins + for plugin in plugins: + args.add("-fplugin={}".format(plugin[GhcPluginInfo].module)) + for opt in plugin[GhcPluginInfo].args: + args.add_all(["-fplugin-opt", "{}:{}".format(plugin[GhcPluginInfo].module, opt)]) + + plugin_tool_inputs = [plugin[GhcPluginInfo].tool_inputs for plugin in plugins] + plugin_tool_input_manifests = [ + manifest + for plugin in plugins + for manifest in plugin[GhcPluginInfo].tool_input_manifests + ] + + # Pass source files + for f in set.to_list(source_files): + args.add(f) + + extra_source_files = depset( + transitive = [extra_srcs, depset(header_files), depset(boot_files)], + ) + + # Transitive library dependencies for runtime. + (library_deps, ld_library_deps, ghc_env) = get_libs_for_ghc_linker( + hs, + merge_HaskellCcInfo( + dep_info.transitive_cc_dependencies, + plugin_dep_info.transitive_cc_dependencies, + ), + ) + + return struct( + args = args, + compile_flags = compile_flags, + inputs = depset(transitive = [ + depset(header_files), + depset(boot_files), + set.to_depset(source_files), + extra_source_files, + depset(cc.hdrs), + set.to_depset(dep_info.package_databases), + set.to_depset(dep_info.interface_dirs), + depset(dep_info.static_libraries), + depset(dep_info.static_libraries_prof), + set.to_depset(dep_info.dynamic_libraries), + set.to_depset(plugin_dep_info.package_databases), + set.to_depset(plugin_dep_info.interface_dirs), + depset(plugin_dep_info.static_libraries), + depset(plugin_dep_info.static_libraries_prof), + set.to_depset(plugin_dep_info.dynamic_libraries), + depset(library_deps), + depset(ld_library_deps), + java.inputs, + locale_archive_depset, + depset(transitive = plugin_tool_inputs), + depset([optp_args_file]), + ]), + input_manifests = plugin_tool_input_manifests, + objects_dir = objects_dir, + interfaces_dir = interfaces_dir, + outputs = [objects_dir, interfaces_dir], + source_files = source_files, + extra_source_files = depset(transitive = [extra_source_files, depset([optp_args_file])]), + import_dirs = import_dirs, + env = dicts.add( + ghc_env, + java.env, + hs.env, + ), + ) + +def _hpc_compiler_args(hs): + hpcdir = "{}/{}/.hpc".format(hs.bin_dir.path, hs.package_root) + return ["-fhpc", "-hpcdir", hpcdir] + +def _coverage_datum(mix_file, src_file, target_label): + return struct( + mix_file = mix_file, + src_file = src_file, + target_label = target_label, + ) + +def compile_binary( + hs, + cc, + java, + dep_info, + plugin_dep_info, + srcs, + ls_modules, + import_dir_map, + extra_srcs, + user_compile_flags, + dynamic, + with_profiling, + main_function, + version, + inspect_coverage = False, + plugins = []): + """Compile a Haskell target into object files suitable for linking. + + Returns: + struct with the following fields: + object_files: list of static object files + object_dyn_files: list of dynamic object files + modules: set of module names + source_files: set of Haskell source files + """ + c = _compilation_defaults(hs, cc, java, dep_info, plugin_dep_info, srcs, import_dir_map, extra_srcs, user_compile_flags, with_profiling, my_pkg_id = None, version = version, plugins = plugins) + c.args.add_all(["-main-is", main_function]) + if dynamic: + # For binaries, GHC creates .o files even for code to be + # linked dynamically. So we have to force the object suffix to + # be consistent with the dynamic object suffix in the library + # case. + c.args.add_all(["-dynamic", "-osuf dyn_o"]) + + coverage_data = [] + if inspect_coverage: + c.args.add_all(_hpc_compiler_args(hs)) + for src_file in srcs: + module = module_name(hs, src_file) + mix_file = hs.actions.declare_file(".hpc/{module}.mix".format(module = module)) + coverage_data.append(_coverage_datum(mix_file, src_file, hs.label)) + + hs.toolchain.actions.run_ghc( + hs, + cc, + inputs = c.inputs, + input_manifests = c.input_manifests, + outputs = c.outputs + [datum.mix_file for datum in coverage_data], + mnemonic = "HaskellBuildBinary" + ("Prof" if with_profiling else ""), + progress_message = "HaskellBuildBinary {}".format(hs.label), + env = c.env, + arguments = c.args, + ) + + if with_profiling: + exposed_modules_file = None + else: + exposed_modules_file = hs.actions.declare_file( + target_unique_name(hs, "exposed-modules"), + ) + hs.actions.run( + inputs = [c.interfaces_dir, hs.toolchain.global_pkg_db], + outputs = [exposed_modules_file], + executable = ls_modules, + arguments = [ + c.interfaces_dir.path, + hs.toolchain.global_pkg_db.path, + "/dev/null", # no hidden modules + "/dev/null", # no reexported modules + exposed_modules_file.path, + ], + use_default_shell_env = True, + ) + + return struct( + objects_dir = c.objects_dir, + source_files = c.source_files, + extra_source_files = c.extra_source_files, + import_dirs = c.import_dirs, + compile_flags = c.compile_flags, + exposed_modules_file = exposed_modules_file, + coverage_data = coverage_data, + ) + +def compile_library( + hs, + cc, + java, + dep_info, + plugin_dep_info, + srcs, + ls_modules, + other_modules, + exposed_modules_reexports, + import_dir_map, + extra_srcs, + user_compile_flags, + with_shared, + with_profiling, + my_pkg_id, + plugins = []): + """Build arguments for Haskell package build. + + Returns: + struct with the following fields: + interfaces_dir: directory containing interface files + interface_files: list of interface files + object_files: list of static object files + object_dyn_files: list of dynamic object files + compile_flags: list of string arguments suitable for Haddock + modules: set of module names + source_files: set of Haskell module files + import_dirs: import directories that should make all modules visible (for GHCi) + """ + c = _compilation_defaults(hs, cc, java, dep_info, plugin_dep_info, srcs, import_dir_map, extra_srcs, user_compile_flags, with_profiling, my_pkg_id = my_pkg_id, version = my_pkg_id.version, plugins = plugins) + if with_shared: + c.args.add("-dynamic-too") + + coverage_data = [] + if hs.coverage_enabled: + c.args.add_all(_hpc_compiler_args(hs)) + for src_file in srcs: + pkg_id_string = pkg_id.to_string(my_pkg_id) + module = module_name(hs, src_file) + mix_file = hs.actions.declare_file(".hpc/{pkg}/{module}.mix".format(pkg = pkg_id_string, module = module)) + coverage_data.append(_coverage_datum(mix_file, src_file, hs.label)) + + hs.toolchain.actions.run_ghc( + hs, + cc, + inputs = c.inputs, + input_manifests = c.input_manifests, + outputs = c.outputs + [datum.mix_file for datum in coverage_data], + mnemonic = "HaskellBuildLibrary" + ("Prof" if with_profiling else ""), + progress_message = "HaskellBuildLibrary {}".format(hs.label), + env = c.env, + arguments = c.args, + ) + + if with_profiling: + exposed_modules_file = None + else: + hidden_modules_file = hs.actions.declare_file( + target_unique_name(hs, "hidden-modules"), + ) + hs.actions.write( + output = hidden_modules_file, + content = ", ".join(other_modules), + ) + reexported_modules_file = hs.actions.declare_file( + target_unique_name(hs, "reexported-modules"), + ) + hs.actions.write( + output = reexported_modules_file, + content = ", ".join(exposed_modules_reexports), + ) + exposed_modules_file = hs.actions.declare_file( + target_unique_name(hs, "exposed-modules"), + ) + hs.actions.run( + inputs = [ + c.interfaces_dir, + hs.toolchain.global_pkg_db, + hidden_modules_file, + reexported_modules_file, + ], + outputs = [exposed_modules_file], + executable = ls_modules, + arguments = [ + c.interfaces_dir.path, + hs.toolchain.global_pkg_db.path, + hidden_modules_file.path, + reexported_modules_file.path, + exposed_modules_file.path, + ], + use_default_shell_env = True, + ) + + return struct( + interfaces_dir = c.interfaces_dir, + objects_dir = c.objects_dir, + compile_flags = c.compile_flags, + source_files = c.source_files, + extra_source_files = c.extra_source_files, + import_dirs = c.import_dirs, + exposed_modules_file = exposed_modules_file, + coverage_data = coverage_data, + ) diff --git a/third_party/bazel/rules_haskell/haskell/private/actions/link.bzl b/third_party/bazel/rules_haskell/haskell/private/actions/link.bzl new file mode 100644 index 000000000000..65cd2c6e4327 --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/private/actions/link.bzl @@ -0,0 +1,667 @@ +"""Actions for linking object code produced by compilation""" + +load(":private/packages.bzl", "expose_packages", "pkg_info_to_compile_flags") +load("@bazel_skylib//lib:paths.bzl", "paths") +load( + ":private/path_utils.bzl", + "get_lib_name", + "is_shared_library", + "is_static_library", + "ln", +) +load(":private/pkg_id.bzl", "pkg_id") +load(":private/set.bzl", "set") +load(":private/list.bzl", "list") + +# tests in /tests/unit_tests/BUILD +def parent_dir_path(path): + """Returns the path of the parent directory. + For a relative path with just a file, "." is returned. + The path is not normalized. + + foo => . + foo/ => foo + foo/bar => foo + foo/bar/baz => foo/bar + foo/../bar => foo/.. + + Args: + a path string + + Returns: + A path list of the form `["foo", "bar"]` + """ + path_dir = paths.dirname(path) + + # dirname returns "" if there is no parent directory + # In that case we return the identity path, which is ".". + if path_dir == "": + return ["."] + else: + return path_dir.split("/") + +def __check_dots(target, path): + # thereโs still (non-leading) .. in split + if ".." in path: + fail("the short_path of target {} (which is {}) contains more dots than loading `../`. We canโt handle that.".format( + target, + target.short_path, + )) + +# skylark doesnโt allow nested defs, which is a mystery. +def _get_target_parent_dir(target): + """get the parent dir and handle leading short_path dots, + which signify that the target is in an external repository. + + Args: + target: a target, .short_path is used + Returns: + (is_external, parent_dir) + `is_external`: Bool whether the path points to an external repository + `parent_dir`: The parent directory, either up to the runfiles toplel, + up to the external repository toplevel. + Is `[]` if there is no parent dir. + """ + + parent_dir = parent_dir_path(target.short_path) + + if parent_dir[0] == "..": + __check_dots(target, parent_dir[1:]) + return (True, parent_dir[1:]) + elif parent_dir[0] == ".": + return (False, []) + else: + __check_dots(target, parent_dir) + return (False, parent_dir) + +# tests in /tests/unit_tests/BUILD +def create_rpath_entry( + binary, + dependency, + keep_filename, + prefix = ""): + """Return a (relative) path that points from `binary` to `dependecy` + while not leaving the current bazel runpath, taking into account weird + corner cases of `.short_path` concerning external repositories. + The resulting entry should be able to be inserted into rpath or similar. + + Examples: + + bin.short_path=foo/a.so and dep.short_path=bar/b.so + => create_rpath_entry(bin, dep, False) = ../bar + and + create_rpath_entry(bin, dep, True) = ../bar/b.so + and + create_rpath_entry(bin, dep, True, "$ORIGIN") = $ORIGIN/../bar/b.so + + Args: + binary: target of current binary + dependency: target of dependency to relatively point to + keep_filename: whether to point to the filename or its parent dir + prefix: string path prefix to add before the relative path + + Returns: + relative path string + """ + + (bin_is_external, bin_parent_dir) = _get_target_parent_dir(binary) + (dep_is_external, dep_parent_dir) = _get_target_parent_dir(dependency) + + # backup through parent directories of the binary, + # to the runfiles directory + bin_backup = [".."] * len(bin_parent_dir) + + # external repositories live in `target.runfiles/external`, + # while the internal repository lives in `target.runfiles`. + # The `.short_path`s of external repositories are strange, + # they start with `../`, but you cannot just append that in + # order to find the correct runpath. Instead you have to use + # the following logic to construct the correct runpaths: + if bin_is_external: + if dep_is_external: + # stay in `external` + path_segments = bin_backup + else: + # backup out of `external` + path_segments = [".."] + bin_backup + elif dep_is_external: + # go into `external` + path_segments = bin_backup + ["external"] + else: + # no special external traversal + path_segments = bin_backup + + # then add the parent dir to our dependency + path_segments.extend(dep_parent_dir) + + # optionally add the filename + if keep_filename: + path_segments.append( + paths.basename(dependency.short_path), + ) + + # normalize for good measure and create the final path + path = paths.normalize("/".join(path_segments)) + + # and add the prefix if applicable + if prefix == "": + return path + else: + return prefix + "/" + path + +def _merge_parameter_files(hs, file1, file2): + """Merge two GHC parameter files into one. + + Args: + hs: Haskell context. + file1: The first parameter file. + file2: The second parameter file. + + Returns: + File: A new parameter file containing the parameters of both input files. + The file name is based on the file names of the input files. The file + is located next to the first input file. + """ + params_file = hs.actions.declare_file( + file1.basename + ".and." + file2.basename, + sibling = file1, + ) + hs.actions.run_shell( + inputs = [file1, file2], + outputs = [params_file], + command = """ + cat {file1} {file2} > {out} + """.format( + file1 = file1.path, + file2 = file2.path, + out = params_file.path, + ), + ) + return params_file + +def _darwin_create_extra_linker_flags_file(hs, cc, objects_dir, executable, dynamic, solibs): + """Write additional linker flags required on MacOS to a parameter file. + + Args: + hs: Haskell context. + cc: CcInteropInfo, information about C dependencies. + objects_dir: Directory storing object files. + Used to determine output file location. + executable: The executable being built. + dynamic: Bool: Whether to link dynamically or statically. + solibs: List of dynamic library dependencies. + + Returns: + File: Parameter file with additional linker flags. To be passed to GHC. + """ + + # On Darwin GHC will pass the dead_strip_dylibs flag to the linker. This + # flag will remove any shared library loads from the binary's header that + # are not directly resolving undefined symbols in the binary. I.e. any + # indirect shared library dependencies will be removed. This conflicts with + # Bazel's builtin cc rules, which assume that the final binary will load + # all transitive shared library dependencies. In particlar shared libraries + # produced by Bazel's cc rules never load shared libraries themselves. This + # causes missing symbols at runtime on MacOS, see #170. + # + # The following work-around applies the `-u` flag to the linker for any + # symbol that is undefined in any transitive shared library dependency. + # This forces the linker to resolve these undefined symbols in all + # transitive shared library dependencies and keep the corresponding load + # commands in the binary's header. + # + # Unfortunately, this prohibits elimination of any truly redundant shared + # library dependencies. Furthermore, the transitive closure of shared + # library dependencies can be large, so this makes it more likely to exceed + # the MACH-O header size limit on MacOS. + # + # This is a horrendous hack, but it seems to be forced on us by how Bazel + # builds dynamic cc libraries. + suffix = ".dynamic.linker_flags" if dynamic else ".static.linker_flags" + linker_flags_file = hs.actions.declare_file( + executable.basename + suffix, + sibling = objects_dir, + ) + + hs.actions.run_shell( + inputs = solibs, + outputs = [linker_flags_file], + command = """ + touch {out} + for lib in {solibs}; do + {nm} -u "$lib" | sed 's/^/-optl-Wl,-u,/' >> {out} + done + """.format( + nm = cc.tools.nm, + solibs = " ".join(["\"" + l.path + "\"" for l in solibs]), + out = linker_flags_file.path, + ), + ) + return linker_flags_file + +def _create_objects_dir_manifest(hs, objects_dir, dynamic, with_profiling): + suffix = ".dynamic.manifest" if dynamic else ".static.manifest" + objects_dir_manifest = hs.actions.declare_file( + objects_dir.basename + suffix, + sibling = objects_dir, + ) + + if with_profiling: + ext = "p_o" + elif dynamic: + ext = "dyn_o" + else: + ext = "o" + hs.actions.run_shell( + inputs = [objects_dir], + outputs = [objects_dir_manifest], + command = """ + find {dir} -name '*.{ext}' > {out} + """.format( + dir = objects_dir.path, + ext = ext, + out = objects_dir_manifest.path, + ), + use_default_shell_env = True, + ) + + return objects_dir_manifest + +def _link_dependencies(hs, dep_info, dynamic, binary, args): + """Configure linker flags and inputs. + + Configure linker flags for C library dependencies and runtime dynamic + library dependencies. And collect the C libraries to pass as inputs to + the linking action. + + Args: + hs: Haskell context. + dep_info: HaskellInfo provider. + dynamic: Bool: Whether to link dynamically, or statically. + binary: Final linked binary. + args: Arguments to the linking action. + + Returns: + depset: C library dependencies to provide as input to the linking action. + """ + + # Pick linking context based on linking mode. + if dynamic: + link_ctx = dep_info.cc_dependencies.dynamic_linking + trans_link_ctx = dep_info.transitive_cc_dependencies.dynamic_linking + else: + link_ctx = dep_info.cc_dependencies.static_linking + trans_link_ctx = dep_info.transitive_cc_dependencies.static_linking + + # Direct C library dependencies to link. + # I.e. not indirect through another Haskell dependency. + # Such indirect dependencies are linked by GHC based on the extra-libraries + # fields in the dependency's package configuration file. + libs_to_link = link_ctx.libraries_to_link.to_list() + _add_external_libraries(args, libs_to_link) + + # Transitive library dependencies to have in scope for linking. + trans_libs_to_link = trans_link_ctx.libraries_to_link.to_list() + + # Libraries to pass as inputs to linking action. + cc_link_libs = depset(transitive = [ + depset(trans_libs_to_link), + ]) + + # Transitive dynamic library dependencies to have in RUNPATH. + cc_solibs = trans_link_ctx.dynamic_libraries_for_runtime.to_list() + + # Collect Haskell dynamic library dependencies in common RUNPATH. + # This is to keep the number of RUNPATH entries low, for faster loading + # and to avoid exceeding the MACH-O header size limit on MacOS. + hs_solibs = [] + if dynamic: + hs_solibs_prefix = "_hssolib_%s" % hs.name + for dep in set.to_list(dep_info.dynamic_libraries): + dep_link = hs.actions.declare_file( + paths.join(hs_solibs_prefix, dep.basename), + sibling = binary, + ) + ln(hs, dep, dep_link) + hs_solibs.append(dep_link) + + # Configure RUNPATH. + rpaths = _infer_rpaths( + hs.toolchain.is_darwin, + binary, + trans_link_ctx.dynamic_libraries_for_runtime.to_list() + + hs_solibs, + ) + for rpath in set.to_list(rpaths): + args.add("-optl-Wl,-rpath," + rpath) + + return (cc_link_libs, cc_solibs, hs_solibs) + +def link_binary( + hs, + cc, + dep_info, + extra_srcs, + compiler_flags, + objects_dir, + dynamic, + with_profiling, + version): + """Link Haskell binary from static object files. + + Returns: + File: produced executable + """ + + exe_name = hs.name + (".exe" if hs.toolchain.is_windows else "") + executable = hs.actions.declare_file(exe_name) + + args = hs.actions.args() + args.add_all(["-optl" + f for f in cc.linker_flags]) + if with_profiling: + args.add("-prof") + args.add_all(hs.toolchain.compiler_flags) + args.add_all(compiler_flags) + + # By default, GHC will produce mostly-static binaries, i.e. in which all + # Haskell code is statically linked and foreign libraries and system + # dependencies are dynamically linked. If linkstatic is false, i.e. the user + # has requested fully dynamic linking, we must therefore add flags to make + # sure that GHC dynamically links Haskell code too. The one exception to + # this is when we are compiling for profiling, which currently does not play + # nicely with dynamic linking. + if dynamic: + if with_profiling: + print("WARNING: dynamic linking and profiling don't mix. Omitting -dynamic.\nSee https://ghc.haskell.org/trac/ghc/ticket/15394") + else: + args.add_all(["-pie", "-dynamic"]) + + # When compiling with `-threaded`, GHC needs to link against + # the pthread library when linking against static archives (.a). + # We assume itโs not a problem to pass it for other cases, + # so we just default to passing it. + args.add("-optl-pthread") + + args.add_all(["-o", executable.path]) + + # De-duplicate optl calls while preserving ordering: we want last + # invocation of an object to remain last. That is `-optl foo -optl + # bar -optl foo` becomes `-optl bar -optl foo`. Do this by counting + # number of occurrences. That way we only build dict and add to args + # directly rather than doing multiple reversals with temporary + # lists. + + args.add_all(pkg_info_to_compile_flags(expose_packages( + dep_info, + lib_info = None, + use_direct = True, + use_my_pkg_id = None, + custom_package_databases = None, + version = version, + ))) + + (cc_link_libs, cc_solibs, hs_solibs) = _link_dependencies( + hs = hs, + dep_info = dep_info, + dynamic = dynamic, + binary = executable, + args = args, + ) + + # XXX: Suppress a warning that Clang prints due to GHC automatically passing + # "-pie" or "-no-pie" to the C compiler. + # This is linked to https://ghc.haskell.org/trac/ghc/ticket/15319 + args.add_all([ + "-optc-Wno-unused-command-line-argument", + "-optl-Wno-unused-command-line-argument", + ]) + + objects_dir_manifest = _create_objects_dir_manifest( + hs, + objects_dir, + dynamic = dynamic, + with_profiling = with_profiling, + ) + + extra_linker_flags_file = None + if hs.toolchain.is_darwin: + args.add("-optl-Wl,-headerpad_max_install_names") + + # Nixpkgs commit 3513034208a introduces -liconv in NIX_LDFLAGS on + # Darwin. We don't currently handle NIX_LDFLAGS in any special + # way, so a hack is to simply do what NIX_LDFLAGS is telling us we + # should do always when using a toolchain from Nixpkgs. + # TODO remove this gross hack. + args.add("-liconv") + + extra_linker_flags_file = _darwin_create_extra_linker_flags_file( + hs, + cc, + objects_dir, + executable, + dynamic, + cc_solibs, + ) + + if extra_linker_flags_file != None: + params_file = _merge_parameter_files(hs, objects_dir_manifest, extra_linker_flags_file) + else: + params_file = objects_dir_manifest + + hs.toolchain.actions.run_ghc( + hs, + cc, + inputs = depset(transitive = [ + depset(extra_srcs), + set.to_depset(dep_info.package_databases), + set.to_depset(dep_info.dynamic_libraries), + depset(dep_info.static_libraries), + depset(dep_info.static_libraries_prof), + depset([objects_dir]), + cc_link_libs, + ]), + outputs = [executable], + mnemonic = "HaskellLinkBinary", + arguments = args, + params_file = params_file, + ) + + return (executable, cc_solibs + hs_solibs) + +def _add_external_libraries(args, ext_libs): + """Add options to `args` that allow us to link to `ext_libs`. + + Args: + args: Args object. + ext_libs: C library dependencies. + """ + + # Deduplicate the list of ext_libs based on their + # library name (file name stripped of lib prefix and endings). + # This keeps the command lines short, e.g. when a C library + # like `liblz4.so` appears in multiple dependencies. + # XXX: this is only done in here + # Shouldnโt the deduplication be applied to *all* external libraries? + deduped = list.dedup_on(get_lib_name, ext_libs) + + for lib in deduped: + args.add_all([ + "-L{0}".format( + paths.dirname(lib.path), + ), + "-l{0}".format( + # technically this is the second call to get_lib_name, + # but the added clarity makes up for it. + get_lib_name(lib), + ), + ]) + +def _infer_rpaths(is_darwin, target, solibs): + """Return set of RPATH values to be added to target so it can find all + solibs + + The resulting paths look like: + $ORIGIN/../../path/to/solib/dir + This means: "go upwards to your runfiles directory, then descend into + the parent folder of the solib". + + Args: + is_darwin: Whether we're compiling on and for Darwin. + target: File, executable or library we're linking. + solibs: A list of Files, shared objects that the target needs. + + Returns: + Set of strings: rpaths to add to target. + """ + r = set.empty() + + if is_darwin: + prefix = "@loader_path" + else: + prefix = "$ORIGIN" + + for solib in solibs: + rpath = create_rpath_entry( + binary = target, + dependency = solib, + keep_filename = False, + prefix = prefix, + ) + set.mutable_insert(r, rpath) + + return r + +def _so_extension(hs): + """Returns the extension for shared libraries. + + Args: + hs: Haskell rule context. + + Returns: + string of extension. + """ + return "dylib" if hs.toolchain.is_darwin else "so" + +def link_library_static(hs, cc, dep_info, objects_dir, my_pkg_id, with_profiling): + """Link a static library for the package using given object files. + + Returns: + File: Produced static library. + """ + static_library = hs.actions.declare_file( + "lib{0}.a".format(pkg_id.library_name(hs, my_pkg_id, prof_suffix = with_profiling)), + ) + objects_dir_manifest = _create_objects_dir_manifest( + hs, + objects_dir, + dynamic = False, + with_profiling = with_profiling, + ) + args = hs.actions.args() + inputs = [objects_dir, objects_dir_manifest] + cc.files + + if hs.toolchain.is_darwin: + # On Darwin, ar doesn't support params files. + args.add_all([ + static_library, + objects_dir_manifest.path, + ]) + + # TODO Get ar location from the CC toolchain. This is + # complicated by the fact that the CC toolchain does not + # always use ar, and libtool has an entirely different CLI. + # See https://github.com/bazelbuild/bazel/issues/5127 + hs.actions.run_shell( + inputs = inputs, + outputs = [static_library], + mnemonic = "HaskellLinkStaticLibrary", + command = "{ar} qc $1 $(< $2)".format(ar = cc.tools.ar), + arguments = [args], + + # Use the default macosx toolchain + env = {"SDKROOT": "macosx"}, + ) + else: + args.add_all([ + "qc", + static_library, + "@" + objects_dir_manifest.path, + ]) + hs.actions.run( + inputs = inputs, + outputs = [static_library], + mnemonic = "HaskellLinkStaticLibrary", + executable = cc.tools.ar, + arguments = [args], + ) + + return static_library + +def link_library_dynamic(hs, cc, dep_info, extra_srcs, objects_dir, my_pkg_id): + """Link a dynamic library for the package using given object files. + + Returns: + File: Produced dynamic library. + """ + + dynamic_library = hs.actions.declare_file( + "lib{0}-ghc{1}.{2}".format( + pkg_id.library_name(hs, my_pkg_id), + hs.toolchain.version, + _so_extension(hs), + ), + ) + + args = hs.actions.args() + args.add_all(["-optl" + f for f in cc.linker_flags]) + args.add_all(["-shared", "-dynamic"]) + + # Work around macOS linker limits. This fix has landed in GHC HEAD, but is + # not yet in a release; plus, we still want to support older versions of + # GHC. For details, see: https://phabricator.haskell.org/D4714 + if hs.toolchain.is_darwin: + args.add("-optl-Wl,-dead_strip_dylibs") + + args.add_all(pkg_info_to_compile_flags(expose_packages( + dep_info, + lib_info = None, + use_direct = True, + use_my_pkg_id = None, + custom_package_databases = None, + version = my_pkg_id.version if my_pkg_id else None, + ))) + + (cc_link_libs, _cc_solibs, _hs_solibs) = _link_dependencies( + hs = hs, + dep_info = dep_info, + dynamic = True, + binary = dynamic_library, + args = args, + ) + + args.add_all(["-o", dynamic_library.path]) + + # Profiling not supported for dynamic libraries. + objects_dir_manifest = _create_objects_dir_manifest( + hs, + objects_dir, + dynamic = True, + with_profiling = False, + ) + + hs.toolchain.actions.run_ghc( + hs, + cc, + inputs = depset([objects_dir], transitive = [ + depset(extra_srcs), + set.to_depset(dep_info.package_databases), + set.to_depset(dep_info.dynamic_libraries), + cc_link_libs, + ]), + outputs = [dynamic_library], + mnemonic = "HaskellLinkDynamicLibrary", + arguments = args, + params_file = objects_dir_manifest, + ) + + return dynamic_library diff --git a/third_party/bazel/rules_haskell/haskell/private/actions/package.bzl b/third_party/bazel/rules_haskell/haskell/private/actions/package.bzl new file mode 100644 index 000000000000..1c438e8445a5 --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/private/actions/package.bzl @@ -0,0 +1,210 @@ +"""Action for creating packages and registering them with ghc-pkg""" + +load("@bazel_skylib//lib:paths.bzl", "paths") +load(":private/path_utils.bzl", "target_unique_name") +load(":private/pkg_id.bzl", "pkg_id") +load(":private/set.bzl", "set") +load(":private/path_utils.bzl", "get_lib_name") + +def _get_extra_libraries(dep_info): + """Get directories and library names for extra library dependencies. + + Args: + dep_info: HaskellInfo provider of the package. + + Returns: + (dirs, libs): + dirs: list: Library search directories for extra library dependencies. + libs: list: Extra library dependencies. + """ + cc_libs = dep_info.cc_dependencies.dynamic_linking.libraries_to_link.to_list() + + # The order in which library dependencies are listed is relevant when + # linking static archives. To maintain the order defined by the input + # depset we collect the library dependencies in a list, and use a separate + # set to deduplicate entries. + seen_libs = set.empty() + extra_libs = [] + extra_lib_dirs = set.empty() + for lib in cc_libs: + lib_name = get_lib_name(lib) + if not set.is_member(seen_libs, lib_name): + set.mutable_insert(seen_libs, lib_name) + extra_libs.append(lib_name) + set.mutable_insert(extra_lib_dirs, lib.dirname) + return (set.to_list(extra_lib_dirs), extra_libs) + +def package( + hs, + dep_info, + interfaces_dir, + interfaces_dir_prof, + static_library, + dynamic_library, + exposed_modules_file, + other_modules, + my_pkg_id, + static_library_prof): + """Create GHC package using ghc-pkg. + + Args: + hs: Haskell context. + interfaces_dir: Directory containing interface files. + static_library: Static library of the package. + dynamic_library: Dynamic library of the package. + static_library_prof: Static library compiled with profiling or None. + + Returns: + (File, File): GHC package conf file, GHC package cache file + """ + pkg_db_dir = pkg_id.to_string(my_pkg_id) + conf_file = hs.actions.declare_file( + paths.join(pkg_db_dir, "{0}.conf".format(pkg_db_dir)), + ) + cache_file = hs.actions.declare_file("package.cache", sibling = conf_file) + + import_dir = paths.join( + "${pkgroot}", + paths.join(pkg_db_dir, "_iface"), + ) + interfaces_dirs = [interfaces_dir] + + if interfaces_dir_prof != None: + import_dir_prof = paths.join( + "${pkgroot}", + paths.join(pkg_db_dir, "_iface_prof"), + ) + interfaces_dirs.append(interfaces_dir_prof) + else: + import_dir_prof = "" + + (extra_lib_dirs, extra_libs) = _get_extra_libraries(dep_info) + + metadata_entries = { + "name": my_pkg_id.name, + "version": my_pkg_id.version, + "id": pkg_id.to_string(my_pkg_id), + "key": pkg_id.to_string(my_pkg_id), + "exposed": "True", + "hidden-modules": " ".join(other_modules), + "import-dirs": " ".join([import_dir, import_dir_prof]), + "library-dirs": " ".join(["${pkgroot}"] + extra_lib_dirs), + "dynamic-library-dirs": " ".join(["${pkgroot}"] + extra_lib_dirs), + "hs-libraries": pkg_id.library_name(hs, my_pkg_id), + "extra-libraries": " ".join(extra_libs), + "depends": ", ".join( + # Prebuilt dependencies are added further down, since their + # package-ids are not available as strings but in build outputs. + set.to_list(dep_info.package_ids), + ), + } + + # Create a file from which ghc-pkg will create the actual package + # from. List of exposed modules generated below. + metadata_file = hs.actions.declare_file(target_unique_name(hs, "metadata")) + hs.actions.write( + output = metadata_file, + content = "\n".join([ + "{0}: {1}".format(k, v) + for k, v in metadata_entries.items() + if v + ]) + "\n", + ) + + # Collect the package id files of all prebuilt dependencies. + prebuilt_deps_id_files = [ + dep.id_file + for dep in set.to_list(dep_info.prebuilt_dependencies) + ] + + # Combine exposed modules and other metadata to form the package + # configuration file. + + prebuilt_deps_args = hs.actions.args() + prebuilt_deps_args.add_all([f.path for f in prebuilt_deps_id_files]) + prebuilt_deps_args.use_param_file("%s", use_always = True) + prebuilt_deps_args.set_param_file_format("multiline") + + hs.actions.run_shell( + inputs = [metadata_file, exposed_modules_file] + prebuilt_deps_id_files, + outputs = [conf_file], + command = """ + cat $1 > $4 + echo "exposed-modules: `cat $2`" >> $4 + + # this is equivalent to 'readarray'. We do use 'readarray' in order to + # support older bash versions. + while IFS= read -r line; do deps_id_files+=("$line"); done < $3 + + if [ ${#deps_id_files[@]} -eq 0 ]; then + deps="" + else + deps=$(cat "${deps_id_files[@]}" | tr '\n' " ") + fi + echo "depends: $deps" >> $4 +""", + arguments = [ + metadata_file.path, + exposed_modules_file.path, + prebuilt_deps_args, + conf_file.path, + ], + use_default_shell_env = True, + ) + + # Make the call to ghc-pkg and use the package configuration file + package_path = ":".join([c.dirname for c in set.to_list(dep_info.package_databases)]) + ":" + hs.actions.run( + inputs = depset(transitive = [ + set.to_depset(dep_info.package_databases), + depset(interfaces_dirs), + depset([ + input + for input in [ + static_library, + conf_file, + dynamic_library, + static_library_prof, + ] + if input + ]), + ]), + outputs = [cache_file], + env = { + "GHC_PACKAGE_PATH": package_path, + }, + mnemonic = "HaskellRegisterPackage", + progress_message = "HaskellRegisterPackage {}".format(hs.label), + executable = hs.tools.ghc_pkg, + # Registration of a new package consists in, + # + # 1. copying the registration file into the package db, + # 2. performing some validation on the registration file content, + # 3. recaching, i.e. regenerating the package db cache file. + # + # Normally, this is all done by `ghc-pkg register`. But in our + # case, `ghc-pkg register` is painful, because the validation + # it performs is slow, somewhat redundant but especially, too + # strict (see e.g. + # https://ghc.haskell.org/trac/ghc/ticket/15478). So we do (1) + # and (3) manually, by copying then calling `ghc-pkg recache` + # directly. + # + # The downside is that we do lose the few validations that + # `ghc-pkg register` was doing that was useful. e.g. when + # reexporting modules, validation checks that the source + # module does exist. + # + # TODO Go back to using `ghc-pkg register`. Blocked by + # https://ghc.haskell.org/trac/ghc/ticket/15478 + arguments = [ + "recache", + "--package-db={0}".format(conf_file.dirname), + "-v0", + "--no-expand-pkgroot", + ], + # XXX: Seems required for this to work on Windows + use_default_shell_env = True, + ) + + return conf_file, cache_file diff --git a/third_party/bazel/rules_haskell/haskell/private/actions/repl.bzl b/third_party/bazel/rules_haskell/haskell/private/actions/repl.bzl new file mode 100644 index 000000000000..5de64955d0af --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/private/actions/repl.bzl @@ -0,0 +1,175 @@ +"""GHCi REPL support""" + +load(":private/context.bzl", "render_env") +load(":private/packages.bzl", "expose_packages", "pkg_info_to_compile_flags") +load( + ":private/path_utils.bzl", + "get_lib_name", + "is_shared_library", + "link_libraries", + "ln", + "target_unique_name", +) +load(":providers.bzl", "get_libs_for_ghc_linker") +load( + ":private/set.bzl", + "set", +) +load("@bazel_skylib//lib:paths.bzl", "paths") +load("@bazel_skylib//lib:shell.bzl", "shell") + +def build_haskell_repl( + hs, + ghci_script, + ghci_repl_wrapper, + user_compile_flags, + repl_ghci_args, + hs_info, + output, + package_databases, + version, + lib_info = None): + """Build REPL script. + + Args: + hs: Haskell context. + hs_info: HaskellInfo. + + package_databases: package caches excluding the cache file of the package + we're creating a REPL for. + lib_info: If we're building REPL for a library target, pass + HaskellLibraryInfo here, otherwise it should be None. + + Returns: + None. + """ + + # The base and directory packages are necessary for the GHCi script we use + # (loads source files and brings in scope the corresponding modules). + args = ["-package", "base", "-package", "directory"] + + pkg_ghc_info = expose_packages( + hs_info, + lib_info, + use_direct = False, + use_my_pkg_id = None, + custom_package_databases = package_databases, + version = version, + ) + args += pkg_info_to_compile_flags(pkg_ghc_info) + + lib_imports = [] + if lib_info != None: + for idir in set.to_list(hs_info.import_dirs): + args += ["-i{0}".format(idir)] + lib_imports.append(idir) + + link_ctx = hs_info.cc_dependencies.dynamic_linking + libs_to_link = link_ctx.dynamic_libraries_for_runtime.to_list() + + # External C libraries that we need to make available to the REPL. + libraries = link_libraries(libs_to_link, args) + + # Transitive library dependencies to have in runfiles. + (library_deps, ld_library_deps, ghc_env) = get_libs_for_ghc_linker( + hs, + hs_info.transitive_cc_dependencies, + path_prefix = "$RULES_HASKELL_EXEC_ROOT", + ) + library_path = [paths.dirname(lib.path) for lib in library_deps] + ld_library_path = [paths.dirname(lib.path) for lib in ld_library_deps] + + repl_file = hs.actions.declare_file(target_unique_name(hs, "repl")) + + add_sources = ["*" + f.path for f in set.to_list(hs_info.source_files)] + + ghci_repl_script = hs.actions.declare_file( + target_unique_name(hs, "ghci-repl-script"), + ) + hs.actions.expand_template( + template = ghci_script, + output = ghci_repl_script, + substitutions = { + "{ADD_SOURCES}": " ".join(add_sources), + "{COMMANDS}": "", + }, + ) + + # Extra arguments. + # `compiler flags` is the default set of arguments for the repl, + # augmented by `repl_ghci_args`. + # The ordering is important, first compiler flags (from toolchain + # and local rule), then from `repl_ghci_args`. This way the more + # specific arguments are listed last, and then have more priority in + # GHC. + # Note that most flags for GHCI do have their negative value, so a + # negative flag in `repl_ghci_args` can disable a positive flag set + # in `user_compile_flags`, such as `-XNoOverloadedStrings` will disable + # `-XOverloadedStrings`. + args += hs.toolchain.compiler_flags + user_compile_flags + hs.toolchain.repl_ghci_args + repl_ghci_args + + hs.actions.expand_template( + template = ghci_repl_wrapper, + output = repl_file, + substitutions = { + "{ENV}": render_env(ghc_env), + "{TOOL}": hs.tools.ghci.path, + "{ARGS}": " ".join( + [ + "-ghci-script", + paths.join("$RULES_HASKELL_EXEC_ROOT", ghci_repl_script.path), + ] + [ + shell.quote(a) + for a in args + ], + ), + }, + is_executable = True, + ) + + ghc_info = struct( + has_version = pkg_ghc_info.has_version, + library_path = library_path, + ld_library_path = ld_library_path, + packages = pkg_ghc_info.packages, + package_ids = pkg_ghc_info.package_ids, + package_dbs = pkg_ghc_info.package_dbs, + lib_imports = lib_imports, + libraries = libraries, + execs = struct( + ghc = hs.tools.ghc.path, + ghci = hs.tools.ghci.path, + runghc = hs.tools.runghc.path, + ), + flags = struct( + compiler = user_compile_flags, + toolchain_compiler = hs.toolchain.compiler_flags, + repl = repl_ghci_args, + toolchain_repl = hs.toolchain.repl_ghci_args, + ), + ) + ghc_info_file = hs.actions.declare_file( + target_unique_name(hs, "ghc-info"), + ) + hs.actions.write( + output = ghc_info_file, + content = ghc_info.to_json(), + ) + + # XXX We create a symlink here because we need to force + # hs.tools.ghci and ghci_script and the best way to do that is + # to use hs.actions.run. That action, in turn must produce + # a result, so using ln seems to be the only sane choice. + extra_inputs = depset(transitive = [ + depset([ + hs.tools.ghci, + ghci_repl_script, + repl_file, + ghc_info_file, + ]), + set.to_depset(package_databases), + depset(library_deps), + depset(ld_library_deps), + set.to_depset(hs_info.source_files), + ]) + ln(hs, repl_file, output, extra_inputs) diff --git a/third_party/bazel/rules_haskell/haskell/private/actions/runghc.bzl b/third_party/bazel/rules_haskell/haskell/private/actions/runghc.bzl new file mode 100644 index 000000000000..da855a3adb3c --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/private/actions/runghc.bzl @@ -0,0 +1,115 @@ +"""runghc support""" + +load(":private/context.bzl", "render_env") +load(":private/packages.bzl", "expose_packages", "pkg_info_to_compile_flags") +load( + ":private/path_utils.bzl", + "get_lib_name", + "is_shared_library", + "link_libraries", + "ln", + "target_unique_name", +) +load( + ":private/set.bzl", + "set", +) +load(":providers.bzl", "get_libs_for_ghc_linker") +load("@bazel_skylib//lib:shell.bzl", "shell") + +def build_haskell_runghc( + hs, + runghc_wrapper, + user_compile_flags, + extra_args, + hs_info, + output, + package_databases, + version, + lib_info = None): + """Build runghc script. + + Args: + hs: Haskell context. + hs_info: HaskellInfo. + + package_databases: package caches excluding the cache file of the package + we're creating a runghc for. + lib_info: If we're building runghc for a library target, pass + HaskellLibraryInfo here, otherwise it should be None. + + Returns: + None. + """ + + args = pkg_info_to_compile_flags(expose_packages( + hs_info, + lib_info, + use_direct = False, + use_my_pkg_id = None, + custom_package_databases = package_databases, + version = version, + )) + + if lib_info != None: + for idir in set.to_list(hs_info.import_dirs): + args += ["-i{0}".format(idir)] + + link_ctx = hs_info.cc_dependencies.dynamic_linking + libs_to_link = link_ctx.dynamic_libraries_for_runtime.to_list() + + # External C libraries that we need to make available to runghc. + link_libraries(libs_to_link, args) + + # Transitive library dependencies to have in runfiles. + (library_deps, ld_library_deps, ghc_env) = get_libs_for_ghc_linker( + hs, + hs_info.transitive_cc_dependencies, + path_prefix = "$RULES_HASKELL_EXEC_ROOT", + ) + + runghc_file = hs.actions.declare_file(target_unique_name(hs, "runghc")) + + # Extra arguments. + # `compiler flags` is the default set of arguments for runghc, + # augmented by `extra_args`. + # The ordering is important, first compiler flags (from toolchain + # and local rule), then from `extra_args`. This way the more + # specific arguments are listed last, and then have more priority in + # GHC. + # Note that most flags for GHCI do have their negative value, so a + # negative flag in `extra_args` can disable a positive flag set + # in `user_compile_flags`, such as `-XNoOverloadedStrings` will disable + # `-XOverloadedStrings`. + args += hs.toolchain.compiler_flags + user_compile_flags + hs.toolchain.repl_ghci_args + + # ghc args need to be wrapped up in "--ghc-arg=" when passing to runghc + runcompile_flags = ["--ghc-arg=%s" % a for a in args] + runcompile_flags += extra_args + + hs.actions.expand_template( + template = runghc_wrapper, + output = runghc_file, + substitutions = { + "{ENV}": render_env(ghc_env), + "{TOOL}": hs.tools.runghc.path, + "{ARGS}": " ".join([shell.quote(a) for a in runcompile_flags]), + }, + is_executable = True, + ) + + # XXX We create a symlink here because we need to force + # hs.tools.runghc and the best way to do that is + # to use hs.actions.run. That action, in turn must produce + # a result, so using ln seems to be the only sane choice. + extra_inputs = depset(transitive = [ + depset([ + hs.tools.runghc, + runghc_file, + ]), + set.to_depset(package_databases), + depset(library_deps), + depset(ld_library_deps), + set.to_depset(hs_info.source_files), + ]) + ln(hs, runghc_file, output, extra_inputs) diff --git a/third_party/bazel/rules_haskell/haskell/private/context.bzl b/third_party/bazel/rules_haskell/haskell/private/context.bzl new file mode 100644 index 000000000000..3cd3ff92cb65 --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/private/context.bzl @@ -0,0 +1,64 @@ +"""Derived context with Haskell-specific fields and methods""" + +load("@bazel_skylib//lib:paths.bzl", "paths") + +HaskellContext = provider() + +def haskell_context(ctx, attr = None): + toolchain = ctx.toolchains["@io_tweag_rules_haskell//haskell:toolchain"] + + if not attr: + attr = ctx.attr + + if hasattr(attr, "src_strip_prefix"): + src_strip_prefix = attr.src_strip_prefix + else: + src_strip_prefix = "" + + src_root = paths.join( + ctx.label.workspace_root, + ctx.label.package, + src_strip_prefix, + ) + + env = { + "LANG": toolchain.locale, + } + + if toolchain.locale_archive != None: + env["LOCALE_ARCHIVE"] = toolchain.locale_archive.path + + coverage_enabled = False + if hasattr(ctx, "configuration"): + coverage_enabled = ctx.configuration.coverage_enabled + + return HaskellContext( + # Fields + name = attr.name, + label = ctx.label, + toolchain = toolchain, + tools = toolchain.tools, + src_root = src_root, + package_root = ctx.label.workspace_root + ctx.label.package, + env = env, + mode = ctx.var["COMPILATION_MODE"], + actions = ctx.actions, + bin_dir = ctx.bin_dir, + genfiles_dir = ctx.genfiles_dir, + coverage_enabled = coverage_enabled, + ) + +def render_env(env): + """Render environment dict to shell exports. + + Example: + + >>> render_env({"PATH": "foo:bar", "LANG": "lang"}) + export PATH=foo:bar + export LANG=lang + + """ + return "\n".join([ + "export {}={}".format(k, v) + for k, v in env.items() + ]) diff --git a/third_party/bazel/rules_haskell/haskell/private/coverage_wrapper.sh.tpl b/third_party/bazel/rules_haskell/haskell/private/coverage_wrapper.sh.tpl new file mode 100644 index 000000000000..8bc12187f4e8 --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/private/coverage_wrapper.sh.tpl @@ -0,0 +1,128 @@ +#!/usr/bin/env bash +# A wrapper for Haskell binaries which have been instrumented for hpc code coverage. + +# Copy-pasted from Bazel's Bash runfiles library (tools/bash/runfiles/runfiles.bash). +set -euo pipefail +if [[ ! -d "${RUNFILES_DIR:-/dev/null}" && ! -f "${RUNFILES_MANIFEST_FILE:-/dev/null}" ]]; then + if [[ -f "$0.runfiles_manifest" ]]; then + export RUNFILES_MANIFEST_FILE="$0.runfiles_manifest" + elif [[ -f "$0.runfiles/MANIFEST" ]]; then + export RUNFILES_MANIFEST_FILE="$0.runfiles/MANIFEST" + elif [[ -f "$0.runfiles/bazel_tools/tools/bash/runfiles/runfiles.bash" ]]; then + export RUNFILES_DIR="$0.runfiles" + fi +fi +if [[ -f "${RUNFILES_DIR:-/dev/null}/bazel_tools/tools/bash/runfiles/runfiles.bash" ]]; then + source "${RUNFILES_DIR}/bazel_tools/tools/bash/runfiles/runfiles.bash" +elif [[ -f "${RUNFILES_MANIFEST_FILE:-/dev/null}" ]]; then + source "$(grep -m1 "^bazel_tools/tools/bash/runfiles/runfiles.bash " \ + "$RUNFILES_MANIFEST_FILE" | cut -d ' ' -f 2-)" +else + echo >&2 "ERROR: cannot find @bazel_tools//tools/bash/runfiles:runfiles.bash" + exit 1 +fi +# --- end runfiles.bash initialization --- + +ERRORCOLOR='\033[1;31m' +CLEARCOLOR='\033[0m' +binary_path=$(rlocation {binary_path}) +hpc_path=$(rlocation {hpc_path}) +tix_file_path={tix_file_path} +coverage_report_format={coverage_report_format} +strict_coverage_analysis={strict_coverage_analysis} +package_path={package_path} + +# either of the two expected coverage metrics should be set to -1 if they're meant to be unused +expected_covered_expressions_percentage={expected_covered_expressions_percentage} +expected_uncovered_expression_count={expected_uncovered_expression_count} + +# gather the hpc directories +hpc_dir_args="" +mix_file_paths={mix_file_paths} +for m in "${mix_file_paths[@]}" +do + absolute_mix_file_path=$(rlocation $m) + hpc_parent_dir=$(dirname $absolute_mix_file_path) + trimmed_hpc_parent_dir=$(echo "${hpc_parent_dir%%.hpc*}") + hpc_dir_args="$hpc_dir_args --hpcdir=$trimmed_hpc_parent_dir.hpc" +done + +# gather the modules to exclude from the coverage analysis +hpc_exclude_args="" +modules_to_exclude={modules_to_exclude} +for m in "${modules_to_exclude[@]}" +do + hpc_exclude_args="$hpc_exclude_args --exclude=$m" +done + +# run the test binary, and then generate the report +$binary_path "$@" > /dev/null 2>&1 +$hpc_path report "$tix_file_path" $hpc_dir_args $hpc_exclude_args \ + --srcdir "." --srcdir "$package_path" > __hpc_coverage_report + +# if we want a text report, just output the file generated in the previous step +if [ "$coverage_report_format" == "text" ] +then + echo "Overall report" + cat __hpc_coverage_report +fi + +# check the covered expression percentage, and if it matches our expectations +if [ "$expected_covered_expressions_percentage" -ne -1 ] +then + covered_expression_percentage=$(grep "expressions used" __hpc_coverage_report | cut -c 1-3) + if [ "$covered_expression_percentage" -lt "$expected_covered_expressions_percentage" ] + then + echo -e "\n==>$ERRORCOLOR Inadequate expression coverage percentage.$CLEARCOLOR" + echo -e "==> Expected $expected_covered_expressions_percentage%, but the actual coverage was $ERRORCOLOR$(($covered_expression_percentage))%$CLEARCOLOR.\n" + exit 1 + elif [ "$strict_coverage_analysis" == "True" ] && [ "$covered_expression_percentage" -gt "$expected_covered_expressions_percentage" ] + then + echo -e "\n==>$ERRORCOLOR ** BECAUSE STRICT COVERAGE ANALYSIS IS ENABLED **$CLEARCOLOR" + echo -e "==> Your coverage percentage is now higher than expected.$CLEARCOLOR" + echo -e "==> Expected $expected_covered_expressions_percentage% of expressions covered, but the actual value is $ERRORCOLOR$(($covered_expression_percentage))%$CLEARCOLOR." + echo -e "==> Please increase the expected coverage percentage to match.\n" + exit 1 + fi +fi + +# check how many uncovered expressions there are, and if that number matches our expectations +if [ "$expected_uncovered_expression_count" -ne -1 ] +then + coverage_numerator=$(grep "expressions used" __hpc_coverage_report | sed s:.*\(::g | cut -f1 -d "/") + coverage_denominator=$(grep "expressions used" __hpc_coverage_report | sed s:.*/::g | cut -f1 -d ")") + uncovered_expression_count="$(($coverage_denominator - $coverage_numerator))" + if [ "$uncovered_expression_count" -gt "$expected_uncovered_expression_count" ] + then + echo -e "\n==>$ERRORCOLOR Too many uncovered expressions.$CLEARCOLOR" + echo -e "==> Expected $expected_uncovered_expression_count uncovered expressions, but the actual count was $ERRORCOLOR$(($uncovered_expression_count))$CLEARCOLOR.\n" + exit 1 + elif [ "$strict_coverage_analysis" == "True" ] && [ "$uncovered_expression_count" -lt "$expected_uncovered_expression_count" ] + then + echo -e "\n==>$ERRORCOLOR ** BECAUSE STRICT COVERAGE ANALYSIS IS ENABLED **$CLEARCOLOR" + echo -e "==>$ERRORCOLOR Your uncovered expression count is now lower than expected.$CLEARCOLOR" + echo -e "==> Expected $expected_uncovered_expression_count uncovered expressions, but there is $ERRORCOLOR$(($uncovered_expression_count))$CLEARCOLOR." + echo -e "==> Please lower the expected uncovered expression count to match.\n" + exit 1 + fi +fi + +# if we want an html report, run the hpc binary again with the "markup" command, +# and feed its generated files into stdout, wrapped in XML tags +if [ "$coverage_report_format" == "html" ] +then + $hpc_path markup "$tix_file_path" $hpc_dir_args $hpc_exclude_args \ + --srcdir "." --srcdir "$package_path" --destdir=hpc_out > /dev/null 2>&1 + cd hpc_out + echo "COVERAGE REPORT BELOW" + echo "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%" + for file in *.html **/*.hs.html; do + [ -e "$file" ] || continue + echo "<coverage-report-part name=\"$file\">" + echo '<![CDATA[' + cat $file + echo ']]>' + echo "</coverage-report-part>" + done + echo "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%" +fi \ No newline at end of file diff --git a/third_party/bazel/rules_haskell/haskell/private/dependencies.bzl b/third_party/bazel/rules_haskell/haskell/private/dependencies.bzl new file mode 100644 index 000000000000..6a2a797872fe --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/private/dependencies.bzl @@ -0,0 +1,222 @@ +load("@bazel_skylib//lib:dicts.bzl", "dicts") +load("@bazel_skylib//lib:paths.bzl", "paths") +load( + "@io_tweag_rules_haskell//haskell:providers.bzl", + "HaskellCcInfo", + "HaskellInfo", + "HaskellLibraryInfo", + "HaskellPrebuiltPackageInfo", + "empty_HaskellCcInfo", + "merge_HaskellCcInfo", +) +load( + ":private/path_utils.bzl", + "get_lib_name", + "is_shared_library", + "is_static_library", + "ln", +) +load(":private/set.bzl", "set") + +def _cc_get_static_lib(lib_info): + """Return the library to use in static linking mode. + + This returns the first available library artifact in the following order: + - static_library + - pic_static_library + - dynamic_library + - interface_library + + Args: + lib_info: LibraryToLink provider. + + Returns: + File: The library to link against in static mode. + """ + if lib_info.static_library: + return lib_info.static_library + elif lib_info.pic_static_library: + return lib_info.pic_static_library + elif lib_info.dynamic_library: + return lib_info.dynamic_library + else: + return lib_info.interface_library + +def _cc_get_dynamic_lib(lib_info): + """Return the library to use in dynamic linking mode. + + This returns the first available library artifact in the following order: + - dynamic_library + - interface_library + - pic_static_library + - static_library + + Args: + lib_info: LibraryToLink provider. + + Returns: + File: The library to link against in dynamic mode. + """ + if lib_info.dynamic_library: + return lib_info.dynamic_library + elif lib_info.interface_library: + return lib_info.interface_library + elif lib_info.pic_static_library: + return lib_info.pic_static_library + else: + return lib_info.static_library + +def _HaskellCcInfo_from_CcInfo(ctx, cc_info): + libs_to_link = cc_info.linking_context.libraries_to_link + static_libs_to_link = [] + dynamic_libs_to_link = [] + static_libs_for_runtime = [] + dynamic_libs_for_runtime = [] + for l in libs_to_link: + _static_lib = _cc_get_static_lib(l) + dynamic_lib = _cc_get_dynamic_lib(l) + + # Bazel itself only mangles dynamic libraries, not static libraries. + # However, we need the library name of the static and dynamic version + # of a library to match so that we can refer to both with one entry in + # the package configuration file. Here we rename any static archives + # with mismatching mangled dynamic library name. + static_name = get_lib_name(_static_lib) + dynamic_name = get_lib_name(dynamic_lib) + if static_name != dynamic_name: + ext = _static_lib.extension + static_lib = ctx.actions.declare_file( + "lib%s.%s" % (dynamic_name, ext), + ) + ln(ctx, _static_lib, static_lib) + else: + static_lib = _static_lib + + static_libs_to_link.append(static_lib) + if is_shared_library(static_lib): + static_libs_for_runtime.append(static_lib) + dynamic_libs_to_link.append(dynamic_lib) + if is_shared_library(dynamic_lib): + dynamic_libs_for_runtime.append(dynamic_lib) + + return HaskellCcInfo( + static_linking = struct( + libraries_to_link = depset( + direct = static_libs_to_link, + order = "topological", + ), + dynamic_libraries_for_runtime = depset( + direct = static_libs_for_runtime, + order = "topological", + ), + user_link_flags = depset( + direct = cc_info.linking_context.user_link_flags, + order = "topological", + ), + ), + dynamic_linking = struct( + libraries_to_link = depset( + direct = dynamic_libs_to_link, + order = "topological", + ), + dynamic_libraries_for_runtime = depset( + direct = dynamic_libs_for_runtime, + order = "topological", + ), + user_link_flags = depset( + direct = cc_info.linking_context.user_link_flags, + order = "topological", + ), + ), + ) + +def gather_dep_info(ctx, deps): + """Collapse dependencies into a single `HaskellInfo`. + + Note that the field `prebuilt_dependencies` also includes + prebuilt_dependencies of current target. + + Args: + ctx: Rule context. + deps: deps attribute. + + Returns: + HaskellInfo: Unified information about all dependencies. + """ + + acc = HaskellInfo( + package_ids = set.empty(), + package_databases = set.empty(), + version_macros = set.empty(), + static_libraries = [], + static_libraries_prof = [], + dynamic_libraries = set.empty(), + interface_dirs = set.empty(), + prebuilt_dependencies = set.empty(), + direct_prebuilt_deps = set.empty(), + cc_dependencies = empty_HaskellCcInfo(), + transitive_cc_dependencies = empty_HaskellCcInfo(), + ) + + for dep in deps: + if HaskellInfo in dep: + binfo = dep[HaskellInfo] + package_ids = acc.package_ids + if HaskellLibraryInfo not in dep: + fail("Target {0} cannot depend on binary".format(ctx.attr.name)) + if HaskellLibraryInfo in dep: + set.mutable_insert(package_ids, dep[HaskellLibraryInfo].package_id) + acc = HaskellInfo( + package_ids = package_ids, + package_databases = set.mutable_union(acc.package_databases, binfo.package_databases), + version_macros = set.mutable_union(acc.version_macros, binfo.version_macros), + static_libraries = acc.static_libraries + binfo.static_libraries, + static_libraries_prof = acc.static_libraries_prof + binfo.static_libraries_prof, + dynamic_libraries = set.mutable_union(acc.dynamic_libraries, binfo.dynamic_libraries), + interface_dirs = set.mutable_union(acc.interface_dirs, binfo.interface_dirs), + prebuilt_dependencies = set.mutable_union(acc.prebuilt_dependencies, binfo.prebuilt_dependencies), + direct_prebuilt_deps = acc.direct_prebuilt_deps, + cc_dependencies = acc.cc_dependencies, + transitive_cc_dependencies = merge_HaskellCcInfo(acc.transitive_cc_dependencies, binfo.transitive_cc_dependencies), + ) + elif HaskellPrebuiltPackageInfo in dep: + pkg = dep[HaskellPrebuiltPackageInfo] + acc = HaskellInfo( + package_ids = acc.package_ids, + package_databases = acc.package_databases, + version_macros = set.mutable_insert(acc.version_macros, pkg.version_macros_file), + static_libraries = acc.static_libraries, + static_libraries_prof = acc.static_libraries_prof, + dynamic_libraries = acc.dynamic_libraries, + interface_dirs = acc.interface_dirs, + prebuilt_dependencies = set.mutable_insert(acc.prebuilt_dependencies, pkg), + direct_prebuilt_deps = set.mutable_insert(acc.direct_prebuilt_deps, pkg), + cc_dependencies = acc.cc_dependencies, + transitive_cc_dependencies = acc.transitive_cc_dependencies, + ) + elif CcInfo in dep and HaskellInfo not in dep: + # The final link of a binary must include all static libraries we + # depend on, including transitives ones. Theses libs are provided + # in the `CcInfo` provider. + hs_cc_info = _HaskellCcInfo_from_CcInfo(ctx, dep[CcInfo]) + acc = HaskellInfo( + package_ids = acc.package_ids, + package_databases = acc.package_databases, + version_macros = acc.version_macros, + static_libraries = acc.static_libraries, + static_libraries_prof = acc.static_libraries_prof, + dynamic_libraries = acc.dynamic_libraries, + interface_dirs = acc.interface_dirs, + prebuilt_dependencies = acc.prebuilt_dependencies, + direct_prebuilt_deps = acc.direct_prebuilt_deps, + cc_dependencies = merge_HaskellCcInfo( + acc.cc_dependencies, + hs_cc_info, + ), + transitive_cc_dependencies = merge_HaskellCcInfo( + acc.transitive_cc_dependencies, + hs_cc_info, + ), + ) + + return acc diff --git a/third_party/bazel/rules_haskell/haskell/private/ghci_repl_wrapper.sh b/third_party/bazel/rules_haskell/haskell/private/ghci_repl_wrapper.sh new file mode 100644 index 000000000000..cd6acefc7a85 --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/private/ghci_repl_wrapper.sh @@ -0,0 +1,59 @@ +#!/usr/bin/env bash +# +# Usage: ghci_repl_wrapper.sh <ARGS> + +# this variable is set by `bazel run` +if [ "$BUILD_WORKSPACE_DIRECTORY" = "" ] +then + cat <<EOF +It looks like you are trying to invoke the REPL incorrectly. +We only support calling the repl script with + +$ bazel run <target> + +for now. + +If you are on bazel < 0.15 you must invoke as follows: + +$ bazel run --direct_run <target> +EOF + exit 1 +fi + +# Derived from Bazel's Bash runfiles library (tools/bash/runfiles/runfiles.bash). +if [[ -z "$RUNFILES_DIR" ]]; then + if [[ -d "$0.runfiles" ]]; then + export RUNFILES_DIR="$0.runfiles" + fi +fi +if [[ -z "$RUNFILES_MANIFEST_FILE" ]]; then + if [[ -f "$0.runfiles_manifest" ]]; then + export RUNFILES_MANIFEST_FILE="$0.runfiles_manifest" + elif [[ -f "$0.runfiles/MANIFEST" ]]; then + export RUNFILES_MANIFEST_FILE="$0.runfiles/MANIFEST" + fi +fi + +# GHCi script and libraries are loaded relative to workspace directory. +# bazel run //some:target@repl will be executed from the workspace directory. +# bazel run //some:haskell_repl will be executed from its execroot. +# Explicitly change into the workspace root in that case. +cd "$BUILD_WORKSPACE_DIRECTORY" + +# This is a workaround for https://github.com/bazelbuild/bazel/issues/5506 +# and also for the fact that REPL script relies on so-called โconvenience +# linksโ and the names of those links are controlled by the --symlink_prefix +# option, which can be set by the user to something unpredictable. +# +# It seems that we can't locate the files of interest/build outputs in +# general. However, due to โinternal issuesโ in Bazel mentioned e.g. +# https://github.com/bazelbuild/bazel/issues/3796, the directory bazel-out +# is always created under the workspace directory. We exploit this to get +# location of exec root reliably and then prefix locations of various +# components, such as shared libraries with that exec root. + +RULES_HASKELL_EXEC_ROOT=$(dirname $(readlink ${BUILD_WORKSPACE_DIRECTORY}/bazel-out)) +TOOL_LOCATION="$RULES_HASKELL_EXEC_ROOT/{TOOL}" + +{ENV} +"$TOOL_LOCATION" {ARGS} "$@" diff --git a/third_party/bazel/rules_haskell/haskell/private/haddock_wrapper.sh.tpl b/third_party/bazel/rules_haskell/haskell/private/haddock_wrapper.sh.tpl new file mode 100755 index 000000000000..c359da1c321d --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/private/haddock_wrapper.sh.tpl @@ -0,0 +1,49 @@ +#!/usr/bin/env bash +# +# Usage: haddock-wrapper.sh <PREBUILD_DEPS_FILE> <HADDOCK_ARGS> + +set -eo pipefail + +%{env} + +PREBUILT_DEPS_FILE=$1 +shift + +extra_args=() + +for pkg in $(< $PREBUILT_DEPS_FILE) +do + # Assumption: the `haddock-interfaces` field always only contains + # exactly one file name. This seems to hold in practice, though the + # ghc documentation defines it as: + # > (string list) A list of filenames containing Haddock interface files + # > (.haddock files) for this package. + # If there were more than one file, going by the output for the `depends`, + # the file names would be separated by a space character. + # https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/packages.html#installedpackageinfo-a-package-specification + haddock_interfaces=$(%{ghc-pkg} --simple-output field $pkg haddock-interfaces) + haddock_html=$(%{ghc-pkg} --simple-output field $pkg haddock-html) + + # Sometimes the referenced `.haddock` file does not exist + # (e.g. for `nixpkgs.haskellPackages` deps with haddock disabled). + # In that case, skip this package with a warning. + if [[ -f "$haddock_interfaces" ]] + then + # TODO: link source code, + # `--read-interface=$haddock_html,$pkg_src,$haddock_interfaces + # https://haskell-haddock.readthedocs.io/en/latest/invoking.html#cmdoption-read-interface + extra_args+=("--read-interface=$haddock_html,$haddock_interfaces") + else + echo "Warning: haddock missing for package $pkg" 1>&2 + fi +done + +# BSD and GNU mktemp are very different; attempt GNU first +TEMP=$(mktemp -d 2>/dev/null || mktemp -d -t 'haddock_wrapper') +trap cleanup 1 2 3 6 +cleanup() { rmdir "$TEMP"; } +# XXX Override TMPDIR to prevent race conditions on certain platforms. +# This is a workaround for +# https://github.com/haskell/haddock/issues/894. +TMPDIR=$TEMP %{haddock} "${extra_args[@]}" "$@" +cleanup diff --git a/third_party/bazel/rules_haskell/haskell/private/haskell_impl.bzl b/third_party/bazel/rules_haskell/haskell/private/haskell_impl.bzl new file mode 100644 index 000000000000..a58239fad1d5 --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/private/haskell_impl.bzl @@ -0,0 +1,668 @@ +"""Implementation of core Haskell rules""" + +load( + "@io_tweag_rules_haskell//haskell:providers.bzl", + "C2hsLibraryInfo", + "HaskellInfo", + "HaskellLibraryInfo", + "HaskellPrebuiltPackageInfo", +) +load(":cc.bzl", "cc_interop_info") +load( + ":private/actions/link.bzl", + "link_binary", + "link_library_dynamic", + "link_library_static", +) +load(":private/actions/package.bzl", "package") +load(":private/actions/repl.bzl", "build_haskell_repl") +load(":private/actions/runghc.bzl", "build_haskell_runghc") +load(":private/context.bzl", "haskell_context") +load(":private/dependencies.bzl", "gather_dep_info") +load(":private/java.bzl", "java_interop_info") +load(":private/mode.bzl", "is_profiling_enabled") +load( + ":private/path_utils.bzl", + "ln", + "match_label", + "parse_pattern", + "target_unique_name", +) +load(":private/pkg_id.bzl", "pkg_id") +load(":private/set.bzl", "set") +load(":private/version_macros.bzl", "generate_version_macros") +load(":providers.bzl", "GhcPluginInfo", "HaskellCoverageInfo") +load("@bazel_skylib//lib:paths.bzl", "paths") +load("@bazel_skylib//lib:collections.bzl", "collections") +load("@bazel_skylib//lib:shell.bzl", "shell") + +def _prepare_srcs(srcs): + srcs_files = [] + import_dir_map = {} + + for src in srcs: + # If it has the "files" attribute, it must be a Target + if hasattr(src, "files"): + if C2hsLibraryInfo in src: + srcs_files += src.files.to_list() + for f in src.files.to_list(): + import_dir_map[f] = src[C2hsLibraryInfo].import_dir + else: + srcs_files += src.files.to_list() + + # otherwise it's just a file + + else: + srcs_files.append(src) + + return srcs_files, import_dir_map + +def haskell_test_impl(ctx): + return _haskell_binary_common_impl(ctx, is_test = True) + +def haskell_binary_impl(ctx): + return _haskell_binary_common_impl(ctx, is_test = False) + +def _should_inspect_coverage(ctx, hs, is_test): + return hs.coverage_enabled and is_test + +def _coverage_enabled_for_target(coverage_source_patterns, label): + for pat in coverage_source_patterns: + if match_label(pat, label): + return True + + return False + +# Mix files refer to genfile srcs including their root. Therefore, we +# must condition the src filepaths passed in for coverage to match. +def _condition_coverage_src(hs, src): + if not src.path.startswith(hs.genfiles_dir.path): + return src + + """ Genfiles have the genfile directory as part of their path, + so declaring a file with the sample path actually makes the new + file double-qualified by the genfile directory. + + This is necessary because mix files capture the genfile + path before compilation, and then expect those files to be + qualified by the genfile directory when `hpc report` or + `hpc markup` are used. But, genfiles included as runfiles + are no longer qualified. So, double-qualifying them results in + only one level of qualification as runfiles. + """ + conditioned_src = hs.actions.declare_file(src.path) + hs.actions.run_shell( + inputs = [src], + outputs = [conditioned_src], + arguments = [ + src.path, + conditioned_src.path, + ], + command = """ + mkdir -p $(dirname "$2") && cp "$1" "$2" + """, + ) + + return conditioned_src + +def _haskell_binary_common_impl(ctx, is_test): + hs = haskell_context(ctx) + dep_info = gather_dep_info(ctx, ctx.attr.deps) + plugin_dep_info = gather_dep_info( + ctx, + [dep for plugin in ctx.attr.plugins for dep in plugin[GhcPluginInfo].deps], + ) + + # Add any interop info for other languages. + cc = cc_interop_info(ctx) + java = java_interop_info(ctx) + + with_profiling = is_profiling_enabled(hs) + srcs_files, import_dir_map = _prepare_srcs(ctx.attr.srcs) + inspect_coverage = _should_inspect_coverage(ctx, hs, is_test) + + c = hs.toolchain.actions.compile_binary( + hs, + cc, + java, + dep_info, + plugin_dep_info, + srcs = srcs_files, + ls_modules = ctx.executable._ls_modules, + import_dir_map = import_dir_map, + extra_srcs = depset(ctx.files.extra_srcs), + user_compile_flags = ctx.attr.compiler_flags, + dynamic = False if hs.toolchain.is_windows else not ctx.attr.linkstatic, + with_profiling = False, + main_function = ctx.attr.main_function, + version = ctx.attr.version, + inspect_coverage = inspect_coverage, + plugins = ctx.attr.plugins, + ) + + # gather intermediary code coverage instrumentation data + coverage_data = c.coverage_data + for dep in ctx.attr.deps: + if HaskellCoverageInfo in dep: + coverage_data += dep[HaskellCoverageInfo].coverage_data + + c_p = None + + if with_profiling: + c_p = hs.toolchain.actions.compile_binary( + hs, + cc, + java, + dep_info, + plugin_dep_info, + srcs = srcs_files, + ls_modules = ctx.executable._ls_modules, + import_dir_map = import_dir_map, + # NOTE We must make the object files compiled without profiling + # available to this step for TH to work, presumably because GHC is + # linked against RTS without profiling. + extra_srcs = depset(transitive = [ + depset(ctx.files.extra_srcs), + depset([c.objects_dir]), + ]), + user_compile_flags = ctx.attr.compiler_flags, + # NOTE We can't have profiling and dynamic code at the + # same time, see: + # https://ghc.haskell.org/trac/ghc/ticket/15394 + dynamic = False, + with_profiling = True, + main_function = ctx.attr.main_function, + version = ctx.attr.version, + plugins = ctx.attr.plugins, + ) + + (binary, solibs) = link_binary( + hs, + cc, + dep_info, + ctx.files.extra_srcs, + ctx.attr.compiler_flags, + c_p.objects_dir if with_profiling else c.objects_dir, + dynamic = False if hs.toolchain.is_windows else not ctx.attr.linkstatic, + with_profiling = with_profiling, + version = ctx.attr.version, + ) + + hs_info = HaskellInfo( + package_ids = dep_info.package_ids, + package_databases = dep_info.package_databases, + version_macros = set.empty(), + source_files = c.source_files, + extra_source_files = c.extra_source_files, + import_dirs = c.import_dirs, + static_libraries = dep_info.static_libraries, + static_libraries_prof = dep_info.static_libraries_prof, + dynamic_libraries = dep_info.dynamic_libraries, + interface_dirs = dep_info.interface_dirs, + compile_flags = c.compile_flags, + prebuilt_dependencies = dep_info.prebuilt_dependencies, + cc_dependencies = dep_info.cc_dependencies, + transitive_cc_dependencies = dep_info.transitive_cc_dependencies, + ) + cc_info = cc_common.merge_cc_infos( + cc_infos = [dep[CcInfo] for dep in ctx.attr.deps if CcInfo in dep], + ) + + target_files = depset([binary]) + + build_haskell_repl( + hs, + ghci_script = ctx.file._ghci_script, + ghci_repl_wrapper = ctx.file._ghci_repl_wrapper, + user_compile_flags = ctx.attr.compiler_flags, + repl_ghci_args = ctx.attr.repl_ghci_args, + output = ctx.outputs.repl, + package_databases = dep_info.package_databases, + version = ctx.attr.version, + hs_info = hs_info, + ) + + # XXX Temporary backwards compatibility hack. Remove eventually. + # See https://github.com/tweag/rules_haskell/pull/460. + ln(hs, ctx.outputs.repl, ctx.outputs.repl_deprecated) + + build_haskell_runghc( + hs, + runghc_wrapper = ctx.file._ghci_repl_wrapper, + extra_args = ctx.attr.runcompile_flags, + user_compile_flags = ctx.attr.compiler_flags, + output = ctx.outputs.runghc, + package_databases = dep_info.package_databases, + version = ctx.attr.version, + hs_info = hs_info, + ) + + executable = binary + extra_runfiles = [] + + if inspect_coverage: + binary_path = paths.join(ctx.workspace_name, binary.short_path) + hpc_path = paths.join(ctx.workspace_name, hs.toolchain.tools.hpc.short_path) + tix_file_path = hs.label.name + ".tix" + mix_file_paths = [ + paths.join(ctx.workspace_name, datum.mix_file.short_path) + for datum in coverage_data + ] + mix_file_paths = collections.uniq(mix_file_paths) # remove duplicates + + # find which modules to exclude from coverage analysis, by using the specified source patterns + raw_coverage_source_patterns = ctx.attr.experimental_coverage_source_patterns + coverage_source_patterns = [parse_pattern(ctx, pat) for pat in raw_coverage_source_patterns] + modules_to_exclude = [paths.split_extension(datum.mix_file.basename)[0] for datum in coverage_data if not _coverage_enabled_for_target(coverage_source_patterns, datum.target_label)] + modules_to_exclude = collections.uniq(modules_to_exclude) # remove duplicates + + expected_covered_expressions_percentage = ctx.attr.expected_covered_expressions_percentage + expected_uncovered_expression_count = ctx.attr.expected_uncovered_expression_count + strict_coverage_analysis = ctx.attr.strict_coverage_analysis + coverage_report_format = ctx.attr.coverage_report_format + + if coverage_report_format != "text" and coverage_report_format != "html": + fail("""haskell_test attribute "coverage_report_format" must be one of "text" or "html".""") + + wrapper = hs.actions.declare_file("{}_coverage/coverage_wrapper.sh".format(ctx.label.name)) + ctx.actions.expand_template( + template = ctx.file._coverage_wrapper_template, + output = wrapper, + substitutions = { + "{binary_path}": shell.quote(binary_path), + "{hpc_path}": shell.quote(hpc_path), + "{tix_file_path}": shell.quote(tix_file_path), + "{expected_covered_expressions_percentage}": str(expected_covered_expressions_percentage), + "{expected_uncovered_expression_count}": str(expected_uncovered_expression_count), + "{mix_file_paths}": shell.array_literal(mix_file_paths), + "{modules_to_exclude}": shell.array_literal(modules_to_exclude), + "{strict_coverage_analysis}": str(strict_coverage_analysis), + "{coverage_report_format}": shell.quote(ctx.attr.coverage_report_format), + "{package_path}": shell.quote(ctx.label.package), + }, + is_executable = True, + ) + executable = wrapper + mix_runfiles = [datum.mix_file for datum in coverage_data] + srcs_runfiles = [_condition_coverage_src(hs, datum.src_file) for datum in coverage_data] + extra_runfiles = [ + ctx.file._bash_runfiles, + hs.toolchain.tools.hpc, + binary, + ] + mix_runfiles + srcs_runfiles + + return [ + hs_info, + cc_info, + DefaultInfo( + executable = executable, + files = target_files, + runfiles = ctx.runfiles( + files = + solibs + + extra_runfiles, + collect_data = True, + ), + ), + ] + +def haskell_library_impl(ctx): + hs = haskell_context(ctx) + dep_info = gather_dep_info(ctx, ctx.attr.deps) + plugin_dep_info = gather_dep_info( + ctx, + [dep for plugin in ctx.attr.plugins for dep in plugin[GhcPluginInfo].deps], + ) + version = ctx.attr.version if ctx.attr.version else None + my_pkg_id = pkg_id.new(ctx.label, version) + with_profiling = is_profiling_enabled(hs) + with_shared = False if hs.toolchain.is_windows else not ctx.attr.linkstatic + + # Add any interop info for other languages. + cc = cc_interop_info(ctx) + java = java_interop_info(ctx) + + srcs_files, import_dir_map = _prepare_srcs(ctx.attr.srcs) + other_modules = ctx.attr.hidden_modules + exposed_modules_reexports = _exposed_modules_reexports(ctx.attr.exports) + + c = hs.toolchain.actions.compile_library( + hs, + cc, + java, + dep_info, + plugin_dep_info, + srcs = srcs_files, + ls_modules = ctx.executable._ls_modules, + other_modules = other_modules, + exposed_modules_reexports = exposed_modules_reexports, + import_dir_map = import_dir_map, + extra_srcs = depset(ctx.files.extra_srcs), + user_compile_flags = ctx.attr.compiler_flags, + with_shared = with_shared, + with_profiling = False, + my_pkg_id = my_pkg_id, + plugins = ctx.attr.plugins, + ) + + c_p = None + + if with_profiling: + c_p = hs.toolchain.actions.compile_library( + hs, + cc, + java, + dep_info, + plugin_dep_info, + srcs = srcs_files, + ls_modules = ctx.executable._ls_modules, + other_modules = other_modules, + exposed_modules_reexports = exposed_modules_reexports, + import_dir_map = import_dir_map, + # NOTE We must make the object files compiled without profiling + # available to this step for TH to work, presumably because GHC is + # linked against RTS without profiling. + extra_srcs = depset(transitive = [ + depset(ctx.files.extra_srcs), + depset([c.objects_dir]), + ]), + user_compile_flags = ctx.attr.compiler_flags, + # NOTE We can't have profiling and dynamic code at the + # same time, see: + # https://ghc.haskell.org/trac/ghc/ticket/15394 + with_shared = False, + with_profiling = True, + my_pkg_id = my_pkg_id, + plugins = ctx.attr.plugins, + ) + + static_library = link_library_static( + hs, + cc, + dep_info, + c.objects_dir, + my_pkg_id, + with_profiling = False, + ) + + if with_shared: + dynamic_library = link_library_dynamic( + hs, + cc, + dep_info, + depset(ctx.files.extra_srcs), + c.objects_dir, + my_pkg_id, + ) + dynamic_libraries = set.insert( + dep_info.dynamic_libraries, + dynamic_library, + ) + else: + dynamic_library = None + dynamic_libraries = dep_info.dynamic_libraries + + static_library_prof = None + if with_profiling: + static_library_prof = link_library_static( + hs, + cc, + dep_info, + c_p.objects_dir, + my_pkg_id, + with_profiling = True, + ) + + conf_file, cache_file = package( + hs, + dep_info, + c.interfaces_dir, + c_p.interfaces_dir if c_p != None else None, + static_library, + dynamic_library, + c.exposed_modules_file, + other_modules, + my_pkg_id, + static_library_prof = static_library_prof, + ) + + static_libraries_prof = dep_info.static_libraries_prof + + if static_library_prof != None: + static_libraries_prof = [static_library_prof] + dep_info.static_libraries_prof + + interface_dirs = set.union( + dep_info.interface_dirs, + set.singleton(c.interfaces_dir), + ) + + if c_p != None: + interface_dirs = set.mutable_union( + interface_dirs, + set.singleton(c_p.interfaces_dir), + ) + + version_macros = set.empty() + if version != None: + version_macros = set.singleton( + generate_version_macros(ctx, hs.name, version), + ) + + hs_info = HaskellInfo( + package_ids = set.insert(dep_info.package_ids, pkg_id.to_string(my_pkg_id)), + package_databases = set.insert(dep_info.package_databases, cache_file), + version_macros = version_macros, + source_files = c.source_files, + extra_source_files = c.extra_source_files, + import_dirs = c.import_dirs, + # NOTE We have to use lists for static libraries because the order is + # important for linker. Linker searches for unresolved symbols to the + # left, i.e. you first feed a library which has unresolved symbols and + # then you feed the library which resolves the symbols. + static_libraries = [static_library] + dep_info.static_libraries, + static_libraries_prof = static_libraries_prof, + dynamic_libraries = dynamic_libraries, + interface_dirs = interface_dirs, + compile_flags = c.compile_flags, + prebuilt_dependencies = dep_info.prebuilt_dependencies, + cc_dependencies = dep_info.cc_dependencies, + transitive_cc_dependencies = dep_info.transitive_cc_dependencies, + ) + lib_info = HaskellLibraryInfo( + package_id = pkg_id.to_string(my_pkg_id), + version = version, + ) + + dep_coverage_data = [] + for dep in ctx.attr.deps: + if HaskellCoverageInfo in dep: + dep_coverage_data += dep[HaskellCoverageInfo].coverage_data + + coverage_info = HaskellCoverageInfo( + coverage_data = dep_coverage_data + c.coverage_data, + ) + + target_files = depset([file for file in [static_library, dynamic_library] if file]) + + if hasattr(ctx, "outputs"): + build_haskell_repl( + hs, + ghci_script = ctx.file._ghci_script, + ghci_repl_wrapper = ctx.file._ghci_repl_wrapper, + repl_ghci_args = ctx.attr.repl_ghci_args, + user_compile_flags = ctx.attr.compiler_flags, + output = ctx.outputs.repl, + package_databases = dep_info.package_databases, + version = ctx.attr.version, + hs_info = hs_info, + lib_info = lib_info, + ) + + # XXX Temporary backwards compatibility hack. Remove eventually. + # See https://github.com/tweag/rules_haskell/pull/460. + ln(hs, ctx.outputs.repl, ctx.outputs.repl_deprecated) + + build_haskell_runghc( + hs, + runghc_wrapper = ctx.file._ghci_repl_wrapper, + extra_args = ctx.attr.runcompile_flags, + user_compile_flags = ctx.attr.compiler_flags, + output = ctx.outputs.runghc, + package_databases = dep_info.package_databases, + version = ctx.attr.version, + hs_info = hs_info, + lib_info = lib_info, + ) + + default_info = None + + if hasattr(ctx, "runfiles"): + default_info = DefaultInfo( + files = target_files, + runfiles = ctx.runfiles(collect_data = True), + ) + else: + default_info = DefaultInfo( + files = target_files, + ) + + # Create a CcInfo provider so that CC rules can work with + # a haskell library as if it was a regular CC one. + + # XXX Workaround https://github.com/bazelbuild/bazel/issues/6874. + # Should be find_cpp_toolchain() instead. + cc_toolchain = ctx.attr._cc_toolchain[cc_common.CcToolchainInfo] + feature_configuration = cc_common.configure_features( + cc_toolchain = cc_toolchain, + requested_features = ctx.features, + unsupported_features = ctx.disabled_features, + ) + library_to_link = cc_common.create_library_to_link( + actions = ctx.actions, + feature_configuration = feature_configuration, + dynamic_library = dynamic_library, + static_library = static_library, + cc_toolchain = cc_toolchain, + ) + compilation_context = cc_common.create_compilation_context() + linking_context = cc_common.create_linking_context( + libraries_to_link = [library_to_link], + ) + cc_info = cc_common.merge_cc_infos( + cc_infos = [ + CcInfo( + compilation_context = compilation_context, + linking_context = linking_context, + ), + ] + [dep[CcInfo] for dep in ctx.attr.deps if CcInfo in dep], + ) + + return [ + hs_info, + cc_info, + coverage_info, + default_info, + lib_info, + ] + +def haskell_toolchain_library_impl(ctx): + hs = haskell_context(ctx) + + if ctx.attr.package: + package = ctx.attr.package + else: + package = ctx.label.name + + id_file = hs.actions.declare_file(target_unique_name(hs, "id")) + hs.actions.run_shell( + inputs = [hs.tools.ghc_pkg], + outputs = [id_file], + command = """ + "$1" --simple-output -v1 field "$2" id > "$3" + """, + arguments = [ + hs.tools.ghc_pkg.path, + package, + id_file.path, + ], + ) + + version_macros_file = hs.actions.declare_file("{}_version_macros.h".format(hs.name)) + hs.actions.run_shell( + inputs = [hs.tools.ghc_pkg, ctx.executable._version_macros], + outputs = [version_macros_file], + command = """ + "$1" \\ + `"$2" --simple-output -v1 field "$3" name` \\ + `"$2" --simple-output -v1 field "$3" version` \\ + > "$4" + """, + arguments = [ + ctx.executable._version_macros.path, + hs.tools.ghc_pkg.path, + package, + version_macros_file.path, + ], + ) + + prebuilt_package_info = HaskellPrebuiltPackageInfo( + package = package, + id_file = id_file, + version_macros_file = version_macros_file, + ) + + return [prebuilt_package_info] + +def _exposed_modules_reexports(exports): + """Creates a ghc-pkg-compatible list of reexport declarations. + + A ghc-pkg registration file declares reexports as part of the + exposed-modules field in the following format: + + exposed-modules: A, B, C from pkg-c:C, D from pkg-d:Original.D + + Here, the Original.D module from pkg-d is renamed by virtue of a + different name being used before the "from" keyword. + + This function creates a ghc-pkg-compatible list of reexport declarations + (as shown above) from a dictionary mapping package targets to "Cabal-style" + reexported-modules declarations. That is, something like: + + { + ":pkg-c": "C", + ":pkg-d": "Original.D as D", + ":pkg-e": "E1, Original.E2 as E2", + } + + Args: + exports: a dictionary mapping package targets to "Cabal-style" + reexported-modules declarations. + + Returns: + a ghc-pkg-compatible list of reexport declarations. + """ + exposed_reexports = [] + for dep, cabal_decls in exports.items(): + for cabal_decl in cabal_decls.split(","): + stripped_cabal_decl = cabal_decl.strip() + cabal_decl_parts = stripped_cabal_decl.split(" as ") + original = cabal_decl_parts[0] + if len(cabal_decl_parts) == 2: + reexported = cabal_decl_parts[1] + else: + reexported = cabal_decl_parts[0] + + if HaskellPrebuiltPackageInfo in dep: + pkg = dep[HaskellPrebuiltPackageInfo].package + elif HaskellLibraryInfo in dep: + pkg = dep[HaskellLibraryInfo].package_id + + exposed_reexport = "{reexported} from {pkg}:{original}".format( + reexported = reexported, + pkg = pkg, + original = original, + ) + + exposed_reexports.append(exposed_reexport) + + return exposed_reexports diff --git a/third_party/bazel/rules_haskell/haskell/private/java.bzl b/third_party/bazel/rules_haskell/haskell/private/java.bzl new file mode 100644 index 000000000000..44c4e114d7ba --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/private/java.bzl @@ -0,0 +1,48 @@ +"""Interop with Java.""" + +load("@bazel_skylib//lib:collections.bzl", "collections") + +JavaInteropInfo = provider( + doc = "Information needed for interop with Java rules.", + fields = { + "inputs": "Files needed during build.", + "env": "Dict with env variables that should be set during build.", + }, +) + +def java_interop_info(ctx): + """Gather information from any Java dependencies. + + Args: + ctx: Rule context. + + Returns: + JavaInteropInfo: Information needed for Java interop. + """ + + inputs = depset( + transitive = [ + # We only expose direct dependencies, though we could + # expose transitive ones as well. Only exposing the direct + # ones corresponds to Bazel's "strict Java dependencies" + # mode. See + # https://github.com/tweag/rules_haskell/issues/96. + dep[JavaInfo].compile_jars + for dep in ctx.attr.deps + if JavaInfo in dep + ], + ) + + env_dict = dict() + uniq_classpath = collections.uniq([ + f.path + for f in inputs + ]) + + if len(uniq_classpath) > 0: + env_dict["CLASSPATH"] = ":".join(uniq_classpath) + + return JavaInteropInfo( + inputs = inputs, + env = env_dict, + ) diff --git a/third_party/bazel/rules_haskell/haskell/private/list.bzl b/third_party/bazel/rules_haskell/haskell/private/list.bzl new file mode 100644 index 000000000000..14ffd5f06876 --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/private/list.bzl @@ -0,0 +1,26 @@ +"""Helper functions on lists.""" + +load(":private/set.bzl", "set") + +def _dedup_on(f, list_): + """deduplicate `list_` by comparing the result of applying + f to each element (e.g. comparing sub fields) + + def compare_x(el): + return el.x + + dedup_on([struct(x=3), struct(x=4), struct(x=3)], compare_x) + => [struct(x=3), struct(x=4)] + """ + seen = set.empty() + deduped = [] + for el in list_: + by = f(el) + if not set.is_member(seen, by): + set.mutable_insert(seen, by) + deduped.append(el) + return deduped + +list = struct( + dedup_on = _dedup_on, +) diff --git a/third_party/bazel/rules_haskell/haskell/private/ls_modules.py b/third_party/bazel/rules_haskell/haskell/private/ls_modules.py new file mode 100755 index 000000000000..8e281366cca9 --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/private/ls_modules.py @@ -0,0 +1,109 @@ +#!/usr/bin/env python +# +# Create a list of exposed modules (including reexported modules) +# given a directory full of interface files and the content of the +# global package database (to mine the versions of all prebuilt +# dependencies). The exposed modules are filtered using a provided +# list of hidden modules, and augmented with reexport declarations. + +from __future__ import unicode_literals, print_function + +import collections +import fnmatch +import itertools +import os +import re +import sys +import io + +if len(sys.argv) != 6: + sys.exit("Usage: %s <DIRECTORY> <GLOBAL_PKG_DB> <HIDDEN_MODS_FILE> <REEXPORTED_MODS_FILE> <RESULT_FILE>" % sys.argv[0]) + +root = sys.argv[1] +global_pkg_db_dump = sys.argv[2] +hidden_modules_file = sys.argv[3] +reexported_modules_file = sys.argv[4] +results_file = sys.argv[5] + +with io.open(global_pkg_db_dump, "r", encoding='utf8') as f: + names = [line.split()[1] for line in f if line.startswith("name:")] + f.seek(0) + ids = [line.split()[1] for line in f if line.startswith("id:")] + + # A few sanity checks. + assert len(names) == len(ids) + + # compute duplicate, i.e. package name associated with multiples ids + duplicates = set() + if len(names) != len(set(names)): + duplicates = set([ + name for name, count in collections.Counter(names).items() + if count > 1 + ]) + + # This associate pkg name to pkg id + pkg_ids_map = dict(zip(names, ids)) + +with io.open(hidden_modules_file, "r", encoding='utf8') as f: + hidden_modules = [mod.strip() for mod in f.read().split(",")] + +with io.open(reexported_modules_file, "r", encoding='utf8') as f: + raw_reexported_modules = ( + mod.strip() for mod in f.read().split(",") if mod.strip() + ) + # Substitute package ids for package names in reexports, because + # GHC really wants package ids. + regexp = re.compile("from (%s):" % "|".join(map(re.escape, pkg_ids_map))) + + def replace_pkg_by_pkgid(match): + pkgname = match.group(1) + + if pkgname in duplicates: + sys.exit( + "\n".join([ + "Multiple versions of the following packages installed: ", + ", ".join(duplicates), + "\nThe following was explictly used: " + pkgname, + "\nThis is not currently supported.", + ]) + ) + + return "from %s:" % pkg_ids_map[pkgname] + + reexported_modules = ( + regexp.sub(replace_pkg_by_pkgid, mod) + for mod in raw_reexported_modules + ) + +def handle_walk_error(e): + print(""" +Failed to list interface files: + {} +On Windows you may need to enable long file path support: + Set-ItemProperty -Path 'HKLM:\SYSTEM\CurrentControlSet\Control\FileSystem' -Name 'LongPathsEnabled' -Value 1 + """.strip().format(e), file=sys.stderr) + exit(1) + +interface_files = ( + os.path.join(path, f) + for path, dirs, files in os.walk(root, onerror=handle_walk_error) + for f in fnmatch.filter(files, '*.hi') +) + +modules = ( + # replace directory separators by . to generate module names + # / and \ are respectively the separators for unix (linux / darwin) and windows systems + os.path.splitext(os.path.relpath(f, start=root))[0] + .replace("/",".") + .replace("\\",".") + for f in interface_files +) + +exposed_modules = ( + m + for m in modules + if m not in hidden_modules +) + +with io.open(results_file, "w", encoding='utf8') as f: + f.write(", ".join(itertools.chain(exposed_modules, reexported_modules))) diff --git a/third_party/bazel/rules_haskell/haskell/private/mode.bzl b/third_party/bazel/rules_haskell/haskell/private/mode.bzl new file mode 100644 index 000000000000..8058f09eb536 --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/private/mode.bzl @@ -0,0 +1,12 @@ +"""Compilation modes.""" + +def is_profiling_enabled(hs): + """Check whether profiling mode is enabled. + + Args: + hs: Haskell context. + + Returns: + bool: True if the mode is enabled, False otherwise. + """ + return hs.mode == "dbg" diff --git a/third_party/bazel/rules_haskell/haskell/private/osx_cc_wrapper.sh.tpl b/third_party/bazel/rules_haskell/haskell/private/osx_cc_wrapper.sh.tpl new file mode 100644 index 000000000000..9abf9ce9a1a2 --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/private/osx_cc_wrapper.sh.tpl @@ -0,0 +1,313 @@ +#!/bin/bash +# +# Copyright 2015 The Bazel Authors. All rights reserved. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. +# +# This is a wrapper script around gcc/clang that adjusts linker flags for +# Haskell library and binary targets. +# +# Load commands that attempt to load dynamic libraries relative to the working +# directory in their package output path (bazel-out/...) are converted to load +# commands relative to @rpath. rules_haskell passes the corresponding +# -Wl,-rpath,... flags itself. +# +# rpath commands that attempt to add rpaths relative to the working directory +# to look for libraries in their package output path (bazel-out/...) are +# omitted, since rules_haskell adds more appropriate rpaths itself. +# +# GHC generates intermediate dynamic libraries outside the build tree. +# Additional RPATH entries are provided for those to make dynamic library +# dependencies in the Bazel build tree available at runtime. +# +# See https://blogs.oracle.com/dipol/entry/dynamic_libraries_rpath_and_mac +# on how to set those paths for Mach-O binaries. +# +set -euo pipefail + +INSTALL_NAME_TOOL="/usr/bin/install_name_tool" +OTOOL="/usr/bin/otool" + +# Collect arguments to forward in a fresh response file. +RESPONSE_FILE="$(mktemp osx_cc_args_XXXX.rsp)" +rm_response_file() { + rm -f "$RESPONSE_FILE" +} +trap rm_response_file EXIT + +add_args() { + # Add the given arguments to the fresh response file. We follow GHC's + # example in storing one argument per line, wrapped in double quotes. Double + # quotes in the argument itself are escaped. + for arg in "$@"; do + printf '"%s"\n' "${arg//\"/\\\"}" >> "$RESPONSE_FILE" + done +} + +# Collect library, library dir, and rpath arguments. +LIBS=() +LIB_DIRS=() +RPATHS=() + +# Parser state. +# Parsing response file - unquote arguments. +QUOTES= +# Upcoming linker argument. +LINKER= +# Upcoming rpath argument. +RPATH= +# Upcoming install-name argument. +INSTALL= +# Upcoming output argument. +OUTPUT= + +parse_arg() { + # Parse the given argument. Decide whether to pass it on to the compiler, + # and how it affects the parser state. + local arg="$1" + # Unquote response file arguments. + if [[ "$QUOTES" = "1" && "$arg" =~ ^\"(.*)\"$ ]]; then + # Take GHC's argument quoting into account when parsing a response + # file. Note, no indication was found that GHC would pass multiline + # arguments, or insert escape codes into the quoted arguments. If you + # observe ill-formed arguments being passed to the compiler, then this + # logic may need to be extended. + arg="${BASH_REMATCH[1]}" + fi + # Parse given argument. + if [[ "$OUTPUT" = "1" ]]; then + # The previous argument was -o. Read output file. + OUTPUT="$arg" + add_args "$arg" + elif [[ "$LINKER" = "1" ]]; then + # The previous argument was -Xlinker. Read linker argument. + if [[ "$RPATH" = "1" ]]; then + # The previous argument was -rpath. Read RPATH. + parse_rpath "$arg" + RPATH=0 + elif [[ "$arg" = "-rpath" ]]; then + # rpath is coming + RPATH=1 + else + # Unrecognized linker argument. Pass it on. + add_args "-Xlinker" "$arg" + fi + LINKER= + elif [[ "$INSTALL" = "1" ]]; then + INSTALL= + add_args "$arg" + elif [[ "$arg" =~ ^@(.*)$ ]]; then + # Handle response file argument. Parse the arguments contained in the + # response file one by one. Take GHC's argument quoting into account. + # Note, assumes that response file arguments are not nested in other + # response files. + QUOTES=1 + while read line; do + parse_arg "$line" + done < "${BASH_REMATCH[1]}" + QUOTES= + elif [[ "$arg" = "-install_name" ]]; then + # Install name is coming. We don't use it, but it can start with an @ + # and be mistaken for a response file. + INSTALL=1 + add_args "$arg" + elif [[ "$arg" = "-o" ]]; then + # output is coming + OUTPUT=1 + add_args "$arg" + elif [[ "$arg" = "-Xlinker" ]]; then + # linker flag is coming + LINKER=1 + elif [[ "$arg" =~ ^-l(.*)$ ]]; then + LIBS+=("${BASH_REMATCH[1]}") + add_args "$arg" + elif [[ "$arg" =~ ^-L(.*)$ ]]; then + LIB_DIRS+=("${BASH_REMATCH[1]}") + add_args "$arg" + elif [[ "$arg" =~ ^-Wl,-rpath,(.*)$ ]]; then + parse_rpath "${BASH_REMATCH[1]}" + else + # Unrecognized argument. Pass it on. + add_args "$arg" + fi +} + +parse_rpath() { + # Parse the given -rpath argument and decide whether it should be + # forwarded to the compiler/linker. + local rpath="$1" + if [[ "$rpath" =~ ^/ || "$rpath" =~ ^@ ]]; then + # Absolute rpaths or rpaths relative to @loader_path or similar, are + # passed on to the linker. Other relative rpaths are dropped, these + # are auto-generated by GHC, but are useless because rules_haskell + # constructs dedicated rpaths to the _solib or _hssolib directory. + # See https://github.com/tweag/rules_haskell/issues/689 + add_args "-Wl,-rpath,$rpath" + RPATHS+=("$rpath") + fi +} + +# Parse all given arguments. +for arg in "$@"; do + parse_arg "$arg" +done + +get_library_in() { + # Find the given library in the given directory. + # Returns empty string if the library is not found. + local lib="$1" + local dir="$2" + local solib="${dir}${dir:+/}lib${lib}.so" + local dylib="${dir}${dir:+/}lib${lib}.dylib" + if [[ -f "$solib" ]]; then + echo "$solib" + elif [[ -f "$dylib" ]]; then + echo "$dylib" + fi +} + +get_library_path() { + # Find the given library in the specified library search paths. + # Returns empty string if the library is not found. + if [[ ${#LIB_DIRS[@]} -gt 0 ]]; then + local libpath + for libdir in "${LIB_DIRS[@]}"; do + libpath="$(get_library_in "$1" "$libdir")" + if [[ -n "$libpath" ]]; then + echo "$libpath" + return + fi + done + fi +} + +resolve_rpath() { + # Resolve the given rpath. I.e. if it is an absolute path, just return it. + # If it is relative to the output, then prepend the output path. + local rpath="$1" + if [[ "$rpath" =~ ^/ ]]; then + echo "$rpath" + elif [[ "$rpath" =~ ^@loader_path/(.*)$ || "$rpath" =~ ^@executable_path/(.*)$ ]]; then + echo "$(dirname "$OUTPUT")/${BASH_REMATCH[1]}" + else + echo "$rpath" + fi +} + +get_library_rpath() { + # Find the given library in the specified rpaths. + # Returns empty string if the library is not found. + if [[ ${#RPATHS[@]} -gt 0 ]]; then + local libdir libpath + for rpath in "${RPATHS[@]}"; do + libdir="$(resolve_rpath "$rpath")" + libpath="$(get_library_in "$1" "$libdir")" + if [[ -n "$libpath" ]]; then + echo "$libpath" + return + fi + done + fi +} + +get_library_name() { + # Get the "library name" of the given library. + "$OTOOL" -D "$1" | tail -1 +} + +relpath() { + # Find relative path from the first to the second path. Assuming the first + # is a directory. If either is an absolute path, then we return the + # absolute path to the second. + local from="$1" + local to="$2" + if [[ "$to" =~ ^/ ]]; then + echo "$to" + elif [[ "$from" =~ ^/ ]]; then + echo "$PWD/$to" + else + # Split path and store components in bash array. + IFS=/ read -a fromarr <<<"$from" + IFS=/ read -a toarr <<<"$to" + # Drop common prefix. + for ((i=0; i < ${#fromarr[@]}; ++i)); do + if [[ "${fromarr[$i]}" != "${toarr[$i]}" ]]; then + break + fi + done + # Construct relative path. + local common=$i + local out= + for ((i=$common; i < ${#fromarr[@]}; ++i)); do + out="$out${out:+/}.." + done + for ((i=$common; i < ${#toarr[@]}; ++i)); do + out="$out${out:+/}${toarr[$i]}" + done + echo $out + fi +} + +generate_rpath() { + # Generate an rpath entry for the given library path. + local rpath="$(relpath "$(dirname "$OUTPUT")" "$(dirname "$1")")" + if [[ "$rpath" =~ ^/ ]]; then + echo "$rpath" + else + # Relative rpaths are relative to the binary. + echo "@loader_path${rpath:+/}$rpath" + fi +} + +if [[ ! "$OUTPUT" =~ ^bazel-out/ && ${#LIBS[@]} -gt 0 ]]; then + # GHC generates temporary dynamic libraries during compilation outside of + # the build directory. References to dynamic C libraries are broken in this + # case. Here we add additional RPATHs to fix these references. The Hazel + # package for swagger2 is an example that triggers this issue. + for lib in "${LIBS[@]}"; do + librpath="$(get_library_rpath "$lib")" + if [[ -z "$librpath" ]]; then + # The given library was not found in any of the rpaths. + # Find it in the library search paths. + libpath="$(get_library_path "$lib")" + if [[ "$libpath" =~ ^bazel-out/ ]]; then + # The library is Bazel generated and loaded relative to PWD. + # Add an RPATH entry, so it is found at runtime. + rpath="$(generate_rpath "$libpath")" + parse_rpath "$rpath" + fi + fi + done +fi + +# Call the C++ compiler with the fresh response file. +%{cc} "@$RESPONSE_FILE" + +if [[ ${#LIBS[@]} -gt 0 ]]; then + # Replace load commands relative to the working directory, by load commands + # relative to the rpath, if the library can be found relative to an rpath. + for lib in "${LIBS[@]}"; do + librpath="$(get_library_rpath "$lib")" + if [[ -n "$librpath" ]]; then + libname="$(get_library_name "$librpath")" + if [[ "$libname" =~ ^bazel-out/ ]]; then + "${INSTALL_NAME_TOOL}" -change \ + "$libname" \ + "@rpath/$(basename "$librpath")" \ + "$OUTPUT" + fi + fi + done +fi + +# vim: ft=sh diff --git a/third_party/bazel/rules_haskell/haskell/private/packages.bzl b/third_party/bazel/rules_haskell/haskell/private/packages.bzl new file mode 100644 index 000000000000..e35fbb2820b1 --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/private/packages.bzl @@ -0,0 +1,94 @@ +"""Package list handling""" + +load(":private/set.bzl", "set") + +def pkg_info_to_compile_flags(pkg_info, for_plugin = False): + """Map package info to GHC command-line arguments. + + Args: + pkg_info: Package info collected by `ghc_info()`. + for_plugin: Whether the package is a plugin dependency. + + Returns: + The list of command-line arguments that should be passed to GHC. + """ + namespace = "plugin-" if for_plugin else "" + args = [ + # In compile.bzl, we pass this just before all -package-id + # arguments. Not doing so leads to bizarre compile-time failures. + # It turns out that equally, not doing so leads to bizarre + # link-time failures. See + # https://github.com/tweag/rules_haskell/issues/395. + "-hide-all-{}packages".format(namespace), + ] + + if not pkg_info.has_version: + args.extend([ + # Macro version are disabled for all packages by default + # and enabled for package with version + # see https://github.com/tweag/rules_haskell/issues/414 + "-fno-version-macros", + ]) + + for package in pkg_info.packages: + args.extend(["-{}package".format(namespace), package]) + + for package_id in pkg_info.package_ids: + args.extend(["-{}package-id".format(namespace), package_id]) + + for package_db in pkg_info.package_dbs: + args.extend(["-package-db", package_db]) + + return args + +def expose_packages(hs_info, lib_info, use_direct, use_my_pkg_id, custom_package_databases, version): + """ + Returns the information that is needed by GHC in order to enable haskell + packages. + + hs_info: is common to all builds + version: if the rule contains a version, we will export the CPP version macro + + All the other arguments are not understood well: + + lib_info: only used for repl and linter + use_direct: only used for repl and linter + use_my_pkg_id: only used for one specific task in compile.bzl + custom_package_databases: override the package_databases of hs_info, used only by the repl + """ + has_version = version != None and version != "" + + # Expose all prebuilt dependencies + # + # We have to remember to specify all (transitive) wired-in + # dependencies or we can't find objects for linking + # + # Set use_direct if hs_info does not have a direct_prebuilt_deps field. + packages = [] + for prebuilt_dep in set.to_list(hs_info.direct_prebuilt_deps if use_direct else hs_info.prebuilt_dependencies): + packages.append(prebuilt_dep.package) + + # Expose all bazel dependencies + package_ids = [] + for package in set.to_list(hs_info.package_ids): + # XXX: repl and lint uses this lib_info flags + # It is set to None in all other usage of this function + # TODO: find the meaning of this flag + if lib_info == None or package != lib_info.package_id: + # XXX: use_my_pkg_id is not None only in compile.bzl + if (use_my_pkg_id == None) or package != use_my_pkg_id: + package_ids.append(package) + + # Only include package DBs for deps, prebuilt deps should be found + # auto-magically by GHC + package_dbs = [] + for cache in set.to_list(hs_info.package_databases if not custom_package_databases else custom_package_databases): + package_dbs.append(cache.dirname) + + ghc_info = struct( + has_version = has_version, + packages = packages, + package_ids = package_ids, + package_dbs = package_dbs, + ) + return ghc_info diff --git a/third_party/bazel/rules_haskell/haskell/private/path_utils.bzl b/third_party/bazel/rules_haskell/haskell/private/path_utils.bzl new file mode 100644 index 000000000000..1162a95aebe1 --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/private/path_utils.bzl @@ -0,0 +1,471 @@ +"""Utilities for module and path manipulations.""" + +load("@bazel_skylib//lib:paths.bzl", "paths") +load(":private/set.bzl", "set") + +def module_name(hs, f, rel_path = None): + """Given Haskell source file path, turn it into a dot-separated module name. + + module_name( + hs, + "some-workspace/some-package/src/Foo/Bar/Baz.hs", + ) => "Foo.Bar.Baz" + + Args: + hs: Haskell context. + f: Haskell source file. + rel_path: Explicit relative path from import root to the module, or None + if it should be deduced. + + Returns: + string: Haskell module name. + """ + + rpath = rel_path + + if not rpath: + rpath = _rel_path_to_module(hs, f) + + (hsmod, _) = paths.split_extension(rpath.replace("/", ".")) + return hsmod + +def target_unique_name(hs, name_prefix): + """Make a target-unique name. + + `name_prefix` is made target-unique by adding a rule name + suffix to it. This means that given two different rules, the same + `name_prefix` is distinct. Note that this is does not disambiguate two + names within the same rule. Given a haskell_library with name foo + you could expect: + + target_unique_name(hs, "libdir") => "libdir-foo" + + This allows two rules using same name_prefix being built in same + environment to avoid name clashes of their output files and directories. + + Args: + hs: Haskell context. + name_prefix: Template for the name. + + Returns: + string: Target-unique name_prefix. + """ + return "{0}-{1}".format(name_prefix, hs.name) + +def module_unique_name(hs, source_file, name_prefix): + """Make a target- and module- unique name. + + module_unique_name( + hs, + "some-workspace/some-package/src/Foo/Bar/Baz.hs", + "libdir" + ) => "libdir-foo-Foo.Bar.Baz" + + This is quite similar to `target_unique_name` but also uses a path built + from `source_file` to prevent clashes with other names produced using the + same `name_prefix`. + + Args: + hs: Haskell context. + source_file: Source file name. + name_prefix: Template for the name. + + Returns: + string: Target- and source-unique name. + """ + return "{0}-{1}".format( + target_unique_name(hs, name_prefix), + module_name(hs, source_file), + ) + +def declare_compiled(hs, src, ext, directory = None, rel_path = None): + """Given a Haskell-ish source file, declare its output. + + Args: + hs: Haskell context. + src: Haskell source file. + ext: New extension. + directory: String, directory prefix the new file should live in. + rel_path: Explicit relative path from import root to the module, or None + if it should be deduced. + + Returns: + File: Declared output file living in `directory` with given `ext`. + """ + + rpath = rel_path + + if not rpath: + rpath = _rel_path_to_module(hs, src) + + fp = paths.replace_extension(rpath, ext) + fp_with_dir = fp if directory == None else paths.join(directory, fp) + + return hs.actions.declare_file(fp_with_dir) + +def make_path(libs, prefix = None, sep = None): + """Return a string value for using as LD_LIBRARY_PATH or similar. + + Args: + libs: List of library files that should be available + prefix: String, an optional prefix to add to every path. + sep: String, the path separator, defaults to ":". + + Returns: + String: paths to the given library directories separated by ":". + """ + r = set.empty() + + sep = sep if sep else ":" + + for lib in libs: + lib_dir = paths.dirname(lib.path) + if prefix: + lib_dir = paths.join(prefix, lib_dir) + + set.mutable_insert(r, lib_dir) + + return sep.join(set.to_list(r)) + +def darwin_convert_to_dylibs(hs, libs): + """Convert .so dynamic libraries to .dylib. + + Bazel's cc_library rule will create .so files for dynamic libraries even + on MacOS. GHC's builtin linker, which is used during compilation, GHCi, + or doctests, hard-codes the assumption that all dynamic libraries on MacOS + end on .dylib. This function serves as an adaptor and produces symlinks + from a .dylib version to the .so version for every dynamic library + dependencies that does not end on .dylib. + + Args: + hs: Haskell context. + libs: List of library files dynamic or static. + + Returns: + List of library files where all dynamic libraries end on .dylib. + """ + lib_prefix = "_dylibs" + new_libs = [] + for lib in libs: + if is_shared_library(lib) and lib.extension != "dylib": + dylib_name = paths.join( + target_unique_name(hs, lib_prefix), + lib.dirname, + "lib" + get_lib_name(lib) + ".dylib", + ) + dylib = hs.actions.declare_file(dylib_name) + ln(hs, lib, dylib) + new_libs.append(dylib) + else: + new_libs.append(lib) + return new_libs + +def windows_convert_to_dlls(hs, libs): + """Convert .so dynamic libraries to .dll. + + Bazel's cc_library rule will create .so files for dynamic libraries even + on Windows. GHC's builtin linker, which is used during compilation, GHCi, + or doctests, hard-codes the assumption that all dynamic libraries on Windows + end on .dll. This function serves as an adaptor and produces symlinks + from a .dll version to the .so version for every dynamic library + dependencies that does not end on .dll. + + Args: + hs: Haskell context. + libs: List of library files dynamic or static. + + Returns: + List of library files where all dynamic libraries end on .dll. + """ + lib_prefix = "_dlls" + new_libs = [] + for lib in libs: + if is_shared_library(lib) and lib.extension != "dll": + dll_name = paths.join( + target_unique_name(hs, lib_prefix), + paths.dirname(lib.short_path), + "lib" + get_lib_name(lib) + ".dll", + ) + dll = hs.actions.declare_file(dll_name) + ln(hs, lib, dll) + new_libs.append(dll) + else: + new_libs.append(lib) + return new_libs + +def get_lib_name(lib): + """Return name of library by dropping extension and "lib" prefix. + + Args: + lib: The library File. + + Returns: + String: name of library. + """ + + base = lib.basename[3:] if lib.basename[:3] == "lib" else lib.basename + n = base.find(".so.") + end = paths.replace_extension(base, "") if n == -1 else base[:n] + return end + +def link_libraries(libs_to_link, args): + """Add linker flags to link against the given libraries. + + Args: + libs_to_link: List of library Files. + args: Append arguments to this list. + + Returns: + List of library names that were linked. + + """ + seen_libs = set.empty() + libraries = [] + for lib in libs_to_link: + lib_name = get_lib_name(lib) + if not set.is_member(seen_libs, lib_name): + set.mutable_insert(seen_libs, lib_name) + args += ["-l{0}".format(lib_name)] + libraries.append(lib_name) + +def is_shared_library(f): + """Check if the given File is a shared library. + + Args: + f: The File to check. + + Returns: + Bool: True if the given file `f` is a shared library, False otherwise. + """ + return f.extension in ["so", "dylib"] or f.basename.find(".so.") != -1 + +def is_static_library(f): + """Check if the given File is a static library. + + Args: + f: The File to check. + + Returns: + Bool: True if the given file `f` is a static library, False otherwise. + """ + return f.extension in ["a"] + +def _rel_path_to_module(hs, f): + """Make given file name relative to the directory where the module hierarchy + starts. + + _rel_path_to_module( + "some-workspace/some-package/src/Foo/Bar/Baz.hs" + ) => "Foo/Bar/Baz.hs" + + Args: + hs: Haskell context. + f: Haskell source file. + + Returns: + string: Relative path to module file. + """ + + # If it's a generated file, strip off the bin or genfiles prefix. + path = f.path + if path.startswith(hs.bin_dir.path): + path = paths.relativize(path, hs.bin_dir.path) + elif path.startswith(hs.genfiles_dir.path): + path = paths.relativize(path, hs.genfiles_dir.path) + + return paths.relativize(path, hs.src_root) + +# TODO Consider merging with paths.relativize. See +# https://github.com/bazelbuild/bazel-skylib/pull/44. +def _truly_relativize(target, relative_to): + """Return a relative path to `target` from `relative_to`. + + Args: + target: string, path to directory we want to get relative path to. + relative_to: string, path to directory from which we are starting. + + Returns: + string: relative path to `target`. + """ + t_pieces = target.split("/") + r_pieces = relative_to.split("/") + common_part_len = 0 + + for tp, rp in zip(t_pieces, r_pieces): + if tp == rp: + common_part_len += 1 + else: + break + + result = [".."] * (len(r_pieces) - common_part_len) + result += t_pieces[common_part_len:] + + return "/".join(result) + +def ln(hs, target, link, extra_inputs = depset()): + """Create a symlink to target. + + Args: + hs: Haskell context. + extra_inputs: extra phony dependencies of symlink. + + Returns: + None + """ + relative_target = _truly_relativize(target.path, link.dirname) + hs.actions.run_shell( + inputs = depset([target], transitive = [extra_inputs]), + outputs = [link], + mnemonic = "Symlink", + command = "ln -s {target} {link}".format( + target = relative_target, + link = link.path, + ), + use_default_shell_env = True, + ) + +def link_forest(ctx, srcs, basePath = ".", **kwargs): + """Write a symlink to each file in `srcs` into a destination directory + defined using the same arguments as `ctx.actions.declare_directory`""" + local_files = [] + for src in srcs.to_list(): + dest = ctx.actions.declare_file( + paths.join(basePath, src.basename), + **kwargs + ) + local_files.append(dest) + ln(ctx, src, dest) + return local_files + +def copy_all(ctx, srcs, dest): + """Copy all the files in `srcs` into `dest`""" + if list(srcs.to_list()) == []: + ctx.actions.run_shell( + command = "mkdir -p {dest}".format(dest = dest.path), + outputs = [dest], + ) + else: + args = ctx.actions.args() + args.add_all(srcs) + ctx.actions.run_shell( + inputs = depset(srcs), + outputs = [dest], + mnemonic = "Copy", + command = "mkdir -p {dest} && cp -L -R \"$@\" {dest}".format(dest = dest.path), + arguments = [args], + ) + +def parse_pattern(ctx, pattern_str): + """Parses a string label pattern. + + Args: + ctx: Standard Bazel Rule context. + + pattern_str: The pattern to parse. + Patterns are absolute labels in the local workspace. E.g. + `//some/package:some_target`. The following wild-cards are allowed: + `...`, `:all`, and `:*`. Also the `//some/package` shortcut is allowed. + + Returns: + A struct of + package: A list of package path components. May end on the wildcard `...`. + target: The target name. None if the package ends on `...`. May be one + of the wildcards `all` or `*`. + + NOTE: it would be better if Bazel itself exposed this functionality to Starlark. + + Any feature using this function should be marked as experimental, until the + resolution of https://github.com/bazelbuild/bazel/issues/7763. + """ + + # We only load targets in the local workspace anyway. So, it's never + # necessary to specify a workspace. Therefore, we don't allow it. + if pattern_str.startswith("@"): + fail("Invalid haskell_repl pattern. Patterns may not specify a workspace. They only apply to the current workspace") + + # To keep things simple, all patterns have to be absolute. + if not pattern_str.startswith("//"): + if not pattern_str.startswith(":"): + fail("Invalid haskell_repl pattern. Patterns must start with either '//' or ':'.") + + # if the pattern string doesn't start with a package (it starts with :, e.g. :two), + # then we prepend the contextual package + pattern_str = "//{package}{target}".format(package = ctx.label.package, target = pattern_str) + + # Separate package and target (if present). + package_target = pattern_str[2:].split(":", maxsplit = 2) + package_str = package_target[0] + target_str = None + if len(package_target) == 2: + target_str = package_target[1] + + # Parse package pattern. + package = [] + dotdotdot = False # ... has to be last component in the pattern. + for s in package_str.split("/"): + if dotdotdot: + fail("Invalid haskell_repl pattern. ... has to appear at the end.") + if s == "...": + dotdotdot = True + package.append(s) + + # Parse target pattern. + if dotdotdot: + if target_str != None: + fail("Invalid haskell_repl pattern. ... has to appear at the end.") + elif target_str == None: + if len(package) > 0 and package[-1] != "": + target_str = package[-1] + else: + fail("Invalid haskell_repl pattern. The empty string is not a valid target.") + + return struct( + package = package, + target = target_str, + ) + +def match_label(patterns, label): + """Whether the given local workspace label matches any of the patterns. + + Args: + patterns: A list of parsed patterns to match the label against. + Apply `parse_pattern` before passing patterns into this function. + label: Match this label against the patterns. + + Returns: + A boolean. True if the label is in the local workspace and matches any of + the given patterns. False otherwise. + + NOTE: it would be better if Bazel itself exposed this functionality to Starlark. + + Any feature using this function should be marked as experimental, until the + resolution of https://github.com/bazelbuild/bazel/issues/7763. + """ + + # Only local workspace labels can match. + # Despite the docs saying otherwise, labels don't have a workspace_name + # attribute. So, we use the workspace_root. If it's empty, the target is in + # the local workspace. Otherwise, it's an external target. + if label.workspace_root != "": + return False + + package = label.package.split("/") + target = label.name + + # Match package components. + for i in range(min(len(patterns.package), len(package))): + if patterns.package[i] == "...": + return True + elif patterns.package[i] != package[i]: + return False + + # If no wild-card or mismatch was encountered, the lengths must match. + # Otherwise, the label's package is not covered. + if len(patterns.package) != len(package): + return False + + # Match target. + if patterns.target == "all" or patterns.target == "*": + return True + else: + return patterns.target == target diff --git a/third_party/bazel/rules_haskell/haskell/private/pkg_id.bzl b/third_party/bazel/rules_haskell/haskell/private/pkg_id.bzl new file mode 100644 index 000000000000..0a3c5fa439d2 --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/private/pkg_id.bzl @@ -0,0 +1,67 @@ +"""Package identifiers""" + +load(":private/mode.bzl", "is_profiling_enabled") +load("@bazel_skylib//lib:paths.bzl", "paths") + +def _zencode(s): + """Z-escape special characters to make a valid GHC package identifier. + + Args: + s: string + """ + return s.replace("Z", "ZZ").replace("_", "ZU").replace("/", "ZS") + +def _to_string(my_pkg_id): + """Get a globally unique package identifier. + + The identifier is required to be unique for each Haskell rule. + It includes the Bazel package and the name of this component. + We can't use just the latter because then two components with + the same names in different packages would clash. + """ + return _zencode( + paths.join( + my_pkg_id.label.workspace_root, + my_pkg_id.label.package, + my_pkg_id.name, + ), + ) + +def _new(label, version = None): + """Create a new package identifier. + + Package identifiers should be globally unique. This is why we use + a label to identify them. + + Args: + label: The label of the rule declaring the package. + version: an optional version annotation. + + Returns: + string: GHC package ID to use. + + """ + return struct( + label = label, + name = label.name.replace("_", "-"), + version = version, + ) + +def _library_name(hs, my_pkg_id, prof_suffix = False): + """Get library name. + + Args: + hs: Haskell context. + my_pkg_id: pkg_id struct. + prof_suffix: whether to automatically add profiling suffix. + """ + library_name = "HS" + _to_string(my_pkg_id) + if is_profiling_enabled(hs) and prof_suffix: + library_name += "_p" + return library_name + +pkg_id = struct( + new = _new, + to_string = _to_string, + library_name = _library_name, +) diff --git a/third_party/bazel/rules_haskell/haskell/private/set.bzl b/third_party/bazel/rules_haskell/haskell/private/set.bzl new file mode 100644 index 000000000000..f5c6220f79d6 --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/private/set.bzl @@ -0,0 +1,150 @@ +"""Immutable sets that support efficient merging, traversal, and membership +check. +""" + +def _empty(): + """Create an empty set. + + Returns: + set, new empty set. + """ + return struct(_set_items = dict()) + +def _singleton(e): + """Create a set with single element `e` inside. + + Args: + e: The element to put in the set. + + Returns: + set, new set. + """ + r = dict() + r[e] = None + return struct(_set_items = r) + +def _is_member(s, e): + """Return true if `e` is in the set `s`. + + Args: + s: The set to inspect. + e: The element to search for. + + Result: + Bool, true if `e` is in `s`, false otherwise. + """ + return e in s._set_items + +def _insert(s, e): + """Insert an element into the set. + + Args: + s: Set to insert new element into. + e: The element to insert. + + Result: + A copy of set `s` with `s` element added. + """ + r = dict(s._set_items) + r[e] = None + return struct(_set_items = r) + +def _mutable_insert(s, e): + """The same as `set.insert`, but modifies the first argument in place. + + Args: + s: Set to insert new element into. + e: The element to insert. + + Result: + set `s` with `s` element added. + """ + s._set_items[e] = None + return s + +def _union(s0, s1): + """Return union of two sets. + + Args: + s0: One set. + s1: Another set. + + Result: + set, union of the two sets. + """ + r = dict(s0._set_items) + r.update(s1._set_items) + return struct(_set_items = r) + +def _mutable_union(s0, s1): + """Modify set `s0` adding elements from `s1` to it. + + Args: + s0: One set. + s1: Another set. + + Result: + set, union of the two sets. + """ + s0._set_items.update(s1._set_items) + return s0 + +def _map(s, f): + """Map elements of given set using a function. + + Args: + s: Original set. + f: Function to apply to elements of the set. + + Result: + set with elements obtained by application of function `f` to the + elements of `s`. + """ + return struct(_set_items = {f(x): None for x in s._set_items.keys()}) + +def _from_list(l): + """Create a set containing elements from given list. + + Args: + l: List, source of the elements for the new set. + + Result: + set containing elements from given list. + """ + return (struct(_set_items = {x: None for x in l})) + +def _to_list(s): + """Convert set into a list of its elements. + + Args: + s: Set to convert. + + Returns: + List of elements of the set. + """ + return s._set_items.keys() + +def _to_depset(s): + """Similar to `set.to_list`, but produces a depset. + + Args: + s: Set to convert. + + Returns: + Depset of elements from the set. + """ + return depset(_to_list(s)) + +set = struct( + empty = _empty, + singleton = _singleton, + is_member = _is_member, + insert = _insert, + mutable_insert = _mutable_insert, + union = _union, + mutable_union = _mutable_union, + map = _map, + from_list = _from_list, + to_list = _to_list, + to_depset = _to_depset, +) diff --git a/third_party/bazel/rules_haskell/haskell/private/version_macros.bzl b/third_party/bazel/rules_haskell/haskell/private/version_macros.bzl new file mode 100644 index 000000000000..35f913f26b01 --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/private/version_macros.bzl @@ -0,0 +1,47 @@ +load(":private/set.bzl", "set") + +def generate_version_macros(ctx, name, version): + """Generate a version macros header file. + + Args: + ctx: Rule context. Needs to define a _version_macros executable attribute. + name: The package name. + version: The package version. + + Returns: + Version macros header File. + """ + version_macros_file = ctx.actions.declare_file("{}_version_macros.h".format(name)) + ctx.actions.run_shell( + inputs = [ctx.executable._version_macros], + outputs = [version_macros_file], + command = """ + "$1" "$2" "$3" > "$4" + """, + arguments = [ + ctx.executable._version_macros.path, + name, + version, + version_macros_file.path, + ], + ) + return version_macros_file + +def version_macro_includes(hs_info): + """Generate a list of version macro header includes. + + Args: + hs_info: HaskellInfo provider. + + Returns: + (files, flags): + files: Set of version macros header files. + flags: List of C preprocessor flags to include version macros. + """ + files = hs_info.version_macros + flags = [ + f + for include in set.to_list(files) + for f in ["-include", include.path] + ] + return (files, flags) diff --git a/third_party/bazel/rules_haskell/haskell/private/version_macros.py b/third_party/bazel/rules_haskell/haskell/private/version_macros.py new file mode 100755 index 000000000000..4bc6052cb032 --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/private/version_macros.py @@ -0,0 +1,101 @@ +#!/usr/bin/env python3 +"""Generate Cabal version macros. + +Generates the content of a C header file for the given library name and version +and prints it to standard output. +""" + +import argparse + + +def main(): + parser = argparse.ArgumentParser(description=__doc__) + parser.add_argument("name", help="The package name.") + parser.add_argument("version", help="The package version.") + args = parser.parse_args() + + print(version_macros(args.name, args.version)) + + +def version_macros(name, version): + """Generate Cabal version macros. + + Based on Cabal's version macro generation, see [1]. + + [1]: http://hackage.haskell.org/package/Cabal-2.4.1.0/docs/src/Distribution.Simple.Build.Macros.html#generatePackageVersionMacros + """ + (major1, major2, minor) = version_components(version) + escaped_name = cpp_escape_name(name) + return "\n".join([ + # #define VERSION_pkg "1.2.3" + cpp_ifndef_define( + "VERSION_" + escaped_name, + [], + '"{}"'.format(version), + ), + # #define MIN_VERSION_pkg(major1, major2, minor) ... + cpp_ifndef_define( + "MIN_VERSION_" + escaped_name, + ["major1", "major2", "minor"], + " \\\n".join([ + "(", + " (major1) < {} ||".format(major1), + " (major1) == {} && (major2) < {} ||".format(major1, major2), + " (major1) == {} && (major2) == {} && (minor) <= {} )".format( + major1, major2, minor), + ])), + ]) + + +def version_components(version): + """Split version string into major1.major2.minor components.""" + components = version.split(".") + num = len(components) + + if num < 1: + raise ValueError("version should have at least one component.") + + major1 = components[0] + + if num >= 2: + major2 = components[1] + else: + major2 = "0" + + if num >= 3: + minor = components[2] + else: + minor = "0" + + return (major1, major2, minor) + + +def cpp_escape_name(name): + """Escape package name to be CPP macro safe.""" + return name.replace("-", "_") + + +def cpp_define(macro, params, val): + """CPP macro definition, optionally with parameters.""" + return "#define {macro}{params} {val}".format( + macro = macro, + params = "({})".format(",".join(params)) if params else "", + val = val, + ) + + +def cpp_ifndef(macro, body): + """CPP ifndef block.""" + return "#ifndef {macro}\n{body}\n#endif /* {macro} */".format( + macro = macro, + body = body, + ) + + +def cpp_ifndef_define(macro, params, val): + """CPP macro definition, if not previously defined.""" + return cpp_ifndef(macro, cpp_define(macro, params, val)) + + +if __name__ == "__main__": + main() diff --git a/third_party/bazel/rules_haskell/haskell/protobuf.bzl b/third_party/bazel/rules_haskell/haskell/protobuf.bzl new file mode 100644 index 000000000000..5c8b9a817648 --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/protobuf.bzl @@ -0,0 +1,395 @@ +"""Support for protocol buffers""" + +load( + ":private/haskell_impl.bzl", + _haskell_library_impl = "haskell_library_impl", +) +load("@bazel_skylib//lib:paths.bzl", "paths") +load( + "@io_tweag_rules_haskell//haskell:providers.bzl", + "HaskellInfo", + "HaskellLibraryInfo", + "HaskellProtobufInfo", +) + +def _capitalize_first_letter(c): + """Capitalize the first letter of the input. Unlike the built-in + `capitalize()` method, doesn't lower-case the other characters. This helps + mimic the behavior of `proto-lens-protoc`, which turns `Foo/Bar/BAZ.proto` + into `Foo/Bar/BAZ.hs` (rather than `Foo/Bar/Baz.hs`). + + Args: + c: A non-empty string word. + + Returns: + The input with the first letter upper-cased. + """ + return c[0].capitalize() + c[1:] + +def _camel_case(comp): + """Camel-case the input string, preserving any existing capital letters. + """ + + # Split on both "-" and "_", matching the behavior of proto-lens-protoc. + # Be sure to ignore any empty segments from input with leading or trailing + # delimiters. + return "".join([ + _capitalize_first_letter(c2) + for c1 in comp.split("_") + for c2 in c1.split("-") + if len(c2) > 0 + ]) + +def _proto_lens_output_file(path): + """The output file from `proto-lens-protoc` when run on the given `path`. + """ + + path = path[:-len(".proto")] + result = "/".join([_camel_case(p) for p in path.split("/")]) + ".hs" + + return "Proto/" + result + +def _proto_lens_fields_file(path): + """The fields file from `proto-lens-protoc` when run on the given `path`. + """ + + path = path[:-len(".proto")] + result = "/".join([_camel_case(p) for p in path.split("/")]) + "_Fields.hs" + + return "Proto/" + result + +def _proto_path(proto, proto_source_roots): + """A path to the proto file which matches any import statements.""" + proto_path = proto.path + for p in proto_source_roots: + if proto_path.startswith(p): + return paths.relativize(proto_path, p) + + return paths.relativize( + proto_path, + paths.join(proto.root.path, proto.owner.workspace_root), + ) + +def _haskell_proto_aspect_impl(target, ctx): + pb = ctx.toolchains["@io_tweag_rules_haskell//protobuf:toolchain"].tools + + args = ctx.actions.args() + + src_prefix = paths.join( + ctx.label.workspace_root, + ctx.label.package, + ) + + args.add("--plugin=protoc-gen-haskell=" + pb.plugin.path) + + hs_files = [] + inputs = [] + + direct_proto_paths = [target.proto.proto_source_root] + transitive_proto_paths = target.proto.transitive_proto_path + + args.add_all([ + "-I{0}={1}".format(_proto_path(s, transitive_proto_paths), s.path) + for s in target.proto.transitive_sources.to_list() + ]) + + inputs.extend(target.proto.transitive_sources.to_list()) + + for src in target.proto.direct_sources: + inputs.append(src) + + # As with the native rules, require the .proto file to be in the same + # Bazel package as the proto_library rule. This allows us to put the + # output .hs file next to the input .proto file. Unfortunately Skylark + # doesn't let us check the package of the file directly, so instead we + # just look at its short_path and rely on the proto_library rule itself + # to check for consistency. We use the file's path rather than its + # dirname/basename in case it's in a subdirectory; for example, if the + # proto_library rule is in "foo/BUILD" but the .proto file is + # "foo/bar/baz.proto". + + if not src.path.startswith(paths.join(src.root.path, src_prefix)): + fail("Mismatch between rule context " + str(ctx.label.package) + + " and source file " + src.short_path) + if src.basename[-6:] != ".proto": + fail("bad extension for proto file " + src) + + args.add(src.path) + hs_files.append(ctx.actions.declare_file( + _proto_lens_output_file( + _proto_path(src, direct_proto_paths), + ), + )) + hs_files.append(ctx.actions.declare_file( + _proto_lens_fields_file( + _proto_path(src, direct_proto_paths), + ), + )) + + args.add_all([ + "--proto_path=" + target.proto.proto_source_root, + "--haskell_out=no-runtime:" + paths.join( + hs_files[0].root.path, + src_prefix, + ), + ]) + + ctx.actions.run( + inputs = depset([pb.protoc, pb.plugin] + inputs), + outputs = hs_files, + mnemonic = "HaskellProtoc", + executable = pb.protoc, + arguments = [args], + ) + + patched_attrs = { + "compiler_flags": [], + "src_strip_prefix": "", + "repl_interpreted": True, + "repl_ghci_args": [], + "version": "", + "linkstatic": False, + "_ghci_script": ctx.attr._ghci_script, + "_ghci_repl_wrapper": ctx.attr._ghci_repl_wrapper, + "hidden_modules": [], + "exports": {}, + "name": "proto-autogen-" + ctx.rule.attr.name, + "srcs": hs_files, + "deps": ctx.rule.attr.deps + + ctx.toolchains["@io_tweag_rules_haskell//protobuf:toolchain"].deps, + "prebuilt_dependencies": ctx.toolchains["@io_tweag_rules_haskell//protobuf:toolchain"].prebuilt_deps, + "plugins": [], + "_cc_toolchain": ctx.attr._cc_toolchain, + } + + patched_ctx = struct( + actions = ctx.actions, + attr = struct(**patched_attrs), + bin_dir = ctx.bin_dir, + disabled_features = ctx.rule.attr.features, + executable = struct( + _ls_modules = ctx.executable._ls_modules, + ), + # Necessary for CC interop (see cc.bzl). + features = ctx.rule.attr.features, + file = ctx.file, + files = struct( + srcs = hs_files, + _cc_toolchain = ctx.files._cc_toolchain, + extra_srcs = depset(), + ), + genfiles_dir = ctx.genfiles_dir, + label = ctx.label, + toolchains = ctx.toolchains, + var = ctx.var, + ) + + # TODO this pattern match is very brittle. Let's not do this. The + # order should match the order in the return value expression in + # haskell_library_impl(). + [hs_info, cc_info, coverage_info, default_info, library_info] = _haskell_library_impl(patched_ctx) + + return [ + cc_info, # CcInfo + hs_info, # HaskellInfo + library_info, # HaskellLibraryInfo + # We can't return DefaultInfo here because target already provides that. + HaskellProtobufInfo(files = default_info.files), + ] + +_haskell_proto_aspect = aspect( + _haskell_proto_aspect_impl, + attr_aspects = ["deps"], + attrs = { + "_ghci_script": attr.label( + allow_single_file = True, + default = Label("@io_tweag_rules_haskell//haskell:assets/ghci_script"), + ), + "_ghci_repl_wrapper": attr.label( + allow_single_file = True, + default = Label("@io_tweag_rules_haskell//haskell:private/ghci_repl_wrapper.sh"), + ), + "_ls_modules": attr.label( + executable = True, + cfg = "host", + default = Label("@io_tweag_rules_haskell//haskell:ls_modules"), + ), + "_cc_toolchain": attr.label( + default = Label("@bazel_tools//tools/cpp:current_cc_toolchain"), + ), + }, + toolchains = [ + "@io_tweag_rules_haskell//haskell:toolchain", + "@io_tweag_rules_haskell//protobuf:toolchain", + ], +) + +def _haskell_proto_library_impl(ctx): + dep = ctx.attr.deps[0] # FIXME + return [ + dep[CcInfo], + dep[HaskellInfo], + dep[HaskellLibraryInfo], + DefaultInfo(files = dep[HaskellProtobufInfo].files), + ] + +haskell_proto_library = rule( + _haskell_proto_library_impl, + attrs = { + "deps": attr.label_list( + mandatory = True, + allow_files = False, + aspects = [_haskell_proto_aspect], + doc = "List of `proto_library` targets to use for generation.", + ), + }, + toolchains = [ + "@io_tweag_rules_haskell//haskell:toolchain", + "@io_tweag_rules_haskell//protobuf:toolchain", + ], +) + +"""Generate Haskell library allowing to use protobuf definitions with help +of [`proto-lens`](https://github.com/google/proto-lens#readme). + +Example: + ```bzl + proto_library( + name = "foo_proto", + srcs = ["foo.proto"], + ) + + haskell_proto_library( + name = "foo_haskell_proto", + deps = [":foo_proto"], + ) + ``` + +`haskell_proto_library` targets require `haskell_proto_toolchain` to be +registered. +""" + +def _protobuf_toolchain_impl(ctx): + if ctx.attr.prebuilt_deps: + print("""The attribute 'prebuilt_deps' has been deprecated, +use the 'deps' attribute instead. +""") + + return [ + platform_common.ToolchainInfo( + name = ctx.label.name, + tools = struct( + plugin = ctx.executable.plugin, + protoc = ctx.executable.protoc, + ), + deps = ctx.attr.deps, + prebuilt_deps = ctx.attr.prebuilt_deps, + ), + ] + +_protobuf_toolchain = rule( + _protobuf_toolchain_impl, + attrs = { + "protoc": attr.label( + executable = True, + cfg = "host", + allow_single_file = True, + mandatory = True, + doc = "protoc compiler", + ), + "plugin": attr.label( + executable = True, + cfg = "host", + allow_single_file = True, + mandatory = True, + doc = "proto-lens-protoc plugin for protoc", + ), + "deps": attr.label_list( + doc = "List of other Haskell libraries to be linked to protobuf libraries.", + ), + "prebuilt_deps": attr.string_list( + doc = "Non-Bazel supplied Cabal dependencies for protobuf libraries.", + ), + }, +) + +def haskell_proto_toolchain( + name, + plugin, + deps = [], + prebuilt_deps = [], + protoc = Label("@com_google_protobuf//:protoc"), + **kwargs): + """Declare a Haskell protobuf toolchain. + + You need at least one of these declared somewhere in your `BUILD` files + for the `haskell_proto_library` rules to work. Once declared, you then + need to *register* the toolchain using `register_toolchains` in your + `WORKSPACE` file (see example below). + + Example: + + In a `BUILD` file: + + ```bzl + haskell_proto_toolchain( + name = "protobuf-toolchain", + protoc = "@com_google_protobuf//:protoc", + plugin = "@hackage-proto-lens-protoc//:bin/proto-lens-protoc", + prebuilt_deps = [ + "base", + "bytestring", + "containers", + "data-default-class", + "lens-family", + "lens-labels", + "proto-lens", + "text", + ], + ) + ``` + + The `prebuilt_deps` and `deps` arguments allow to specify Haskell + libraries to use to compile the auto-generated source files. + + In `WORKSPACE` you could have something like this: + + ```bzl + http_archive( + name = "com_google_protobuf", + sha256 = "cef7f1b5a7c5fba672bec2a319246e8feba471f04dcebfe362d55930ee7c1c30", + strip_prefix = "protobuf-3.5.0", + urls = ["https://github.com/google/protobuf/archive/v3.5.0.zip"], + ) + + nixpkgs_package( + name = "protoc_gen_haskell", + repository = "@nixpkgs", + attribute_path = "haskell.packages.ghc822.proto-lens-protoc + ) + + register_toolchains( + "//tests:ghc", # assuming you called your Haskell toolchain "ghc" + "//tests:protobuf-toolchain", + ) + ``` + """ + impl_name = name + "-impl" + _protobuf_toolchain( + name = impl_name, + plugin = plugin, + deps = deps, + prebuilt_deps = prebuilt_deps, + protoc = protoc, + visibility = ["//visibility:public"], + **kwargs + ) + + native.toolchain( + name = name, + toolchain_type = "@io_tweag_rules_haskell//protobuf:toolchain", + toolchain = ":" + impl_name, + exec_compatible_with = [ + "@bazel_tools//platforms:x86_64", + ], + ) diff --git a/third_party/bazel/rules_haskell/haskell/providers.bzl b/third_party/bazel/rules_haskell/haskell/providers.bzl new file mode 100644 index 000000000000..2b70ec2e8700 --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/providers.bzl @@ -0,0 +1,234 @@ +"""Providers exposed by the Haskell rules.""" + +load( + ":private/path_utils.bzl", + "darwin_convert_to_dylibs", + "make_path", + "windows_convert_to_dlls", +) + +HaskellCcInfo = provider( + doc = "Haskell cc dependency information. Part of HaskellInfo.", + fields = { + "static_linking": """static linking mode parameters. + A struct of + (libraries_to_link, dynamic_libraries_for_runtime, user_link_flags). + Libraries in libraries_to_link are struct(lib, mangled_lib) + because the Darwin linker needs the original library path, + while the Linux linker needs the mangled path. + """, + "dynamic_linking": """static linking mode parameters. + A struct of + (libraries_to_link, dynamic_libraries_for_runtime, user_link_flags). + Libraries in libraries_to_link are struct(lib, mangled_lib) + because the Darwin linker needs the original library path, + while the Linux linker needs the mangled path. + """, + }, +) + +def empty_HaskellCcInfo(): + return HaskellCcInfo( + static_linking = struct( + libraries_to_link = depset(order = "topological"), + dynamic_libraries_for_runtime = depset(order = "topological"), + user_link_flags = depset(order = "topological"), + ), + dynamic_linking = struct( + libraries_to_link = depset(order = "topological"), + dynamic_libraries_for_runtime = depset(order = "topological"), + user_link_flags = depset(order = "topological"), + ), + ) + +def merge_HaskellCcInfo(*args): + return HaskellCcInfo( + static_linking = struct( + libraries_to_link = depset( + order = "topological", + transitive = [arg.static_linking.libraries_to_link for arg in args], + ), + dynamic_libraries_for_runtime = depset( + order = "topological", + transitive = [arg.static_linking.dynamic_libraries_for_runtime for arg in args], + ), + user_link_flags = depset( + order = "topological", + transitive = [arg.static_linking.user_link_flags for arg in args], + ), + ), + dynamic_linking = struct( + libraries_to_link = depset( + order = "topological", + transitive = [arg.dynamic_linking.libraries_to_link for arg in args], + ), + dynamic_libraries_for_runtime = depset( + order = "topological", + transitive = [arg.dynamic_linking.dynamic_libraries_for_runtime for arg in args], + ), + user_link_flags = depset( + order = "topological", + transitive = [arg.dynamic_linking.user_link_flags for arg in args], + ), + ), + ) + +HaskellInfo = provider( + doc = "Common information about build process: dependencies, etc.", + fields = { + "package_ids": "Set of all package ids of direct (non-prebuilt) dependencies.", + "package_databases": "Set of package cache files.", + "version_macros": "Set of version macro files.", + "import_dirs": "Import hierarchy roots.", + "source_files": "Set of files that contain Haskell modules.", + "extra_source_files": "A depset of non-Haskell source files.", + "static_libraries": "Ordered collection of compiled library archives.", + "static_libraries_prof": "Ordered collection of static libraries with profiling.", + "dynamic_libraries": "Set of dynamic libraries.", + "interface_dirs": "Set of interface dirs belonging to the packages.", + "compile_flags": "Arguments that were used to compile the code.", + "prebuilt_dependencies": "Transitive collection of info of wired-in Haskell dependencies.", + "direct_prebuilt_deps": "Set of info of direct prebuilt dependencies.", + "cc_dependencies": "Direct cc library dependencies. See HaskellCcInfo.", + "transitive_cc_dependencies": "Transitive cc library dependencies. See HaskellCcInfo.", + }, +) + +def get_libs_for_ghc_linker(hs, transitive_cc_dependencies, path_prefix = None): + """Return all C library dependencies for GHC's linker. + + GHC has it's own builtin linker. It is used for Template Haskell, for GHCi, + during doctests, etc. GHC's linker differs from the system's dynamic linker + in some ways. E.g. it strictly assumes that dynamic libraries end on .dylib + on MacOS. + + This function returns a list of all transitive C library dependencies + (static or dynamic), taking the requirements of GHC's linker into account. + + Args: + hs: Haskell context. + transitive_cc_dependencies: HaskellCcInfo provider. + path_prefix: Prefix for paths in GHC environment variables. + + Returns: + (library_deps, ld_library_deps, env) + library_deps: List of library files suitable for GHC's builtin linker. + ld_library_deps: List of library files that should be available for + dynamic loading. + env: A mapping environment variables LIBRARY_PATH and LD_LIBRARY_PATH, + to the corresponding values as expected by GHC. + """ + trans_link_ctx = transitive_cc_dependencies.dynamic_linking + + libs_to_link = trans_link_ctx.libraries_to_link.to_list() + libs_for_runtime = trans_link_ctx.dynamic_libraries_for_runtime.to_list() + + _library_deps = libs_to_link + _ld_library_deps = libs_for_runtime + if hs.toolchain.is_darwin: + # GHC's builtin linker requires .dylib files on MacOS. + library_deps = darwin_convert_to_dylibs(hs, _library_deps) + + # Additionally ghc 8.4 requires library_deps here although 8.6 does not + ld_library_deps = library_deps + _ld_library_deps + elif hs.toolchain.is_windows: + # GHC's builtin linker requires .dll files on Windows. + library_deps = windows_convert_to_dlls(hs, _library_deps) + + # copied over from Darwin 5 lines above + ld_library_deps = library_deps + _ld_library_deps + else: + library_deps = _library_deps + ld_library_deps = _ld_library_deps + + sep = ";" if hs.toolchain.is_windows else None + + library_path = make_path( + library_deps, + prefix = path_prefix, + sep = sep, + ) + ld_library_path = make_path( + ld_library_deps, + prefix = path_prefix, + sep = sep, + ) + + # GHC's builtin linker/loader looks for libraries in the paths defined by + # LIBRARY_PATH and LD_LIBRARY_PATH. + # See https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/ghci.html?highlight=library_path#extra-libraries + # In certain cases it is not enough to specify LD_LIBRARY_PATH alone, and + # libraries are only found if their path is included in LIBRARY_PATH. + # See https://github.com/tweag/rules_haskell/pull/685 + env = { + "LIBRARY_PATH": library_path, + "LD_LIBRARY_PATH": ld_library_path, + } + + return (library_deps, ld_library_deps, env) + +HaskellLibraryInfo = provider( + doc = "Library-specific information.", + fields = { + "package_id": "Workspace unique package identifier.", + "version": "Package version.", + }, +) + +HaskellCoverageInfo = provider( + doc = "Information about coverage instrumentation for Haskell files.", + fields = { + "coverage_data": "A list of coverage data containing which parts of Haskell source code are being tracked for code coverage.", + }, +) + +HaskellPrebuiltPackageInfo = provider( + doc = "Information about a prebuilt GHC package.", + fields = { + "package": "Package name", + "id_file": "File containing package id", + "version_macros_file": "C header file containing Cabal version macros", + }, +) + +HaddockInfo = provider( + doc = "Haddock information.", + fields = { + "package_id": "Package id, usually of the form name-version.", + "transitive_html": "Dictionary from package id to html dirs.", + "transitive_haddocks": "Dictionary from package id to Haddock files.", + }, +) + +HaskellLintInfo = provider( + doc = "Provider that collects files produced by linters", + fields = { + "outputs": "Set of linter log files.", + }, +) + +HaskellProtobufInfo = provider( + doc = "Provider that wraps providers of auto-generated Haskell libraries", + fields = { + "files": "files", + }, +) + +C2hsLibraryInfo = provider( + doc = "Information about c2hs dependencies.", + fields = { + "chi_file": "c2hs interface file", + "import_dir": "Import directory containing generated Haskell source file.", + }, +) + +GhcPluginInfo = provider( + doc = "Encapsulates GHC plugin dependencies and tools", + fields = { + "module": "Plugin entrypoint.", + "deps": "Plugin dependencies.", + "args": "Plugin options.", + "tool_inputs": "Inputs required for plugin tools.", + "tool_input_manifests": "Plugin tools input manifests.", + }, +) diff --git a/third_party/bazel/rules_haskell/haskell/repl.bzl b/third_party/bazel/rules_haskell/haskell/repl.bzl new file mode 100644 index 000000000000..7480c03add6e --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/repl.bzl @@ -0,0 +1,460 @@ +"""Multi target Haskell REPL.""" + +load("@bazel_skylib//lib:paths.bzl", "paths") +load("@bazel_skylib//lib:shell.bzl", "shell") +load("@io_tweag_rules_haskell//haskell:private/context.bzl", "haskell_context", "render_env") +load( + "@io_tweag_rules_haskell//haskell:private/path_utils.bzl", + "link_libraries", + "match_label", + "parse_pattern", + "target_unique_name", +) +load( + "@io_tweag_rules_haskell//haskell:providers.bzl", + "HaskellInfo", + "HaskellLibraryInfo", + "empty_HaskellCcInfo", + "get_libs_for_ghc_linker", + "merge_HaskellCcInfo", +) +load("@io_tweag_rules_haskell//haskell:private/set.bzl", "set") + +HaskellReplLoadInfo = provider( + doc = """Haskell REPL target information. + + Information to a Haskell target to load into the REPL as source. + """, + fields = { + "source_files": "Set of files that contain Haskell modules.", + "cc_dependencies": "Direct cc library dependencies. See HaskellCcInfo.", + "compiler_flags": "Flags to pass to the Haskell compiler.", + "repl_ghci_args": "Arbitrary extra arguments to pass to GHCi. This extends `compiler_flags` and `repl_ghci_args` from the toolchain", + }, +) + +HaskellReplDepInfo = provider( + doc = """Haskell REPL dependency information. + + Information to a Haskell target to load into the REPL as a built package. + """, + fields = { + "package_ids": "Set of workspace unique package identifiers.", + "package_databases": "Set of package cache files.", + }, +) + +HaskellReplCollectInfo = provider( + doc = """Collect Haskell REPL information. + + Holds information to generate a REPL that loads some targets as source + and some targets as built packages. + """, + fields = { + "load_infos": "Dictionary from labels to HaskellReplLoadInfo.", + "dep_infos": "Dictionary from labels to HaskellReplDepInfo.", + "prebuilt_dependencies": "Transitive collection of info of wired-in Haskell dependencies.", + "transitive_cc_dependencies": "Transitive cc library dependencies. See HaskellCcInfo.", + }, +) + +HaskellReplInfo = provider( + doc = """Haskell REPL information. + + Holds information to generate a REPL that loads a specific set of targets + from source or as built packages. + """, + fields = { + "load_info": "Combined HaskellReplLoadInfo.", + "dep_info": "Combined HaskellReplDepInfo.", + "prebuilt_dependencies": "Transitive collection of info of wired-in Haskell dependencies.", + "transitive_cc_dependencies": "Transitive cc library dependencies. See HaskellCcInfo.", + }, +) + +def _merge_HaskellReplLoadInfo(load_infos): + source_files = set.empty() + cc_dependencies = empty_HaskellCcInfo() + compiler_flags = [] + repl_ghci_args = [] + + for load_info in load_infos: + set.mutable_union(source_files, load_info.source_files) + cc_dependencies = merge_HaskellCcInfo( + cc_dependencies, + load_info.cc_dependencies, + ) + compiler_flags += load_info.compiler_flags + repl_ghci_args += load_info.repl_ghci_args + + return HaskellReplLoadInfo( + source_files = source_files, + cc_dependencies = cc_dependencies, + compiler_flags = compiler_flags, + repl_ghci_args = repl_ghci_args, + ) + +def _merge_HaskellReplDepInfo(dep_infos): + package_ids = set.empty() + package_databases = set.empty() + + for dep_info in dep_infos: + set.mutable_union(package_ids, dep_info.package_ids) + set.mutable_union(package_databases, dep_info.package_databases) + + return HaskellReplDepInfo( + package_ids = package_ids, + package_databases = package_databases, + ) + +def _create_HaskellReplCollectInfo(target, ctx): + load_infos = {} + dep_infos = {} + + hs_info = target[HaskellInfo] + prebuilt_dependencies = hs_info.prebuilt_dependencies + transitive_cc_dependencies = hs_info.transitive_cc_dependencies + + load_infos[target.label] = HaskellReplLoadInfo( + source_files = hs_info.source_files, + cc_dependencies = hs_info.cc_dependencies, + compiler_flags = getattr(ctx.rule.attr, "compiler_flags", []), + repl_ghci_args = getattr(ctx.rule.attr, "repl_ghci_args", []), + ) + if HaskellLibraryInfo in target: + lib_info = target[HaskellLibraryInfo] + dep_infos[target.label] = HaskellReplDepInfo( + package_ids = set.singleton(lib_info.package_id), + package_databases = hs_info.package_databases, + ) + + return HaskellReplCollectInfo( + load_infos = load_infos, + dep_infos = dep_infos, + prebuilt_dependencies = prebuilt_dependencies, + transitive_cc_dependencies = transitive_cc_dependencies, + ) + +def _merge_HaskellReplCollectInfo(args): + load_infos = {} + dep_infos = {} + prebuilt_dependencies = set.empty() + transitive_cc_dependencies = empty_HaskellCcInfo() + for arg in args: + load_infos.update(arg.load_infos) + dep_infos.update(arg.dep_infos) + set.mutable_union( + prebuilt_dependencies, + arg.prebuilt_dependencies, + ) + transitive_cc_dependencies = merge_HaskellCcInfo( + transitive_cc_dependencies, + arg.transitive_cc_dependencies, + ) + + return HaskellReplCollectInfo( + load_infos = load_infos, + dep_infos = dep_infos, + prebuilt_dependencies = prebuilt_dependencies, + transitive_cc_dependencies = transitive_cc_dependencies, + ) + +def _load_as_source(from_source, from_binary, lbl): + """Whether a package should be loaded by source or as binary.""" + for pat in from_binary: + if match_label(pat, lbl): + return False + + for pat in from_source: + if match_label(pat, lbl): + return True + + return False + +def _create_HaskellReplInfo(from_source, from_binary, collect_info): + """Convert a HaskellReplCollectInfo to a HaskellReplInfo. + + Args: + from_source: List of patterns for packages to load by source. + from_binary: List of patterns for packages to load as binary packages. + collect_info: HaskellReplCollectInfo provider. + + Returns: + HaskellReplInfo provider. + """ + + # Collect all packages to load by source. + load_info = _merge_HaskellReplLoadInfo([ + load_info + for (lbl, load_info) in collect_info.load_infos.items() + if _load_as_source(from_source, from_binary, lbl) + ]) + + # Collect all packages to load as binary packages. + dep_info = _merge_HaskellReplDepInfo([ + dep_info + for (lbl, dep_info) in collect_info.dep_infos.items() + if not _load_as_source(from_source, from_binary, lbl) + ]) + + return HaskellReplInfo( + load_info = load_info, + dep_info = dep_info, + prebuilt_dependencies = collect_info.prebuilt_dependencies, + transitive_cc_dependencies = collect_info.transitive_cc_dependencies, + ) + +def _create_repl(hs, ctx, repl_info, output): + """Build a multi target REPL. + + Args: + hs: Haskell context. + ctx: Rule context. + repl_info: HaskellReplInfo provider. + output: The output for the executable REPL script. + + Returns: + List of providers: + DefaultInfo provider for the executable REPL script. + + """ + + # The base and directory packages are necessary for the GHCi script we use + # (loads source files and brings in scope the corresponding modules). + args = ["-package", "base", "-package", "directory"] + + # Load prebuilt dependencies (-package) + for dep in set.to_list(repl_info.prebuilt_dependencies): + args.extend(["-package", dep.package]) + + # Load built dependencies (-package-id, -package-db) + for package_id in set.to_list(repl_info.dep_info.package_ids): + args.extend(["-package-id", package_id]) + for package_cache in set.to_list(repl_info.dep_info.package_databases): + args.extend([ + "-package-db", + paths.join("$RULES_HASKELL_EXEC_ROOT", package_cache.dirname), + ]) + + # Load C library dependencies + link_ctx = repl_info.load_info.cc_dependencies.dynamic_linking + libs_to_link = link_ctx.dynamic_libraries_for_runtime.to_list() + + # External C libraries that we need to make available to the REPL. + libraries = link_libraries(libs_to_link, args) + + # Transitive library dependencies to have in runfiles. + (library_deps, ld_library_deps, ghc_env) = get_libs_for_ghc_linker( + hs, + repl_info.transitive_cc_dependencies, + path_prefix = "$RULES_HASKELL_EXEC_ROOT", + ) + library_path = [paths.dirname(lib.path) for lib in library_deps] + ld_library_path = [paths.dirname(lib.path) for lib in ld_library_deps] + + # Load source files + # Force loading by source with `:add *...`. + # See https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/ghci.html#ghci-cmd-:add + add_sources = [ + "*" + f.path + for f in set.to_list(repl_info.load_info.source_files) + ] + ghci_repl_script = hs.actions.declare_file( + target_unique_name(hs, "ghci-repl-script"), + ) + hs.actions.expand_template( + template = ctx.file._ghci_repl_script, + output = ghci_repl_script, + substitutions = { + "{ADD_SOURCES}": " ".join(add_sources), + "{COMMANDS}": "\n".join(ctx.attr.repl_ghci_commands), + }, + ) + args += [ + "-ghci-script", + paths.join("$RULES_HASKELL_EXEC_ROOT", ghci_repl_script.path), + ] + + # Extra arguments. + # `compiler flags` is the default set of arguments for the repl, + # augmented by `repl_ghci_args`. + # The ordering is important, first compiler flags (from toolchain + # and local rule), then from `repl_ghci_args`. This way the more + # specific arguments are listed last, and then have more priority in + # GHC. + # Note that most flags for GHCI do have their negative value, so a + # negative flag in `repl_ghci_args` can disable a positive flag set + # in `compiler_flags`, such as `-XNoOverloadedStrings` will disable + # `-XOverloadedStrings`. + quote_args = ( + hs.toolchain.compiler_flags + + repl_info.load_info.compiler_flags + + hs.toolchain.repl_ghci_args + + repl_info.load_info.repl_ghci_args + + ctx.attr.repl_ghci_args + ) + + hs.actions.expand_template( + template = ctx.file._ghci_repl_wrapper, + output = output, + is_executable = True, + substitutions = { + "{ENV}": render_env(ghc_env), + "{TOOL}": hs.tools.ghci.path, + "{ARGS}": " ".join( + args + [ + shell.quote(a) + for a in quote_args + ], + ), + }, + ) + + extra_inputs = [ + hs.tools.ghci, + ghci_repl_script, + ] + extra_inputs.extend(set.to_list(repl_info.load_info.source_files)) + extra_inputs.extend(set.to_list(repl_info.dep_info.package_databases)) + extra_inputs.extend(library_deps) + extra_inputs.extend(ld_library_deps) + return [DefaultInfo( + executable = output, + runfiles = ctx.runfiles( + files = extra_inputs, + collect_data = ctx.attr.collect_data, + ), + )] + +def _haskell_repl_aspect_impl(target, ctx): + if not HaskellInfo in target: + return [] + + target_info = _create_HaskellReplCollectInfo(target, ctx) + deps_infos = [ + dep[HaskellReplCollectInfo] + for dep in ctx.rule.attr.deps + if HaskellReplCollectInfo in dep + ] + collect_info = _merge_HaskellReplCollectInfo([target_info] + deps_infos) + + # This aspect currently does not generate an executable REPL script by + # itself. This could be extended in future. Note, to that end it's + # necessary to construct a Haskell context without `ctx.attr.name`. + + return [collect_info] + +haskell_repl_aspect = aspect( + implementation = _haskell_repl_aspect_impl, + attr_aspects = ["deps"], +) +""" +Haskell REPL aspect. + +Used to implement the haskell_repl rule. Does not generate an executable REPL +by itself. +""" + +def _haskell_repl_impl(ctx): + collect_info = _merge_HaskellReplCollectInfo([ + dep[HaskellReplCollectInfo] + for dep in ctx.attr.deps + if HaskellReplCollectInfo in dep + ]) + from_source = [parse_pattern(ctx, pat) for pat in ctx.attr.experimental_from_source] + from_binary = [parse_pattern(ctx, pat) for pat in ctx.attr.experimental_from_binary] + repl_info = _create_HaskellReplInfo(from_source, from_binary, collect_info) + hs = haskell_context(ctx) + return _create_repl(hs, ctx, repl_info, ctx.outputs.repl) + +haskell_repl = rule( + implementation = _haskell_repl_impl, + attrs = { + "_ghci_repl_script": attr.label( + allow_single_file = True, + default = Label("@io_tweag_rules_haskell//haskell:assets/ghci_script"), + ), + "_ghci_repl_wrapper": attr.label( + allow_single_file = True, + default = Label("@io_tweag_rules_haskell//haskell:private/ghci_repl_wrapper.sh"), + ), + "deps": attr.label_list( + aspects = [haskell_repl_aspect], + doc = "List of Haskell targets to load into the REPL", + ), + "experimental_from_source": attr.string_list( + doc = """White-list of targets to load by source. + + Wild-card targets such as //... or //:all are allowed. + + The black-list takes precedence over the white-list. + + Note, this attribute will change depending on the outcome of + https://github.com/bazelbuild/bazel/issues/7763. + """, + default = ["//..."], + ), + "experimental_from_binary": attr.string_list( + doc = """Black-list of targets to not load by source but as packages. + + Wild-card targets such as //... or //:all are allowed. + + The black-list takes precedence over the white-list. + + Note, this attribute will change depending on the outcome of + https://github.com/bazelbuild/bazel/issues/7763. + """, + default = [], + ), + "repl_ghci_args": attr.string_list( + doc = "Arbitrary extra arguments to pass to GHCi. This extends `compiler_flags` and `repl_ghci_args` from the toolchain", + default = [], + ), + "repl_ghci_commands": attr.string_list( + doc = "Arbitrary extra commands to execute in GHCi.", + default = [], + ), + "collect_data": attr.bool( + doc = "Whether to collect the data runfiles from the dependencies in srcs, data and deps attributes.", + default = True, + ), + }, + executable = True, + outputs = { + "repl": "%{name}@repl", + }, + toolchains = ["@io_tweag_rules_haskell//haskell:toolchain"], +) +"""Build a REPL for multiple targets. + +Example: + ```bzl + haskell_repl( + name = "repl", + deps = [ + "//lib:some_lib", + "//exe:some_exe", + ], + experimental_from_source = [ + "//lib/...", + "//exe/...", + "//common/...", + ], + experimental_from_binary = [ + "//lib/vendored/...", + ], + ) + ``` + + Collects all transitive Haskell dependencies from `deps`. Those that match + `experimental_from_binary` or are defined in an external workspace will be + loaded as binary packages. Those that match `experimental_from_source` and + are defined in the local workspace will be loaded by source. + + You can call the REPL like this: + +``` +$ bazel run //:repl +``` + +""" diff --git a/third_party/bazel/rules_haskell/haskell/repositories.bzl b/third_party/bazel/rules_haskell/haskell/repositories.bzl new file mode 100644 index 000000000000..ca432523106b --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/repositories.bzl @@ -0,0 +1,17 @@ +"""Workspace rules (repositories)""" + +load("@bazel_tools//tools/build_defs/repo:http.bzl", "http_archive") + +def haskell_repositories(): + """Provide all repositories that are necessary for `rules_haskell` to + function. + """ + excludes = native.existing_rules().keys() + + if "bazel_skylib" not in excludes: + http_archive( + name = "bazel_skylib", + sha256 = "eb5c57e4c12e68c0c20bc774bfbc60a568e800d025557bc4ea022c6479acc867", + strip_prefix = "bazel-skylib-0.6.0", + urls = ["https://github.com/bazelbuild/bazel-skylib/archive/0.6.0.tar.gz"], + ) diff --git a/third_party/bazel/rules_haskell/haskell/toolchain.bzl b/third_party/bazel/rules_haskell/haskell/toolchain.bzl new file mode 100644 index 000000000000..b05d51ea3ba6 --- /dev/null +++ b/third_party/bazel/rules_haskell/haskell/toolchain.bzl @@ -0,0 +1,334 @@ +"""Rules for defining toolchains""" + +load("@bazel_skylib//lib:paths.bzl", "paths") +load(":ghc_bindist.bzl", "haskell_register_ghc_bindists") +load( + ":private/actions/compile.bzl", + "compile_binary", + "compile_library", +) +load( + ":private/actions/link.bzl", + "link_binary", + "link_library_dynamic", + "link_library_static", +) +load(":private/actions/package.bzl", "package") + +_GHC_BINARIES = ["ghc", "ghc-pkg", "hsc2hs", "haddock", "ghci", "runghc", "hpc"] + +def _run_ghc(hs, cc, inputs, outputs, mnemonic, arguments, params_file = None, env = None, progress_message = None, input_manifests = None): + if not env: + env = hs.env + + args = hs.actions.args() + args.add(hs.tools.ghc) + + # Do not use Bazel's CC toolchain on Windows, as it leads to linker and librarty compatibility issues. + # XXX: We should also tether Bazel's CC toolchain to GHC's, so that we can properly mix Bazel-compiled + # C libraries with Haskell targets. + if not hs.toolchain.is_windows: + args.add_all([ + # GHC uses C compiler for assemly, linking and preprocessing as well. + "-pgma", + cc.tools.cc, + "-pgmc", + cc.tools.cc, + "-pgml", + cc.tools.cc, + "-pgmP", + cc.tools.cc, + # Setting -pgm* flags explicitly has the unfortunate side effect + # of resetting any program flags in the GHC settings file. So we + # restore them here. See + # https://ghc.haskell.org/trac/ghc/ticket/7929. + "-optc-fno-stack-protector", + "-optP-E", + "-optP-undef", + "-optP-traditional", + ]) + + compile_flags_file = hs.actions.declare_file("compile_flags_%s_%s" % (hs.name, mnemonic)) + extra_args_file = hs.actions.declare_file("extra_args_%s_%s" % (hs.name, mnemonic)) + + args.set_param_file_format("multiline") + arguments.set_param_file_format("multiline") + hs.actions.write(compile_flags_file, args) + hs.actions.write(extra_args_file, arguments) + + extra_inputs = [ + hs.tools.ghc, + # Depend on the version file of the Haskell toolchain, + # to ensure the version comparison check is run first. + hs.toolchain.version_file, + compile_flags_file, + extra_args_file, + ] + cc.files + + if params_file: + params_file_src = params_file.path + extra_inputs.append(params_file) + else: + params_file_src = "<(:)" # a temporary file with no contents + + script = """ +export PATH=${PATH:-} # otherwise GCC fails on Windows + +# this is equivalent to 'readarray'. We do not use 'readarray' in order to +# support older bash versions. +while IFS= read -r line; do compile_flags+=("$line"); done < %s +while IFS= read -r line; do extra_args+=("$line"); done < %s +while IFS= read -r line; do param_file_args+=("$line"); done < %s + +"${compile_flags[@]}" "${extra_args[@]}" ${param_file_args+"${param_file_args[@]}"} +""" % (compile_flags_file.path, extra_args_file.path, params_file_src) + + ghc_wrapper_name = "ghc_wrapper_%s_%s" % (hs.name, mnemonic) + ghc_wrapper = hs.actions.declare_file(ghc_wrapper_name) + hs.actions.write(ghc_wrapper, script, is_executable = True) + extra_inputs.append(ghc_wrapper) + + if type(inputs) == type(depset()): + inputs = depset(extra_inputs, transitive = [inputs]) + else: + inputs += extra_inputs + + hs.actions.run_shell( + inputs = inputs, + input_manifests = input_manifests, + outputs = outputs, + command = ghc_wrapper.path, + mnemonic = mnemonic, + progress_message = progress_message, + env = env, + arguments = [], + ) + + return args + +def _haskell_toolchain_impl(ctx): + # Store the binaries of interest in ghc_binaries. + ghc_binaries = {} + for tool in _GHC_BINARIES: + for file in ctx.files.tools: + if tool in ghc_binaries: + continue + + basename_no_ext = paths.split_extension(file.basename)[0] + if tool == basename_no_ext: + ghc_binaries[tool] = file + elif "%s-%s" % (tool, ctx.attr.version) == basename_no_ext: + ghc_binaries[tool] = file + if not tool in ghc_binaries: + fail("Cannot find {} in {}".format(tool, ctx.attr.tools.label)) + + # Run a version check on the compiler. + version_file = ctx.actions.declare_file("ghc-version") + ghc = ghc_binaries["ghc"] + ctx.actions.run_shell( + inputs = [ghc], + outputs = [version_file], + mnemonic = "HaskellVersionCheck", + command = """ +{ghc} --numeric-version > {version_file} +if [[ "{expected_version}" != "$(< {version_file})" ]] +then + echo ERROR: GHC version does not match expected version. + echo Your haskell_toolchain specifies {expected_version}, + echo but you have $(< {version_file}) in your environment. +exit 1 +fi + """.format( + ghc = ghc.path, + version_file = version_file.path, + expected_version = ctx.attr.version, + ), + ) + + # Get the versions of every prebuilt package. + ghc_pkg = ghc_binaries["ghc-pkg"] + pkgdb_file = ctx.actions.declare_file("ghc-global-pkgdb") + ctx.actions.run_shell( + inputs = [ghc_pkg], + outputs = [pkgdb_file], + mnemonic = "HaskellPackageDatabaseDump", + command = "{ghc_pkg} dump --global > {output}".format( + ghc_pkg = ghc_pkg.path, + output = pkgdb_file.path, + ), + ) + + tools_struct_args = { + name.replace("-", "_"): file + for name, file in ghc_binaries.items() + } + + locale_archive = None + + if ctx.attr.locale_archive != None: + locale_archive = ctx.file.locale_archive + + return [ + platform_common.ToolchainInfo( + name = ctx.label.name, + tools = struct(**tools_struct_args), + compiler_flags = ctx.attr.compiler_flags, + repl_ghci_args = ctx.attr.repl_ghci_args, + haddock_flags = ctx.attr.haddock_flags, + locale = ctx.attr.locale, + locale_archive = locale_archive, + osx_cc_wrapper_tpl = ctx.file._osx_cc_wrapper_tpl, + mode = ctx.var["COMPILATION_MODE"], + actions = struct( + compile_binary = compile_binary, + compile_library = compile_library, + link_binary = link_binary, + link_library_dynamic = link_library_dynamic, + link_library_static = link_library_static, + package = package, + run_ghc = _run_ghc, + ), + is_darwin = ctx.attr.is_darwin, + is_windows = ctx.attr.is_windows, + version = ctx.attr.version, + # Pass through the version_file, that it can be required as + # input in _run_ghc, to make every call to GHC depend on a + # successful version check. + version_file = version_file, + global_pkg_db = pkgdb_file, + ), + ] + +_haskell_toolchain = rule( + _haskell_toolchain_impl, + attrs = { + "tools": attr.label_list( + doc = "GHC and executables that come with it. First item take precedance.", + mandatory = True, + ), + "compiler_flags": attr.string_list( + doc = "A collection of flags that will be passed to GHC on every invocation.", + ), + "repl_ghci_args": attr.string_list( + doc = "A collection of flags that will be passed to GHCI on repl invocation. It extends the `compiler_flags` collection. Flags set here have precedance over `compiler_flags`.", + ), + "haddock_flags": attr.string_list( + doc = "A collection of flags that will be passed to haddock.", + ), + "version": attr.string( + doc = "Version of your GHC compiler. It has to match the version reported by the GHC used by bazel.", + mandatory = True, + ), + "is_darwin": attr.bool( + doc = "Whether compile on and for Darwin (macOS).", + mandatory = True, + ), + "is_windows": attr.bool( + doc = "Whether compile on and for Windows.", + mandatory = True, + ), + "locale": attr.string( + default = "en_US.UTF-8", + doc = "Locale that will be set during compiler invocations.", + ), + "locale_archive": attr.label( + allow_single_file = True, + doc = """ +Label pointing to the locale archive file to use. Mostly useful on NixOS. +""", + ), + "_osx_cc_wrapper_tpl": attr.label( + allow_single_file = True, + default = Label("@io_tweag_rules_haskell//haskell:private/osx_cc_wrapper.sh.tpl"), + ), + }, +) + +def haskell_toolchain( + name, + version, + tools, + exec_compatible_with = None, + target_compatible_with = None, + compiler_flags = [], + repl_ghci_args = [], + haddock_flags = [], + locale_archive = None, + **kwargs): + """Declare a compiler toolchain. + + You need at least one of these declared somewhere in your `BUILD` files + for the other rules to work. Once declared, you then need to *register* + the toolchain using `register_toolchains` in your `WORKSPACE` file (see + example below). + + Example: + + In a `BUILD` file: + + ```bzl + haskell_toolchain( + name = "ghc", + version = "1.2.3", + tools = ["@sys_ghc//:bin"], + compiler_flags = ["-Wall"], + ) + ``` + + where `@sys_ghc` is an external repository defined in the `WORKSPACE`, + e.g. using: + + ```bzl + nixpkgs_package( + name = 'sys_ghc', + attribute_path = 'haskell.compiler.ghc822', + ) + + register_toolchains("//:ghc") + ``` + """ + if exec_compatible_with and not target_compatible_with: + target_compatible_with = exec_compatible_with + elif target_compatible_with and not exec_compatible_with: + exec_compatible_with = target_compatible_with + impl_name = name + "-impl" + corrected_ghci_args = repl_ghci_args + ["-no-user-package-db"] + _haskell_toolchain( + name = impl_name, + version = version, + tools = tools, + compiler_flags = compiler_flags, + repl_ghci_args = corrected_ghci_args, + haddock_flags = haddock_flags, + visibility = ["//visibility:public"], + is_darwin = select({ + "@io_tweag_rules_haskell//haskell/platforms:darwin": True, + "//conditions:default": False, + }), + is_windows = select({ + "@io_tweag_rules_haskell//haskell/platforms:mingw32": True, + "//conditions:default": False, + }), + # Ignore this attribute on any platform that is not Linux. The + # LOCALE_ARCHIVE environment variable is a Linux-specific + # Nixpkgs hack. + locale_archive = select({ + "@io_tweag_rules_haskell//haskell/platforms:linux": locale_archive, + "//conditions:default": None, + }), + **kwargs + ) + native.toolchain( + name = name, + toolchain_type = "@io_tweag_rules_haskell//haskell:toolchain", + toolchain = ":" + impl_name, + exec_compatible_with = exec_compatible_with, + target_compatible_with = target_compatible_with, + ) + +def haskell_register_toolchains(version): + """Download the binary distribution of GHC for your current platform + and register it as a toolchain. This currently has the same effect + as just `haskell_register_ghc_bindists(version)`. + """ + haskell_register_ghc_bindists(version) diff --git a/third_party/bazel/rules_haskell/logo/horizontal.png b/third_party/bazel/rules_haskell/logo/horizontal.png new file mode 100644 index 000000000000..17d8c3978bca --- /dev/null +++ b/third_party/bazel/rules_haskell/logo/horizontal.png Binary files differdiff --git a/third_party/bazel/rules_haskell/logo/horizontal.svg b/third_party/bazel/rules_haskell/logo/horizontal.svg new file mode 100644 index 000000000000..1b9cb2cdb196 --- /dev/null +++ b/third_party/bazel/rules_haskell/logo/horizontal.svg @@ -0,0 +1,135 @@ +<?xml version="1.0" encoding="utf-8"?> +<!-- Generator: Adobe Illustrator 16.0.0, SVG Export Plug-In . SVG Version: 6.00 Build 0) --> +<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN" "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd"> +<svg version="1.1" id="Layer_1" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" x="0px" y="0px" + width="896.016px" height="166.047px" viewBox="0 0 896.016 166.047" enable-background="new 0 0 896.016 166.047" + xml:space="preserve"> +<g> + <g> + <path opacity="0.5" fill="#95653A" d="M109.042,0H36.74h-5.75c-7.396,0-14.188,2.61-19.521,6.949C4.479,12.638,0,21.298,0,30.991 + v104.064c0,9.693,4.479,18.354,11.468,24.042c5.334,4.339,12.127,6.949,19.522,6.949h5.75h66.552h5.749 + c7.396,0,14.188-2.61,19.523-6.949c6.988-5.688,11.468-14.349,11.468-24.042V30.991C140.032,13.901,126.129,0,109.042,0z + M14.977,153.021c-4.951-4.419-8.09-10.822-8.09-17.966V30.991c0-7.144,3.139-13.55,8.09-17.966L55.39,83.023h-0.032l0.015,0.027 + L14.977,153.021z M40.715,159.159l29.3-50.745l29.3,50.745H40.715z M133.145,135.056c0,7.144-3.139,13.547-8.089,17.966 + L84.659,83.051l0.015-0.027L40.715,6.888h68.326c13.29,0,24.104,10.813,24.104,24.104V135.056z"/> + <g> + <g> + <g> + <circle fill="#F97E2F" cx="35.109" cy="45.958" r="9.482"/> + <path fill="#F97E2F" d="M114.405,45.958c0,2.857-2.315,5.173-5.171,5.173H58.381c-2.855,0-5.172-2.316-5.172-5.173l0,0 + c0-2.854,2.316-5.17,5.172-5.17h50.852C112.09,40.787,114.405,43.104,114.405,45.958L114.405,45.958z"/> + </g> + <g> + <path fill="#F97E2F" d="M44.592,83.025c0,5.238-4.248,9.481-9.482,9.481c-5.238,0-9.482-4.243-9.482-9.481 + c0-5.24,4.245-9.484,9.482-9.484C40.344,73.541,44.592,77.785,44.592,83.025z"/> + <path fill="#F97E2F" d="M114.405,83.025c0,2.854-2.315,5.169-5.171,5.169H58.381c-2.855,0-5.172-2.315-5.172-5.169l0,0 + c0-2.857,2.316-5.173,5.172-5.173h50.852C112.09,77.852,114.405,80.168,114.405,83.025L114.405,83.025z"/> + </g> + <g> + <circle fill="#F97E2F" cx="35.109" cy="120.089" r="9.482"/> + <path fill="#F97E2F" d="M114.405,120.089c0,2.854-2.315,5.171-5.171,5.171H58.381c-2.855,0-5.172-2.316-5.172-5.171l0,0 + c0-2.855,2.316-5.173,5.172-5.173h50.852C112.09,114.916,114.405,117.233,114.405,120.089L114.405,120.089z"/> + </g> + </g> + </g> + </g> + <g> + <rect x="453.679" y="120.31" fill="#F97E2F" width="49.715" height="10.095"/> + <path fill="#F97E2F" d="M193.988,66.934c-3.113,2.314-5.827,5.47-8.139,9.465l-0.946-7.823c-0.211-1.43-0.631-2.44-1.262-3.03 + c-0.631-0.587-1.746-0.881-3.344-0.881h-9.148v64.729h15.584V89.081c1.598-3.45,3.553-6.068,5.867-7.854 + c2.313-1.789,5.088-2.684,8.328-2.684c1.808,0,3.26,0.15,4.354,0.443c1.093,0.294,1.956,0.441,2.587,0.441 + c0.715,0,1.283-0.157,1.703-0.472s0.694-0.853,0.82-1.608l2.019-11.674c-2.103-1.472-4.753-2.206-7.949-2.206 + C200.59,63.466,197.1,64.623,193.988,66.934z"/> + <path fill="#F97E2F" d="M262.188,111.477c-2.104,2.104-4.333,3.754-6.688,4.953c-2.356,1.199-4.879,1.8-7.571,1.8 + c-3.659,0-6.404-1.084-8.233-3.251c-1.829-2.167-2.744-5.226-2.744-9.179V64.665h-15.583V105.8c0,3.617,0.473,6.928,1.419,9.938 + c0.947,3.006,2.345,5.604,4.196,7.791c1.85,2.186,4.132,3.88,6.845,5.079c2.712,1.199,5.835,1.797,9.369,1.797 + c2.145,0,4.153-0.221,6.025-0.661c1.871-0.443,3.617-1.052,5.237-1.831c1.619-0.776,3.144-1.724,4.574-2.839 + c1.429-1.114,2.817-2.345,4.164-3.69l1.072,5.173c0.631,1.895,1.956,2.839,3.975,2.839h9.527V64.665h-15.583V111.477z"/> + <rect x="295.436" y="35.643" fill="#F97E2F" width="15.583" height="93.752"/> + <path fill="#F97E2F" d="M375.498,71.32c-2.482-2.502-5.437-4.407-8.864-5.711c-3.429-1.301-7.182-1.955-11.262-1.955 + c-4.837,0-9.18,0.842-13.028,2.524s-7.109,3.964-9.779,6.844c-2.671,2.883-4.721,6.268-6.151,10.158 + c-1.43,3.891-2.145,8.043-2.145,12.461c0,5.678,0.82,10.672,2.461,14.985c1.64,4.31,3.89,7.928,6.75,10.85 + c2.86,2.926,6.225,5.132,10.095,6.624c3.87,1.493,8.054,2.241,12.555,2.241c2.271,0,4.616-0.168,7.035-0.504 + c2.418-0.339,4.795-0.916,7.13-1.737c2.334-0.818,4.574-1.912,6.719-3.279c2.145-1.366,4.079-3.061,5.805-5.078l-4.542-5.68 + c-0.338-0.462-0.737-0.818-1.199-1.073c-0.463-0.252-1.009-0.378-1.64-0.378c-0.968,0-1.967,0.294-2.997,0.885 + c-1.031,0.59-2.23,1.24-3.596,1.954c-1.367,0.716-2.965,1.369-4.795,1.957c-1.83,0.59-4.006,0.884-6.529,0.884 + c-5.133,0-9.254-1.556-12.366-4.67c-3.113-3.111-4.9-7.99-5.363-14.638h40c0.715,0,1.303-0.095,1.767-0.283 + c0.462-0.189,0.83-0.504,1.104-0.947c0.273-0.44,0.462-1.05,0.568-1.829c0.104-0.776,0.158-1.755,0.158-2.933 + c0-4.67-0.695-8.822-2.083-12.461S377.979,73.823,375.498,71.32z M340.104,89.585c0.715-4.709,2.355-8.348,4.921-10.914 + c2.565-2.566,6.12-3.849,10.663-3.849c2.313,0,4.332,0.388,6.057,1.165c1.725,0.779,3.155,1.842,4.29,3.188 + c1.136,1.346,1.977,2.912,2.524,4.701c0.546,1.786,0.82,3.691,0.82,5.709H340.104z"/> + <path fill="#F97E2F" d="M433.76,97.438c-1.493-1.324-3.186-2.418-5.079-3.279c-1.893-0.862-3.828-1.629-5.805-2.303 + c-1.977-0.672-3.911-1.293-5.804-1.862c-1.893-0.567-3.586-1.207-5.079-1.923c-1.494-0.717-2.692-1.546-3.596-2.492 + c-0.905-0.947-1.357-2.115-1.357-3.503c0-2.101,0.884-3.806,2.65-5.11c1.766-1.304,4.184-1.954,7.255-1.954 + c1.977,0,3.691,0.21,5.143,0.629c1.451,0.422,2.744,0.895,3.88,1.419c1.135,0.527,2.134,1,2.997,1.419 + c0.862,0.423,1.672,0.632,2.429,0.632c0.714,0,1.303-0.136,1.766-0.409c0.462-0.275,0.905-0.748,1.325-1.422l3.533-5.614 + c-2.439-2.398-5.489-4.332-9.147-5.803c-3.66-1.474-7.719-2.209-12.177-2.209c-3.997,0-7.519,0.536-10.567,1.608 + c-3.05,1.073-5.594,2.502-7.634,4.289c-2.041,1.789-3.586,3.88-4.637,6.278c-1.052,2.398-1.578,4.921-1.578,7.571 + c0,2.862,0.452,5.299,1.356,7.319c0.904,2.02,2.104,3.723,3.597,5.11c1.492,1.388,3.196,2.534,5.11,3.439 + c1.913,0.904,3.869,1.691,5.867,2.366c1.997,0.671,3.953,1.293,5.867,1.859c1.914,0.566,3.617,1.21,5.11,1.923 + c1.493,0.717,2.691,1.559,3.597,2.524c0.904,0.968,1.356,2.208,1.356,3.722c0,1.011-0.2,1.989-0.6,2.936 + c-0.4,0.945-1.031,1.776-1.893,2.492c-0.863,0.714-1.956,1.294-3.281,1.734c-1.325,0.441-2.913,0.661-4.763,0.661 + c-2.356,0-4.301-0.272-5.836-0.818c-1.536-0.546-2.871-1.136-4.006-1.769c-1.135-0.629-2.136-1.217-2.997-1.766 + c-0.863-0.545-1.777-0.82-2.745-0.82c-0.968,0-1.767,0.191-2.397,0.569c-0.631,0.377-1.178,0.926-1.64,1.64l-3.597,5.931 + c1.262,1.137,2.723,2.188,4.385,3.153c1.661,0.969,3.47,1.811,5.426,2.524c1.956,0.716,3.995,1.272,6.12,1.674 + c2.124,0.398,4.3,0.598,6.53,0.598c4.164,0,7.854-0.535,11.072-1.608c3.218-1.072,5.92-2.565,8.107-4.48 + c2.187-1.912,3.849-4.185,4.984-6.813c1.136-2.629,1.704-5.499,1.704-8.613c0-2.607-0.453-4.835-1.357-6.687 + C436.452,100.354,435.253,98.764,433.76,97.438z"/> + <path fill="#F97E2F" d="M569.872,70.5c-1.83-2.165-4.112-3.849-6.846-5.047c-2.734-1.199-5.867-1.797-9.4-1.797 + c-4.08,0-7.634,0.735-10.662,2.209c-3.029,1.472-5.805,3.405-8.328,5.803V35.643h-15.583v93.752h15.583V82.583 + c2.103-2.104,4.331-3.764,6.688-4.984c2.355-1.22,4.879-1.831,7.57-1.831c3.66,0,6.404,1.083,8.233,3.25 + c1.83,2.167,2.746,5.226,2.746,9.179v41.198h15.583V88.196c0-3.617-0.474-6.928-1.42-9.937 + C573.089,75.253,571.701,72.667,569.872,70.5z"/> + <path fill="#F97E2F" d="M635.202,70.5c-2.061-2.209-4.574-3.933-7.539-5.173c-2.967-1.241-6.34-1.86-10.126-1.86 + c-10.517,0-19.495,3.405-26.94,10.221l2.84,4.984c0.461,0.797,1.072,1.472,1.828,2.017c0.758,0.548,1.662,0.821,2.714,0.821 + c1.262,0,2.418-0.294,3.47-0.884c1.052-0.587,2.198-1.251,3.439-1.986c1.239-0.737,2.701-1.398,4.383-1.988 + c1.682-0.588,3.786-0.884,6.31-0.884c3.492,0,6.152,1.049,7.981,3.148c1.83,2.096,2.744,5.331,2.744,9.693v3.814 + c-7.359,0-13.521,0.635-18.485,1.899c-4.964,1.268-8.938,2.859-11.923,4.78c-2.988,1.92-5.121,4.071-6.404,6.456 + c-1.284,2.385-1.926,4.801-1.926,7.248c0,2.912,0.463,5.465,1.388,7.66c0.927,2.193,2.22,4.029,3.881,5.507 + c1.661,1.477,3.648,2.586,5.963,3.323c2.313,0.737,4.836,1.107,7.57,1.107c2.313,0,4.417-0.188,6.31-0.566 + c1.893-0.381,3.681-0.947,5.362-1.705c1.682-0.756,3.313-1.692,4.89-2.808c1.577-1.114,3.187-2.408,4.827-3.88l1.388,4.606 + c0.42,1.346,1.05,2.238,1.892,2.682c0.842,0.44,1.998,0.661,3.471,0.661h7.003V88.512c0-3.66-0.536-7.023-1.609-10.095 + C638.829,75.348,637.263,72.708,635.202,70.5z M626.306,112.786c-1.135,1.159-2.261,2.164-3.375,3.011 + c-1.114,0.851-2.271,1.564-3.471,2.144c-1.198,0.58-2.471,1.013-3.816,1.304c-1.346,0.289-2.818,0.436-4.416,0.436 + c-2.608,0-4.722-0.593-6.34-1.781c-1.62-1.186-2.43-3.153-2.43-5.907c0-1.398,0.389-2.689,1.167-3.878 + c0.777-1.186,2.091-2.222,3.943-3.114c1.85-0.889,4.3-1.618,7.351-2.19c3.049-0.571,6.845-0.857,11.387-0.857V112.786z"/> + <path fill="#F97E2F" d="M694.539,97.438c-1.494-1.324-3.188-2.418-5.079-3.279c-1.895-0.862-3.828-1.629-5.806-2.303 + c-1.977-0.672-3.911-1.293-5.803-1.862c-1.895-0.567-3.586-1.207-5.079-1.923c-1.494-0.717-2.693-1.546-3.597-2.492 + c-0.905-0.947-1.356-2.115-1.356-3.503c0-2.101,0.883-3.806,2.649-5.11c1.766-1.304,4.185-1.954,7.255-1.954 + c1.978,0,3.691,0.21,5.144,0.629c1.451,0.422,2.744,0.895,3.88,1.419c1.135,0.527,2.133,1,2.996,1.419 + c0.861,0.423,1.671,0.632,2.43,0.632c0.713,0,1.304-0.136,1.765-0.409c0.464-0.275,0.905-0.748,1.325-1.422l3.534-5.614 + c-2.44-2.398-5.488-4.332-9.148-5.803c-3.659-1.474-7.718-2.209-12.176-2.209c-3.997,0-7.519,0.536-10.568,1.608 + s-5.594,2.502-7.635,4.289c-2.04,1.789-3.586,3.88-4.637,6.278c-1.052,2.398-1.577,4.921-1.577,7.571 + c0,2.862,0.452,5.299,1.355,7.319c0.905,2.02,2.104,3.723,3.597,5.11c1.493,1.388,3.197,2.534,5.11,3.439 + c1.914,0.904,3.87,1.691,5.869,2.366c1.996,0.671,3.952,1.293,5.865,1.859c1.915,0.566,3.618,1.21,5.11,1.923 + c1.493,0.717,2.692,1.559,3.597,2.524c0.905,0.968,1.356,2.208,1.356,3.722c0,1.011-0.199,1.989-0.598,2.936 + c-0.401,0.945-1.031,1.776-1.895,2.492c-0.861,0.714-1.954,1.294-3.279,1.734c-1.324,0.441-2.914,0.661-4.764,0.661 + c-2.356,0-4.302-0.272-5.836-0.818c-1.536-0.546-2.871-1.136-4.007-1.769c-1.135-0.629-2.136-1.217-2.996-1.766 + c-0.863-0.545-1.777-0.82-2.744-0.82c-0.968,0-1.767,0.191-2.397,0.569c-0.631,0.377-1.179,0.926-1.64,1.64l-3.597,5.931 + c1.262,1.137,2.723,2.188,4.384,3.153c1.661,0.969,3.471,1.811,5.426,2.524c1.956,0.716,3.996,1.272,6.119,1.674 + c2.125,0.398,4.301,0.598,6.531,0.598c4.164,0,7.854-0.535,11.072-1.608c3.217-1.072,5.919-2.565,8.107-4.48 + c2.187-1.912,3.848-4.185,4.982-6.813c1.137-2.629,1.705-5.499,1.705-8.613c0-2.607-0.453-4.835-1.357-6.687 + C697.23,100.354,696.031,98.764,694.539,97.438z"/> + <path fill="#F97E2F" d="M748.323,95.264c-0.674-0.842-1.452-1.579-2.335-2.208c0.883-0.546,1.703-1.188,2.461-1.926 + c0.757-0.734,1.493-1.545,2.208-2.43l20.125-24.035h-14.258c-1.305,0-2.356,0.241-3.153,0.724 + c-0.801,0.485-1.559,1.146-2.272,1.988L735.01,87.25c-0.672,0.8-1.304,1.348-1.892,1.642c-0.59,0.294-1.41,0.441-2.461,0.441 + h-2.902v-53.69h-15.583v93.752h15.583V99.742h3.533c1.261,0,2.208,0.146,2.839,0.44c0.631,0.297,1.262,0.927,1.893,1.895 + l16.467,24.542c0.672,1.01,1.43,1.726,2.272,2.146c0.839,0.42,1.87,0.63,3.09,0.63h14.069l-21.577-31.418 + C749.669,97.009,748.995,96.104,748.323,95.264z"/> + <path fill="#F97E2F" d="M824.662,71.32c-2.482-2.502-5.437-4.407-8.864-5.711c-3.429-1.301-7.182-1.955-11.261-1.955 + c-4.838,0-9.181,0.842-13.029,2.524s-7.107,3.964-9.778,6.844c-2.672,2.883-4.723,6.268-6.152,10.158 + c-1.43,3.891-2.146,8.043-2.146,12.461c0,5.678,0.821,10.672,2.461,14.985c1.641,4.31,3.891,7.928,6.751,10.85 + c2.861,2.926,6.224,5.132,10.095,6.624c3.87,1.493,8.054,2.241,12.555,2.241c2.271,0,4.617-0.168,7.035-0.504 + c2.418-0.339,4.795-0.916,7.13-1.737c2.333-0.818,4.573-1.912,6.72-3.279c2.143-1.366,4.077-3.061,5.803-5.078l-4.541-5.68 + c-0.339-0.462-0.737-0.818-1.199-1.073c-0.464-0.252-1.01-0.378-1.641-0.378c-0.968,0-1.967,0.294-2.997,0.885 + c-1.031,0.59-2.23,1.24-3.597,1.954c-1.367,0.716-2.965,1.369-4.795,1.957c-1.829,0.59-4.007,0.884-6.529,0.884 + c-5.133,0-9.254-1.556-12.365-4.67c-3.114-3.111-4.9-7.99-5.363-14.638h40c0.713,0,1.302-0.095,1.766-0.283 + c0.463-0.189,0.83-0.504,1.104-0.947c0.272-0.44,0.461-1.05,0.567-1.829c0.104-0.776,0.159-1.755,0.159-2.933 + c0-4.67-0.695-8.822-2.083-12.461S827.143,73.823,824.662,71.32z M789.269,89.585c0.714-4.709,2.354-8.348,4.921-10.914 + c2.564-2.566,6.12-3.849,10.662-3.849c2.313,0,4.331,0.388,6.058,1.165c1.724,0.779,3.153,1.842,4.289,3.188 + s1.977,2.912,2.523,4.701c0.546,1.786,0.821,3.691,0.821,5.709H789.269z"/> + <rect x="846.237" y="35.643" fill="#F97E2F" width="15.584" height="93.752"/> + <rect x="880.432" y="35.643" fill="#F97E2F" width="15.584" height="93.752"/> + </g> +</g> +</svg> diff --git a/third_party/bazel/rules_haskell/logo/logomark.png b/third_party/bazel/rules_haskell/logo/logomark.png new file mode 100644 index 000000000000..33eacb0e60fc --- /dev/null +++ b/third_party/bazel/rules_haskell/logo/logomark.png Binary files differdiff --git a/third_party/bazel/rules_haskell/logo/logomark.svg b/third_party/bazel/rules_haskell/logo/logomark.svg new file mode 100644 index 000000000000..ab08a2b46867 --- /dev/null +++ b/third_party/bazel/rules_haskell/logo/logomark.svg @@ -0,0 +1,37 @@ +<?xml version="1.0" encoding="utf-8"?> +<!-- Generator: Adobe Illustrator 16.0.0, SVG Export Plug-In . SVG Version: 6.00 Build 0) --> +<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN" "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd"> +<svg version="1.1" id="Layer_1" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" x="0px" y="0px" + width="493.272px" height="292.348px" viewBox="0 0 493.272 292.348" enable-background="new 0 0 493.272 292.348" + xml:space="preserve"> +<g> + <path opacity="0.5" fill="#95653A" d="M303.244,25.748H198.37h-8.34c-10.727,0-20.581,3.787-28.316,10.081 + c-10.138,8.251-16.636,20.812-16.636,34.873v150.943c0,14.063,6.498,26.626,16.635,34.873c7.737,6.294,17.591,10.083,28.318,10.083 + h8.34h96.534h8.34c10.728,0,20.581-3.789,28.316-10.083c10.138-8.247,16.636-20.811,16.636-34.873V70.702 + C348.196,45.912,328.029,25.748,303.244,25.748z M166.801,247.706c-7.18-6.409-11.734-15.697-11.734-26.061V70.702 + c0-10.364,4.554-19.654,11.734-26.061l58.62,101.533h-0.046l0.022,0.04L166.801,247.706z M204.136,256.611l42.5-73.607l42.5,73.607 + H204.136z M338.206,221.645c0,10.363-4.554,19.651-11.733,26.061l-58.597-101.492l0.023-0.04L204.136,35.74h99.108 + c19.275,0,34.962,15.682,34.962,34.962V221.645z"/> + <g> + <g> + <g> + <path fill="#F97E2F" d="M209.758,92.409c0,7.6-6.16,13.756-13.754,13.756c-7.597,0-13.754-6.157-13.754-13.756 + c0-7.593,6.157-13.75,13.754-13.75C203.598,78.659,209.758,84.816,209.758,92.409z"/> + <path fill="#F97E2F" d="M311.021,92.409c0,4.145-3.357,7.504-7.499,7.504H229.76c-4.142,0-7.502-3.359-7.502-7.504l0,0 + c0-4.14,3.36-7.499,7.502-7.499h73.762C307.664,84.91,311.021,88.27,311.021,92.409L311.021,92.409z"/> + </g> + <g> + <path fill="#F97E2F" d="M209.758,146.177c0,7.596-6.16,13.75-13.754,13.75c-7.597,0-13.754-6.154-13.754-13.75 + c0-7.603,6.157-13.756,13.754-13.756C203.598,132.421,209.758,138.574,209.758,146.177z"/> + <path fill="#F97E2F" d="M311.021,146.177c0,4.14-3.357,7.497-7.499,7.497H229.76c-4.142,0-7.502-3.357-7.502-7.497l0,0 + c0-4.146,3.36-7.505,7.502-7.505h73.762C307.664,138.672,311.021,142.031,311.021,146.177L311.021,146.177z"/> + </g> + <g> + <circle fill="#F97E2F" cx="196.004" cy="199.939" r="13.754"/> + <path fill="#F97E2F" d="M311.021,199.939c0,4.139-3.357,7.499-7.499,7.499H229.76c-4.142,0-7.502-3.36-7.502-7.499l0,0 + c0-4.143,3.36-7.504,7.502-7.504h73.762C307.664,192.435,311.021,195.796,311.021,199.939L311.021,199.939z"/> + </g> + </g> + </g> +</g> +</svg> diff --git a/third_party/bazel/rules_haskell/logo/vertical.png b/third_party/bazel/rules_haskell/logo/vertical.png new file mode 100644 index 000000000000..655a8a6f38a8 --- /dev/null +++ b/third_party/bazel/rules_haskell/logo/vertical.png Binary files differdiff --git a/third_party/bazel/rules_haskell/logo/vertical.svg b/third_party/bazel/rules_haskell/logo/vertical.svg new file mode 100644 index 000000000000..7cc7bffb870f --- /dev/null +++ b/third_party/bazel/rules_haskell/logo/vertical.svg @@ -0,0 +1,134 @@ +<?xml version="1.0" encoding="utf-8"?> +<!-- Generator: Adobe Illustrator 16.0.0, SVG Export Plug-In . SVG Version: 6.00 Build 0) --> +<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN" "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd"> +<svg version="1.1" id="Layer_1" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" x="0px" y="0px" + width="493.272px" height="292.348px" viewBox="0 0 493.272 292.348" enable-background="new 0 0 493.272 292.348" + xml:space="preserve"> +<g> + <path opacity="0.5" fill="#95653A" d="M294.334,0h-88.368h-7.027c-9.039,0-17.342,3.191-23.86,8.495 + c-8.543,6.952-14.018,17.536-14.018,29.384v127.187c0,11.85,5.475,22.436,14.017,29.385c6.519,5.304,14.822,8.496,23.861,8.496 + h7.027h81.341h7.027c9.039,0,17.342-3.192,23.86-8.496c8.542-6.949,14.018-17.535,14.018-29.385V37.879 + C332.212,16.99,315.219,0,294.334,0z M179.366,187.025c-6.05-5.4-9.887-13.227-9.887-21.959V37.879 + c0-8.732,3.837-16.561,9.887-21.959l49.394,85.553h-0.039l0.019,0.033L179.366,187.025z M210.825,194.529l35.811-62.022 + l35.811,62.022H210.825z M323.794,165.066c0,8.732-3.837,16.559-9.887,21.959l-49.375-85.519l0.02-0.033L210.825,8.419h83.51 + c16.242,0,29.46,13.214,29.46,29.459V165.066z"/> + <g> + <g> + <g> + <path fill="#F97E2F" d="M215.562,56.17c0,6.403-5.191,11.591-11.589,11.591c-6.401,0-11.589-5.188-11.589-11.591 + c0-6.398,5.188-11.586,11.589-11.586C210.371,44.584,215.562,49.771,215.562,56.17z"/> + <path fill="#F97E2F" d="M300.888,56.17c0,3.492-2.829,6.323-6.319,6.323h-62.153c-3.49,0-6.321-2.831-6.321-6.323l0,0 + c0-3.488,2.831-6.319,6.321-6.319h62.153C298.059,49.851,300.888,52.682,300.888,56.17L300.888,56.17z"/> + </g> + <g> + <path fill="#F97E2F" d="M215.562,101.476c0,6.401-5.191,11.586-11.589,11.586c-6.401,0-11.589-5.185-11.589-11.586 + c0-6.406,5.188-11.591,11.589-11.591C210.371,89.884,215.562,95.069,215.562,101.476z"/> + <path fill="#F97E2F" d="M300.888,101.476c0,3.488-2.829,6.317-6.319,6.317h-62.153c-3.49,0-6.321-2.829-6.321-6.317l0,0 + c0-3.494,2.831-6.324,6.321-6.324h62.153C298.059,95.151,300.888,97.982,300.888,101.476L300.888,101.476z"/> + </g> + <g> + <path fill="#F97E2F" d="M215.562,146.776c0,6.4-5.191,11.587-11.589,11.587c-6.401,0-11.589-5.188-11.589-11.587 + c0-6.402,5.188-11.592,11.589-11.592C210.371,135.185,215.562,140.374,215.562,146.776z"/> + <path fill="#F97E2F" d="M300.888,146.776c0,3.487-2.829,6.319-6.319,6.319h-62.153c-3.49,0-6.321-2.832-6.321-6.319l0,0 + c0-3.491,2.831-6.323,6.321-6.323h62.153C298.059,140.453,300.888,143.285,300.888,146.776L300.888,146.776z"/> + </g> + </g> + </g> +</g> +<g> + <rect x="192.262" y="285.479" fill="#F97E2F" width="33.832" height="6.869"/> + <path fill="#F97E2F" d="M15.542,249.156c-2.12,1.576-3.965,3.723-5.539,6.441l-0.644-5.322c-0.144-0.974-0.43-1.659-0.859-2.063 + c-0.429-0.398-1.188-0.6-2.275-0.6H0v44.05h10.604v-27.435c1.087-2.349,2.418-4.129,3.993-5.345 + c1.574-1.218,3.463-1.825,5.667-1.825c1.231,0,2.218,0.102,2.962,0.301s1.332,0.299,1.76,0.299c0.487,0,0.874-0.105,1.16-0.32 + s0.472-0.581,0.558-1.095l1.374-7.944c-1.431-1.001-3.235-1.501-5.41-1.501C20.035,246.797,17.66,247.585,15.542,249.156z"/> + <path fill="#F97E2F" d="M61.953,279.468c-1.432,1.431-2.949,2.555-4.552,3.37c-1.603,0.817-3.32,1.227-5.152,1.227 + c-2.489,0-4.357-0.74-5.603-2.214c-1.245-1.474-1.867-3.555-1.867-6.247v-27.991H34.174v27.991c0,2.463,0.322,4.717,0.966,6.764 + c0.644,2.047,1.595,3.813,2.855,5.301c1.259,1.487,2.812,2.642,4.658,3.459c1.845,0.814,3.971,1.221,6.376,1.221 + c1.459,0,2.826-0.15,4.099-0.449c1.274-0.301,2.462-0.716,3.564-1.245c1.102-0.53,2.139-1.176,3.113-1.934 + c0.971-0.759,1.917-1.595,2.833-2.512l0.73,3.521c0.43,1.29,1.332,1.934,2.705,1.934h6.483v-44.05H61.953V279.468z"/> + <rect x="84.578" y="227.864" fill="#F97E2F" width="10.605" height="63.799"/> + <path fill="#F97E2F" d="M139.06,252.141c-1.689-1.702-3.7-2.998-6.032-3.886c-2.333-0.885-4.887-1.329-7.664-1.329 + c-3.292,0-6.247,0.573-8.866,1.716c-2.619,1.146-4.837,2.698-6.655,4.658c-1.818,1.964-3.213,4.266-4.186,6.912 + c-0.973,2.649-1.459,5.473-1.459,8.479c0,3.865,0.558,7.265,1.675,10.198c1.115,2.932,2.646,5.396,4.593,7.383 + c1.946,1.99,4.236,3.493,6.87,4.507c2.633,1.017,5.48,1.525,8.543,1.525c1.545,0,3.141-0.113,4.787-0.342 + c1.646-0.231,3.262-0.624,4.852-1.184c1.589-0.557,3.112-1.302,4.573-2.229c1.46-0.93,2.775-2.084,3.95-3.455l-3.091-3.868 + c-0.23-0.312-0.502-0.557-0.816-0.729c-0.316-0.172-0.688-0.258-1.117-0.258c-0.659,0-1.338,0.201-2.04,0.603 + c-0.701,0.4-1.517,0.844-2.446,1.331c-0.931,0.486-2.018,0.931-3.263,1.331s-2.727,0.6-4.443,0.6c-3.493,0-6.297-1.057-8.415-3.176 + c-2.12-2.117-3.335-5.438-3.65-9.962h27.22c0.487,0,0.886-0.064,1.202-0.193c0.315-0.13,0.564-0.342,0.751-0.644 + c0.187-0.301,0.315-0.715,0.387-1.245c0.071-0.529,0.107-1.193,0.107-1.995c0-3.179-0.473-6.003-1.417-8.479 + C142.065,255.933,140.748,253.846,139.06,252.141z M114.974,264.572c0.487-3.206,1.602-5.683,3.348-7.428 + c1.746-1.746,4.166-2.62,7.256-2.62c1.574,0,2.948,0.267,4.123,0.794c1.172,0.529,2.146,1.253,2.918,2.17 + c0.773,0.914,1.346,1.979,1.717,3.198c0.373,1.215,0.559,2.512,0.559,3.886H114.974z"/> + <path fill="#F97E2F" d="M178.707,269.916c-1.016-0.9-2.167-1.646-3.456-2.232c-1.288-0.586-2.604-1.107-3.95-1.567 + c-1.346-0.455-2.662-0.88-3.95-1.267c-1.288-0.385-2.44-0.82-3.457-1.308c-1.016-0.489-1.832-1.052-2.447-1.696 + c-0.616-0.646-0.924-1.439-0.924-2.383c0-1.432,0.602-2.59,1.804-3.478c1.201-0.888,2.847-1.332,4.937-1.332 + c1.345,0,2.512,0.143,3.499,0.431c0.988,0.285,1.868,0.607,2.64,0.966c0.773,0.357,1.452,0.681,2.04,0.965 + c0.586,0.288,1.137,0.431,1.653,0.431c0.486,0,0.887-0.094,1.202-0.279c0.314-0.188,0.616-0.509,0.901-0.969l2.405-3.818 + c-1.66-1.633-3.735-2.948-6.225-3.948c-2.491-1.003-5.253-1.504-8.286-1.504c-2.72,0-5.116,0.363-7.191,1.095 + c-2.076,0.729-3.807,1.702-5.195,2.918c-1.389,1.219-2.44,2.642-3.155,4.271c-0.716,1.632-1.074,3.351-1.074,5.152 + c0,1.947,0.308,3.606,0.923,4.98c0.616,1.375,1.432,2.534,2.447,3.478c1.016,0.944,2.176,1.725,3.478,2.34 + c1.303,0.616,2.634,1.151,3.993,1.611c1.359,0.457,2.69,0.879,3.993,1.267c1.302,0.385,2.462,0.823,3.477,1.307 + c1.016,0.487,1.833,1.063,2.448,1.719c0.614,0.659,0.922,1.504,0.922,2.533c0,0.687-0.136,1.354-0.407,1.999 + c-0.272,0.64-0.702,1.207-1.289,1.694c-0.586,0.486-1.331,0.879-2.232,1.181c-0.902,0.298-1.983,0.449-3.242,0.449 + c-1.603,0-2.927-0.187-3.971-0.558c-1.045-0.371-1.954-0.771-2.727-1.202c-0.772-0.43-1.453-0.828-2.039-1.202 + c-0.588-0.371-1.209-0.559-1.869-0.559c-0.659,0-1.201,0.132-1.63,0.387c-0.43,0.259-0.802,0.632-1.117,1.116l-2.447,4.037 + c0.858,0.771,1.853,1.489,2.984,2.146c1.131,0.659,2.361,1.232,3.692,1.716c1.331,0.49,2.719,0.866,4.164,1.141 + c1.445,0.271,2.927,0.406,4.444,0.406c2.833,0,5.345-0.363,7.534-1.095c2.19-0.729,4.029-1.745,5.517-3.047 + s2.619-2.849,3.392-4.637s1.159-3.743,1.159-5.863c0-1.771-0.308-3.289-0.923-4.55 + C180.539,271.898,179.723,270.817,178.707,269.916z"/> + <path fill="#F97E2F" d="M271.332,251.584c-1.245-1.474-2.798-2.619-4.658-3.437c-1.86-0.815-3.993-1.222-6.397-1.222 + c-2.775,0-5.195,0.501-7.256,1.504c-2.061,1-3.95,2.315-5.667,3.948v-24.515h-10.604v63.799h10.604v-31.856 + c1.431-1.431,2.947-2.563,4.551-3.392c1.603-0.831,3.321-1.247,5.152-1.247c2.491,0,4.358,0.739,5.603,2.213 + c1.245,1.474,1.869,3.556,1.869,6.245v28.037h10.603v-28.037c0-2.461-0.321-4.715-0.965-6.762 + C273.521,254.817,272.577,253.058,271.332,251.584z"/> + <path fill="#F97E2F" d="M315.788,251.584c-1.4-1.503-3.111-2.679-5.129-3.521c-2.02-0.844-4.316-1.267-6.891-1.267 + c-7.155,0-13.268,2.315-18.333,6.955l1.931,3.392c0.315,0.543,0.732,1.003,1.246,1.374c0.516,0.371,1.131,0.557,1.846,0.557 + c0.859,0,1.646-0.199,2.361-0.6c0.716-0.401,1.497-0.853,2.341-1.353c0.842-0.501,1.839-0.952,2.983-1.354 + c1.146-0.4,2.576-0.602,4.293-0.602c2.376,0,4.187,0.715,5.432,2.143c1.245,1.426,1.866,3.629,1.866,6.598v2.595 + c-5.008,0-9.2,0.431-12.578,1.291c-3.378,0.863-6.084,1.947-8.114,3.255c-2.033,1.307-3.485,2.77-4.358,4.392 + c-0.874,1.624-1.308,3.268-1.308,4.933c0,1.981,0.313,3.719,0.943,5.215c0.63,1.492,1.509,2.74,2.64,3.746s2.482,1.762,4.058,2.262 + c1.573,0.503,3.291,0.753,5.152,0.753c1.573,0,3.004-0.129,4.293-0.385c1.288-0.258,2.505-0.646,3.649-1.162 + c1.146-0.514,2.253-1.15,3.326-1.909c1.074-0.758,2.169-1.638,3.285-2.641l0.945,3.136c0.285,0.914,0.714,1.522,1.288,1.823 + c0.572,0.301,1.358,0.452,2.36,0.452h4.766V263.84c0-2.49-0.364-4.779-1.093-6.869C318.256,254.882,317.19,253.085,315.788,251.584 + z M309.734,280.359c-0.771,0.791-1.538,1.474-2.297,2.049c-0.758,0.578-1.544,1.065-2.359,1.461 + c-0.816,0.393-1.683,0.688-2.599,0.885c-0.915,0.196-1.919,0.299-3.005,0.299c-1.775,0-3.214-0.404-4.314-1.214 + c-1.103-0.807-1.653-2.146-1.653-4.021c0-0.952,0.264-1.828,0.795-2.638c0.528-0.808,1.424-1.512,2.683-2.12 + c1.26-0.604,2.926-1.103,5.002-1.489c2.075-0.39,4.658-0.584,7.748-0.584V280.359z"/> + <path fill="#F97E2F" d="M356.167,269.916c-1.017-0.9-2.167-1.646-3.456-2.232c-1.288-0.586-2.604-1.107-3.949-1.567 + c-1.346-0.455-2.661-0.88-3.949-1.267c-1.288-0.385-2.442-0.82-3.457-1.308c-1.017-0.489-1.833-1.052-2.447-1.696 + c-0.616-0.646-0.923-1.439-0.923-2.383c0-1.432,0.602-2.59,1.804-3.478s2.847-1.332,4.937-1.332c1.346,0,2.512,0.143,3.5,0.431 + c0.986,0.285,1.866,0.607,2.641,0.966c0.772,0.357,1.452,0.681,2.039,0.965c0.586,0.288,1.138,0.431,1.652,0.431 + c0.485,0,0.886-0.094,1.202-0.279c0.313-0.188,0.614-0.509,0.902-0.969l2.403-3.818c-1.661-1.633-3.734-2.948-6.225-3.948 + c-2.491-1.003-5.253-1.504-8.286-1.504c-2.721,0-5.117,0.363-7.191,1.095c-2.077,0.729-3.808,1.702-5.195,2.918 + c-1.389,1.219-2.44,2.642-3.155,4.271c-0.716,1.632-1.073,3.351-1.073,5.152c0,1.947,0.307,3.606,0.922,4.98 + c0.616,1.375,1.431,2.534,2.447,3.478c1.016,0.944,2.176,1.725,3.478,2.34c1.302,0.616,2.633,1.151,3.994,1.611 + c1.358,0.457,2.689,0.879,3.992,1.267c1.302,0.385,2.461,0.823,3.478,1.307c1.016,0.487,1.831,1.063,2.447,1.719 + c0.614,0.659,0.924,1.504,0.924,2.533c0,0.687-0.137,1.354-0.409,1.999c-0.271,0.64-0.701,1.207-1.288,1.694 + c-0.586,0.486-1.331,0.879-2.231,1.181c-0.901,0.298-1.982,0.449-3.242,0.449c-1.604,0-2.928-0.187-3.971-0.558 + c-1.047-0.371-1.953-0.771-2.728-1.202c-0.771-0.43-1.452-0.828-2.039-1.202c-0.586-0.371-1.21-0.559-1.867-0.559 + s-1.202,0.132-1.631,0.387c-0.431,0.259-0.802,0.632-1.116,1.116l-2.447,4.037c0.857,0.771,1.853,1.489,2.983,2.146 + c1.131,0.659,2.361,1.232,3.691,1.716c1.331,0.49,2.719,0.866,4.166,1.141c1.444,0.271,2.926,0.406,4.442,0.406 + c2.835,0,5.346-0.363,7.535-1.095c2.19-0.729,4.028-1.745,5.517-3.047c1.487-1.302,2.62-2.849,3.392-4.637 + c0.774-1.788,1.16-3.743,1.16-5.863c0-1.771-0.308-3.289-0.924-4.55C357.999,271.898,357.183,270.817,356.167,269.916z"/> + <path fill="#F97E2F" d="M392.768,268.437c-0.46-0.573-0.989-1.076-1.589-1.504c0.6-0.371,1.159-0.81,1.674-1.31 + s1.016-1.052,1.502-1.654l13.697-16.356h-9.703c-0.888,0-1.604,0.164-2.146,0.492c-0.545,0.33-1.06,0.782-1.546,1.355 + l-10.949,13.521c-0.457,0.544-0.886,0.918-1.287,1.116c-0.401,0.202-0.96,0.302-1.675,0.302h-1.975v-36.536h-10.604v63.799h10.604 + v-20.179h2.404c0.858,0,1.502,0.1,1.932,0.298c0.429,0.202,0.859,0.633,1.288,1.291l11.205,16.699 + c0.459,0.688,0.974,1.175,1.547,1.46c0.572,0.288,1.271,0.431,2.103,0.431h9.574l-14.683-21.381 + C393.683,269.623,393.224,269.006,392.768,268.437z"/> + <path fill="#F97E2F" d="M444.717,252.141c-1.689-1.702-3.701-2.998-6.032-3.886c-2.335-0.885-4.889-1.329-7.664-1.329 + c-3.292,0-6.247,0.573-8.865,1.716c-2.62,1.146-4.839,2.698-6.655,4.658c-1.819,1.964-3.214,4.266-4.186,6.912 + c-0.974,2.649-1.461,5.473-1.461,8.479c0,3.865,0.559,7.265,1.676,10.198c1.116,2.932,2.646,5.396,4.594,7.383 + c1.945,1.99,4.235,3.493,6.868,4.507c2.633,1.017,5.481,1.525,8.545,1.525c1.545,0,3.141-0.113,4.787-0.342 + c1.645-0.231,3.262-0.624,4.852-1.184c1.588-0.557,3.111-1.302,4.572-2.229c1.46-0.93,2.775-2.084,3.95-3.455l-3.093-3.868 + c-0.229-0.312-0.5-0.557-0.814-0.729c-0.316-0.172-0.688-0.258-1.116-0.258c-0.659,0-1.34,0.201-2.04,0.603 + c-0.702,0.4-1.519,0.844-2.446,1.331c-0.932,0.486-2.02,0.931-3.265,1.331s-2.726,0.6-4.443,0.6c-3.492,0-6.297-1.057-8.415-3.176 + c-2.118-2.117-3.335-5.438-3.649-9.962h27.22c0.486,0,0.888-0.064,1.203-0.193c0.313-0.13,0.563-0.342,0.751-0.644 + c0.187-0.301,0.315-0.715,0.386-1.245c0.072-0.529,0.108-1.193,0.108-1.995c0-3.179-0.473-6.003-1.418-8.479 + C447.721,255.933,446.406,253.846,444.717,252.141z M420.63,264.572c0.487-3.206,1.604-5.683,3.349-7.428 + c1.745-1.746,4.166-2.62,7.256-2.62c1.573,0,2.948,0.267,4.123,0.794c1.173,0.529,2.146,1.253,2.918,2.17 + c0.773,0.914,1.345,1.979,1.719,3.198c0.371,1.215,0.558,2.512,0.558,3.886H420.63z"/> + <rect x="459.399" y="227.864" fill="#F97E2F" width="10.604" height="63.799"/> + <rect x="482.667" y="227.864" fill="#F97E2F" width="10.604" height="63.799"/> +</g> +</svg> diff --git a/third_party/bazel/rules_haskell/netlify.toml b/third_party/bazel/rules_haskell/netlify.toml new file mode 100644 index 000000000000..88aff2054956 --- /dev/null +++ b/third_party/bazel/rules_haskell/netlify.toml @@ -0,0 +1,3 @@ +[build] +command = ".netlify/install.sh && .netlify/build.sh" +publish = "public" diff --git a/third_party/bazel/rules_haskell/nixpkgs/BUILD.bazel b/third_party/bazel/rules_haskell/nixpkgs/BUILD.bazel new file mode 100644 index 000000000000..e69de29bb2d1 --- /dev/null +++ b/third_party/bazel/rules_haskell/nixpkgs/BUILD.bazel diff --git a/third_party/bazel/rules_haskell/nixpkgs/NOTUSED b/third_party/bazel/rules_haskell/nixpkgs/NOTUSED new file mode 100644 index 000000000000..e69de29bb2d1 --- /dev/null +++ b/third_party/bazel/rules_haskell/nixpkgs/NOTUSED diff --git a/third_party/bazel/rules_haskell/nixpkgs/cc-toolchain.nix b/third_party/bazel/rules_haskell/nixpkgs/cc-toolchain.nix new file mode 100644 index 000000000000..1795dc55b71b --- /dev/null +++ b/third_party/bazel/rules_haskell/nixpkgs/cc-toolchain.nix @@ -0,0 +1,36 @@ +with import ./. {}; +with darwin.apple_sdk.frameworks; + +# XXX On Darwin, workaround +# https://github.com/NixOS/nixpkgs/issues/42059. See also +# https://github.com/NixOS/nixpkgs/pull/41589. +let cc = runCommand "cc-wrapper-bazel" { + buildInputs = [ pkgs.stdenv.cc makeWrapper ]; + } + '' + mkdir -p $out/bin + + # Copy the content of pkgs.stdenv.cc + for i in ${pkgs.stdenv.cc}/bin/* + do + ln -sf $i $out/bin + done + + # Override clang + rm $out/bin/clang + + makeWrapper ${pkgs.stdenv.cc}/bin/clang $out/bin/clang \ + --add-flags "-isystem ${llvmPackages.libcxx}/include/c++/v1 \ + -F${CoreFoundation}/Library/Frameworks \ + -F${CoreServices}/Library/Frameworks \ + -F${Security}/Library/Frameworks \ + -F${Foundation}/Library/Frameworks \ + -L${libcxx}/lib \ + -L${darwin.libobjc}/lib" + ''; + stdenv = if pkgs.stdenv.isDarwin then overrideCC pkgs.stdenv cc else pkgs.stdenv; +in +buildEnv { + name = "bazel-cc-toolchain"; + paths = [ stdenv.cc ] ++ (if stdenv.isDarwin then [ ] else [ binutils ]); +} diff --git a/third_party/bazel/rules_haskell/nixpkgs/default.nix b/third_party/bazel/rules_haskell/nixpkgs/default.nix new file mode 100644 index 000000000000..f56f04a9935b --- /dev/null +++ b/third_party/bazel/rules_haskell/nixpkgs/default.nix @@ -0,0 +1,6 @@ +import (fetchTarball { + # Nixpkgs checkout from 2019-01-30. + + url = https://github.com/NixOS/nixpkgs/archive/2e2ab461b76ec2c586ab126acc53f53bce49cb94.tar.gz; + sha256 = "17gicjn4cafpajczv49czy5r61w16kplkbz6r8hqn5rkvp4i5i9b"; +}) diff --git a/third_party/bazel/rules_haskell/protobuf/BUILD.bazel b/third_party/bazel/rules_haskell/protobuf/BUILD.bazel new file mode 100644 index 000000000000..17305e6e3761 --- /dev/null +++ b/third_party/bazel/rules_haskell/protobuf/BUILD.bazel @@ -0,0 +1,4 @@ +toolchain_type( + name = "toolchain", + visibility = ["//visibility:public"], +) diff --git a/third_party/bazel/rules_haskell/serve-docs.sh b/third_party/bazel/rules_haskell/serve-docs.sh new file mode 100755 index 000000000000..3ae4525fd84f --- /dev/null +++ b/third_party/bazel/rules_haskell/serve-docs.sh @@ -0,0 +1,28 @@ +#!/bin/sh +# +# Usage: +# +# ./serve-docs.sh [PORT_NUMBER] + +set -e + +SCRATCH=$(mktemp -d --tmpdir rules_haskell-docs.XXXX) +PORT=${1:-8000} + +function finish { + echo Deleting $SCRATCH ... + rm -rf "$scratch" +} + +trap finish EXIT + +bazel build //docs:api_html +mkdir $SCRATCH/api +unzip -d $SCRATCH/api bazel-bin/docs/api_html-skydoc.zip + +bazel build //docs:guide_html +mkdir $SCRATCH/guide +unzip -d $SCRATCH/guide bazel-genfiles/docs/guide_html.zip + +cd $SCRATCH +python -m SimpleHTTPServer $PORT diff --git a/third_party/bazel/rules_haskell/shell.nix b/third_party/bazel/rules_haskell/shell.nix new file mode 100644 index 000000000000..35fecb07126a --- /dev/null +++ b/third_party/bazel/rules_haskell/shell.nix @@ -0,0 +1,51 @@ +{ pkgs ? import ./nixpkgs {}, docTools ? true }: + +with pkgs; + +mkShell { + # XXX: hack for macosX, this flags disable bazel usage of xcode + # Note: this is set even for linux so any regression introduced by this flag + # will be catched earlier + # See: https://github.com/bazelbuild/bazel/issues/4231 + BAZEL_USE_CPP_ONLY_TOOLCHAIN=1; + + buildInputs = [ + go + nix + which + perl + python + bazel + # Needed for @com_github_golang_protobuf, itself needed by buildifier. + git + # Needed to get correct locale for tests with encoding + glibcLocales + # to check haddock outputs + linkchecker + # to avoid CA certificate failures on MacOS CI + cacert + # Needed for debug/linking_utils + binutils + ] ++ lib.optionals docTools [graphviz python36Packages.sphinx zip unzip]; + + shellHook = '' + # Add nix config flags to .bazelrc.local. + # + BAZELRC_LOCAL=".bazelrc.local" + if [ ! -e "$BAZELRC_LOCAL" ] + then + ARCH="" + if [ "$(uname)" == "Darwin" ]; then + ARCH="darwin" + elif [ "$(expr substr $(uname -s) 1 5)" == "Linux" ]; then + ARCH="linux" + fi + echo "[!] It looks like you are using a ''${ARCH} nix-based system. In order to build this project, you probably need to add the two following host_platform entries to your .bazelrc.local file." + echo "" + echo "test --host_platform=@io_tweag_rules_haskell//haskell/platforms:''${ARCH}_x86_64_nixpkgs" + fi + + # source bazel bash completion + source ${pkgs.bazel}/share/bash-completion/completions/bazel + ''; +} diff --git a/third_party/bazel/rules_haskell/start b/third_party/bazel/rules_haskell/start new file mode 100755 index 000000000000..24f300cb6ec9 --- /dev/null +++ b/third_party/bazel/rules_haskell/start @@ -0,0 +1,124 @@ +#!/bin/sh + +MIN_BAZEL_MAJOR=0 +MIN_BAZEL_MINOR=24 + +set -e + +check_files_dont_exist () { + if [ -e WORKSPACE ] || [ -e BUILD ] || [ -e BazelExample.hs ] + then + echo "Current directory already has WORKSPACE and/or BUILD and/or BazelExample.hs files." >/dev/stderr + exit 1 + fi +} + +check_bazel_version () { + local actual_raw=$(bazel version | egrep '^Build label:' | egrep -o '[0-9.]+') + + IFS=. read actual_major actual_minor actual_patch <<EOF +$actual_raw +EOF + + local expected=$MIN_BAZEL_MAJOR.$MIN_BAZEL_MINOR.0 + local cmp=$expected'\n'$actual + + if ! ( [ "$actual_major" -gt "$MIN_BAZEL_MAJOR" ] || ( + [ "$actual_major" -eq "$MIN_BAZEL_MAJOR" ] && + [ "$actual_minor" -ge "$MIN_BAZEL_MINOR" ] ) ) + then + echo "Need at least Bazel v${expected}. v${actual_raw} detected." >/dev/stderr + exit 1 + fi +} + +check_files_dont_exist +check_bazel_version + +cat > WORKSPACE <<"EOF" +# Give your project a name. :) +workspace(name = "YOUR_PROJECT_NAME_HERE") + +# Load the repository rule to download an http archive. +load( + "@bazel_tools//tools/build_defs/repo:http.bzl", + "http_archive" +) + +# Download `rules_haskell`. +# and make it accessible `@io_tweag_rules_haskell`. +http_archive( + name = "io_tweag_rules_haskell", + strip_prefix = "rules_haskell-0.8", + urls = ["https://github.com/tweag/rules_haskell/archive/v0.8.tar.gz"], + sha256 = "431d492a8ee6a110cdf42496181c9d27225dfb997379e64a148eb8e69f272ab7", +) + +load( + "@io_tweag_rules_haskell//haskell:repositories.bzl", + "haskell_repositories" +) + +# `haskell_repositories()` sets up all bazel dependencies +# required by `rules_haskell`. +haskell_repositories() + +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_register_ghc_bindists", +) + +# Registers a haskell toolchain with a GHC binary +# downloaded from haskell.org. +haskell_register_ghc_bindists(version = "8.6.4") +EOF + +cat > BUILD.bazel <<"EOF" +# Set all targetโs visibility in this package to "public". +package(default_visibility = ["//visibility:public"]) + +# Load `rules_haskell` rules. +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_toolchain_library", + "haskell_library", + "haskell_binary", +) + +# `haskell_toolchain_library` can access builtin GHC packages +# and assign them a bazel target name, so that they +# can be referenced as dependencies. +haskell_toolchain_library(name = "base") + +# You can add your own libraries with `haskell_library`. +# haskell_library( +# name = "MY_LIBRARY_NAME", +# src_strip_prefix = "src", +# srcs = glob(['src/**/*.hs']), +# deps = [ +# "base_pkg" +# ], +# ) + +# An example binary using the Prelude module from the +# GHC base package, to print the hello world. +haskell_binary( + name = "example", + srcs = [":Example.hs"], + deps = [":base"], +) +EOF + +cat > Example.hs <<"EOF" +module Main where + +import Prelude (putStrLn) + +main = putStrLn "Hello from rules_haskell!" +EOF + +cat <<"EOF" +WORKSPACE and initial BUILD files created. To run Bazel and build the example: + + $ bazel run //:example +EOF diff --git a/third_party/bazel/rules_haskell/tests/BUILD.bazel b/third_party/bazel/rules_haskell/tests/BUILD.bazel new file mode 100644 index 000000000000..276db5546332 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/BUILD.bazel @@ -0,0 +1,322 @@ +load(":inline_tests.bzl", "sh_inline_test") +load("@bazel_tools//tools/build_rules:test_rules.bzl", "rule_test") +load("//tests:rule_test_exe.bzl", "rule_test_exe") +load( + "@io_tweag_rules_haskell//haskell:c2hs.bzl", + "c2hs_toolchain", +) +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_binary", + "haskell_doctest_toolchain", + "haskell_proto_toolchain", + "haskell_test", + "haskell_toolchain", +) +load( + "//:constants.bzl", + "test_ghc_version", +) + +package(default_testonly = 1) + +haskell_doctest_toolchain( + name = "doctest-toolchain", + doctest = "@hackage-doctest//:bin", + tags = ["requires_doctest"], +) + +# This toolchain is morally testonly. However, that would break our +# tests of haskell_library_rules: aspects of non-testonly +# proto_library rules (from com_google_protobuf) can't themselves be +# testonly. + +haskell_proto_toolchain( + name = "protobuf-toolchain", + testonly = 0, + plugin = "@hackage-proto-lens-protoc//:bin/proto-lens-protoc", + protoc = "@com_google_protobuf//:protoc", + tags = ["requires_hackage"], + deps = [ + "//tests/hackage:base", + "//tests/hackage:bytestring", + "//tests/hackage:containers", + "//tests/hackage:deepseq", + "//tests/hackage:mtl", + "//tests/hackage:text", + "@hackage//:data-default-class", + "@hackage//:lens-family", + "@hackage//:lens-family-core", + "@hackage//:lens-labels", + "@hackage//:proto-lens", + ], +) + +c2hs_toolchain( + name = "c2hs-toolchain", + c2hs = "@hackage-c2hs//:bin", + tags = ["requires_c2hs"], +) + +rule_test_exe( + name = "test-binary-simple", + size = "small", + generates = ["binary-simple"], + rule = "//tests/binary-simple", +) + +rule_test_exe( + name = "test-binary-custom-main", + size = "small", + generates = ["binary-custom-main"], + rule = "//tests/binary-custom-main", +) + +rule_test( + name = "test-binary-with-lib", + size = "small", + generates = ["binary-with-lib"], + rule = "//tests/binary-with-lib", +) + +rule_test( + name = "test-binary-with-prebuilt", + size = "small", + generates = ["binary-with-prebuilt"], + rule = "//tests/binary-with-prebuilt", + tags = ["requires_hackage"], +) + +rule_test( + name = "test-binary-with-main", + size = "small", + generates = ["binary-with-main"], + rule = "//tests/binary-with-main", +) + +rule_test( + name = "test-binary-with-sysdeps", + size = "small", + generates = ["binary-with-sysdeps"], + rule = "//tests/binary-with-sysdeps", + tags = ["requires_zlib"], +) + +sh_test( + name = "test-binary-with-data", + size = "small", + srcs = ["//tests/binary-with-data"], + args = ["$(location //tests/binary-with-data:bin1)"], + data = ["//tests/binary-with-data:bin1"], + tags = ["requires_hackage"], +) + +rule_test( + name = "test-library-deps", + size = "small", + generates = select({ + "@bazel_tools//src/conditions:darwin": [ + "libHStestsZSlibrary-depsZSlibrary-deps-ghc{}.dylib".format(test_ghc_version), + "libHStestsZSlibrary-depsZSlibrary-deps.a", + ], + "@bazel_tools//src/conditions:windows": [ + "libHStestsZSlibrary-depsZSlibrary-deps-ghc{}.dll".format(test_ghc_version), + "libHStestsZSlibrary-depsZSlibrary-deps.a", + ], + "//conditions:default": [ + "libHStestsZSlibrary-depsZSlibrary-deps-ghc{}.so".format(test_ghc_version), + "libHStestsZSlibrary-depsZSlibrary-deps.a", + ], + }), + rule = "//tests/library-deps", +) + +rule_test( + name = "test-hsc", + size = "small", + generates = ["hsc"], + rule = "//tests/hsc", +) + +rule_test( + name = "test-haddock", + size = "small", + generates = [ + "haddock/index", + "haddock/testsZShaddockZShaddock-lib-a", + "haddock/testsZShaddockZShaddock-lib-b", + "haddock/testsZShaddockZShaddock-lib-deep", + ], + rule = "//tests/haddock", + tags = ["requires_hackage"], +) + +rule_test( + name = "test-haskell_lint-library", + size = "small", + generates = [ + "lint-log-lib-b", + ], + rule = "//tests/haskell_lint:lint-lib-b", +) + +rule_test( + name = "test-haskell_lint-binary", + size = "small", + generates = [ + "lint-log-bin", + ], + rule = "//tests/haskell_lint:lint-bin", +) + +rule_test( + name = "test-haskell_doctest", + size = "small", + generates = [ + "doctest-log-doctest-lib-lib-b", + ], + rule = "//tests/haskell_doctest:doctest-lib", + tags = ["requires_doctest"], +) + +rule_test( + name = "test-haskell_test", + size = "small", + generates = ["haskell_test"], + rule = "//tests/haskell_test:haskell_test", +) + +rule_test( + name = "test-java_classpath", + size = "small", + generates = ["java_classpath"], + rule = "//tests/java_classpath", +) + +rule_test( + name = "test-cc_haskell_import-cc-link", + size = "small", + generates = ["cc-bin"], + rule = "//tests/cc_haskell_import:cc-bin", + tags = ["requires_threaded_rts"], +) + +sh_test( + name = "test-cc_haskell_import_python", + size = "small", + srcs = ["scripts/exec.sh"], + args = ["tests/cc_haskell_import/python_add_one"], + data = [ + "//tests/cc_haskell_import:python_add_one", + "@bazel_tools//tools/bash/runfiles", + ], + tags = ["requires_threaded_rts"], +) + +sh_inline_test( + name = "test-haskell_binary-with-link-flags", + size = "small", + args = ["$(location //tests/binary-with-link-flags:binary-with-link-flags)"], + data = ["//tests/binary-with-link-flags"], + script = """\ +set -e + +# Fails if executable was linked without -threaded flag. +$1 +RTS -N +""", +) + +rule_test( + name = "test-lhs", + size = "small", + generates = ["lhs-bin"], + rule = "//tests/lhs:lhs-bin", +) + +rule_test( + name = "test-hs-boot", + size = "small", + generates = ["hs-boot"], + rule = "//tests/hs-boot:hs-boot", +) + +rule_test( + name = "test-textual-hdrs", + size = "small", + generates = ["textual-hdrs"], + rule = "//tests/textual-hdrs:textual-hdrs", +) + +rule_test( + name = "test-two-libs", + size = "small", + generates = ["two-libs"], + rule = "//tests/two-libs:two-libs", +) + +genrule( + name = "run-bin-with-lib", + outs = ["dummy"], + cmd = """sh -c ' + set -e + $(location //tests/binary-with-lib:binary-with-lib) + touch $(location dummy) +'""", + tools = ["//tests/binary-with-lib"], +) + +rule_test( + name = "test-run-bin-with-lib", + size = "small", + generates = ["dummy"], + rule = "//tests:run-bin-with-lib", +) + +genrule( + name = "run-bin-with-lib-dynamic", + outs = ["dyn-dummy"], + cmd = """sh -c ' + set -e + $(location //tests/binary-with-lib-dynamic:binary-with-lib-dynamic) + touch $(location dyn-dummy) +'""", + tools = ["//tests/binary-with-lib-dynamic"], +) + +rule_test( + name = "test-run-bin-with-lib-dynamic", + size = "small", + generates = ["dyn-dummy"], + rule = "//tests:run-bin-with-lib-dynamic", +) + +genrule( + name = "run-bin-with-c-lib", + outs = ["c-dummy"], + cmd = """sh -c ' + set -e + $(location //tests/c-compiles) + touch $(location c-dummy) +'""", + tools = ["//tests/c-compiles"], +) + +rule_test( + name = "test-run-bin-with-c-lib", + size = "small", + generates = ["c-dummy"], + rule = "//tests:run-bin-with-c-lib", +) + +# This is the test runner +haskell_binary( + name = "run-tests", + srcs = ["RunTests.hs"], + tags = ["requires_hackage"], + deps = [ + "//tests/hackage:base", + "//tests/hackage:process", + "@hackage//:hspec", + "@hackage//:hspec-core", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/RunTests.hs b/third_party/bazel/rules_haskell/tests/RunTests.hs new file mode 100644 index 000000000000..b6218bbcefc2 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/RunTests.hs @@ -0,0 +1,155 @@ +{-# OPTIONS -Wall #-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE QuasiQuotes #-} + +import Data.Foldable (for_) +import Data.List (isInfixOf, sort) +import System.Exit (ExitCode(..)) + +import qualified System.Process as Process +import Test.Hspec.Core.Spec (SpecM) +import Test.Hspec (hspec, it, describe, runIO, shouldSatisfy, expectationFailure) + +main :: IO () +main = hspec $ do + it "bazel lint" $ do + assertSuccess (bazel ["run", "//:buildifier"]) + + it "bazel test" $ do + assertSuccess (bazel ["test", "//...", "--build_tests_only"]) + + it "haddock links" $ do + -- Test haddock links + -- All haddock tests are stored inside //tests/haddock + -- Temporaries files appears inside /doc-.... outputs and are ignored + + -- the copy / chmod is here to workaround the fact that + -- linkchecker is dropping privileges to "nobody" user if called + -- from root, which is the case on CI. + assertSuccess (safeShell + [ "bazel build --config=ci //tests/haddock/..." + , "pwd=$(pwd)" + , "cd $(mktemp -d)" + , "cp -r $pwd/bazel-ci-bin/tests/haddock ." + , "chmod -R o+r ." + , "linkchecker . --ignore-url=/doc-" + ]) + + it "bazel test prof" $ do + assertSuccess (bazel ["test", "-c", "dbg", "//...", "--build_tests_only"]) + + describe "repl" $ do + it "for libraries" $ do + assertSuccess (bazel ["run", "//tests/repl-targets:hs-lib@repl", "--", "-ignore-dot-ghci", "-e", "show (foo 10) ++ bar ++ baz ++ gen"]) + assertSuccess (bazel ["run", "//tests/repl-targets:hs-lib-bad@repl", "--", "-ignore-dot-ghci", "-e", "1 + 2"]) + + it "for binaries" $ do + assertSuccess (bazel ["run", "//tests/repl-targets:hs-bin@repl", "--", "-ignore-dot-ghci", "-e", ":main"]) + + assertSuccess (bazel ["run", "//tests/binary-indirect-cbits:binary-indirect-cbits@repl", "--", "-ignore-dot-ghci", "-e", ":main"]) + + -- Test `compiler_flags` from toolchain and rule for REPL + it "compiler flags" $ do + assertSuccess (bazel ["run", "//tests/repl-flags:compiler_flags@repl", "--", "-ignore-dot-ghci", "-e", ":main"]) + + -- Test `repl_ghci_args` from toolchain and rule for REPL + it "repl flags" $ do + assertSuccess (bazel ["run", "//tests/repl-flags:repl_flags@repl", "--", "-ignore-dot-ghci", "-e", "foo"]) + + describe "multi_repl" $ do + it "loads transitive library dependencies" $ do + let p' (stdout, _stderr) = lines stdout == ["tests/multi_repl/bc/src/BC/C.hs"] + outputSatisfy p' (bazel ["run", "//tests/multi_repl:c_only_repl", "--", "-ignore-dot-ghci", "-e", ":show targets"]) + it "loads transitive source dependencies" $ do + let p' (stdout, _stderr) = sort (lines stdout) == ["tests/multi_repl/a/src/A/A.hs","tests/multi_repl/bc/src/BC/B.hs","tests/multi_repl/bc/src/BC/C.hs"] + outputSatisfy p' (bazel ["run", "//tests/multi_repl:c_multi_repl", "--", "-ignore-dot-ghci", "-e", ":show targets"]) + + it "startup script" $ do + assertSuccess (safeShell ["./tests/run-start-script.sh"]) + + describe "failures" $ do + all_failure_tests <- bazelQuery "kind(rule, //tests/failures/...) intersect attr('tags', 'manual', //tests/failures/...)" + + for_ all_failure_tests $ \test -> do + it test $ do + assertFailure (bazel ["build", "test"]) + + -- Test that the repl still works if we shadow some Prelude functions + it "repl name shadowing" $ do + let p (stdout, stderr) = not $ any ("error" `isInfixOf`) [stdout, stderr] + outputSatisfy p (bazel ["run", "//tests/repl-name-conflicts:lib@repl", "--", "-ignore-dot-ghci", "-e", "stdin"]) + + it "bazel test examples" $ do + assertSuccess (bazel ["test", "@io_tweag_rules_haskell_examples//..."]) + + it "bazel test tutorial" $ do + assertSuccess (bazel ["test", "@io_tweag_rules_haskell_tutorial//..."]) + +-- * Bazel commands + +-- | Returns a bazel command line suitable for CI +-- This should be called with the action as first item of the list. e.g 'bazel ["build", "//..."]'. +bazel :: [String] -> Process.CreateProcess +-- Note: --config=ci is intercalated between the action and the list +-- of arguments. It should appears after the action, but before any +-- @--@ following argument. +bazel (command:args) = Process.proc "bazel" (command:"--config=ci":args) +bazel [] = Process.proc "bazel" [] + +-- | Runs a bazel query and return the list of matching targets +bazelQuery :: String -> SpecM a [String] +bazelQuery q = lines <$> runIO (Process.readProcess "bazel" ["query", q] "") + +-- * Action helpers + +-- | Ensure that @(stdout, stderr)@ of the command satisfies a predicate +outputSatisfy + :: ((String, String) -> Bool) + -> Process.CreateProcess + -> IO () +outputSatisfy predicate cmd = do + (exitCode, stdout, stderr) <- Process.readCreateProcessWithExitCode cmd "" + + case exitCode of + ExitSuccess -> (stdout, stderr) `shouldSatisfy` predicate + ExitFailure _ -> expectationFailure (formatOutput exitCode stdout stderr) + +-- | The command must success +assertSuccess :: Process.CreateProcess -> IO () +assertSuccess = outputSatisfy (const True) + +-- | The command must fail +assertFailure :: Process.CreateProcess -> IO () +assertFailure cmd = do + (exitCode, stdout, stderr) <- Process.readCreateProcessWithExitCode cmd "" + + case exitCode of + ExitFailure _ -> pure () + ExitSuccess -> expectationFailure ("Unexpected success of a failure test with output:\n" ++ formatOutput exitCode stdout stderr) + +-- | Execute in a sub shell the list of command +-- This will fail if any of the command in the list fail +safeShell :: [String] -> Process.CreateProcess +safeShell l = Process.shell (unlines ("set -e":l)) + +-- * Formatting helpers + +formatOutput :: ExitCode -> String -> String -> String +formatOutput exitcode stdout stderr = + let + header = replicate 20 '-' + headerLarge = replicate 20 '=' + + in unlines [ + headerLarge + , "Exit Code: " <> show exitcode + , headerLarge + , "Standard Output" + , header + , stdout + , headerLarge + , "Error Output" + , header + , stderr + , header] diff --git a/third_party/bazel/rules_haskell/tests/binary-custom-main/BUILD.bazel b/third_party/bazel/rules_haskell/tests/binary-custom-main/BUILD.bazel new file mode 100644 index 000000000000..c749b85eaac4 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-custom-main/BUILD.bazel @@ -0,0 +1,17 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_test", +) + +package(default_testonly = 1) + +haskell_test( + name = "binary-custom-main", + srcs = ["Main.hs"], + expected_covered_expressions_percentage = 50, + tags = [ + "coverage-compatible", + ], + visibility = ["//visibility:public"], + deps = ["//tests/hackage:base"], +) diff --git a/third_party/bazel/rules_haskell/tests/binary-custom-main/Main.hs b/third_party/bazel/rules_haskell/tests/binary-custom-main/Main.hs new file mode 100644 index 000000000000..c8dbf9fbdb9e --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-custom-main/Main.hs @@ -0,0 +1,4 @@ +module Main (main) where + +main :: IO () +main = return () diff --git a/third_party/bazel/rules_haskell/tests/binary-dynamic/BUILD.bazel b/third_party/bazel/rules_haskell/tests/binary-dynamic/BUILD.bazel new file mode 100644 index 000000000000..765963f19fe0 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-dynamic/BUILD.bazel @@ -0,0 +1,14 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_test", +) + +package(default_testonly = 1) + +haskell_test( + name = "binary-dynamic", + srcs = ["Main.hs"], + linkstatic = False, + visibility = ["//visibility:public"], + deps = ["//tests/hackage:base"], +) diff --git a/third_party/bazel/rules_haskell/tests/binary-dynamic/Main.hs b/third_party/bazel/rules_haskell/tests/binary-dynamic/Main.hs new file mode 100644 index 000000000000..2048dbdecd9a --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-dynamic/Main.hs @@ -0,0 +1,3 @@ +module Main where + +main = putStrLn "hello world" diff --git a/third_party/bazel/rules_haskell/tests/binary-exe-path/BUILD.bazel b/third_party/bazel/rules_haskell/tests/binary-exe-path/BUILD.bazel new file mode 100644 index 000000000000..0cb617a50877 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-exe-path/BUILD.bazel @@ -0,0 +1,13 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_test", +) + +package(default_testonly = 1) + +haskell_test( + name = "binary-exe-path", + srcs = ["Main.hs"], + visibility = ["//visibility:public"], + deps = ["//tests/hackage:base"], +) diff --git a/third_party/bazel/rules_haskell/tests/binary-exe-path/Main.hs b/third_party/bazel/rules_haskell/tests/binary-exe-path/Main.hs new file mode 100644 index 000000000000..6a02bb9fc8ec --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-exe-path/Main.hs @@ -0,0 +1,5 @@ +module Main where + +import System.Environment + +main = getExecutablePath >>= putStrLn diff --git a/third_party/bazel/rules_haskell/tests/binary-indirect-cbits/BUILD.bazel b/third_party/bazel/rules_haskell/tests/binary-indirect-cbits/BUILD.bazel new file mode 100644 index 000000000000..6668f230e508 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-indirect-cbits/BUILD.bazel @@ -0,0 +1,36 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_binary", + "haskell_library", +) + +haskell_binary( + name = "binary-indirect-cbits", + srcs = ["Main.hs"], + linkstatic = False, + visibility = ["//visibility:public"], + deps = [ + "//tests/hackage:base", + "//tests/library-with-cbits", + ], +) + +haskell_binary( + name = "binary-indirect-cbits-partially-static", + srcs = ["Main.hs"], + linkstatic = False, + deps = [ + "//tests/hackage:base", + "//tests/library-with-cbits:library-with-cbits-static", + ], +) + +haskell_binary( + name = "binary-indirect-cbits-fully-static", + srcs = ["Main.hs"], + linkstatic = True, + deps = [ + "//tests/hackage:base", + "//tests/library-with-cbits:library-with-cbits-static", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/binary-indirect-cbits/Main.hs b/third_party/bazel/rules_haskell/tests/binary-indirect-cbits/Main.hs new file mode 100644 index 000000000000..c9d7037e23c2 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-indirect-cbits/Main.hs @@ -0,0 +1,5 @@ +import AddOne + +main :: IO () +main = do + putStrLn $ show $ addOne 2 diff --git a/third_party/bazel/rules_haskell/tests/binary-indirect-cbits/Wrapper.hs b/third_party/bazel/rules_haskell/tests/binary-indirect-cbits/Wrapper.hs new file mode 100644 index 000000000000..00b6be28f405 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-indirect-cbits/Wrapper.hs @@ -0,0 +1,5 @@ +module Wrapper + ( module AddOne + ) where + +import AddOne diff --git a/third_party/bazel/rules_haskell/tests/binary-indirect-cbits/Wrapper2.hs b/third_party/bazel/rules_haskell/tests/binary-indirect-cbits/Wrapper2.hs new file mode 100644 index 000000000000..a39233a84271 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-indirect-cbits/Wrapper2.hs @@ -0,0 +1,9 @@ +module Wrapper2 + ( module AddOne + , addOne2 + ) where + +import AddOne +import qualified Wrapper + +addOne2 = Wrapper.addOne diff --git a/third_party/bazel/rules_haskell/tests/binary-linkstatic-flag/BUILD.bazel b/third_party/bazel/rules_haskell/tests/binary-linkstatic-flag/BUILD.bazel new file mode 100644 index 000000000000..4e8e7cfa6684 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-linkstatic-flag/BUILD.bazel @@ -0,0 +1,118 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", + "haskell_test", +) +load("//tests:inline_tests.bzl", "sh_inline_test") + +# test whether `linkstatic` works as expected +package(default_testonly = 1) + +cc_library( + name = "c-lib", + srcs = ["c-lib.c"], +) + +haskell_library( + name = "HsLib", + srcs = ["HsLib.hs"], + deps = [ + "//tests/hackage:base", + ], +) + +haskell_test( + name = "binary-static", + srcs = ["Main.hs"], + linkstatic = True, + deps = [ + ":HsLib", + ":c-lib", + "//tests/hackage:base", + ], +) + +haskell_test( + name = "binary-dynamic", + srcs = ["Main.hs"], + linkstatic = False, + deps = [ + ":HsLib", + ":c-lib", + "//tests/hackage:base", + ], +) + +config_setting( + name = "debug_build", + values = { + "compilation_mode": "dbg", + }, +) + +# Ensure that linkstatic=True only links to static library targets. +sh_inline_test( + name = "test-binary-static-symbols", + size = "small", + args = [ + "$(rootpath :binary-static)", + ], + data = [ + ":binary-static", + ], + script = """ + set -eo pipefail + binary="$1" + # Symbols are prefixed with underscore on MacOS but not on Linux. + if nm -u "$binary" | grep -q "\<_\?value"; then + echo "C library dependency not linked statically: ${binary}" + exit 1 + fi + if nm -u "$binary" | grep -q HsLib_value_closure; then + echo "Haskell library dependency not linked statically ${binary}" + exit 1 + fi + """, +) + +# Ensure that linkstatic=False only links to dynamic library targets. +sh_inline_test( + name = "test-binary-dynamic-symbols", + size = "small", + args = [ + "$(rootpath :binary-dynamic)", + ] + select({ + ":debug_build": ["dbg"], + "//conditions:default": ["rls"], + }), + data = [ + ":binary-dynamic", + ], + script = """ + set -eo pipefail + binary="$1" + mode="$2" + if [[ $mode = dbg ]]; then + # Skip test in debug builds. Debug mode forces static linking. + exit 0 + fi + # Symbols are prefixed with underscore on MacOS but not on Linux. + if ! nm -u "$binary" | grep -q "\<_\?value"; then + echo "C library dependency not linked dynamically" + exit 1 + fi + if ! nm -u "$binary" | grep -q HsLib_value_closure; then + echo "Haskell library dependency not linked dynamically" + exit 1 + fi + """, +) + +test_suite( + name = "binary-linkstatic-flag", + tests = [ + ":test-binary-dynamic-symbols", + ":test-binary-static-symbols", + ], + visibility = ["//visibility:public"], +) diff --git a/third_party/bazel/rules_haskell/tests/binary-linkstatic-flag/HsLib.hs b/third_party/bazel/rules_haskell/tests/binary-linkstatic-flag/HsLib.hs new file mode 100644 index 000000000000..68271826d7ee --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-linkstatic-flag/HsLib.hs @@ -0,0 +1,4 @@ +module HsLib (value) where + +value :: Int +value = 13 diff --git a/third_party/bazel/rules_haskell/tests/binary-linkstatic-flag/Main.hs b/third_party/bazel/rules_haskell/tests/binary-linkstatic-flag/Main.hs new file mode 100644 index 000000000000..7836c2220277 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-linkstatic-flag/Main.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module Main (main) where + +import qualified HsLib + +foreign import ccall "value" value :: Int + +main = print $ HsLib.value + value diff --git a/third_party/bazel/rules_haskell/tests/binary-linkstatic-flag/c-lib.c b/third_party/bazel/rules_haskell/tests/binary-linkstatic-flag/c-lib.c new file mode 100644 index 000000000000..9a1e526017ec --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-linkstatic-flag/c-lib.c @@ -0,0 +1 @@ +int value() { return 29; } diff --git a/third_party/bazel/rules_haskell/tests/binary-simple/BUILD.bazel b/third_party/bazel/rules_haskell/tests/binary-simple/BUILD.bazel new file mode 100644 index 000000000000..d44d395fb8c7 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-simple/BUILD.bazel @@ -0,0 +1,15 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_test", +) + +package(default_testonly = 1) + +haskell_test( + name = "binary-simple", + srcs = ["Main.hs"], + expected_covered_expressions_percentage = 100, + tags = ["coverage-compatible"], + visibility = ["//visibility:public"], + deps = ["//tests/hackage:base"], +) diff --git a/third_party/bazel/rules_haskell/tests/binary-simple/Main.hs b/third_party/bazel/rules_haskell/tests/binary-simple/Main.hs new file mode 100644 index 000000000000..2048dbdecd9a --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-simple/Main.hs @@ -0,0 +1,3 @@ +module Main where + +main = putStrLn "hello world" diff --git a/third_party/bazel/rules_haskell/tests/binary-with-compiler-flags/BUILD.bazel b/third_party/bazel/rules_haskell/tests/binary-with-compiler-flags/BUILD.bazel new file mode 100644 index 000000000000..727d8447ab4b --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-with-compiler-flags/BUILD.bazel @@ -0,0 +1,18 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_test", +) + +package(default_testonly = 1) + +haskell_test( + name = "binary-with-compiler-flags", + srcs = ["Main.hs"], + # Flags that require -threaded, which we should get from the toolchain's + # compiler_flags. Include spaces to validate proper quoting: + compiler_flags = [ + "-with-rtsopts=-N2 -qg -I0 -n2m -A128m", + "-XLambdaCase", + ], + deps = ["//tests/hackage:base"], +) diff --git a/third_party/bazel/rules_haskell/tests/binary-with-compiler-flags/Main.hs b/third_party/bazel/rules_haskell/tests/binary-with-compiler-flags/Main.hs new file mode 100644 index 000000000000..b95db17f76da --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-with-compiler-flags/Main.hs @@ -0,0 +1,13 @@ +-- Expects to pull -XStandaloneDeriving from the default compiler flags. +module Main (main) where + +data Foo = Foo +deriving instance Show Foo + +-- Expects -XLambdaCase to be passed via the 'compiler_flags' rule attribute. +dummyId :: Foo -> Foo +dummyId = \case + Foo -> Foo + +main :: IO () +main = print $ dummyId Foo diff --git a/third_party/bazel/rules_haskell/tests/binary-with-data/BUILD.bazel b/third_party/bazel/rules_haskell/tests/binary-with-data/BUILD.bazel new file mode 100644 index 000000000000..200498f64018 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-with-data/BUILD.bazel @@ -0,0 +1,31 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_test", +) + +package(default_testonly = 1) + +# XXX: on Windows those tests need `--experimental_enable_runfiles` to succeed +# XXX: see: https://github.com/tweag/rules_haskell/issues/647#issuecomment-459001362 + +haskell_test( + name = "bin1", + srcs = ["bin1.hs"], + # Regular file input: + data = ["bin1-input"], + visibility = ["//visibility:public"], + deps = ["//tests/hackage:base"], +) + +haskell_test( + name = "binary-with-data", + srcs = ["bin2.hs"], + args = ["$(location :bin1)"], + data = [":bin1"], + tags = ["requires_hackage"], + visibility = ["//visibility:public"], + deps = [ + "//tests/hackage:base", + "//tests/hackage:process", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/binary-with-data/bin1-input b/third_party/bazel/rules_haskell/tests/binary-with-data/bin1-input new file mode 100644 index 000000000000..12f00e90b6ef --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-with-data/bin1-input @@ -0,0 +1 @@ +contents diff --git a/third_party/bazel/rules_haskell/tests/binary-with-data/bin1.hs b/third_party/bazel/rules_haskell/tests/binary-with-data/bin1.hs new file mode 100644 index 000000000000..309f6ecd5641 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-with-data/bin1.hs @@ -0,0 +1,9 @@ +module Main where + +import Control.Monad (unless) + +main :: IO () +main = do + contents <- readFile "tests/binary-with-data/bin1-input" + unless (contents == "contents\n") + $ error $ "Incorrect input; got " ++ show contents diff --git a/third_party/bazel/rules_haskell/tests/binary-with-data/bin2.hs b/third_party/bazel/rules_haskell/tests/binary-with-data/bin2.hs new file mode 100644 index 000000000000..31d2404a6a9d --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-with-data/bin2.hs @@ -0,0 +1,8 @@ +module Main where + +import System.Process (callProcess) +import System.Environment (getArgs) + +main = do + [arg] <- getArgs + callProcess arg [] diff --git a/third_party/bazel/rules_haskell/tests/binary-with-import/BUILD.bazel b/third_party/bazel/rules_haskell/tests/binary-with-import/BUILD.bazel new file mode 100644 index 000000000000..3b920d37c41a --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-with-import/BUILD.bazel @@ -0,0 +1,26 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", + "haskell_test", +) + +package(default_testonly = 1) + +haskell_library( + name = "lib", + srcs = ["src/Lib.hs"], + deps = [ + "//tests/hackage:base", + "//tests/hackage:transformers", + ], +) + +haskell_test( + name = "binary-with-import", + srcs = ["Main.hs"], + visibility = ["//visibility:public"], + deps = [ + ":lib", + "//tests/hackage:base", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/binary-with-import/Main.hs b/third_party/bazel/rules_haskell/tests/binary-with-import/Main.hs new file mode 100644 index 000000000000..1bded5e8e55b --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-with-import/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Lib (printValue) + +main :: IO () +main = printValue diff --git a/third_party/bazel/rules_haskell/tests/binary-with-import/src/Lib.hs b/third_party/bazel/rules_haskell/tests/binary-with-import/src/Lib.hs new file mode 100644 index 000000000000..d384e73e6337 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-with-import/src/Lib.hs @@ -0,0 +1,13 @@ +module Lib (printValue) where + +import Control.Monad (void) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT, runExceptT) + +getValue :: Monad m => ExceptT e m Int +getValue = pure 42 + +printValue :: IO () +printValue = void $ runExceptT $ do + value <- getValue + lift $ print value diff --git a/third_party/bazel/rules_haskell/tests/binary-with-indirect-sysdeps/BUILD.bazel b/third_party/bazel/rules_haskell/tests/binary-with-indirect-sysdeps/BUILD.bazel new file mode 100644 index 000000000000..195288882b1a --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-with-indirect-sysdeps/BUILD.bazel @@ -0,0 +1,27 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", + "haskell_test", +) + +package(default_testonly = 1) + +haskell_library( + name = "hs-lib", + srcs = ["HsLib.hs"], + tags = ["requires_zlib"], + deps = [ + "//tests/hackage:base", + "@zlib.dev//:zlib", + ], +) + +haskell_test( + name = "binary-with-indirect-sysdeps", + srcs = ["Main.hs"], + tags = ["requires_zlib"], + deps = [ + ":hs-lib", + "//tests/hackage:base", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/binary-with-indirect-sysdeps/HsLib.hs b/third_party/bazel/rules_haskell/tests/binary-with-indirect-sysdeps/HsLib.hs new file mode 100644 index 000000000000..1077606e31e2 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-with-indirect-sysdeps/HsLib.hs @@ -0,0 +1,8 @@ +module HsLib where + +import Foreign.Ptr +import Foreign.C.Types + +foreign import ccall crc32 :: CLong -> Ptr () -> CInt -> IO () + +test = crc32 0 nullPtr 0 diff --git a/third_party/bazel/rules_haskell/tests/binary-with-indirect-sysdeps/Main.hs b/third_party/bazel/rules_haskell/tests/binary-with-indirect-sysdeps/Main.hs new file mode 100644 index 000000000000..9c92b34c8a38 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-with-indirect-sysdeps/Main.hs @@ -0,0 +1,5 @@ +module Main where + +import HsLib (test) + +main = test diff --git a/third_party/bazel/rules_haskell/tests/binary-with-lib-dynamic/BUILD.bazel b/third_party/bazel/rules_haskell/tests/binary-with-lib-dynamic/BUILD.bazel new file mode 100644 index 000000000000..6be2db88b732 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-with-lib-dynamic/BUILD.bazel @@ -0,0 +1,25 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", + "haskell_test", +) + +package(default_testonly = 1) + +haskell_library( + name = "lib", + srcs = glob(["src/*.hs"]), + linkstatic = False, + src_strip_prefix = "src", +) + +haskell_test( + name = "binary-with-lib-dynamic", + srcs = ["Main.hs"], + linkstatic = False, + visibility = ["//visibility:public"], + deps = [ + ":lib", + "//tests/hackage:base", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/binary-with-lib-dynamic/Main.hs b/third_party/bazel/rules_haskell/tests/binary-with-lib-dynamic/Main.hs new file mode 100644 index 000000000000..d88f7c93d66a --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-with-lib-dynamic/Main.hs @@ -0,0 +1,7 @@ +module Main where + +import Control.Monad (unless) +import Lib (value) + +main = unless (value == 42) + $ error $ "Incorrect lib value. Got " <> show value diff --git a/third_party/bazel/rules_haskell/tests/binary-with-lib-dynamic/src/Lib.hs b/third_party/bazel/rules_haskell/tests/binary-with-lib-dynamic/src/Lib.hs new file mode 100644 index 000000000000..0521761f3572 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-with-lib-dynamic/src/Lib.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Lib (value) where + +value = 42 diff --git a/third_party/bazel/rules_haskell/tests/binary-with-lib/BUILD.bazel b/third_party/bazel/rules_haskell/tests/binary-with-lib/BUILD.bazel new file mode 100644 index 000000000000..196d551305a9 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-with-lib/BUILD.bazel @@ -0,0 +1,27 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", + "haskell_test", +) + +package(default_testonly = 1) + +haskell_library( + name = "lib", + srcs = glob(["src/*.hs"]), + src_strip_prefix = "src", + deps = [ + "//tests/hackage:template-haskell", + ], +) + +haskell_test( + name = "binary-with-lib", + srcs = ["Main.hs"], + visibility = ["//visibility:public"], + deps = [ + ":lib", + "//tests/hackage:base", + "//tests/hackage:template-haskell", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/binary-with-lib/Main.hs b/third_party/bazel/rules_haskell/tests/binary-with-lib/Main.hs new file mode 100644 index 000000000000..19ad3dd58ea0 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-with-lib/Main.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Control.Monad (unless) +import Lib (value) +import Language.Haskell.TH + +val = $(value) + +main = unless (val == 42) + $ error $ "Incorrect lib value. Got " <> show val diff --git a/third_party/bazel/rules_haskell/tests/binary-with-lib/src/Lib.hs b/third_party/bazel/rules_haskell/tests/binary-with-lib/src/Lib.hs new file mode 100644 index 000000000000..e78d2ef77f1b --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-with-lib/src/Lib.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} + +module Lib (value) where + +import Language.Haskell.TH + +value = [|42|] diff --git a/third_party/bazel/rules_haskell/tests/binary-with-link-flags/BUILD.bazel b/third_party/bazel/rules_haskell/tests/binary-with-link-flags/BUILD.bazel new file mode 100644 index 000000000000..cf2aba515b69 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-with-link-flags/BUILD.bazel @@ -0,0 +1,17 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_test", +) + +package( + default_testonly = 1, + default_visibility = ["//visibility:public"], +) + +haskell_test( + name = "binary-with-link-flags", + srcs = ["Main.hs"], + compiler_flags = ["-threaded"], + visibility = ["//visibility:public"], + deps = ["//tests/hackage:base"], +) diff --git a/third_party/bazel/rules_haskell/tests/binary-with-link-flags/Main.hs b/third_party/bazel/rules_haskell/tests/binary-with-link-flags/Main.hs new file mode 100644 index 000000000000..de106fe48f9a --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-with-link-flags/Main.hs @@ -0,0 +1,3 @@ +module Main where + +main = return () diff --git a/third_party/bazel/rules_haskell/tests/binary-with-main/BUILD.bazel b/third_party/bazel/rules_haskell/tests/binary-with-main/BUILD.bazel new file mode 100644 index 000000000000..e1243260c2ab --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-with-main/BUILD.bazel @@ -0,0 +1,14 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_test", +) + +package(default_testonly = 1) + +haskell_test( + name = "binary-with-main", + srcs = ["MainIsHere.hs"], + main_function = "MainIsHere.this", + visibility = ["//visibility:public"], + deps = ["//tests/hackage:base"], +) diff --git a/third_party/bazel/rules_haskell/tests/binary-with-main/MainIsHere.hs b/third_party/bazel/rules_haskell/tests/binary-with-main/MainIsHere.hs new file mode 100644 index 000000000000..5e8d38ba70df --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-with-main/MainIsHere.hs @@ -0,0 +1,4 @@ +module MainIsHere (this) where + +this :: IO () +this = return () diff --git a/third_party/bazel/rules_haskell/tests/binary-with-plugin/BUILD.bazel b/third_party/bazel/rules_haskell/tests/binary-with-plugin/BUILD.bazel new file mode 100644 index 000000000000..f3a8e3f4d689 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-with-plugin/BUILD.bazel @@ -0,0 +1,53 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "ghc_plugin", + "haskell_library", + "haskell_test", + "haskell_toolchain_library", +) + +package(default_testonly = 1) + +config_setting( + name = "debug_build", + values = { + "compilation_mode": "dbg", + }, +) + +haskell_toolchain_library(name = "base") + +haskell_toolchain_library(name = "ghc") + +haskell_toolchain_library(name = "process") + +haskell_library( + name = "plugin-lib", + srcs = ["Plugin.hs"], + deps = [ + ":base", + ":ghc", + ":process", + ], +) + +ghc_plugin( + name = "plugin", + args = ["$(location //tests/binary-simple)"], + module = "Plugin", + tools = ["//tests/binary-simple"], + deps = [":plugin-lib"], +) + +haskell_test( + name = "binary-with-plugin", + srcs = ["Main.hs"], + plugins = select({ + # XXX If profiling is enabled, ignore the plugin because of + # https://gitlab.haskell.org/ghc/ghc/issues/14335. + ":debug_build": [], + "//conditions:default": [":plugin"], + }), + visibility = ["//visibility:public"], + deps = [":base"], +) diff --git a/third_party/bazel/rules_haskell/tests/binary-with-plugin/Main.hs b/third_party/bazel/rules_haskell/tests/binary-with-plugin/Main.hs new file mode 100644 index 000000000000..2048dbdecd9a --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-with-plugin/Main.hs @@ -0,0 +1,3 @@ +module Main where + +main = putStrLn "hello world" diff --git a/third_party/bazel/rules_haskell/tests/binary-with-plugin/Plugin.hs b/third_party/bazel/rules_haskell/tests/binary-with-plugin/Plugin.hs new file mode 100644 index 000000000000..3827bb799215 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-with-plugin/Plugin.hs @@ -0,0 +1,15 @@ +module Plugin (plugin) where + +import Control.Monad (when) +import GhcPlugins +import System.Process (readProcess) + +plugin :: Plugin +plugin = defaultPlugin { installCoreToDos = install } + +install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +install [arg] todo = do + when ('$' `elem` arg) $ + fail "Make variable not expanded." + _ <- liftIO $ readProcess arg [] "" + return todo diff --git a/third_party/bazel/rules_haskell/tests/binary-with-prebuilt/BUILD.bazel b/third_party/bazel/rules_haskell/tests/binary-with-prebuilt/BUILD.bazel new file mode 100644 index 000000000000..99a22ae9991f --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-with-prebuilt/BUILD.bazel @@ -0,0 +1,19 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_test", +) + +package(default_testonly = 1) + +haskell_test( + name = "binary-with-prebuilt", + srcs = ["Main.hs"], + tags = ["requires_hackage"], + visibility = ["//visibility:public"], + deps = [ + "//tests/hackage:base", + "//tests/hackage:template-haskell", + "@hackage//:streaming", + "@hackage//:void", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/binary-with-prebuilt/Main.hs b/third_party/bazel/rules_haskell/tests/binary-with-prebuilt/Main.hs new file mode 100644 index 000000000000..aa3b1b40ee8a --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-with-prebuilt/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Data.List () +import Language.Haskell.TH () + +main = return () diff --git a/third_party/bazel/rules_haskell/tests/binary-with-sysdeps/BUILD.bazel b/third_party/bazel/rules_haskell/tests/binary-with-sysdeps/BUILD.bazel new file mode 100644 index 000000000000..769ecf31a38c --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-with-sysdeps/BUILD.bazel @@ -0,0 +1,17 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_test", +) + +package(default_testonly = 1) + +haskell_test( + name = "binary-with-sysdeps", + srcs = ["Main.hs"], + tags = ["requires_zlib"], + visibility = ["//visibility:public"], + deps = [ + "//tests/hackage:base", + "@zlib", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/binary-with-sysdeps/Main.hs b/third_party/bazel/rules_haskell/tests/binary-with-sysdeps/Main.hs new file mode 100644 index 000000000000..bf8da504168a --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/binary-with-sysdeps/Main.hs @@ -0,0 +1,8 @@ +module Main where + +import Foreign.Ptr +import Foreign.C.Types + +foreign import ccall crc32 :: CLong -> Ptr () -> CInt -> IO () + +main = crc32 0 nullPtr 0 diff --git a/third_party/bazel/rules_haskell/tests/c-compiles-still/BUILD.bazel b/third_party/bazel/rules_haskell/tests/c-compiles-still/BUILD.bazel new file mode 100644 index 000000000000..314b895b6be4 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/c-compiles-still/BUILD.bazel @@ -0,0 +1,15 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", +) + +package(default_testonly = 1) + +haskell_library( + name = "foo", + srcs = ["Foo.hs"], + deps = [ + "//tests/data:ourclibrary", + "//tests/hackage:base", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/c-compiles-still/Foo.hs b/third_party/bazel/rules_haskell/tests/c-compiles-still/Foo.hs new file mode 100644 index 000000000000..f325b2efcfbb --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/c-compiles-still/Foo.hs @@ -0,0 +1,4 @@ +module Foo (foo) where + +foo :: Int +foo = 5 diff --git a/third_party/bazel/rules_haskell/tests/c-compiles/BUILD.bazel b/third_party/bazel/rules_haskell/tests/c-compiles/BUILD.bazel new file mode 100644 index 000000000000..b5256bfb18d0 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/c-compiles/BUILD.bazel @@ -0,0 +1,26 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", + "haskell_test", +) + +package(default_testonly = 1) + +haskell_library( + name = "hs-lib", + srcs = ["Lib.hs"], + deps = [ + "//tests/data:ourclibrary", + "//tests/hackage:base", + ], +) + +haskell_test( + name = "c-compiles", + srcs = ["Main.hs"], + visibility = ["//visibility:public"], + deps = [ + ":hs-lib", + "//tests/hackage:base", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/c-compiles/Lib.hs b/third_party/bazel/rules_haskell/tests/c-compiles/Lib.hs new file mode 100644 index 000000000000..6ebec6b460ce --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/c-compiles/Lib.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Lib (ten) where + +import Foreign.C.Types (CInt(..)) + +foreign import ccall "c_add_one" + c_add_one :: CInt -> CInt + +ten :: Int +ten = fromIntegral (c_add_one 9) diff --git a/third_party/bazel/rules_haskell/tests/c-compiles/Main.hs b/third_party/bazel/rules_haskell/tests/c-compiles/Main.hs new file mode 100644 index 000000000000..5fc7b957c84b --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/c-compiles/Main.hs @@ -0,0 +1,8 @@ +module Main (main) where + +import Control.Monad (unless) +import Lib (ten) + +main :: IO () +main = unless (ten == 10) + $ error $ "Incorrect lib value. Got " <> show ten diff --git a/third_party/bazel/rules_haskell/tests/c-compiles/c-compiles.c b/third_party/bazel/rules_haskell/tests/c-compiles/c-compiles.c new file mode 100644 index 000000000000..2d3a4d742c30 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/c-compiles/c-compiles.c @@ -0,0 +1 @@ +int add_five(int x) { return x + 5; } diff --git a/third_party/bazel/rules_haskell/tests/c2hs/BUILD.bazel b/third_party/bazel/rules_haskell/tests/c2hs/BUILD.bazel new file mode 100644 index 000000000000..a343c55f57fc --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/c2hs/BUILD.bazel @@ -0,0 +1,36 @@ +load("@io_tweag_rules_haskell//haskell:c2hs.bzl", "c2hs_library") +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", +) + +package(default_testonly = 1) + +c2hs_library( + name = "foo", + srcs = ["src/Foo/Foo.chs"], + src_strip_prefix = "src", + tags = [ + "requires_c2hs", + "requires_zlib", + ], + deps = ["@zlib.dev//:zlib"], +) + +c2hs_library( + name = "bar", + srcs = ["Bar.chs"], + tags = ["requires_c2hs"], + deps = [":foo"], +) + +haskell_library( + name = "c2hs", + srcs = [ + ":bar", + ":foo", + "@c2hs_repo//:baz", + ], + tags = ["requires_c2hs"], + deps = ["//tests/hackage:base"], +) diff --git a/third_party/bazel/rules_haskell/tests/c2hs/Bar.chs b/third_party/bazel/rules_haskell/tests/c2hs/Bar.chs new file mode 100644 index 000000000000..1de32c1ccb3b --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/c2hs/Bar.chs @@ -0,0 +1,6 @@ +module Bar (bar) where + +{#import Foo.Foo#} + +bar :: Int +bar = 6 diff --git a/third_party/bazel/rules_haskell/tests/c2hs/repo/BUILD.bazel b/third_party/bazel/rules_haskell/tests/c2hs/repo/BUILD.bazel new file mode 100644 index 000000000000..4f1d15c09a6f --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/c2hs/repo/BUILD.bazel @@ -0,0 +1,10 @@ +load("@io_tweag_rules_haskell//haskell:c2hs.bzl", "c2hs_library") + +package(default_testonly = 1) + +c2hs_library( + name = "baz", + srcs = ["Baz.chs"], + visibility = ["//visibility:public"], + deps = ["@zlib.dev//:zlib"], +) diff --git a/third_party/bazel/rules_haskell/tests/c2hs/repo/Baz.chs b/third_party/bazel/rules_haskell/tests/c2hs/repo/Baz.chs new file mode 100644 index 000000000000..b6d74dfc4ea8 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/c2hs/repo/Baz.chs @@ -0,0 +1,6 @@ +module Baz (baz) where + +#include <zlib.h> + +baz :: Int +baz = {# sizeof gz_header_s #} diff --git a/third_party/bazel/rules_haskell/tests/c2hs/repo/WORKSPACE b/third_party/bazel/rules_haskell/tests/c2hs/repo/WORKSPACE new file mode 100644 index 000000000000..e53539f0b46c --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/c2hs/repo/WORKSPACE @@ -0,0 +1 @@ +workspace(name = "c2hs_repo") diff --git a/third_party/bazel/rules_haskell/tests/c2hs/src/Foo/Foo.chs b/third_party/bazel/rules_haskell/tests/c2hs/src/Foo/Foo.chs new file mode 100644 index 000000000000..244f3b2b29ff --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/c2hs/src/Foo/Foo.chs @@ -0,0 +1,6 @@ +module Foo.Foo (foo) where + +#include <zlib.h> + +foo :: Int +foo = {# sizeof gz_header_s #} diff --git a/third_party/bazel/rules_haskell/tests/cc_haskell_import/BUILD.bazel b/third_party/bazel/rules_haskell/tests/cc_haskell_import/BUILD.bazel new file mode 100644 index 000000000000..c89631450059 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/cc_haskell_import/BUILD.bazel @@ -0,0 +1,70 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", +) + +package(default_testonly = 1) + +haskell_library( + name = "hs-lib-a", + srcs = ["LibA.hs"], + deps = [ + "//tests/data:ourclibrary", + "//tests/hackage:base", + ], +) + +haskell_library( + name = "hs-lib-b", + srcs = ["LibB.hs"], + deps = [ + ":hs-lib-a", + "//tests/hackage:base", + ], +) + +cc_binary( + name = "cc-bin", + srcs = [ + "main.c", + ], + # TODO support linking with static haskell libraries. + linkstatic = False, + tags = ["requires_threaded_rts"], + visibility = ["//tests:__subpackages__"], + deps = [ + ":hs-lib-b", + "@ghc//:threaded-rts", + ], +) + +# We go one step further and use the Haskell library from above +# to build a static .so which is then loaded with a Python script +# and calls the Haskell function constructed from GHC C FFI. + +# shared library which python will dlopen +cc_binary( + name = "hs-lib-b-wrapped.so", + linkshared = 1, + linkstatic = 0, + tags = ["requires_threaded_rts"], + visibility = ["//tests:__subpackages__"], + deps = [ + ":hs-lib-b", + "@ghc//:threaded-rts", + ], +) + +# just dlopens hb-lib-b-wrapped.so and prints it +py_binary( + name = "python_add_one", + srcs = ["python_add_one.py"], + data = [ + ":hs-lib-b-wrapped.so", + ], + default_python_version = "PY3", + srcs_version = "PY3ONLY", + tags = ["requires_threaded_rts"], + visibility = ["//tests:__subpackages__"], + deps = ["@bazel_tools//tools/python/runfiles"], +) diff --git a/third_party/bazel/rules_haskell/tests/cc_haskell_import/LibA.hs b/third_party/bazel/rules_haskell/tests/cc_haskell_import/LibA.hs new file mode 100644 index 000000000000..db8e442e5a5f --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/cc_haskell_import/LibA.hs @@ -0,0 +1,8 @@ +module LibA (add_one) where + +import Data.Int (Int32) + +foreign import ccall "c_add_one" c_add_one' :: Int32 -> Int32 + +add_one :: Int32 -> Int32 +add_one x = c_add_one' x diff --git a/third_party/bazel/rules_haskell/tests/cc_haskell_import/LibB.hs b/third_party/bazel/rules_haskell/tests/cc_haskell_import/LibB.hs new file mode 100644 index 000000000000..5904463b51fc --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/cc_haskell_import/LibB.hs @@ -0,0 +1,9 @@ +module LibB (add_one_hs) where + +import LibA (add_one) +import Data.Int (Int32) + +foreign export ccall add_one_hs :: Int32 -> IO Int32 + +add_one_hs :: Int32 -> IO Int32 +add_one_hs x = pure $! add_one x + 0 diff --git a/third_party/bazel/rules_haskell/tests/cc_haskell_import/cbits.c b/third_party/bazel/rules_haskell/tests/cc_haskell_import/cbits.c new file mode 100644 index 000000000000..587d26ba28aa --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/cc_haskell_import/cbits.c @@ -0,0 +1,5 @@ +#include <stdint.h> + +int32_t c_add_one(int32_t x) { + return 1 + x; +} diff --git a/third_party/bazel/rules_haskell/tests/cc_haskell_import/main.c b/third_party/bazel/rules_haskell/tests/cc_haskell_import/main.c new file mode 100644 index 000000000000..661174e5df49 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/cc_haskell_import/main.c @@ -0,0 +1,11 @@ +#include <stdio.h> +#include "HsFFI.h" + +extern HsInt32 add_one_hs(HsInt32 a0); + +int main(int argc, char *argv[]) { + hs_init(&argc, &argv); + printf("Adding one to 5 through Haskell is %d\n", add_one_hs(5)); + hs_exit(); + return 0; +} diff --git a/third_party/bazel/rules_haskell/tests/cc_haskell_import/python_add_one.py b/third_party/bazel/rules_haskell/tests/cc_haskell_import/python_add_one.py new file mode 100644 index 000000000000..b400102d1cc6 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/cc_haskell_import/python_add_one.py @@ -0,0 +1,18 @@ +import os +import ctypes +from bazel_tools.tools.python.runfiles import runfiles +import subprocess + +r = runfiles.Create() + +path = r.Rlocation('io_tweag_rules_haskell/tests/cc_haskell_import/hs-lib-b-wrapped.so') + +foreignlib = ctypes.cdll.LoadLibrary(path) + +# ATTN: If you remove this print *statement* hs_init will segfault! +# If you use the python3 print *function*, it will segfault as well! +# TODO: wtf? +print foreignlib + +foreignlib.hs_init() +assert(str(foreignlib.add_one_hs(1)) == "2") diff --git a/third_party/bazel/rules_haskell/tests/cpp_macro_conflict/BUILD.bazel b/third_party/bazel/rules_haskell/tests/cpp_macro_conflict/BUILD.bazel new file mode 100644 index 000000000000..af8848a6eea7 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/cpp_macro_conflict/BUILD.bazel @@ -0,0 +1,36 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", + "haskell_test", +) + +package(default_testonly = 1) + +# empty library with package name "bytestring" +haskell_library( + name = "bytestring", + srcs = ["src/BS.hs"], + deps = ["//tests/hackage:base"], +) + +# This depends on two packages "bytestring" +# There should be no CPP macro conflict +haskell_test( + name = "macro_conflict", + srcs = ["Main.hs"], + compiler_flags = [ + "-XCPP", + "-Werror", + ] + select({ + # clang on darwin fails because of unused command line argument, it fails because of -Werror + "@bazel_tools//src/conditions:darwin": [ + "-optP-Wno-unused-command-line-argument", + ], + "//conditions:default": [], + }), + deps = [ + ":bytestring", + "//tests/hackage:base", + "//tests/hackage:bytestring", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/cpp_macro_conflict/Main.hs b/third_party/bazel/rules_haskell/tests/cpp_macro_conflict/Main.hs new file mode 100644 index 000000000000..f5a27e6a7efb --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/cpp_macro_conflict/Main.hs @@ -0,0 +1,4 @@ +import qualified Data.ByteString +import BS + +main = putStrLn "hello" diff --git a/third_party/bazel/rules_haskell/tests/cpp_macro_conflict/src/BS.hs b/third_party/bazel/rules_haskell/tests/cpp_macro_conflict/src/BS.hs new file mode 100644 index 000000000000..437b7e5f72cd --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/cpp_macro_conflict/src/BS.hs @@ -0,0 +1 @@ +module BS where diff --git a/third_party/bazel/rules_haskell/tests/data/BUILD.bazel b/third_party/bazel/rules_haskell/tests/data/BUILD.bazel new file mode 100644 index 000000000000..7083de23af40 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/data/BUILD.bazel @@ -0,0 +1,15 @@ +# Generic data files and targets that are used by multiple tests + +cc_library( + name = "ourclibrary", + srcs = [":ourclibrary.c"], + linkstatic = False, + visibility = ["//visibility:public"], +) + +cc_library( + name = "ourclibrary-static", + srcs = [":ourclibrary.c"], + linkstatic = True, + visibility = ["//visibility:public"], +) diff --git a/third_party/bazel/rules_haskell/tests/data/ourclibrary.c b/third_party/bazel/rules_haskell/tests/data/ourclibrary.c new file mode 100644 index 000000000000..587d26ba28aa --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/data/ourclibrary.c @@ -0,0 +1,5 @@ +#include <stdint.h> + +int32_t c_add_one(int32_t x) { + return 1 + x; +} diff --git a/third_party/bazel/rules_haskell/tests/encoding/BUILD.bazel b/third_party/bazel/rules_haskell/tests/encoding/BUILD.bazel new file mode 100644 index 000000000000..588d13f6d0b7 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/encoding/BUILD.bazel @@ -0,0 +1,21 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_test", +) + +package(default_testonly = 1) + +haskell_test( + name = "encoding", + srcs = [ + "Main.hs", + "TH.hs", + ], + extra_srcs = [ + "unicode.txt", + ], + deps = [ + "//tests/hackage:base", + "//tests/hackage:template-haskell", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/encoding/Main.hs b/third_party/bazel/rules_haskell/tests/encoding/Main.hs new file mode 100644 index 000000000000..beb5f2a29497 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/encoding/Main.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Main (main) where + +import TH + +main :: IO () +main = putStrLn $foo diff --git a/third_party/bazel/rules_haskell/tests/encoding/TH.hs b/third_party/bazel/rules_haskell/tests/encoding/TH.hs new file mode 100644 index 000000000000..8cb52b3f1139 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/encoding/TH.hs @@ -0,0 +1,7 @@ +module TH (foo) where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (lift) + +foo :: Q Exp +foo = runIO (readFile "tests/encoding/unicode.txt") >>= lift diff --git a/third_party/bazel/rules_haskell/tests/encoding/unicode.txt b/third_party/bazel/rules_haskell/tests/encoding/unicode.txt new file mode 100644 index 000000000000..74e5f2638d08 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/encoding/unicode.txt @@ -0,0 +1 @@ +ะะตะบะพัะพััะน ัะตะบัั ะฝะฐ ััััะบะพะผ. diff --git a/third_party/bazel/rules_haskell/tests/external-haskell-repository/BUILD.bazel b/third_party/bazel/rules_haskell/tests/external-haskell-repository/BUILD.bazel new file mode 100644 index 000000000000..30ff35704050 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/external-haskell-repository/BUILD.bazel @@ -0,0 +1,17 @@ +# Tests correct linking of haskell packages that were created +# in a different bazel repository, e.g. with hazel. + +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_test", +) + +haskell_test( + name = "external-haskell-repository", + srcs = ["Main.hs"], + visibility = ["//visibility:public"], + deps = [ + "//tests/hackage:base", + "@haskell_package_repository_dummy//:library-with-cbits", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/external-haskell-repository/Main.hs b/third_party/bazel/rules_haskell/tests/external-haskell-repository/Main.hs new file mode 100644 index 000000000000..97fcc158880a --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/external-haskell-repository/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import AddOne +import Control.Exception (assert) + +main = assert (addOne 41 == 42) $ return () diff --git a/third_party/bazel/rules_haskell/tests/external-haskell-repository/workspace_dummy.bzl b/third_party/bazel/rules_haskell/tests/external-haskell-repository/workspace_dummy.bzl new file mode 100644 index 000000000000..1ccc0aadf1de --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/external-haskell-repository/workspace_dummy.bzl @@ -0,0 +1,64 @@ +# This file constructs a dummy workspace to test +# haskell binaries that are included from outside repositories +# (because linking external repositories works differently). + +# Repo-ception, in the sense that we build a WORKSPACE +# that references the workspaces already set up in the +# `rules_haskell` WORKSPACE. +def _haskell_package_repository_dummy_impl(rep_ctx): + rep_ctx.file( + "WORKSPACE", + executable = False, + content = """ +repository(name={name}) + +register_toolchains( + "@io_tweag_rules_haskell//tests/:ghc" +) +""".format(name = rep_ctx.name), + ) + + # this mirrors tests/library-with-cbits + + rep_ctx.file( + "BUILD", + executable = False, + content = """ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_toolchain", + "haskell_library", +) +load( + "@io_tweag_rules_haskell//:constants.bzl", + "test_ghc_version", +) + +haskell_library( + name = "library-with-cbits", + srcs = ["AddOne.hs"], + deps = [ + "@io_tweag_rules_haskell//tests/data:ourclibrary", + "@io_tweag_rules_haskell//tests/hackage:base", + ], + + linkstatic = False, + visibility = ["//visibility:public"], +) +""", + ) + + rep_ctx.file( + "AddOne.hs", + executable = False, + content = """ +module AddOne where + +foreign import ccall "c_add_one" addOne :: Int -> Int +""", + ) + +haskell_package_repository_dummy = repository_rule( + _haskell_package_repository_dummy_impl, + local = True, +) diff --git a/third_party/bazel/rules_haskell/tests/extra-source-files/BUILD.bazel b/third_party/bazel/rules_haskell/tests/extra-source-files/BUILD.bazel new file mode 100644 index 000000000000..9552d7c9e974 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/extra-source-files/BUILD.bazel @@ -0,0 +1,44 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", + "haskell_test", +) + +package(default_testonly = 1) + +haskell_library( + name = "extra-source-files", + srcs = [ + "Foo.hs", + "FooTH.hs", + ], + # Test that the linker can also see the extra_srcs. + compiler_flags = ["-optl-Wl,@tests/extra-source-files/ld-options.txt"], + extra_srcs = [ + "file.txt", + "ld-options.txt", + ], + deps = [ + "//tests/hackage:base", + "//tests/hackage:template-haskell", + ], +) + +haskell_test( + name = "extra-source-files-bin", + srcs = [ + "Foo.hs", + "FooTH.hs", + "Main.hs", + ], + # Test that the linker can also see the extra_srcs. + compiler_flags = ["-optl-Wl,@tests/extra-source-files/ld-options.txt"], + extra_srcs = [ + "file.txt", + "ld-options.txt", + ], + deps = [ + "//tests/hackage:base", + "//tests/hackage:template-haskell", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/extra-source-files/Foo.hs b/third_party/bazel/rules_haskell/tests/extra-source-files/Foo.hs new file mode 100644 index 000000000000..b3f0c04492db --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/extra-source-files/Foo.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Foo (foo) where + +import FooTH (embedFile) + +foo :: String +foo = $(embedFile "tests/extra-source-files/file.txt") ++ "!" diff --git a/third_party/bazel/rules_haskell/tests/extra-source-files/FooTH.hs b/third_party/bazel/rules_haskell/tests/extra-source-files/FooTH.hs new file mode 100644 index 000000000000..24d663108355 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/extra-source-files/FooTH.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TemplateHaskell #-} + +module FooTH (embedFile) where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +embedFile :: FilePath -> Q Exp +embedFile path = do + str <- runIO (readFile path) + addDependentFile path + [| str |] diff --git a/third_party/bazel/rules_haskell/tests/extra-source-files/Main.hs b/third_party/bazel/rules_haskell/tests/extra-source-files/Main.hs new file mode 100644 index 000000000000..13e4bd765b6a --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/extra-source-files/Main.hs @@ -0,0 +1,4 @@ +import Foo (foo) + +main :: IO () +main = putStrLn foo diff --git a/third_party/bazel/rules_haskell/tests/extra-source-files/file.txt b/third_party/bazel/rules_haskell/tests/extra-source-files/file.txt new file mode 100644 index 000000000000..5bc133a4d007 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/extra-source-files/file.txt @@ -0,0 +1 @@ +And here we go diff --git a/third_party/bazel/rules_haskell/tests/extra-source-files/ld-options.txt b/third_party/bazel/rules_haskell/tests/extra-source-files/ld-options.txt new file mode 100644 index 000000000000..e69de29bb2d1 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/extra-source-files/ld-options.txt diff --git a/third_party/bazel/rules_haskell/tests/failures/transitive-deps/BUILD.bazel b/third_party/bazel/rules_haskell/tests/failures/transitive-deps/BUILD.bazel new file mode 100644 index 000000000000..c2efbd924a32 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/failures/transitive-deps/BUILD.bazel @@ -0,0 +1,66 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", +) + +package(default_testonly = 1) + +haskell_library( + name = "lib-a", + srcs = ["LibA.hs"], + deps = ["//tests/hackage:base"], +) + +haskell_library( + name = "lib-b", + srcs = ["LibB.hs"], + visibility = ["//visibility:private"], + deps = [ + ":lib-a", + "//tests/hackage:base", + ], +) + +# Targets that must FAIL. These are tagged as manual so that +# +# $ bazel build //... +# +# does not fail. + +haskell_library( + # Should fail because it doesn't specify "base" explicitly. + name = "lib-cFailure", + srcs = ["LibC.hs"], + tags = ["manual"], + deps = [":lib-b"], +) + +haskell_library( + name = "lib-c", + srcs = ["LibC.hs"], + deps = [ + ":lib-b", + "//tests/hackage:base", + ], +) + +haskell_library( + # Should fail because it doesn't specify "lib-a" explicitly. + name = "lib-dFailure", + srcs = ["LibD.hs"], + tags = ["manual"], + deps = [ + ":lib-b", + "//tests/hackage:base", + ], +) + +haskell_library( + name = "lib-d", + srcs = ["LibD.hs"], + deps = [ + ":lib-a", + ":lib-b", + "//tests/hackage:base", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/failures/transitive-deps/LibA.hs b/third_party/bazel/rules_haskell/tests/failures/transitive-deps/LibA.hs new file mode 100644 index 000000000000..23e9486489fe --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/failures/transitive-deps/LibA.hs @@ -0,0 +1,4 @@ +module LibA (thingA) where + +thingA :: Int +thingA = 5 diff --git a/third_party/bazel/rules_haskell/tests/failures/transitive-deps/LibB.hs b/third_party/bazel/rules_haskell/tests/failures/transitive-deps/LibB.hs new file mode 100644 index 000000000000..9ab883093bd8 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/failures/transitive-deps/LibB.hs @@ -0,0 +1,6 @@ +module LibB (thingB) where + +import LibA (thingA) + +thingB :: Int +thingB = thingA + 1 diff --git a/third_party/bazel/rules_haskell/tests/failures/transitive-deps/LibC.hs b/third_party/bazel/rules_haskell/tests/failures/transitive-deps/LibC.hs new file mode 100644 index 000000000000..70514f13168b --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/failures/transitive-deps/LibC.hs @@ -0,0 +1,6 @@ +module LibC (thingC) where + +import LibB (thingB) + +thingC :: Int +thingC = thingB * 2 diff --git a/third_party/bazel/rules_haskell/tests/failures/transitive-deps/LibD.hs b/third_party/bazel/rules_haskell/tests/failures/transitive-deps/LibD.hs new file mode 100644 index 000000000000..326d224a2a15 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/failures/transitive-deps/LibD.hs @@ -0,0 +1,7 @@ +module LibD (thingD) where + +import LibA (thingA) +import LibB (thingB) + +thingD :: Int +thingD = thingA + thingB diff --git a/third_party/bazel/rules_haskell/tests/generated-modules/BUILD.bazel b/third_party/bazel/rules_haskell/tests/generated-modules/BUILD.bazel new file mode 100644 index 000000000000..098c7148a960 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/generated-modules/BUILD.bazel @@ -0,0 +1,56 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", + "haskell_test", +) + +package( + default_testonly = 1, + default_visibility = ["//visibility:public"], +) + +genrule( + name = "generate-genmodule", + outs = ["src/GenModule.hs"], + cmd = "printf 'module GenModule where\na = 1 :: Int' > $@", +) + +haskell_library( + name = "GenModule", + srcs = [":generate-genmodule"], + src_strip_prefix = "src", + deps = ["//tests/hackage:base"], +) + +genrule( + name = "generate-binmodule", + outs = ["src/BinModule.hs"], + cmd = "printf 'module BinModule where\nb = 2 :: Int' > $@", + output_to_bindir = 1, +) + +haskell_library( + name = "BinModule", + srcs = [":generate-binmodule"], + src_strip_prefix = "src", + deps = ["//tests/hackage:base"], +) + +genrule( + name = "generate-main", + outs = ["src/Main.hs"], + cmd = "printf 'module Main where\nimport GenModule\nimport BinModule\n" + + "main = print (a+b) :: IO ()' > $@", +) + +haskell_test( + name = "generated-modules", + size = "small", + srcs = [":generate-main"], + src_strip_prefix = "src", + deps = [ + ":BinModule", + ":GenModule", + "//tests/hackage:base", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/ghc.nix b/third_party/bazel/rules_haskell/tests/ghc.nix new file mode 100644 index 000000000000..cde1699918f2 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/ghc.nix @@ -0,0 +1,41 @@ +{ pkgs ? import ../nixpkgs {} +# Whether we want to wrap the packages using <bazel_haskell_wrapper>. +# When this is called from inside bazel, we need to wrap the haskell package +# set using <bazel_haskell_wrapper>. Otherwise we don't need (and don't want) +# to. +, wrapPackages ? (builtins.tryEval <bazel_haskell_wrapper>).success +}: + +with pkgs; + +let haskellPackages = pkgs.haskell.packages.ghc864.override { + overrides = with pkgs.haskell.lib; self: super: rec { + libc = import ./haddock/libC.nix self pkgs; + }; + }; + genBazelBuild = + if wrapPackages + then callPackage <bazel_haskell_wrapper> {} + else (x: x); + +in + { + ghc = haskellPackages.ghcWithPackages (p: with p; [ + + # haskell_proto_library inputs + bytestring + containers + data-default-class + lens-family + lens-labels + proto-lens + text + + # test inputs + libc + + # for test runner + hspec + ]); + haskellPackages = genBazelBuild haskellPackages; +} diff --git a/third_party/bazel/rules_haskell/tests/ghc/BUILD.bazel b/third_party/bazel/rules_haskell/tests/ghc/BUILD.bazel new file mode 100644 index 000000000000..345ce4badf91 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/ghc/BUILD.bazel @@ -0,0 +1,3 @@ +load("//tests/ghc:ghc.bzl", "ghc_help") + +ghc_help(name = "ghc_help") diff --git a/third_party/bazel/rules_haskell/tests/ghc/ghc.bzl b/third_party/bazel/rules_haskell/tests/ghc/ghc.bzl new file mode 100644 index 000000000000..443f04e7be63 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/ghc/ghc.bzl @@ -0,0 +1,19 @@ +"""Runs ghc --help""" + +hs_toolchain = "@io_tweag_rules_haskell//haskell:toolchain" + +def _impl(ctx): + output = ctx.outputs.out + ghc = ctx.toolchains[hs_toolchain].tools.ghc + ctx.actions.run_shell( + inputs = [ghc], + outputs = [output], + progress_message = "Printing ghc help message", + command = "%s --help > %s" % (ghc.path, output.path), + ) + +ghc_help = rule( + implementation = _impl, + outputs = {"out": "out_file"}, + toolchains = [hs_toolchain], +) diff --git a/third_party/bazel/rules_haskell/tests/hackage/BUILD.bazel b/third_party/bazel/rules_haskell/tests/hackage/BUILD.bazel new file mode 100644 index 000000000000..63fb6f941b4b --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/hackage/BUILD.bazel @@ -0,0 +1,34 @@ +""" + Fetches GHC boot packages from GHC directly rather than from Nixpkgs + for better bindist support. +""" + +package(default_visibility = [ + "//tests:__subpackages__", + "@haskell_package_repository_dummy//:__subpackages__", +]) + +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_toolchain_library", +) + +[ + haskell_toolchain_library(name = name) + for name in [ + "array", + "base", + "binary", + "bytestring", + "containers", + "deepseq", + "directory", + "filepath", + "mtl", + "template-haskell", + "transformers", + "ghc-prim", + "process", + "text", + ] +] diff --git a/third_party/bazel/rules_haskell/tests/haddock/BUILD.bazel b/third_party/bazel/rules_haskell/tests/haddock/BUILD.bazel new file mode 100644 index 000000000000..6955285c87d2 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/haddock/BUILD.bazel @@ -0,0 +1,73 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_doc", + "haskell_library", + "haskell_toolchain_library", +) + +package( + default_testonly = 1, + default_visibility = ["//visibility:public"], +) + +haskell_library( + name = "haddock-lib-deep", + srcs = ["Deep.hsc"], + deps = ["//tests/hackage:base"], +) + +haskell_library( + name = "haddock-lib-a", + srcs = [ + "LibA.hs", + "LibA/A.hs", + "header.h", + ], + compiler_flags = ["-I."], + deps = [ + ":haddock-lib-deep", + "//tests/hackage:base", + "//tests/hackage:template-haskell", + ], +) + +haskell_toolchain_library( + name = "haddock-lib-c", + package = "libc", +) + +haskell_library( + name = "haddock-lib-b", + srcs = [ + "LibB.hs", + "TH.hs", + ], + extra_srcs = [ + "unicode.txt", + ], + tags = [ + "requires_hackage", + "requires_zlib", + ], + deps = [ + ":haddock-lib-a", + "//tests/hackage:base", + "//tests/hackage:template-haskell", + "@hackage//:libc", + "@zlib", + ], +) + +haskell_doc( + name = "haddock", + index_transitive_deps = False, + tags = ["requires_hackage"], + deps = [":haddock-lib-b"], +) + +haskell_doc( + name = "haddock-transitive", + index_transitive_deps = True, + tags = ["requires_hackage"], + deps = [":haddock-lib-b"], +) diff --git a/third_party/bazel/rules_haskell/tests/haddock/Deep.hsc b/third_party/bazel/rules_haskell/tests/haddock/Deep.hsc new file mode 100644 index 000000000000..6fb0482a1572 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/haddock/Deep.hsc @@ -0,0 +1,11 @@ +-- | "Deep" doc. +module Deep (deep_lib) where + +-- | 'deep_lib' doc. + +#if __GLASGOW_HASKELL__ >= 700 +#ifndef _INTERNAL_HSC_DO_NOT_DEFINE_ME +deep_lib :: Int +deep_lib = 100 +#endif +#endif diff --git a/third_party/bazel/rules_haskell/tests/haddock/LibA.hs b/third_party/bazel/rules_haskell/tests/haddock/LibA.hs new file mode 100644 index 000000000000..252c90ccc6d9 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/haddock/LibA.hs @@ -0,0 +1,19 @@ +-- | "LibA" header +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} + +#include "header.h" + +module LibA where + +import LibA.A (a) +import Deep (deep_lib) + +-- | 'A' declaration. +data A = + -- | 'A' constructor. + A + +-- | Doc for 'f' using 'a' and 'deep_lib'. +f :: Int +f = const $a deep_lib + MAGIC_NUMBER diff --git a/third_party/bazel/rules_haskell/tests/haddock/LibA/A.hs b/third_party/bazel/rules_haskell/tests/haddock/LibA/A.hs new file mode 100644 index 000000000000..3be8dd5aadd3 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/haddock/LibA/A.hs @@ -0,0 +1,10 @@ +-- | "LibA.A" header +{-# LANGUAGE TemplateHaskell #-} + +module LibA.A where + +import Language.Haskell.TH + +-- | 'a' doc +a :: Q Exp +a = [| 5 |] diff --git a/third_party/bazel/rules_haskell/tests/haddock/LibB.hs b/third_party/bazel/rules_haskell/tests/haddock/LibB.hs new file mode 100644 index 000000000000..b4df1ffcb9a2 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/haddock/LibB.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | "LibB" doc. + +module LibB where + +import LibA.A (a) +import LibA (f) +import LibC (mytype, LibCType) +import TH (foo) + +-- | Doc for 'x' using 'f' and 'a' and 'Int'. +x :: Int +x = const f a + +-- | This uses a type from an undocumented package +y :: LibCType +y = mytype + +-- | A thing generated with TH. +z :: String +z = $foo diff --git a/third_party/bazel/rules_haskell/tests/haddock/TH.hs b/third_party/bazel/rules_haskell/tests/haddock/TH.hs new file mode 100644 index 000000000000..6e791b09154e --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/haddock/TH.hs @@ -0,0 +1,7 @@ +module TH (foo) where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (lift) + +foo :: Q Exp +foo = runIO (readFile "tests/haddock/unicode.txt") >>= lift diff --git a/third_party/bazel/rules_haskell/tests/haddock/header.h b/third_party/bazel/rules_haskell/tests/haddock/header.h new file mode 100644 index 000000000000..ec5eddd2766e --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/haddock/header.h @@ -0,0 +1 @@ +#define MAGIC_NUMBER 100 diff --git a/third_party/bazel/rules_haskell/tests/haddock/libC.nix b/third_party/bazel/rules_haskell/tests/haddock/libC.nix new file mode 100644 index 000000000000..d345178838f1 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/haddock/libC.nix @@ -0,0 +1,47 @@ +# A trivial `haskellPackages` library that has haddock generation disabled +self: pkgs: +let + # pkgs = import ../../nixpkgs.nix {}; + + libC = pkgs.writeText "LibC.hs" '' + {-# language NoImplicitPrelude #-} + module LibC where + + data LibCType = LibCType + + -- | myfunction + mytype :: LibCType + mytype = LibCType + ''; + + cabal = pkgs.writeText "libc.cabal" '' + name: libc + version: 0.1.0.0 + build-type: Simple + cabal-version: >=1.10 + + library + default-language: Haskell2010 + exposed-modules: LibC + ''; + + src = pkgs.runCommand "libc-src" {} '' + mkdir $out + cp ${libC} $out/LibC.hs + cp ${cabal} $out/libc.cabal + ''; + +in + # This call means the `.haddock` file is not generated, + # even though the ghc package still references the location + # where it would ordinarily be. + pkgs.haskell.lib.dontHaddock + + (self.callPackage + ({ mkDerivation }: mkDerivation { + pname = "libc"; + version = "0.1.0.0"; + src = src; + license = pkgs.lib.licenses.mit; + isExecutable = false; + }) {}) diff --git a/third_party/bazel/rules_haskell/tests/haddock/unicode.txt b/third_party/bazel/rules_haskell/tests/haddock/unicode.txt new file mode 100644 index 000000000000..74e5f2638d08 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/haddock/unicode.txt @@ -0,0 +1 @@ +ะะตะบะพัะพััะน ัะตะบัั ะฝะฐ ััััะบะพะผ. diff --git a/third_party/bazel/rules_haskell/tests/haskell_doctest/BUILD.bazel b/third_party/bazel/rules_haskell/tests/haskell_doctest/BUILD.bazel new file mode 100644 index 000000000000..c1d4e527aefc --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/haskell_doctest/BUILD.bazel @@ -0,0 +1,73 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_doctest", + "haskell_library", + "haskell_test", +) + +package(default_testonly = 1) + +haskell_library( + name = "lib-a", + srcs = ["Foo.hs"], + tags = ["requires_zlib"], + deps = [ + "//tests/data:ourclibrary", + "//tests/hackage:base", + "@zlib.dev//:zlib", + ], +) + +haskell_library( + name = "lib-b", + srcs = [ + "Bar.hs", + "Baz.hs", + "Quux.hsc", + ], + tags = ["requires_zlib"], + deps = [ + ":lib-a", + "//tests/hackage:base", + ], +) + +haskell_doctest( + name = "doctest-lib-all-fail", + tags = ["manual"], # must FAIL + visibility = ["//visibility:public"], + deps = [":lib-b"], +) + +haskell_doctest( + name = "doctest-lib-all-success", + doctest_flags = ["-DMAGIC_DOCTEST_THING"], + tags = ["requires_doctest"], + visibility = ["//visibility:public"], + deps = [":lib-b"], +) + +haskell_doctest( + name = "doctest-lib", + modules = ["Bar"], # exclude Baz and succeed + tags = ["requires_doctest"], + visibility = ["//visibility:public"], + deps = [":lib-b"], +) + +haskell_test( + name = "bin", + srcs = ["Main.hs"], + tags = ["requires_zlib"], + deps = [ + ":lib-a", + "//tests/hackage:base", + ], +) + +haskell_doctest( + name = "doctest-bin", + tags = ["requires_doctest"], + visibility = ["//visibility:public"], + deps = [":bin"], +) diff --git a/third_party/bazel/rules_haskell/tests/haskell_doctest/Bar.hs b/third_party/bazel/rules_haskell/tests/haskell_doctest/Bar.hs new file mode 100644 index 000000000000..cd82351855c3 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/haskell_doctest/Bar.hs @@ -0,0 +1,13 @@ +module Bar (bar) where + +import Foo (foo) +import Numeric + +-- | +-- >>> bar +-- 9 +-- >>> showInt bar "" ++ "!" +-- "9!" + +bar :: Int +bar = 4 + foo diff --git a/third_party/bazel/rules_haskell/tests/haskell_doctest/Baz.hs b/third_party/bazel/rules_haskell/tests/haskell_doctest/Baz.hs new file mode 100644 index 000000000000..d576235bf488 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/haskell_doctest/Baz.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE CPP #-} + +module Baz (baz) where + +-- | +-- >>> baz +-- 101 + +baz :: Int +#ifndef MAGIC_DOCTEST_THING +baz = 100 +#else +baz = 101 +#endif diff --git a/third_party/bazel/rules_haskell/tests/haskell_doctest/Foo.hs b/third_party/bazel/rules_haskell/tests/haskell_doctest/Foo.hs new file mode 100644 index 000000000000..d2c97b77aeb3 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/haskell_doctest/Foo.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module Foo (foo) where + +import Foreign.C.Types (CInt(..)) + +foreign import ccall "c_add_one" + c_add_one :: CInt -> CInt + +-- | +-- >>> foo +-- 5 +foo :: Int +foo = fromIntegral (c_add_one 4) diff --git a/third_party/bazel/rules_haskell/tests/haskell_doctest/Main.hs b/third_party/bazel/rules_haskell/tests/haskell_doctest/Main.hs new file mode 100644 index 000000000000..1bc6f8abc905 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/haskell_doctest/Main.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Foo (foo) + +main :: IO () +main = print foo diff --git a/third_party/bazel/rules_haskell/tests/haskell_doctest/Quux.hsc b/third_party/bazel/rules_haskell/tests/haskell_doctest/Quux.hsc new file mode 100644 index 000000000000..3d437274c9aa --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/haskell_doctest/Quux.hsc @@ -0,0 +1,11 @@ +-- | This module is in a .hsc file, this way we test that improt directories +-- are passed correctly to the doctest executable. + +module Quux (quux) where + +-- | +-- >>> quux +-- 68 + +quux :: Int +quux = 68 diff --git a/third_party/bazel/rules_haskell/tests/haskell_lint/BUILD.bazel b/third_party/bazel/rules_haskell/tests/haskell_lint/BUILD.bazel new file mode 100644 index 000000000000..702dfdfe07bc --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/haskell_lint/BUILD.bazel @@ -0,0 +1,47 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", + "haskell_lint", + "haskell_test", +) + +package(default_testonly = 1) + +haskell_library( + name = "lib-a", + srcs = ["Foo.hs"], + visibility = ["//visibility:public"], + deps = ["//tests/hackage:base"], +) + +haskell_library( + name = "lib-b", + srcs = ["Bar.hs"], + visibility = ["//visibility:public"], + deps = [ + ":lib-a", + "//tests/hackage:base", + ], +) + +haskell_lint( + name = "lint-lib-b", + visibility = ["//visibility:public"], + deps = [":lib-b"], +) + +haskell_test( + name = "bin", + srcs = ["Main.hs"], + visibility = ["//visibility:public"], + deps = [ + ":lib-a", + "//tests/hackage:base", + ], +) + +haskell_lint( + name = "lint-bin", + visibility = ["//visibility:public"], + deps = [":bin"], +) diff --git a/third_party/bazel/rules_haskell/tests/haskell_lint/Bar.hs b/third_party/bazel/rules_haskell/tests/haskell_lint/Bar.hs new file mode 100644 index 000000000000..18e9583e5ad6 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/haskell_lint/Bar.hs @@ -0,0 +1,6 @@ +module Bar (bar) where + +import Foo (foo) + +bar :: Int +bar = 4 + foo :: Int diff --git a/third_party/bazel/rules_haskell/tests/haskell_lint/Foo.hs b/third_party/bazel/rules_haskell/tests/haskell_lint/Foo.hs new file mode 100644 index 000000000000..119192e6b12b --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/haskell_lint/Foo.hs @@ -0,0 +1,4 @@ +module Foo (foo) where + +foo :: Int +foo = 5 :: Int diff --git a/third_party/bazel/rules_haskell/tests/haskell_lint/Main.hs b/third_party/bazel/rules_haskell/tests/haskell_lint/Main.hs new file mode 100644 index 000000000000..1bc6f8abc905 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/haskell_lint/Main.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Foo (foo) + +main :: IO () +main = print foo diff --git a/third_party/bazel/rules_haskell/tests/haskell_proto_library/BUILD.bazel b/third_party/bazel/rules_haskell/tests/haskell_proto_library/BUILD.bazel new file mode 100644 index 000000000000..f5f8762b3aff --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/haskell_proto_library/BUILD.bazel @@ -0,0 +1,78 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_doc", + "haskell_library", + "haskell_proto_library", +) + +package(default_testonly = 1) + +proto_library( + name = "zip_code_proto", + srcs = ["zip_code.proto"], +) + +proto_library( + name = "address_proto", + srcs = ["address.proto"], + deps = [":zip_code_proto"], +) + +proto_library( + name = "person_proto", + srcs = ["person.proto"], + deps = [ + ":address_proto", + "@com_google_protobuf//:timestamp_proto", + ], +) + +proto_library( + name = "stripped_zip_code_proto", + srcs = ["stripped_zip_code.proto"], + strip_import_prefix = "/tests/haskell_proto_library/", +) + +proto_library( + name = "stripped_address_proto", + srcs = ["stripped_address.proto"], + strip_import_prefix = "/tests/haskell_proto_library/", + deps = [":stripped_zip_code_proto"], +) + +haskell_proto_library( + name = "address_haskell_proto", + tags = ["requires_hackage"], + deps = [":address_proto"], +) + +haskell_proto_library( + name = "stripped_address_haskell_proto", + tags = ["requires_hackage"], + deps = [":stripped_address_proto"], +) + +haskell_proto_library( + name = "person_haskell_proto", + tags = ["requires_hackage"], + deps = [":person_proto"], +) + +haskell_library( + name = "hs-lib", + srcs = ["Bar.hs"], + tags = ["requires_hackage"], + visibility = ["//visibility:public"], + deps = [ + ":address_haskell_proto", + ":person_haskell_proto", + ":stripped_address_haskell_proto", + "//tests/hackage:base", + ], +) + +haskell_doc( + name = "docs", + tags = ["requires_hackage"], + deps = [":hs-lib"], +) diff --git a/third_party/bazel/rules_haskell/tests/haskell_proto_library/Bar.hs b/third_party/bazel/rules_haskell/tests/haskell_proto_library/Bar.hs new file mode 100644 index 000000000000..fa95bf088c91 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/haskell_proto_library/Bar.hs @@ -0,0 +1,8 @@ +module Bar (bar) where + +import Proto.StrippedAddress +import Proto.Tests.HaskellProtoLibrary.Person +import Proto.Tests.HaskellProtoLibrary.Person_Fields + +bar :: Int +bar = 5 diff --git a/third_party/bazel/rules_haskell/tests/haskell_proto_library/address.proto b/third_party/bazel/rules_haskell/tests/haskell_proto_library/address.proto new file mode 100644 index 000000000000..d81642d8bcd4 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/haskell_proto_library/address.proto @@ -0,0 +1,11 @@ +syntax = "proto3"; + +package demo; // Required to generate valid code. + +// Always import protos with a full path relative to the WORKSPACE file. +import "tests/haskell_proto_library/zip_code.proto"; + +message Address { + string city = 1; + ZipCode zip_code = 2; +} diff --git a/third_party/bazel/rules_haskell/tests/haskell_proto_library/person.proto b/third_party/bazel/rules_haskell/tests/haskell_proto_library/person.proto new file mode 100644 index 000000000000..95bf3524f819 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/haskell_proto_library/person.proto @@ -0,0 +1,16 @@ +syntax = "proto3"; + +package demo; // Required to generate valid code. + +// Always import protos with a full path relative to the WORKSPACE file. +import "tests/haskell_proto_library/address.proto"; + +import "google/protobuf/timestamp.proto"; + +message Person { + string name = 1; + int32 id = 2; + string email = 3; + Address address = 4; + google.protobuf.Timestamp timestamp = 5; +} diff --git a/third_party/bazel/rules_haskell/tests/haskell_proto_library/stripped_address.proto b/third_party/bazel/rules_haskell/tests/haskell_proto_library/stripped_address.proto new file mode 100644 index 000000000000..5b5ce47be83a --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/haskell_proto_library/stripped_address.proto @@ -0,0 +1,10 @@ +syntax = "proto3"; + +package demo; // Required to generate valid code. + +import "stripped_zip_code.proto"; + +message StrippedAddress { + string city = 1; + StrippedZipCode zip_code = 2; +} diff --git a/third_party/bazel/rules_haskell/tests/haskell_proto_library/stripped_zip_code.proto b/third_party/bazel/rules_haskell/tests/haskell_proto_library/stripped_zip_code.proto new file mode 100644 index 000000000000..690d7c9d99cc --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/haskell_proto_library/stripped_zip_code.proto @@ -0,0 +1,7 @@ +syntax = "proto3"; + +package demo; // Required to generate valid code. + +message StrippedZipCode { + string code = 1; +} diff --git a/third_party/bazel/rules_haskell/tests/haskell_proto_library/zip_code.proto b/third_party/bazel/rules_haskell/tests/haskell_proto_library/zip_code.proto new file mode 100644 index 000000000000..e72578cf2178 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/haskell_proto_library/zip_code.proto @@ -0,0 +1,7 @@ +syntax = "proto3"; + +package demo; // Required to generate valid code. + +message ZipCode { + string code = 1; +} diff --git a/third_party/bazel/rules_haskell/tests/haskell_test/BUILD.bazel b/third_party/bazel/rules_haskell/tests/haskell_test/BUILD.bazel new file mode 100644 index 000000000000..eb00b2c31881 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/haskell_test/BUILD.bazel @@ -0,0 +1,29 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", + "haskell_test", +) + +package(default_testonly = 1) + +haskell_library( + name = "mylib", + srcs = ["Lib.hs"], + deps = ["//tests/hackage:base"], +) + +haskell_test( + name = "haskell_test", + # Use some parameters that only test rules have. + size = "small", + timeout = "short", + srcs = ["Test.hs"], + flaky = False, + main_function = "Test.test", + visibility = ["//visibility:public"], + deps = [ + ":mylib", + "//tests/data:ourclibrary", + "//tests/hackage:base", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/haskell_test/Lib.hs b/third_party/bazel/rules_haskell/tests/haskell_test/Lib.hs new file mode 100644 index 000000000000..3553d6b6f493 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/haskell_test/Lib.hs @@ -0,0 +1,4 @@ +module Lib where + +foo :: Int +foo = 42 diff --git a/third_party/bazel/rules_haskell/tests/haskell_test/Test.hs b/third_party/bazel/rules_haskell/tests/haskell_test/Test.hs new file mode 100644 index 000000000000..5ba65f82c94b --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/haskell_test/Test.hs @@ -0,0 +1,4 @@ +module Test (test) where + +test :: IO () +test = putStrLn "haskell_test fired" diff --git a/third_party/bazel/rules_haskell/tests/haskell_toolchain_library/BUILD.bazel b/third_party/bazel/rules_haskell/tests/haskell_toolchain_library/BUILD.bazel new file mode 100644 index 000000000000..6c36ce4bdbf1 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/haskell_toolchain_library/BUILD.bazel @@ -0,0 +1,26 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", + "haskell_test", +) + +package(default_testonly = 1) + +haskell_library( + name = "Lib", + srcs = ["Lib.hs"], + deps = [ + "//tests/hackage:base", + "//tests/hackage:bytestring", + ], +) + +haskell_test( + name = "binary", + srcs = ["Bin.hs"], + deps = [ + ":Lib", + "//tests/hackage:base", + "//tests/hackage:text", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/haskell_toolchain_library/Bin.hs b/third_party/bazel/rules_haskell/tests/haskell_toolchain_library/Bin.hs new file mode 100644 index 000000000000..a0e7117d2e22 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/haskell_toolchain_library/Bin.hs @@ -0,0 +1,8 @@ +module Main (main) where + +import qualified Data.Text.IO as T +import qualified Data.Text.Encoding as E + +import Lib (message) + +main = T.putStrLn $ E.decodeUtf8 message diff --git a/third_party/bazel/rules_haskell/tests/haskell_toolchain_library/Lib.hs b/third_party/bazel/rules_haskell/tests/haskell_toolchain_library/Lib.hs new file mode 100644 index 000000000000..66a2161a19c4 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/haskell_toolchain_library/Lib.hs @@ -0,0 +1,5 @@ +module Lib (message) where + +import qualified Data.ByteString.Char8 as B + +message = B.pack "hello, world" diff --git a/third_party/bazel/rules_haskell/tests/hidden-modules/BUILD.bazel b/third_party/bazel/rules_haskell/tests/hidden-modules/BUILD.bazel new file mode 100644 index 000000000000..5d79e56085a2 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/hidden-modules/BUILD.bazel @@ -0,0 +1,35 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", +) + +package( + default_testonly = 1, + default_visibility = ["//visibility:public"], +) + +haskell_library( + name = "lib-a", + srcs = glob(["lib-a/*.hs"]), + hidden_modules = ["Foo"], + src_strip_prefix = "lib-a", + deps = ["//tests/hackage:base"], +) + +haskell_library( + name = "lib-b", + srcs = glob(["lib-b/*.hs"]), + src_strip_prefix = "lib-b", + deps = ["//tests/hackage:base"], +) + +haskell_library( + name = "lib-c", + srcs = glob(["lib-c/*.hs"]), + src_strip_prefix = "lib-c", + deps = [ + ":lib-a", + ":lib-b", + "//tests/hackage:base", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/hidden-modules/lib-a/Bar.hs b/third_party/bazel/rules_haskell/tests/hidden-modules/lib-a/Bar.hs new file mode 100644 index 000000000000..5bc9c68895bf --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/hidden-modules/lib-a/Bar.hs @@ -0,0 +1,6 @@ +module Bar (bar) where + +import Foo (foo) + +bar :: Int +bar = foo * 2 diff --git a/third_party/bazel/rules_haskell/tests/hidden-modules/lib-a/Foo.hs b/third_party/bazel/rules_haskell/tests/hidden-modules/lib-a/Foo.hs new file mode 100644 index 000000000000..664be00d5487 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/hidden-modules/lib-a/Foo.hs @@ -0,0 +1,4 @@ +module Foo (foo) where + +foo :: Int +foo = 15 diff --git a/third_party/bazel/rules_haskell/tests/hidden-modules/lib-b/Foo.hs b/third_party/bazel/rules_haskell/tests/hidden-modules/lib-b/Foo.hs new file mode 100644 index 000000000000..6fdd42f9a8cd --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/hidden-modules/lib-b/Foo.hs @@ -0,0 +1,4 @@ +module Foo (foo) where + +foo :: Int +foo = 16 diff --git a/third_party/bazel/rules_haskell/tests/hidden-modules/lib-c/Baz.hs b/third_party/bazel/rules_haskell/tests/hidden-modules/lib-c/Baz.hs new file mode 100644 index 000000000000..055b2e80ad79 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/hidden-modules/lib-c/Baz.hs @@ -0,0 +1,7 @@ +module Baz (bar) where + +import Foo (foo) +import Bar (bar) + +baz :: Int +baz = foo + bar diff --git a/third_party/bazel/rules_haskell/tests/hs-boot/A.hs-boot.in b/third_party/bazel/rules_haskell/tests/hs-boot/A.hs-boot.in new file mode 100644 index 000000000000..02d37ced950f --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/hs-boot/A.hs-boot.in @@ -0,0 +1,2 @@ +module A where + newtype TA = MkTA Int diff --git a/third_party/bazel/rules_haskell/tests/hs-boot/A.hs.in b/third_party/bazel/rules_haskell/tests/hs-boot/A.hs.in new file mode 100644 index 000000000000..deeff5470b77 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/hs-boot/A.hs.in @@ -0,0 +1,8 @@ +module A where + +import B (TB (..)) + +newtype TA = MkTA Int + +f :: TB -> TA +f (MkTB x) = MkTA x diff --git a/third_party/bazel/rules_haskell/tests/hs-boot/BUILD.bazel b/third_party/bazel/rules_haskell/tests/hs-boot/BUILD.bazel new file mode 100644 index 000000000000..4e69da0e6b34 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/hs-boot/BUILD.bazel @@ -0,0 +1,48 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", + "haskell_test", +) + +package(default_testonly = 1) + +genrule( + name = "gen-A-boot", + srcs = ["A.hs-boot.in"], + outs = ["srcs/A.hs-boot"], + cmd = "cp $< $@", +) + +genrule( + name = "gen-A", + srcs = ["A.hs.in"], + outs = ["srcs/A.hs"], + cmd = "cp $< $@", +) + +haskell_library( + name = "hs-boot-lib", + srcs = [ + "srcs/B.hs", + ":gen-A", + ":gen-A-boot", + ], + src_strip_prefix = "srcs", + visibility = ["//visibility:public"], + deps = ["//tests/hackage:base"], +) + +haskell_test( + name = "hs-boot", + srcs = [ + "MA.hs", + "MA.hs-boot", + "MB.hs", + "Main.hs", + ], + visibility = ["//visibility:public"], + deps = [ + ":hs-boot-lib", + "//tests/hackage:base", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/hs-boot/MA.hs b/third_party/bazel/rules_haskell/tests/hs-boot/MA.hs new file mode 100644 index 000000000000..4e0128596242 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/hs-boot/MA.hs @@ -0,0 +1,8 @@ +module MA where + +import MB (TB (..)) + +newtype TA = MkTA Int + +f :: TB -> TA +f (MkTB x) = MkTA x diff --git a/third_party/bazel/rules_haskell/tests/hs-boot/MA.hs-boot b/third_party/bazel/rules_haskell/tests/hs-boot/MA.hs-boot new file mode 100644 index 000000000000..0ab8c899f2e1 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/hs-boot/MA.hs-boot @@ -0,0 +1,2 @@ +module MA where + newtype TA = MkTA Int diff --git a/third_party/bazel/rules_haskell/tests/hs-boot/MB.hs b/third_party/bazel/rules_haskell/tests/hs-boot/MB.hs new file mode 100644 index 000000000000..d90d041d578e --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/hs-boot/MB.hs @@ -0,0 +1,8 @@ +module MB where + +import {-# SOURCE #-} MA (TA (..)) + +data TB = MkTB !Int + +g :: TA -> TB +g (MkTA x) = MkTB x diff --git a/third_party/bazel/rules_haskell/tests/hs-boot/Main.hs b/third_party/bazel/rules_haskell/tests/hs-boot/Main.hs new file mode 100644 index 000000000000..15c0085fe079 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/hs-boot/Main.hs @@ -0,0 +1,9 @@ +module Main (main) where + +import A () +import B () +import MA () +import MB () + +main :: IO () +main = putStrLn "hsboot" diff --git a/third_party/bazel/rules_haskell/tests/hs-boot/srcs/B.hs b/third_party/bazel/rules_haskell/tests/hs-boot/srcs/B.hs new file mode 100644 index 000000000000..60e1ff5f3edd --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/hs-boot/srcs/B.hs @@ -0,0 +1,8 @@ +module B where + +import {-# SOURCE #-} A (TA (..)) + +data TB = MkTB !Int + +g :: TA -> TB +g (MkTA x) = MkTB x diff --git a/third_party/bazel/rules_haskell/tests/hsc/BUILD.bazel b/third_party/bazel/rules_haskell/tests/hsc/BUILD.bazel new file mode 100644 index 000000000000..1e9a07cd5e08 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/hsc/BUILD.bazel @@ -0,0 +1,35 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", + "haskell_test", +) + +package(default_testonly = 1) + +haskell_library( + name = "hsc-lib", + srcs = [ + "Bar.hsc", + "Bar/Baz.hsc", + "Flags.hsc", + "Foo.hsc", + ], + compiler_flags = [ + "-DTHIS_IS_TRUE", + "-optP-DTHIS_TOO_IS_TRUE", + ], + deps = ["//tests/hackage:base"], +) + +haskell_test( + name = "hsc", + srcs = [ + "BinHsc.hsc", + "Main.hs", + ], + visibility = ["//visibility:public"], + deps = [ + ":hsc-lib", + "//tests/hackage:base", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/hsc/Bar.hsc b/third_party/bazel/rules_haskell/tests/hsc/Bar.hsc new file mode 100644 index 000000000000..a8bb791513b5 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/hsc/Bar.hsc @@ -0,0 +1,6 @@ +module Bar (hscFiredBar) where + +#ifndef _INTERNAL_HSC_DO_NOT_DEFINE_ME +hscFiredBar :: String +hscFiredBar = "hscFiredBar" +#endif diff --git a/third_party/bazel/rules_haskell/tests/hsc/Bar/Baz.hsc b/third_party/bazel/rules_haskell/tests/hsc/Bar/Baz.hsc new file mode 100644 index 000000000000..7db172485de5 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/hsc/Bar/Baz.hsc @@ -0,0 +1,6 @@ +module Bar.Baz (hscFiredBaz) where + +#ifndef _INTERNAL_HSC_DO_NOT_DEFINE_ME +hscFiredBaz :: String +hscFiredBaz = "hscFiredBaz" +#endif diff --git a/third_party/bazel/rules_haskell/tests/hsc/BinHsc.hsc b/third_party/bazel/rules_haskell/tests/hsc/BinHsc.hsc new file mode 100644 index 000000000000..ddfee79c137c --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/hsc/BinHsc.hsc @@ -0,0 +1 @@ +module BinHsc () where \ No newline at end of file diff --git a/third_party/bazel/rules_haskell/tests/hsc/Flags.hsc b/third_party/bazel/rules_haskell/tests/hsc/Flags.hsc new file mode 100644 index 000000000000..b090df576ab4 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/hsc/Flags.hsc @@ -0,0 +1,8 @@ +module Flags (hscFlags) where + +#ifdef THIS_IS_TRUE +#ifdef THIS_TOO_IS_TRUE +hscFlags :: String +hscFlags = "hscFlags" +#endif +#endif diff --git a/third_party/bazel/rules_haskell/tests/hsc/Foo.hsc b/third_party/bazel/rules_haskell/tests/hsc/Foo.hsc new file mode 100644 index 000000000000..2cb726e18110 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/hsc/Foo.hsc @@ -0,0 +1,8 @@ +module Foo (hscFiredFoo) where + +#if __GLASGOW_HASKELL__ >= 700 +#ifndef _INTERNAL_HSC_DO_NOT_DEFINE_ME +hscFiredFoo :: String +hscFiredFoo = "hscFiredFoo" +#endif +#endif diff --git a/third_party/bazel/rules_haskell/tests/hsc/Main.hs b/third_party/bazel/rules_haskell/tests/hsc/Main.hs new file mode 100644 index 000000000000..33ff7f10f78c --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/hsc/Main.hs @@ -0,0 +1,10 @@ +module Main (main) where + +import BinHsc () +import Foo (hscFiredFoo) +import Bar (hscFiredBar) +import Bar.Baz (hscFiredBaz) +import Flags (hscFlags) + +main :: IO () +main = putStrLn (hscFiredFoo ++ hscFiredBar ++ hscFiredBaz ++ hscFlags) diff --git a/third_party/bazel/rules_haskell/tests/indirect-link/BUILD.bazel b/third_party/bazel/rules_haskell/tests/indirect-link/BUILD.bazel new file mode 100644 index 000000000000..60403a4ef277 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/indirect-link/BUILD.bazel @@ -0,0 +1,52 @@ +load("@io_tweag_rules_haskell//haskell:haskell.bzl", "haskell_library", "haskell_test", "haskell_toolchain_library") + +cc_library( + name = "cbits-indirect", + srcs = ["cbits/impl.c"], +) + +cc_library( + name = "cbits", + srcs = ["cbits/intf.c"], + deps = ["cbits-indirect"], +) + +haskell_library( + name = "mypkg", + srcs = ["src/MyModule.hs"], + src_strip_prefix = "src", + deps = [ + ":cbits", + "//tests/hackage:base", + ], +) + +haskell_test( + name = "indirect-link-static", + srcs = ["test/Main.hs"], + linkstatic = True, + src_strip_prefix = "test", + deps = [ + ":mypkg", + "//tests/hackage:base", + ], +) + +haskell_test( + name = "indirect-link-dynamic", + srcs = ["test/Main.hs"], + linkstatic = False, + src_strip_prefix = "test", + deps = [ + ":mypkg", + "//tests/hackage:base", + ], +) + +test_suite( + name = "indirect-link", + tests = [ + ":indirect-link-dynamic", + ":indirect-link-static", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/indirect-link/cbits/impl.c b/third_party/bazel/rules_haskell/tests/indirect-link/cbits/impl.c new file mode 100644 index 000000000000..666ce43962a3 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/indirect-link/cbits/impl.c @@ -0,0 +1,9 @@ +static int thing; + +int real_get_thing(void) { + return thing; +} + +void real_set_thing(int value) { + thing = value; +} diff --git a/third_party/bazel/rules_haskell/tests/indirect-link/cbits/intf.c b/third_party/bazel/rules_haskell/tests/indirect-link/cbits/intf.c new file mode 100644 index 000000000000..f7a8f5e9f2e8 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/indirect-link/cbits/intf.c @@ -0,0 +1,10 @@ +extern int real_get_thing(void); +extern void real_set_thing(int value); + +int get_thing(void) { + return real_get_thing(); +} + +void set_thing(int value) { + real_set_thing(value); +} diff --git a/third_party/bazel/rules_haskell/tests/indirect-link/src/MyModule.hs b/third_party/bazel/rules_haskell/tests/indirect-link/src/MyModule.hs new file mode 100644 index 000000000000..4b75cee13989 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/indirect-link/src/MyModule.hs @@ -0,0 +1,11 @@ +module MyModule where + +foreign import ccall get_thing :: IO Int + +getThing :: IO Int +getThing = get_thing + +foreign import ccall set_thing :: Int -> IO () + +setThing :: Int -> IO () +setThing = set_thing diff --git a/third_party/bazel/rules_haskell/tests/indirect-link/test/Main.hs b/third_party/bazel/rules_haskell/tests/indirect-link/test/Main.hs new file mode 100644 index 000000000000..0b3d188d736a --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/indirect-link/test/Main.hs @@ -0,0 +1,9 @@ +module Main (main) where + +import qualified MyModule + +main :: IO () +main = do + print =<< MyModule.getThing + MyModule.setThing 123 + print =<< MyModule.getThing diff --git a/third_party/bazel/rules_haskell/tests/inline_tests.bzl b/third_party/bazel/rules_haskell/tests/inline_tests.bzl new file mode 100644 index 000000000000..b1ba001c6ec7 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/inline_tests.bzl @@ -0,0 +1,90 @@ +# features sh_inline_test and py_inline_test, +# which are like their respective builtin rules, +# but their scripts can be given inline as a string. + +load("@bazel_skylib//lib:shell.bzl", "shell") + +def quote_make_variables(s): + """Quote all genrule โMakeโ Variables in a string.""" + return s.replace("$", "$$") + +def target_from_string(name, string): + """Write a skylark string to a target.""" + native.genrule( + name = name + "-file", + outs = [name], + # this is exceptionally ugly. + cmd = """echo -n {quoted} > $(@)""".format( + # but should at least be quoted right + quoted = shell.quote(quote_make_variables(string)), + ), + ) + +bash_runfiles_boilerplate = """\ +# Copy-pasted from Bazel's Bash runfiles library (tools/bash/runfiles/runfiles.bash). +set -euo pipefail +if [[ ! -d "${RUNFILES_DIR:-/dev/null}" && ! -f "${RUNFILES_MANIFEST_FILE:-/dev/null}" ]]; then + if [[ -f "$0.runfiles_manifest" ]]; then + export RUNFILES_MANIFEST_FILE="$0.runfiles_manifest" + elif [[ -f "$0.runfiles/MANIFEST" ]]; then + export RUNFILES_MANIFEST_FILE="$0.runfiles/MANIFEST" + elif [[ -f "$0.runfiles/bazel_tools/tools/bash/runfiles/runfiles.bash" ]]; then + export RUNFILES_DIR="$0.runfiles" + fi +fi +if [[ -f "${RUNFILES_DIR:-/dev/null}/bazel_tools/tools/bash/runfiles/runfiles.bash" ]]; then + source "${RUNFILES_DIR}/bazel_tools/tools/bash/runfiles/runfiles.bash" +elif [[ -f "${RUNFILES_MANIFEST_FILE:-/dev/null}" ]]; then + source "$(grep -m1 "^bazel_tools/tools/bash/runfiles/runfiles.bash " \ + "$RUNFILES_MANIFEST_FILE" | cut -d ' ' -f 2-)" +else + echo >&2 "ERROR: cannot find @bazel_tools//tools/bash/runfiles:runfiles.bash" + exit 1 +fi +# --- end runfiles.bash initialization --- +""" + +def sh_inline_test(name, script, **kwargs): + """Like sh_test, but instead of srcs takes the shell script + as verbatim bazel string. The bash runfiles are in scope, + using `rlocation` works by default. + """ + script_name = name + ".sh" + script = bash_runfiles_boilerplate + script + + target_from_string(script_name, script) + + deps = kwargs.pop("deps", []) + + native.sh_test( + name = name, + srcs = [script_name], + deps = ["@bazel_tools//tools/bash/runfiles"] + deps, + **kwargs + ) + +python_runfiles_boilerplate = """ +from bazel_tools.tools.python.runfiles import runfiles +r = runfiles.Create() +""" + +def py_inline_test(name, script, **kwargs): + """Like py_test, but instead of srcs takes the shell script + as verbatim bazel string. The python runfiles are in scope + as the `r` variable. Use `r.Rlocation()` + """ + script_name = name + ".py" + script = python_runfiles_boilerplate + script + + target_from_string(script_name, script) + + deps = kwargs.pop("deps", []) + srcs = kwargs.pop("srcs", []) + + native.py_test( + name = name, + srcs = [script_name] + srcs, + main = script_name, + deps = ["@bazel_tools//tools/python/runfiles"] + deps, + **kwargs + ) diff --git a/third_party/bazel/rules_haskell/tests/java_classpath/BUILD.bazel b/third_party/bazel/rules_haskell/tests/java_classpath/BUILD.bazel new file mode 100644 index 000000000000..b2e5b86daeb9 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/java_classpath/BUILD.bazel @@ -0,0 +1,17 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_test", +) + +package(default_testonly = 1) + +haskell_test( + name = "java_classpath", + srcs = ["Main.hs"], + visibility = ["//visibility:public"], + deps = [ + "//tests/hackage:base", + "//tests/hackage:template-haskell", + "@org_apache_spark_spark_core_2_10//jar", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/java_classpath/Main.hs b/third_party/bazel/rules_haskell/tests/java_classpath/Main.hs new file mode 100644 index 000000000000..13f7b9d51684 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/java_classpath/Main.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TemplateHaskell #-} +module Main (main) where + +import qualified Language.Haskell.TH as TH (runIO) +import qualified Language.Haskell.TH.Syntax as TH (lift) +import System.Environment (lookupEnv) + +main :: IO () +main = putStrLn $( + let ensureClassPath :: IO String + ensureClassPath = lookupEnv "CLASSPATH" >>= \case + Nothing -> error "CLASSPATH not set when it was expected to be." + Just "" -> error "CLASSPATH empty when it was expected to have content." + Just cpath -> pure $ "java-classpath at compile time: " ++ cpath + in TH.runIO ensureClassPath >>= TH.lift + ) diff --git a/third_party/bazel/rules_haskell/tests/lhs/BUILD.bazel b/third_party/bazel/rules_haskell/tests/lhs/BUILD.bazel new file mode 100644 index 000000000000..e344ee6def1c --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/lhs/BUILD.bazel @@ -0,0 +1,23 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", + "haskell_test", +) + +package(default_testonly = 1) + +haskell_library( + name = "lhs-lib", + srcs = ["Lib.lhs"], + deps = ["//tests/hackage:base"], +) + +haskell_test( + name = "lhs-bin", + srcs = ["Main.lhs"], + visibility = ["//visibility:public"], + deps = [ + ":lhs-lib", + "//tests/hackage:base", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/lhs/Lib.lhs b/third_party/bazel/rules_haskell/tests/lhs/Lib.lhs new file mode 100644 index 000000000000..f37350df70f7 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/lhs/Lib.lhs @@ -0,0 +1,4 @@ +> module Lib (lib) where + +> lib :: String +> lib = "lhs" diff --git a/third_party/bazel/rules_haskell/tests/lhs/Main.lhs b/third_party/bazel/rules_haskell/tests/lhs/Main.lhs new file mode 100644 index 000000000000..a9e0659dddf5 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/lhs/Main.lhs @@ -0,0 +1,6 @@ +> module Main (main) where + +> import Lib (lib) + +> main :: IO () +> main = putStrLn lib diff --git a/third_party/bazel/rules_haskell/tests/library-deps/BUILD.bazel b/third_party/bazel/rules_haskell/tests/library-deps/BUILD.bazel new file mode 100644 index 000000000000..d6844e1ac120 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/library-deps/BUILD.bazel @@ -0,0 +1,28 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", + "haskell_test", +) + +package(default_testonly = 1) + +haskell_library( + name = "library-deps", + srcs = ["TestLib.hs"], + visibility = ["//visibility:public"], + deps = [ + "//tests/hackage:base", + "//tests/library-deps/sublib", + ], +) + +haskell_test( + name = "bin-deps", + size = "small", + srcs = ["Bin.hs"], + visibility = ["//visibility:public"], + deps = [ + "//tests/hackage:base", + "//tests/library-deps/sublib", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/library-deps/Bin.hs b/third_party/bazel/rules_haskell/tests/library-deps/Bin.hs new file mode 100644 index 000000000000..8d12d0bdd23f --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/library-deps/Bin.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import TestSubLib (messageEnd) + +main :: IO () +main = putStrLn $ messageEnd diff --git a/third_party/bazel/rules_haskell/tests/library-deps/TestLib.hs b/third_party/bazel/rules_haskell/tests/library-deps/TestLib.hs new file mode 100644 index 000000000000..fe917fecf3b7 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/library-deps/TestLib.hs @@ -0,0 +1,9 @@ +module TestLib (testMessage) where + +import TestSubLib (messageEnd) + +testMessage :: String +testMessage = "hello " ++ messageEnd + +-- Force dynamic linking +{-# ANN testMessage () #-} diff --git a/third_party/bazel/rules_haskell/tests/library-deps/sublib/BUILD.bazel b/third_party/bazel/rules_haskell/tests/library-deps/sublib/BUILD.bazel new file mode 100644 index 000000000000..5f3028e2e02c --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/library-deps/sublib/BUILD.bazel @@ -0,0 +1,21 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", +) + +package(default_testonly = 1) + +haskell_library( + name = "sublib", + srcs = ["TestSubLib.hs"], + visibility = ["//visibility:public"], + deps = [ + ":sublib-c", + "//tests/hackage:base", + ], +) + +cc_library( + name = "sublib-c", + srcs = ["sublib-c.c"], +) diff --git a/third_party/bazel/rules_haskell/tests/library-deps/sublib/TestSubLib.hs b/third_party/bazel/rules_haskell/tests/library-deps/sublib/TestSubLib.hs new file mode 100644 index 000000000000..1e8d2d475552 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/library-deps/sublib/TestSubLib.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module TestSubLib (messageEnd) where + +messageEnd :: String +messageEnd = "world " ++ show (foo 10) + +foreign import ccall foo :: Int -> Int diff --git a/third_party/bazel/rules_haskell/tests/library-deps/sublib/sublib-c.c b/third_party/bazel/rules_haskell/tests/library-deps/sublib/sublib-c.c new file mode 100644 index 000000000000..2f3be3eb9ed7 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/library-deps/sublib/sublib-c.c @@ -0,0 +1,3 @@ +int foo(int x) { + return x * 2; +} diff --git a/third_party/bazel/rules_haskell/tests/library-exports/BUILD.bazel b/third_party/bazel/rules_haskell/tests/library-exports/BUILD.bazel new file mode 100644 index 000000000000..c88e68ebbee4 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/library-exports/BUILD.bazel @@ -0,0 +1,41 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", + "haskell_test", +) + +package(default_testonly = 1) + +haskell_library( + name = "sublib", + srcs = ["TestSubLib.hs"], + exports = {"//tests/hackage:containers": "Data.Map as SubLib.Map"}, + deps = [ + "//tests/hackage:base", + "//tests/hackage:containers", + ], +) + +haskell_library( + name = "lib", + srcs = ["TestLib.hs"], + exports = { + ":sublib": "TestSubLib", + "//tests/hackage:containers": "Data.Map as Lib.Map", + }, + deps = [ + ":sublib", + "//tests/hackage:base", + ], +) + +haskell_test( + name = "library-exports", + size = "small", + srcs = ["Bin.hs"], + visibility = ["//visibility:public"], + deps = [ + ":lib", + "//tests/hackage:base", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/library-exports/Bin.hs b/third_party/bazel/rules_haskell/tests/library-exports/Bin.hs new file mode 100644 index 000000000000..b724bb89d1c2 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/library-exports/Bin.hs @@ -0,0 +1,7 @@ +module Main (main) where + +import TestSubLib (messageEnd) +import Lib.Map + +main :: IO () +main = print $ Lib.Map.singleton 1 messageEnd diff --git a/third_party/bazel/rules_haskell/tests/library-exports/TestLib.hs b/third_party/bazel/rules_haskell/tests/library-exports/TestLib.hs new file mode 100644 index 000000000000..c889c2cc31ac --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/library-exports/TestLib.hs @@ -0,0 +1,7 @@ +module TestLib (testMessage) where + +import TestSubLib (messageEnd) +import SubLib.Map + +testMessage :: String +testMessage = "hello " ++ messageEnd diff --git a/third_party/bazel/rules_haskell/tests/library-exports/TestSubLib.hs b/third_party/bazel/rules_haskell/tests/library-exports/TestSubLib.hs new file mode 100644 index 000000000000..2e1f3f983f40 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/library-exports/TestSubLib.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module TestSubLib (messageEnd) where + +messageEnd :: String +messageEnd = "world" diff --git a/third_party/bazel/rules_haskell/tests/library-linkstatic-flag/BUILD.bazel b/third_party/bazel/rules_haskell/tests/library-linkstatic-flag/BUILD.bazel new file mode 100644 index 000000000000..0b7cae3d7a65 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/library-linkstatic-flag/BUILD.bazel @@ -0,0 +1,112 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", +) +load("//tests:inline_tests.bzl", "sh_inline_test") +load(":get_library_files.bzl", "get_libraries_as_runfiles") + +# test whether `linkstatic` works as expected +package(default_testonly = 1) + +# only .a files +haskell_library( + name = "library-static-only", + srcs = ["Lib.hs"], + linkstatic = True, # <-- + visibility = ["//visibility:public"], + deps = [ + "//tests/hackage:base", + "//tests/hackage:bytestring", + ], +) + +# both .a and .so files +haskell_library( + name = "library-static-and-dynamic", + srcs = ["Lib.hs"], + linkstatic = False, # <-- + visibility = ["//visibility:public"], + deps = [ + "//tests/hackage:base", + "//tests/hackage:bytestring", + ], +) + +# extract all libraries from the haskell_library +get_libraries_as_runfiles( + name = "library-static-only-libraries", + library = ":library-static-only", +) + +get_libraries_as_runfiles( + name = "library-static-and-dynamic-libraries", + library = ":library-static-and-dynamic", +) + +# sh_testโs `data` doesnโt add stuff to runfiles :( +# sh_library can bundle different targets as runfiles for sh_test +# TODO(Profpatsch): add functionality to sh_inline_test by default? +sh_library( + name = "bundled-dependency-files-static-only", + data = [":library-static-only-libraries"], +) + +sh_library( + name = "bundled-dependency-files-static-and-dynamic", + data = [":library-static-and-dynamic-libraries"], +) + +# ensure that linkstatic=True only creates only .a, no .so +sh_inline_test( + name = "library-linkstatic-flag", + size = "small", + # pass the file names as arguments + args = ["$(rootpaths :library-static-only-libraries)"], + data = [ + # for rootpaths + ":library-static-only-libraries", + # to actually get the files โฆ + ":bundled-dependency-files-static-only", + ], + script = """ +set -euo pipefail +for f in "$@"; do + if ! [[ "$f" =~ .a$ ]]; then + echo "not a static library: $f" + exit 1 + fi +done +""", +) + +# test whether .so is linked dynamically and .a statically +sh_inline_test( + name = "test-libraries-static-and-dynamic", + size = "small", + # pass the file names as arguments + args = ["$(rootpaths :library-static-and-dynamic-libraries)"], + data = [ + # for rootpaths + ":library-static-and-dynamic-libraries", + # to actually get the files โฆ + ":bundled-dependency-files-static-and-dynamic", + ], + script = """ +set -euo pipefail +is_dynamic () { + # taken from https://github.com/NixOS/nixpkgs/blob/0b3f50f844e2a6b507b18d7c5259bb850b382f87/pkgs/build-support/setup-hooks/auto-patchelf.sh#L167-L170 + readelf -l -- "$1" | grep -q "^ *INTERP\\>" +} + +for f in "$@"; do + if [[ "$f" =~ .a$ ]] && is_dynamic "$f"; then + echo "should be a static executable: $f" + exit 1 + fi + if [[ "$f" =~ .so$ ]] && ! is_dynamic "$f"; then + echo "should be a dynamic executable: $f" + exit 1 + fi +done +""", +) diff --git a/third_party/bazel/rules_haskell/tests/library-linkstatic-flag/Lib.hs b/third_party/bazel/rules_haskell/tests/library-linkstatic-flag/Lib.hs new file mode 100644 index 000000000000..66a2161a19c4 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/library-linkstatic-flag/Lib.hs @@ -0,0 +1,5 @@ +module Lib (message) where + +import qualified Data.ByteString.Char8 as B + +message = B.pack "hello, world" diff --git a/third_party/bazel/rules_haskell/tests/library-linkstatic-flag/Main.hs b/third_party/bazel/rules_haskell/tests/library-linkstatic-flag/Main.hs new file mode 100644 index 000000000000..2048dbdecd9a --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/library-linkstatic-flag/Main.hs @@ -0,0 +1,3 @@ +module Main where + +main = putStrLn "hello world" diff --git a/third_party/bazel/rules_haskell/tests/library-linkstatic-flag/get_library_files.bzl b/third_party/bazel/rules_haskell/tests/library-linkstatic-flag/get_library_files.bzl new file mode 100644 index 000000000000..31702bfcfa07 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/library-linkstatic-flag/get_library_files.bzl @@ -0,0 +1,28 @@ +load( + "@io_tweag_rules_haskell//haskell:providers.bzl", + "HaskellInfo", + "HaskellLibraryInfo", +) +load("//haskell:private/set.bzl", "set") + +def _get_libraries_as_runfiles_impl(ctx): + """Extract all library files from a haskell_library target + and put them in this targetโs files""" + bi = ctx.attr.library[HaskellInfo] + return [DefaultInfo( + # not necessarily complete + files = depset( + direct = bi.static_libraries, + transitive = [set.to_depset(bi.dynamic_libraries)], + ), + )] + +get_libraries_as_runfiles = rule( + _get_libraries_as_runfiles_impl, + attrs = { + "library": attr.label( + mandatory = True, + providers = [HaskellInfo, HaskellLibraryInfo], + ), + }, +) diff --git a/third_party/bazel/rules_haskell/tests/library-with-cbits/AddOne.hsc b/third_party/bazel/rules_haskell/tests/library-with-cbits/AddOne.hsc new file mode 100644 index 000000000000..b4c446d412c7 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/library-with-cbits/AddOne.hsc @@ -0,0 +1,3 @@ +module AddOne where + +foreign import ccall "c_add_one" addOne :: Int -> Int diff --git a/third_party/bazel/rules_haskell/tests/library-with-cbits/AddOne2.hs b/third_party/bazel/rules_haskell/tests/library-with-cbits/AddOne2.hs new file mode 100644 index 000000000000..f2088f1c6600 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/library-with-cbits/AddOne2.hs @@ -0,0 +1,7 @@ +module AddOne2 + ( addOne2 + ) where + +import AddOne + +addOne2 = addOne diff --git a/third_party/bazel/rules_haskell/tests/library-with-cbits/BUILD.bazel b/third_party/bazel/rules_haskell/tests/library-with-cbits/BUILD.bazel new file mode 100644 index 000000000000..c320502ebf3f --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/library-with-cbits/BUILD.bazel @@ -0,0 +1,36 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", + "haskell_toolchain_library", +) + +haskell_library( + name = "library-with-cbits", + srcs = ["AddOne.hsc"], + linkstatic = False, + visibility = ["//visibility:public"], + deps = [ + "//tests/data:ourclibrary", + "//tests/hackage:base", + ], +) + +haskell_library( + name = "library-with-cbits-indirect", + srcs = ["AddOne2.hs"], + visibility = ["//visibility:public"], + deps = [ + ":library-with-cbits", + "//tests/hackage:base", + ], +) + +haskell_library( + name = "library-with-cbits-static", + srcs = ["AddOne.hsc"], + visibility = ["//visibility:public"], + deps = [ + "//tests/data:ourclibrary-static", + "//tests/hackage:base", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/library-with-includes/BUILD.bazel b/third_party/bazel/rules_haskell/tests/library-with-includes/BUILD.bazel new file mode 100644 index 000000000000..37b5a2ee986e --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/library-with-includes/BUILD.bazel @@ -0,0 +1,29 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", +) + +package(default_testonly = 1) + +genrule( + name = "gen-a", + outs = ["a.h"], + cmd = "echo '#define A 42' >> $@", +) + +cc_library( + name = "clib", + hdrs = [ + "b.h", + ":gen-a", + ], +) + +haskell_library( + name = "library-with-includes", + srcs = ["Lib.hs"], + deps = [ + ":clib", + "//tests/hackage:base", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/library-with-includes/Lib.hs b/third_party/bazel/rules_haskell/tests/library-with-includes/Lib.hs new file mode 100644 index 000000000000..1ca98d615c4a --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/library-with-includes/Lib.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE CPP #-} +module Lib (x) where + +#include "tests/library-with-includes/a.h" +#include "tests/library-with-includes/b.h" + +x :: Int +x = A + B diff --git a/third_party/bazel/rules_haskell/tests/library-with-includes/b.h b/third_party/bazel/rules_haskell/tests/library-with-includes/b.h new file mode 100644 index 000000000000..3425137bf9cf --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/library-with-includes/b.h @@ -0,0 +1 @@ +#define B 17 diff --git a/third_party/bazel/rules_haskell/tests/library-with-sysdeps/BUILD.bazel b/third_party/bazel/rules_haskell/tests/library-with-sysdeps/BUILD.bazel new file mode 100644 index 000000000000..0e34f688fd69 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/library-with-sysdeps/BUILD.bazel @@ -0,0 +1,32 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", + "haskell_test", +) + +package(default_testonly = 1) + +haskell_library( + name = "library-with-sysdeps", + srcs = ["Lib.hs"], + tags = ["requires_zlib"], + visibility = ["//visibility:public"], + deps = [ + "//tests/hackage:base", + "@zlib", + ], +) + +haskell_test( + name = "bin", + srcs = ["Main.hs"], + expected_covered_expressions_percentage = 100, + tags = [ + "coverage-compatible", + "requires_zlib", + ], + deps = [ + ":library-with-sysdeps", + "//tests/hackage:base", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/library-with-sysdeps/Lib.hs b/third_party/bazel/rules_haskell/tests/library-with-sysdeps/Lib.hs new file mode 100644 index 000000000000..771dd7faf10f --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/library-with-sysdeps/Lib.hs @@ -0,0 +1,8 @@ +module Lib (crc) where + +import Foreign.Ptr +import Foreign.C.Types + +foreign import ccall crc32 :: CLong -> Ptr () -> CInt -> IO () + +crc = crc32 0 nullPtr 0 diff --git a/third_party/bazel/rules_haskell/tests/library-with-sysdeps/Main.hs b/third_party/bazel/rules_haskell/tests/library-with-sysdeps/Main.hs new file mode 100644 index 000000000000..b892de88c4a7 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/library-with-sysdeps/Main.hs @@ -0,0 +1,5 @@ +module Main where + +import Lib (crc) + +main = crc diff --git a/third_party/bazel/rules_haskell/tests/library-with-sysincludes/BUILD.bazel b/third_party/bazel/rules_haskell/tests/library-with-sysincludes/BUILD.bazel new file mode 100644 index 000000000000..ddd5de65198c --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/library-with-sysincludes/BUILD.bazel @@ -0,0 +1,86 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", +) + +package(default_testonly = 1) + +genrule( + name = "genrule-header", + outs = [ + "include/foo.h", + ], + cmd = "touch $(location include/foo.h)", +) + +# A locally-defined replica of @zlib.dev//:zlib. +# Since that shared library lives in another package, we must +# use an absolute path for strip_include_prefix. +cc_library( + name = "zlib", + hdrs = ["@zlib.dev//:include"], + strip_include_prefix = "/external/zlib.dev/include", + tags = ["requires_zlib"], + deps = ["@zlib"], +) + +cc_library( + name = "zlib-with-genrule-header", + hdrs = [":genrule-header"], + strip_include_prefix = "include", + tags = ["requires_zlib"], +) + +haskell_library( + name = "intermediate-library", + srcs = ["IntLib.hsc"], + tags = ["requires_zlib"], + deps = [ + ":zlib", + ":zlib-with-genrule-header", + "//tests/hackage:base", + ], +) + +haskell_library( + name = "library-with-sysincludes", + srcs = [ + "Lib.hs", + "TH.hs", + ], + tags = ["requires_zlib"], + visibility = ["//visibility:public"], + deps = [ + ":intermediate-library", + "//tests/hackage:base", + "//tests/hackage:template-haskell", + ], +) + +# Replicate the above example, but use the externally-defined +# cc_library rule. +haskell_library( + name = "intermediate-library-other", + srcs = ["IntLib.hsc"], + tags = ["requires_zlib"], + deps = [ + ":zlib-with-genrule-header", + "//tests/hackage:base", + "@zlib.dev//:zlib", + ], +) + +haskell_library( + name = "library-with-sysincludes-other", + srcs = [ + "Lib.hs", + "TH.hs", + ], + tags = ["requires_zlib"], + visibility = ["//visibility:public"], + deps = [ + ":intermediate-library-other", + "//tests/hackage:base", + "//tests/hackage:template-haskell", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/library-with-sysincludes/IntLib.hsc b/third_party/bazel/rules_haskell/tests/library-with-sysincludes/IntLib.hsc new file mode 100644 index 000000000000..cf31e3d9a844 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/library-with-sysincludes/IntLib.hsc @@ -0,0 +1,15 @@ +{-# LANGUAGE CPP #-} + +module IntLib (crc) where + +import Foreign.Ptr +import Foreign.C.Types + +#include <zlib.h> +#include "foo.h" + +foreign import ccall crc32 :: CLong -> Ptr () -> CInt -> IO () + +crc = crc32 0 nullPtr 0 + +z = #{size struct gz_header_s} diff --git a/third_party/bazel/rules_haskell/tests/library-with-sysincludes/Lib.hs b/third_party/bazel/rules_haskell/tests/library-with-sysincludes/Lib.hs new file mode 100644 index 000000000000..55b1860fdddd --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/library-with-sysincludes/Lib.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Lib (bar) where + +import TH (foo) + +bar :: IO () +bar = $foo diff --git a/third_party/bazel/rules_haskell/tests/library-with-sysincludes/TH.hs b/third_party/bazel/rules_haskell/tests/library-with-sysincludes/TH.hs new file mode 100644 index 000000000000..45929ec84040 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/library-with-sysincludes/TH.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskell #-} + +module TH (foo) where + +import IntLib (crc) +import Language.Haskell.TH + +foo :: Q Exp +foo = [| crc |] diff --git a/third_party/bazel/rules_haskell/tests/multi_repl/BUILD.bazel b/third_party/bazel/rules_haskell/tests/multi_repl/BUILD.bazel new file mode 100644 index 000000000000..b2edce37ab0f --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/multi_repl/BUILD.bazel @@ -0,0 +1,16 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_repl", +) + +haskell_repl( + name = "c_only_repl", + # To only load :c by source. + experimental_from_source = ["//tests/multi_repl/bc:c"], + deps = ["//tests/multi_repl/bc:c"], +) + +haskell_repl( + name = "c_multi_repl", + deps = ["//tests/multi_repl/bc:c"], +) diff --git a/third_party/bazel/rules_haskell/tests/multi_repl/a/BUILD.bazel b/third_party/bazel/rules_haskell/tests/multi_repl/a/BUILD.bazel new file mode 100644 index 000000000000..7d17e834a9cd --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/multi_repl/a/BUILD.bazel @@ -0,0 +1,17 @@ +package(default_visibility = ["//visibility:public"]) + +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", +) + +haskell_library( + name = "a", + srcs = [ + "src/A/A.hs", + ], + src_strip_prefix = "src", + deps = [ + "//tests/hackage:base", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/multi_repl/a/src/A/A.hs b/third_party/bazel/rules_haskell/tests/multi_repl/a/src/A/A.hs new file mode 100644 index 000000000000..92eb0e60759a --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/multi_repl/a/src/A/A.hs @@ -0,0 +1,4 @@ +module A.A ( a ) where + +a :: () +a = () diff --git a/third_party/bazel/rules_haskell/tests/multi_repl/bc/BUILD.bazel b/third_party/bazel/rules_haskell/tests/multi_repl/bc/BUILD.bazel new file mode 100644 index 000000000000..98372a4a1925 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/multi_repl/bc/BUILD.bazel @@ -0,0 +1,30 @@ +package(default_visibility = ["//visibility:public"]) + +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", +) + +haskell_library( + name = "b", + srcs = [ + "src/BC/B.hs", + ], + src_strip_prefix = "src", + deps = [ + "//tests/hackage:base", + "//tests/multi_repl/a", + ], +) + +haskell_library( + name = "c", + srcs = [ + "src/BC/C.hs", + ], + src_strip_prefix = "src", + deps = [ + ":b", + "//tests/hackage:base", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/multi_repl/bc/src/BC/B.hs b/third_party/bazel/rules_haskell/tests/multi_repl/bc/src/BC/B.hs new file mode 100644 index 000000000000..b86223c41ea7 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/multi_repl/bc/src/BC/B.hs @@ -0,0 +1,6 @@ +module BC.B ( b ) where + +import A.A ( a ) + +b :: () +b = a diff --git a/third_party/bazel/rules_haskell/tests/multi_repl/bc/src/BC/C.hs b/third_party/bazel/rules_haskell/tests/multi_repl/bc/src/BC/C.hs new file mode 100644 index 000000000000..6e6f31f0c80a --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/multi_repl/bc/src/BC/C.hs @@ -0,0 +1,6 @@ +module BC.C ( c ) where + +import BC.B ( b ) + +c :: () +c = b diff --git a/third_party/bazel/rules_haskell/tests/package-id-clash-binary/BUILD.bazel b/third_party/bazel/rules_haskell/tests/package-id-clash-binary/BUILD.bazel new file mode 100644 index 000000000000..d64a8909c5f5 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/package-id-clash-binary/BUILD.bazel @@ -0,0 +1,15 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_test", + "haskell_toolchain_library", +) + +haskell_test( + name = "bin", + srcs = ["Main.hs"], + deps = [ + "//tests/hackage:base", + "//tests/package-id-clash-binary/a:foo", + "//tests/package-id-clash-binary/b:foo", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/package-id-clash-binary/Main.hs b/third_party/bazel/rules_haskell/tests/package-id-clash-binary/Main.hs new file mode 100644 index 000000000000..0c341e6f47d2 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/package-id-clash-binary/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Foo +import Baz + +main = print $ x + y diff --git a/third_party/bazel/rules_haskell/tests/package-id-clash-binary/a/BUILD.bazel b/third_party/bazel/rules_haskell/tests/package-id-clash-binary/a/BUILD.bazel new file mode 100644 index 000000000000..02c3a6b36d3f --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/package-id-clash-binary/a/BUILD.bazel @@ -0,0 +1,12 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", + "haskell_toolchain_library", +) + +haskell_library( + name = "foo", + srcs = ["Foo.hs"], + visibility = ["//visibility:public"], + deps = ["//tests/hackage:base"], +) diff --git a/third_party/bazel/rules_haskell/tests/package-id-clash-binary/a/Foo.hs b/third_party/bazel/rules_haskell/tests/package-id-clash-binary/a/Foo.hs new file mode 100644 index 000000000000..ecac0701a07d --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/package-id-clash-binary/a/Foo.hs @@ -0,0 +1,3 @@ +module Foo where + +x = 2 diff --git a/third_party/bazel/rules_haskell/tests/package-id-clash-binary/b/BUILD.bazel b/third_party/bazel/rules_haskell/tests/package-id-clash-binary/b/BUILD.bazel new file mode 100644 index 000000000000..4bf734af5dd1 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/package-id-clash-binary/b/BUILD.bazel @@ -0,0 +1,12 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", + "haskell_toolchain_library", +) + +haskell_library( + name = "foo", + srcs = ["Baz.hs"], + visibility = ["//visibility:public"], + deps = ["//tests/hackage:base"], +) diff --git a/third_party/bazel/rules_haskell/tests/package-id-clash-binary/b/Baz.hs b/third_party/bazel/rules_haskell/tests/package-id-clash-binary/b/Baz.hs new file mode 100644 index 000000000000..3159fda6b00a --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/package-id-clash-binary/b/Baz.hs @@ -0,0 +1,3 @@ +module Baz where + +y = 2 diff --git a/third_party/bazel/rules_haskell/tests/package-id-clash/BUILD.bazel b/third_party/bazel/rules_haskell/tests/package-id-clash/BUILD.bazel new file mode 100644 index 000000000000..9c1b91cf9b83 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/package-id-clash/BUILD.bazel @@ -0,0 +1,24 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", +) + +package(default_testonly = 1) + +haskell_library( + name = "sublib", + srcs = ["Foo.hs"], + visibility = ["//visibility:public"], + deps = ["//tests/hackage:base"], +) + +haskell_library( + name = "lib", + srcs = ["Baz.hs"], + visibility = ["//visibility:public"], + deps = [ + ":sublib", + "//tests/hackage:base", + "//tests/package-id-clash/sublib", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/package-id-clash/Baz.hs b/third_party/bazel/rules_haskell/tests/package-id-clash/Baz.hs new file mode 100644 index 000000000000..718a2dd99241 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/package-id-clash/Baz.hs @@ -0,0 +1,7 @@ +module Baz (baz) where + +import Foo (foo) +import Bar (bar) + +baz :: Int +baz = foo + bar diff --git a/third_party/bazel/rules_haskell/tests/package-id-clash/Foo.hs b/third_party/bazel/rules_haskell/tests/package-id-clash/Foo.hs new file mode 100644 index 000000000000..f325b2efcfbb --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/package-id-clash/Foo.hs @@ -0,0 +1,4 @@ +module Foo (foo) where + +foo :: Int +foo = 5 diff --git a/third_party/bazel/rules_haskell/tests/package-id-clash/sublib/BUILD.bazel b/third_party/bazel/rules_haskell/tests/package-id-clash/sublib/BUILD.bazel new file mode 100644 index 000000000000..e5d277c2a254 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/package-id-clash/sublib/BUILD.bazel @@ -0,0 +1,13 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", +) + +package(default_testonly = 1) + +haskell_library( + name = "sublib", + srcs = ["Bar.hs"], + visibility = ["//visibility:public"], + deps = ["//tests/hackage:base"], +) diff --git a/third_party/bazel/rules_haskell/tests/package-id-clash/sublib/Bar.hs b/third_party/bazel/rules_haskell/tests/package-id-clash/sublib/Bar.hs new file mode 100644 index 000000000000..6fbd9711f58b --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/package-id-clash/sublib/Bar.hs @@ -0,0 +1,4 @@ +module Bar (bar) where + +bar :: Int +bar = 6 diff --git a/third_party/bazel/rules_haskell/tests/package-name/BUILD.bazel b/third_party/bazel/rules_haskell/tests/package-name/BUILD.bazel new file mode 100644 index 000000000000..9d187f083636 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/package-name/BUILD.bazel @@ -0,0 +1,28 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", + "haskell_test", +) + +# Tests around our use of package names. +package(default_testonly = 1) + +haskell_library( + # The character "Z" should be untouched in the GHC package name. + # However, underscores (which are not legal) should be turned into dashes. + name = "lib-a_Z", + srcs = ["Lib.hs"], + version = "1.2.3.4", + deps = ["//tests/hackage:base"], +) + +haskell_test( + name = "bin", + size = "small", + srcs = ["Main.hs"], + version = "0.0.0", # This flags triggers the `MIN_VERSION` macro generation + deps = [ + ":lib-a_Z", + "//tests/hackage:base", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/package-name/Lib.hs b/third_party/bazel/rules_haskell/tests/package-name/Lib.hs new file mode 100644 index 000000000000..e5e06b414ba0 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/package-name/Lib.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE CPP #-} +module Lib (foo, libPackageKey) where + +foo :: Integer +foo = 42 + +libPackageKey :: String +libPackageKey = CURRENT_PACKAGE_KEY diff --git a/third_party/bazel/rules_haskell/tests/package-name/Main.hs b/third_party/bazel/rules_haskell/tests/package-name/Main.hs new file mode 100644 index 000000000000..b1e73dcbf716 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/package-name/Main.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PackageImports #-} +module Main (main) where + +import Control.Monad (when) + +-- Test the PackageImports extension. +import "lib-a-Z" Lib + +-- Test macros that GHC creates automatically based on the package version. +versionHighEnoughTest, versionTooLowTest :: Bool +#if MIN_VERSION_lib_a_Z(1,2,3) +versionHighEnoughTest = True +#else +versionHighEnoughTest = False +#endif + +#if MIN_VERSION_lib_a_Z(1,2,4) +versionTooLowTest = False +#else +versionTooLowTest = True +#endif + +check :: (Show a, Eq a) => a -> a -> IO () +check x y = when (x /= y) $ error $ "Failed check: " ++ show (x, y) + +main :: IO () +main = do + check foo 42 + check VERSION_lib_a_Z "1.2.3.4" + check libPackageKey "testsZSpackage-nameZSlib-a-ZZ" + check versionHighEnoughTest True + check versionTooLowTest True diff --git a/third_party/bazel/rules_haskell/tests/repl-flags/BUILD.bazel b/third_party/bazel/rules_haskell/tests/repl-flags/BUILD.bazel new file mode 100644 index 000000000000..8fd099dc4d12 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/repl-flags/BUILD.bazel @@ -0,0 +1,45 @@ +load("@io_tweag_rules_haskell//haskell:haskell.bzl", "haskell_test") + +package(default_testonly = 1) + +# This test the `compiler` flags in many ways: +# - the test needs to be built with `-DTESTS_TOOLCHAIN_COMPILER_FLAGS`, provided by the toolchain attribute `compiler_flags` +# - the test needs `-XOverloadedStrings`, provided by this rule `compiler_flags` +# - toolchain and rule `compiler_flags` are additive, else one of the previous test will fail +# - the ordering is as such as rule flags are more important that toolchain flags + +# This rule must build correctly (using `bazel build`), but also as a repl (using `bazel run //tests/repl-flags:compiler_flags@repl`) +haskell_test( + name = "compiler_flags", + srcs = ["CompilerFlags.hs"], + + # This also ensure that local `compiler_flags` does not override the `global ones` + compiler_flags = ["-XOverloadedStrings"], + visibility = ["//visibility:public"], + deps = [ + "//tests/hackage:base", + "//tests/hackage:bytestring", + ], +) + +# This test the `repl_ghci_args` flags in a similar way +# - the test needs to be built with `-DTESTS_TOOLCHAIN_REPL_FLAGS`, provided by the toolchain attribute `compiler_flags` +# - the test needs `-XOverloadedStrings`, provided by toolchain `repl_ghci_args` +# - toolchain and rule `compiler_flags` are additive, else one of the previous test will fail +# - the ordering is as such as rule flags are more important that +# toolchain flags and that repl flags are more important that +# copmiler flags + +# This rule must build correctly (using `bazel build`), but also as a repl (using `bazel run //tests/repl-flags:compiler_flags@repl`). The final result between the repl and the binary must be different +haskell_test( + name = "repl_flags", + srcs = ["ReplFlags.hs"], + + # This also ensure that local `repl_flags` does not override the `global ones` + repl_ghci_args = ["-DTESTS_TOOLCHAIN_REPL_FLAGS"], + visibility = ["//visibility:public"], + deps = [ + "//tests/hackage:base", + "//tests/hackage:bytestring", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/repl-flags/CompilerFlags.hs b/third_party/bazel/rules_haskell/tests/repl-flags/CompilerFlags.hs new file mode 100644 index 000000000000..5470fe11b57c --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/repl-flags/CompilerFlags.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE CPP #-} + +module Main where + +import Data.ByteString + +#ifdef TESTS_TOOLCHAIN_COMPILER_FLAGS +main = print ("hello" :: ByteString) +#endif + diff --git a/third_party/bazel/rules_haskell/tests/repl-flags/ReplFlags.hs b/third_party/bazel/rules_haskell/tests/repl-flags/ReplFlags.hs new file mode 100644 index 000000000000..137ec93a72f4 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/repl-flags/ReplFlags.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE CPP #-} +module Main where + +import Data.ByteString + +-- Ensure that `compiler-flags` are correctly set +#ifdef TESTS_TOOLCHAIN_COMPILER_FLAGS +main = print "hello" +#endif + +-- Ensure that `repl_ghci_args` are correctly set +-- OverloadedString is passed by toolchain +-- The CPP constant is unset by toolchain and set by rule, so ordering must be ensured +#ifdef TESTS_TOOLCHAIN_REPL_FLAGS +foo = ("world" :: ByteString) +#endif + diff --git a/third_party/bazel/rules_haskell/tests/repl-name-conflicts/BUILD.bazel b/third_party/bazel/rules_haskell/tests/repl-name-conflicts/BUILD.bazel new file mode 100644 index 000000000000..ea2366cf3e08 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/repl-name-conflicts/BUILD.bazel @@ -0,0 +1,15 @@ +load("@io_tweag_rules_haskell//haskell:haskell.bzl", "haskell_library") + +package(default_testonly = 1) + +# The module in this library hides a lot of identifiers from Prelude and other +# modules used in the repl init script. +# This shouldn't break the @repl target +haskell_library( + name = "lib", + srcs = ["PreludeShadowing.hs"], + deps = [ + "//tests/hackage:base", + "//tests/hackage:bytestring", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/repl-name-conflicts/PreludeShadowing.hs b/third_party/bazel/rules_haskell/tests/repl-name-conflicts/PreludeShadowing.hs new file mode 100644 index 000000000000..02ecd02684ba --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/repl-name-conflicts/PreludeShadowing.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module PreludeShadowing where + +import Data.ByteString + +(>>=) :: ByteString -> ByteString -> ByteString +_ >>= _ = "blah" + +stdin :: ByteString +stdin = "stdin" diff --git a/third_party/bazel/rules_haskell/tests/repl-targets/BUILD.bazel b/third_party/bazel/rules_haskell/tests/repl-targets/BUILD.bazel new file mode 100644 index 000000000000..2fd78bfd6621 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/repl-targets/BUILD.bazel @@ -0,0 +1,81 @@ +load("@io_tweag_rules_haskell//haskell:c2hs.bzl", "c2hs_library") +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", + "haskell_test", +) + +package(default_testonly = 1) + +genrule( + name = "codegen", + outs = [ + "Gen.hs", + ], + cmd = """ + echo "module Gen (gen) where" >> $(location :Gen.hs) + echo "gen :: String" >> $(location :Gen.hs) + echo "gen = \\"gen\\"" >> $(location :Gen.hs) +""", +) + +c2hs_library( + name = "chs", + srcs = ["Chs.chs"], + tags = ["requires_c2hs"], +) + +haskell_library( + name = "hs-lib", + srcs = [ + "Foo.hs", + "Hsc.hsc", + ":chs", + ":codegen", + ], + tags = [ + "requires_hackage", + "requires_zlib", + ], + visibility = ["//visibility:public"], + deps = [ + "//tests/data:ourclibrary", + "//tests/hackage:array", + "//tests/hackage:base", + "@zlib", + ], +) + +haskell_library( + name = "hs-lib-bad", + srcs = [ + "Bad.hs", + ], + tags = [ + "manual", + "requires_zlib", + ], + visibility = ["//visibility:public"], + deps = [ + "//tests/data:ourclibrary", + "//tests/hackage:base", + "@hackage//:array", + "@zlib", + ], +) + +haskell_library( + name = "QuuxLib", + srcs = ["QuuxLib.hs"], + deps = ["//tests/hackage:base"], +) + +haskell_test( + name = "hs-bin", + srcs = ["Quux.hs"], + visibility = ["//visibility:public"], + deps = [ + ":QuuxLib", + "//tests/hackage:base", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/repl-targets/Bad.hs b/third_party/bazel/rules_haskell/tests/repl-targets/Bad.hs new file mode 100644 index 000000000000..2889be2ba757 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/repl-targets/Bad.hs @@ -0,0 +1,6 @@ +module Bad + ( bad ) +where + +bad :: Into +bad = "foo" diff --git a/third_party/bazel/rules_haskell/tests/repl-targets/Chs.chs b/third_party/bazel/rules_haskell/tests/repl-targets/Chs.chs new file mode 100644 index 000000000000..c66bae7d60fd --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/repl-targets/Chs.chs @@ -0,0 +1,6 @@ +module Chs + ( baz ) +where + +baz :: String +baz = "baz" diff --git a/third_party/bazel/rules_haskell/tests/repl-targets/Foo.hs b/third_party/bazel/rules_haskell/tests/repl-targets/Foo.hs new file mode 100644 index 000000000000..5e5138418d5d --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/repl-targets/Foo.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module Foo (foo) where + +foreign import ccall "c_add_one" + c_add_one :: Int -> Int + +foo :: Int -> Int +foo = (+ 5) . c_add_one diff --git a/third_party/bazel/rules_haskell/tests/repl-targets/Hsc.hsc b/third_party/bazel/rules_haskell/tests/repl-targets/Hsc.hsc new file mode 100644 index 000000000000..d4e3d6605c00 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/repl-targets/Hsc.hsc @@ -0,0 +1,8 @@ +module Hsc + ( bar ) +where + +#ifndef _INTERNAL_HSC_DO_NOT_DEFINE_ME +bar :: String +bar = "bar" +#endif diff --git a/third_party/bazel/rules_haskell/tests/repl-targets/Quux.hs b/third_party/bazel/rules_haskell/tests/repl-targets/Quux.hs new file mode 100644 index 000000000000..2e67d221fb22 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/repl-targets/Quux.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import QuuxLib (message) + +main :: IO () +main = putStrLn message diff --git a/third_party/bazel/rules_haskell/tests/repl-targets/QuuxLib.hs b/third_party/bazel/rules_haskell/tests/repl-targets/QuuxLib.hs new file mode 100644 index 000000000000..d321de2adda3 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/repl-targets/QuuxLib.hs @@ -0,0 +1,4 @@ +module QuuxLib (message) where + +message :: String +message = "Hello GHCi!" diff --git a/third_party/bazel/rules_haskell/tests/repl-targets/src/Bar.hs b/third_party/bazel/rules_haskell/tests/repl-targets/src/Bar.hs new file mode 100644 index 000000000000..18fe359e0a2a --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/repl-targets/src/Bar.hs @@ -0,0 +1,4 @@ +module Bar (bar) where + +bar :: Int +bar = 4 diff --git a/third_party/bazel/rules_haskell/tests/repl-targets/src/Baz.hsc b/third_party/bazel/rules_haskell/tests/repl-targets/src/Baz.hsc new file mode 100644 index 000000000000..984ec4ff0ad9 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/repl-targets/src/Baz.hsc @@ -0,0 +1,4 @@ +module Baz (baz) where + +baz :: Int +baz = 8 diff --git a/third_party/bazel/rules_haskell/tests/rule_test_exe.bzl b/third_party/bazel/rules_haskell/tests/rule_test_exe.bzl new file mode 100644 index 000000000000..fdecbb385871 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/rule_test_exe.bzl @@ -0,0 +1,14 @@ +load("@bazel_tools//tools/build_rules:test_rules.bzl", "rule_test") + +def rule_test_exe(generates, **kwargs): + """ + Like 'rule_test' but appends ".exe" to the elements of + "generates". + """ + + new_generates = select({ + "@bazel_tools//src/conditions:windows": [e + ".exe" for e in generates], + "//conditions:default": generates, + }) + + rule_test(generates = new_generates, **kwargs) diff --git a/third_party/bazel/rules_haskell/tests/run-start-script.sh b/third_party/bazel/rules_haskell/tests/run-start-script.sh new file mode 100755 index 000000000000..6803581f0010 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/run-start-script.sh @@ -0,0 +1,30 @@ +#!/bin/sh + +# Run the start script in its own workspace +# and build the example binary target. + +set -e + +pwd=$(pwd) +cd $(mktemp -d) +$pwd/start + +# Copy the bazel configuration, this is only useful for CI +mkdir tools +cp $pwd/.bazelrc .bazelrc + +# Set Nixpkgs in environment variable to avoid hardcoding it in +# start script itself. + +# overrides the used rules_haskell, because +# when we're testing the start on a feature branch (CI), +# the latest rules_haskell version doesn't always work. +# If on the branch we update Bazel to a version with breaking +# changes, then we need to adapt to those changes in the branch. +# Which in turn means the start script should pull in those changes too. + +NIX_PATH=nixpkgs=$pwd/nixpkgs/default.nix \ + bazel build \ + --config=ci \ + --override_repository=io_tweag_rules_haskell=$pwd \ + //:example diff --git a/third_party/bazel/rules_haskell/tests/scripts/exec.sh b/third_party/bazel/rules_haskell/tests/scripts/exec.sh new file mode 100755 index 000000000000..2a6c2a810041 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/scripts/exec.sh @@ -0,0 +1,4 @@ +#!/usr/bin/env bash +set -e + +exec "$1" diff --git a/third_party/bazel/rules_haskell/tests/textual-hdrs/BUILD.bazel b/third_party/bazel/rules_haskell/tests/textual-hdrs/BUILD.bazel new file mode 100644 index 000000000000..e66f497c77f2 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/textual-hdrs/BUILD.bazel @@ -0,0 +1,17 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_test", +) + +package(default_testonly = 1) + +haskell_test( + name = "textual-hdrs", + srcs = [ + "Main.hs", + "include/main_definition.h", + ], + compiler_flags = ["-Itests/textual-hdrs/include"], + visibility = ["//visibility:public"], + deps = ["//tests/hackage:base"], +) diff --git a/third_party/bazel/rules_haskell/tests/textual-hdrs/Main.hs b/third_party/bazel/rules_haskell/tests/textual-hdrs/Main.hs new file mode 100644 index 000000000000..f741091275d8 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/textual-hdrs/Main.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE CPP #-} + +module Main (main) where + +#include "main_definition.h" diff --git a/third_party/bazel/rules_haskell/tests/textual-hdrs/include/main_definition.h b/third_party/bazel/rules_haskell/tests/textual-hdrs/include/main_definition.h new file mode 100644 index 000000000000..071eeddd8706 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/textual-hdrs/include/main_definition.h @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "extras-included-during-comp" diff --git a/third_party/bazel/rules_haskell/tests/two-libs/BUILD.bazel b/third_party/bazel/rules_haskell/tests/two-libs/BUILD.bazel new file mode 100644 index 000000000000..d69dba515c2d --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/two-libs/BUILD.bazel @@ -0,0 +1,42 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", + "haskell_test", +) + +package( + default_testonly = 1, + default_visibility = ["//visibility:public"], +) + +haskell_library( + name = "one", + srcs = ["One.hs"], + deps = [ + "//tests/hackage:base", + ], +) + +haskell_library( + name = "two", + srcs = ["Two.hs"], + deps = [ + ":one", + "//tests/hackage:base", + ], +) + +haskell_test( + name = "two-libs", + srcs = ["Main.hs"], + coverage_report_format = "html", + expected_covered_expressions_percentage = 55, + expected_uncovered_expression_count = 4, + experimental_coverage_source_patterns = [":two"], + strict_coverage_analysis = True, + tags = ["coverage-compatible"], + deps = [ + ":two", + "//tests/hackage:base", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/two-libs/Main.hs b/third_party/bazel/rules_haskell/tests/two-libs/Main.hs new file mode 100644 index 000000000000..99ce449a5281 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/two-libs/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Two (two) + +main :: IO () +main = putStrLn ("Two: " ++ show two) diff --git a/third_party/bazel/rules_haskell/tests/two-libs/One.hs b/third_party/bazel/rules_haskell/tests/two-libs/One.hs new file mode 100644 index 000000000000..f8f04ab2640c --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/two-libs/One.hs @@ -0,0 +1,4 @@ +module One (one) where + +one :: Int +one = 1 diff --git a/third_party/bazel/rules_haskell/tests/two-libs/Two.hs b/third_party/bazel/rules_haskell/tests/two-libs/Two.hs new file mode 100644 index 000000000000..5672263c3d5f --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/two-libs/Two.hs @@ -0,0 +1,14 @@ +module Two (two) where + +import One (one) + +two :: Int +two = + if True then + one + one + else + if True then + 1 + else + 2 + \ No newline at end of file diff --git a/third_party/bazel/rules_haskell/tests/unit-tests/BUILD.bazel b/third_party/bazel/rules_haskell/tests/unit-tests/BUILD.bazel new file mode 100644 index 000000000000..990035af685f --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/unit-tests/BUILD.bazel @@ -0,0 +1,125 @@ +load( + ":tests.bzl", + "create_rpath_entry_test", + "dedup_on_test", + "parent_dir_path_test", +) + +parent_dir_path_test( + name = "parent_dir_just_file", + filename = "foo", + output = ["."], +) + +parent_dir_path_test( + name = "parent_dir", + filename = "foo/", + output = ["foo"], +) + +parent_dir_path_test( + name = "parent_dir_file", + filename = "foo/bar", + output = ["foo"], +) + +parent_dir_path_test( + name = "parent_dir_file_dots", + filename = "foo/../bar", + output = [ + "foo", + "..", + ], +) + +parent_dir_path_test( + name = "parent_dir_rooted", + filename = "/foo/bar", + output = [ + "", + "foo", + ], +) + +create_rpath_entry_test( + name = "rpath_entry_simple", + binary_short_path = "foo/a.so", + dependency_short_path = "bar/b.so", + output = "../bar", +) + +# checks that a binary in //:bin works properly +create_rpath_entry_test( + name = "rpath_entry_binary_root", + binary_short_path = "bin", + dependency_short_path = "xyz/b.so", + output = "xyz", +) + +# same for dependency +create_rpath_entry_test( + name = "rpath_entry_dep_root", + binary_short_path = "lib/bin", + dependency_short_path = "b.so", + output = "..", +) + +create_rpath_entry_test( + name = "rpath_entry_simple_filename", + binary_short_path = "foo/a.so", + dependency_short_path = "bar/b.so", + keep_filename = True, + output = "../bar/b.so", +) + +create_rpath_entry_test( + name = "rpath_entry_prefix", + binary_short_path = "foo/a.so", + dependency_short_path = "bar/b.so", + output = "$ORIGIN/../bar", + prefix = "$ORIGIN", +) + +# if the short-paths have leading dots, they are in `external` + +create_rpath_entry_test( + name = "rpath_entry_binary_leading_dots_dep", + # non-external + binary_short_path = "foo/a.so", + # external dep + dependency_short_path = "../bar/b.so", + output = "../external/bar", +) + +create_rpath_entry_test( + name = "rpath_entry_binary_leading_dots_bin", + # external dep + binary_short_path = "../foo/a.so", + # non-external + dependency_short_path = "bar/b.so", + # back through `external` + output = "../../bar", +) + +create_rpath_entry_test( + name = "rpath_entry_binary_leading_dots_both", + # external dep + binary_short_path = "../foo/a.so", + # external dep + dependency_short_path = "../bar/b.so", + # stay in `external` + output = "../bar", +) + +# we have no idea how to handle internal dots, should they arise +# create_rpath_entry_test( +# name = "rpath_entry_binary_internal_dots", +# binary_short_path = "foo/../../a.so", +# dependency_short_path = "../bar/../b.so", +# # but that doesnโt change anything for the runpath +# output = "../bar", +# ) + +dedup_on_test( + name = "dedup_on_test", +) diff --git a/third_party/bazel/rules_haskell/tests/unit-tests/tests.bzl b/third_party/bazel/rules_haskell/tests/unit-tests/tests.bzl new file mode 100644 index 000000000000..58a3f400adbe --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/unit-tests/tests.bzl @@ -0,0 +1,83 @@ +load( + "@bazel_skylib//lib:unittest.bzl", + "asserts", + unit = "unittest", +) +load("//haskell:private/actions/link.bzl", "create_rpath_entry", "parent_dir_path") +load("//haskell:private/list.bzl", "list") + +def parent_dir_path_test_impl(ctx): + env = unit.begin(ctx) + asserts.equals( + env, + expected = ctx.attr.output, + actual = parent_dir_path(ctx.attr.filename), + ) + unit.end(env) + +parent_dir_path_test = unit.make( + parent_dir_path_test_impl, + attrs = { + "filename": attr.string(), + "output": attr.string_list(), + }, +) + +def create_rpath_entry_test_impl(ctx): + env = unit.begin(ctx) + asserts.equals( + env, + expected = ctx.attr.output, + actual = create_rpath_entry( + struct( + short_path = ctx.attr.binary_short_path, + ), + struct( + short_path = ctx.attr.dependency_short_path, + ), + keep_filename = ctx.attr.keep_filename, + prefix = ctx.attr.prefix, + ), + ) + unit.end(env) + +create_rpath_entry_test = unit.make( + create_rpath_entry_test_impl, + attrs = { + "binary_short_path": attr.string(), + "dependency_short_path": attr.string(), + "keep_filename": attr.bool(default = False, mandatory = False), + "prefix": attr.string(default = "", mandatory = False), + "output": attr.string(), + }, +) + +def compare_x(el): + return el.x + +def dedup_on_test_impl(ctx): + env = unit.begin(ctx) + asserts.equals( + env, + expected = [], + actual = list.dedup_on(compare_x, []), + ) + asserts.equals( + env, + expected = [struct(x = 3)], + actual = list.dedup_on( + compare_x, + [struct(x = 3), struct(x = 3), struct(x = 3)], + ), + ) + asserts.equals( + env, + expected = [struct(x = 3), struct(x = 4), struct(x = 5)], + actual = list.dedup_on( + compare_x, + [struct(x = 3), struct(x = 4), struct(x = 3), struct(x = 5), struct(x = 3)], + ), + ) + unit.end(env) + +dedup_on_test = unit.make(dedup_on_test_impl) diff --git a/third_party/bazel/rules_haskell/tests/version-macros/BUILD.bazel b/third_party/bazel/rules_haskell/tests/version-macros/BUILD.bazel new file mode 100644 index 000000000000..b2be1b7d1598 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/version-macros/BUILD.bazel @@ -0,0 +1,59 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", + "haskell_test", +) +load( + "@io_tweag_rules_haskell//haskell:c2hs.bzl", + "c2hs_library", +) + +package(default_testonly = 1) + +haskell_library( + name = "versioned-lib", + srcs = ["VersionedLib.hs"], + version = "1.2.3.4", + deps = ["//tests/hackage:base"], +) + +haskell_test( + name = "version_macros", + size = "small", + srcs = [ + "HsLib.hs", + "HscLib.hsc", + "Main.hs", + ], + version = "3.4.5.6", + deps = [ + ":versioned-lib", + "//tests/hackage:base", + ], +) + +c2hs_library( + name = "c2hs-lib", + srcs = ["C2hsLib.chs"], + tags = ["requires_c2hs"], + version = "4.5.6.7", + deps = [ + ":versioned-lib", + "//tests/hackage:base", + ], +) + +haskell_test( + name = "version_macros_c2hs", + size = "small", + srcs = [ + "MainC2hs.hs", + ":c2hs-lib", + ], + tags = ["requires_c2hs"], + version = "4.5.6.7", + deps = [ + ":versioned-lib", + "//tests/hackage:base", + ], +) diff --git a/third_party/bazel/rules_haskell/tests/version-macros/C2hsLib.chs b/third_party/bazel/rules_haskell/tests/version-macros/C2hsLib.chs new file mode 100644 index 000000000000..4b484af2a3ed --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/version-macros/C2hsLib.chs @@ -0,0 +1,44 @@ +module C2hsLib where + +import Control.Monad (unless) + +check_version_versioned_lib :: IO () +#ifndef VERSION_versioned_lib +check_version_versioned_lib = fail "c2hs: VERSION_versioned_lib missing" +#else +check_version_versioned_lib = + unless ({#const VERSION_versioned_lib#} == "1.2.3.4") $ + fail "c2hs: VERSION_versioned_lib invalid" +#endif + +check_min_version_versioned_lib :: IO () +#ifndef MIN_VERSION_versioned_lib +check_min_version_versioned_lib = fail "c2hs: MIN_VERSION_versioned_lib missing" +#elif !MIN_VERSION_versioned_lib(1,2,3) +check_min_version_versioned_lib = fail "c2hs: MIN_VERSION_versioned_lib invalid" +#else +check_min_version_versioned_lib = pure () +#endif + +check_version_base :: IO () +#ifndef VERSION_base +check_version_base = fail "c2hs: VERSION_base missing" +#else +check_version_base = pure () +#endif + +check_min_version_base :: IO () +#ifndef MIN_VERSION_base +check_min_version_base = fail "c2hs: MIN_VERSION_base missing" +#elif !MIN_VERSION_base(0,0,0) +check_min_version_base = fail "c2hs: MIN_VERSION_base invalid" +#else +check_min_version_base = pure () +#endif + +check :: IO () +check = do + check_version_versioned_lib + check_min_version_versioned_lib + check_version_base + check_min_version_base diff --git a/third_party/bazel/rules_haskell/tests/version-macros/HsLib.hs b/third_party/bazel/rules_haskell/tests/version-macros/HsLib.hs new file mode 100644 index 000000000000..ce61906c81e6 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/version-macros/HsLib.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE CPP #-} + +module HsLib where + +import Control.Monad (unless) + +check_version_versioned_lib :: IO () +#ifndef VERSION_versioned_lib +check_version_versioned_lib = fail "hs: VERSION_versioned_lib missing" +#else +check_version_versioned_lib = + unless (VERSION_versioned_lib == "1.2.3.4") $ + fail "hs: VERSION_versioned_lib invalid" +#endif + +check_min_version_versioned_lib :: IO () +#ifndef MIN_VERSION_versioned_lib +check_min_version_versioned_lib = fail "hs: MIN_VERSION_versioned_lib missing" +#elif !MIN_VERSION_versioned_lib(1,2,3) +check_min_version_versioned_lib = fail "hs: MIN_VERSION_versioned_lib invalid" +#else +check_min_version_versioned_lib = pure () +#endif + +check_version_base :: IO () +#ifndef VERSION_base +check_version_base = fail "hs: VERSION_base missing" +#else +check_version_base = pure () +#endif + +check_min_version_base :: IO () +#ifndef MIN_VERSION_base +check_min_version_base = fail "hs: MIN_VERSION_base missing" +#elif !MIN_VERSION_base(0,0,0) +check_min_version_base = fail "hs: MIN_VERSION_base invalid" +#else +check_min_version_base = pure () +#endif + +check :: IO () +check = do + check_version_versioned_lib + check_min_version_versioned_lib + check_version_base + check_min_version_base diff --git a/third_party/bazel/rules_haskell/tests/version-macros/HscLib.hsc b/third_party/bazel/rules_haskell/tests/version-macros/HscLib.hsc new file mode 100644 index 000000000000..387e73a08997 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/version-macros/HscLib.hsc @@ -0,0 +1,44 @@ +module HscLib where + +import Control.Monad (unless) + +check_version_versioned_lib :: IO () +#ifndef VERSION_versioned_lib +check_version_versioned_lib = fail "hsc2hs: VERSION_versioned_lib missing" +#else +check_version_versioned_lib = + unless (#{const_str VERSION_versioned_lib} == "1.2.3.4") $ + fail "hsc2hs: VERSION_versioned_lib invalid" +#endif + +check_min_version_versioned_lib :: IO () +#ifndef MIN_VERSION_versioned_lib +check_min_version_versioned_lib = fail "hsc2hs: MIN_VERSION_versioned_lib missing" +#elif !MIN_VERSION_versioned_lib(1,2,3) +check_min_version_versioned_lib = fail "hsc2hs: MIN_VERSION_versioned_lib invalid" +#else +check_min_version_versioned_lib = pure () +#endif + +check_version_base :: IO () +#ifndef VERSION_base +check_version_base = fail "hsc2hs: VERSION_base missing" +#else +check_version_base = pure () +#endif + +check_min_version_base :: IO () +#ifndef MIN_VERSION_base +check_min_version_base = fail "hsc2hs: MIN_VERSION_base missing" +#elif !MIN_VERSION_base(0,0,0) +check_min_version_base = fail "hsc2hs: MIN_VERSION_base invalid" +#else +check_min_version_base = pure () +#endif + +check :: IO () +check = do + check_version_versioned_lib + check_min_version_versioned_lib + check_version_base + check_min_version_base diff --git a/third_party/bazel/rules_haskell/tests/version-macros/Main.hs b/third_party/bazel/rules_haskell/tests/version-macros/Main.hs new file mode 100644 index 000000000000..bbcd108d0b6b --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/version-macros/Main.hs @@ -0,0 +1,9 @@ +module Main where + +import qualified HscLib +import qualified HsLib + +main :: IO () +main = do + HscLib.check + HsLib.check diff --git a/third_party/bazel/rules_haskell/tests/version-macros/MainC2hs.hs b/third_party/bazel/rules_haskell/tests/version-macros/MainC2hs.hs new file mode 100644 index 000000000000..82e4ec72e248 --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/version-macros/MainC2hs.hs @@ -0,0 +1,7 @@ +module Main where + +import qualified C2hsLib + +main :: IO () +main = do + C2hsLib.check diff --git a/third_party/bazel/rules_haskell/tests/version-macros/VersionedLib.hs b/third_party/bazel/rules_haskell/tests/version-macros/VersionedLib.hs new file mode 100644 index 000000000000..0dfd5577e7aa --- /dev/null +++ b/third_party/bazel/rules_haskell/tests/version-macros/VersionedLib.hs @@ -0,0 +1 @@ +module VersionedLib where diff --git a/third_party/bazel/rules_haskell/tools/BUILD.bazel b/third_party/bazel/rules_haskell/tools/BUILD.bazel new file mode 100644 index 000000000000..e69de29bb2d1 --- /dev/null +++ b/third_party/bazel/rules_haskell/tools/BUILD.bazel diff --git a/third_party/bazel/rules_haskell/tools/README.md b/third_party/bazel/rules_haskell/tools/README.md new file mode 100644 index 000000000000..1d3ef16f8d20 --- /dev/null +++ b/third_party/bazel/rules_haskell/tools/README.md @@ -0,0 +1,3 @@ +Note: `py_library`s cannot be put into this folder, lest they produce +a namespace collision with `@bazel_tools/tools`. +See https://github.com/bazelbuild/bazel/issues/7051 diff --git a/third_party/bazel/rules_haskell/tools/coverage-reports/BUILD b/third_party/bazel/rules_haskell/tools/coverage-reports/BUILD new file mode 100644 index 000000000000..6fd59e0ca0d5 --- /dev/null +++ b/third_party/bazel/rules_haskell/tools/coverage-reports/BUILD @@ -0,0 +1,20 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_binary", +) + +haskell_binary( + name = "coverage-report-renderer", + srcs = ["Main.hs"], + visibility = ["//visibility:public"], + deps = [ + "@hackage//:MissingH", + "@hackage//:base", + "@hackage//:cmdargs", + "@hackage//:directory", + "@hackage//:filepath", + "@hackage//:hxt", + "@hackage//:hxt-xpath", + "@hackage//:listsafe", + ], +) diff --git a/third_party/bazel/rules_haskell/tools/coverage-reports/Main.hs b/third_party/bazel/rules_haskell/tools/coverage-reports/Main.hs new file mode 100644 index 000000000000..5ab4dafdefc1 --- /dev/null +++ b/third_party/bazel/rules_haskell/tools/coverage-reports/Main.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +import Control.Monad (forM_) + +import Control.Arrow.ListArrow (runLA) +import Data.Either.Utils (maybeToEither) +import Data.List (find) +import Data.List.Safe (head, tail) +import Data.List.Utils (split) +import Data.Tree.NTree.TypeDefs (NTree(..)) +import Prelude hiding (head, tail) +import System.Console.CmdArgs.Implicit (Data, Typeable, cmdArgs) +import System.Directory (createDirectoryIfMissing) +import System.Exit (exitFailure) +import System.FilePath (FilePath, (</>), takeDirectory) +import qualified Text.XML.HXT.Arrow.ReadDocument as XML +import Text.XML.HXT.DOM.QualifiedName (localPart) +import Text.XML.HXT.DOM.TypeDefs (XNode(..), XmlTree) +import Text.XML.HXT.XPath.XPathEval (getXPath, getXPathSubTrees) + +data Args = Args + { testlog :: FilePath + , destdir :: FilePath + } deriving (Data, Typeable) + +data ReportFile = ReportFile + { content :: String + , filename :: FilePath + } deriving (Show) + +main :: IO () +main = do + Args {testlog, destdir} <- cmdArgs $ Args {testlog = "", destdir = ""} + if testlog == "" + then putStrLn noTestlogError >> exitFailure + else do + fileContents <- readFile testlog + let xmlTrees = runLA XML.xreadDoc fileContents + let rootTree = find isRoot xmlTrees + case rootTree of + Nothing -> do + putStrLn "Invalid XML format for testlog." + exitFailure + Just tree -> do + let reportFiles = generateReportFiles tree + case reportFiles of + Right reports -> + forM_ reports $ \ReportFile {content, filename} -> do + putStrLn $ concat ["Creating ", show $ destdir </> filename] + createDirectoryIfMissing + True + (destdir </> takeDirectory filename) + writeFile (destdir </> filename) content + Left err -> do + putStrLn err + exitFailure + +generateReportFiles :: XmlTree -> Either String [ReportFile] +generateReportFiles doc = + let testSuites = getXPath "/testsuites/testsuite" doc + in concat <$> sequence (reportsForTestCase <$> testSuites) + +reportsForTestCase :: XmlTree -> Either String [ReportFile] +reportsForTestCase testSuite = do + caseName <- + extractAttr =<< + maybeToEither + "Couldn't find testcase name." + (head (getXPathSubTrees "/testsuite/testcase/@name" testSuite)) + let coverageOutputDirectory = takeDirectory caseName + testOutput <- + extractText =<< + maybeToEither + "Couldn't find system output." + (head (getXPathSubTrees "/testsuite/system-out" testSuite)) + htmlPortion <- + maybeToEither + ("Couldn't find HTML report section in test case " ++ caseName ++ ".") + (head =<< tail (split testOutputSeparator testOutput)) + let coverageReportPartXmlTrees = runLA XML.hreadDoc htmlPortion + traverse + (coveragePartToReportFile coverageOutputDirectory) + coverageReportPartXmlTrees + +coveragePartToReportFile :: FilePath -> XmlTree -> Either String ReportFile +coveragePartToReportFile parentDirectory reportPart = do + filename <- + extractAttr =<< + maybeToEither + "Couldn't find report part name." + (head (getXPathSubTrees "/coverage-report-part/@name" reportPart)) + content <- extractText reportPart + return $ + ReportFile + { content = content + , filename = "coverage-reports" </> parentDirectory </> filename + } + +noTestlogError :: String +noTestlogError = + unlines + [ "ERROR: You must specify the testlog XML file location with --testlog." + , "It is found inside the bazel-testlog, in the respective" + , "folder for the test you're interested in." + , "This must be after having run 'bazel coverage'." + ] + +isRoot :: XmlTree -> Bool +isRoot tree = + case tree of + NTree (XTag name _) _ -> localPart name == "testsuites" + _ -> False + +extractAttr :: XmlTree -> Either String String +extractAttr tree = + case tree of + NTree (XAttr _) [NTree (XText value) []] -> pure value + _ -> Left "Couldn't extract attribute from test XML." + +extractText :: XmlTree -> Either String String +extractText tree = + let treeToText :: XmlTree -> String -> String + treeToText textTree acc = + case textTree of + (NTree (XText value) _) -> acc ++ value + _ -> "" + in case tree of + NTree (XTag _ _) textTree -> pure $ foldr treeToText "" textTree + _ -> Left "Couldn't extract text from test XML." + +testOutputSeparator :: String +testOutputSeparator = "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%" diff --git a/third_party/bazel/rules_haskell/tools/os_info.bzl b/third_party/bazel/rules_haskell/tools/os_info.bzl new file mode 100644 index 000000000000..242be51855cf --- /dev/null +++ b/third_party/bazel/rules_haskell/tools/os_info.bzl @@ -0,0 +1,29 @@ +load("@bazel_tools//tools/cpp:lib_cc_configure.bzl", "get_cpu_value") + +_os_info_bzl_template = """ +cpu_value = "{CPU_VALUE}" +is_darwin = cpu_value == "darwin" +is_linux = cpu_value == "k8" +is_windows = cpu_value == "x64_windows" +""" + +def _os_info_impl(repository_ctx): + cpu = get_cpu_value(repository_ctx) + os_info_substitutions = { + "CPU_VALUE": cpu, + } + repository_ctx.file( + "os_info.bzl", + _os_info_bzl_template.format(**os_info_substitutions), + False, + ) + repository_ctx.file( + "BUILD", + "", + False, + ) + +os_info = repository_rule( + implementation = _os_info_impl, + local = True, +) diff --git a/third_party/bazel/rules_haskell/tools/runfiles/BUILD.bazel b/third_party/bazel/rules_haskell/tools/runfiles/BUILD.bazel new file mode 100644 index 000000000000..bc99b96c037a --- /dev/null +++ b/third_party/bazel/rules_haskell/tools/runfiles/BUILD.bazel @@ -0,0 +1,46 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", + "haskell_test", +) + +haskell_library( + name = "runfiles", + srcs = ["src/Bazel/Runfiles.hs"], + src_strip_prefix = "src", + visibility = ["//visibility:public"], + deps = [ + "@hackage//:base", + "@hackage//:directory", + "@hackage//:filepath", + ], +) + +haskell_test( + name = "bin", + testonly = 1, + srcs = ["bin/Bin.hs"], + data = ["bin-data.txt"], + src_strip_prefix = "bin", + deps = [ + ":runfiles", + "@hackage//:base", + "@hackage//:filepath", + ], +) + +haskell_test( + name = "test", + srcs = ["test/Test.hs"], + data = [ + "test-data.txt", + ":bin", + ], + src_strip_prefix = "test", + deps = [ + ":runfiles", + "@hackage//:base", + "@hackage//:filepath", + "@hackage//:process", + ], +) diff --git a/third_party/bazel/rules_haskell/tools/runfiles/LICENSE b/third_party/bazel/rules_haskell/tools/runfiles/LICENSE new file mode 100644 index 000000000000..261eeb9e9f8b --- /dev/null +++ b/third_party/bazel/rules_haskell/tools/runfiles/LICENSE @@ -0,0 +1,201 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/third_party/bazel/rules_haskell/tools/runfiles/README.md b/third_party/bazel/rules_haskell/tools/runfiles/README.md new file mode 100644 index 000000000000..9e95713179af --- /dev/null +++ b/third_party/bazel/rules_haskell/tools/runfiles/README.md @@ -0,0 +1,19 @@ +# Bazel Runfiles + +This is a small utility to enable discovery of the Bazel runfiles location. This is useful in tests for example. + +```haskell +module Main (main) where + +import qualified Bazel.Runfiles as Runfiles +import Control.Monad (when) +import System.Process (callProcess) + +main :: IO () +main = do + r <- Runfiles.create + foo <- readFile (Runfiles.rlocation r "io_tweag_rules_haskell/tools/runfiles/test-data.txt") + when (lines foo /= ["foo"]) -- ignore trailing newline + $ error $ "Incorrect contents: got: " ++ show foo + callProcess (Runfiles.rlocation r "io_tweag_rules_haskell/tools/runfiles/bin") [] +``` diff --git a/third_party/bazel/rules_haskell/tools/runfiles/bazel-runfiles.cabal b/third_party/bazel/rules_haskell/tools/runfiles/bazel-runfiles.cabal new file mode 100644 index 000000000000..edfc7b6e00b9 --- /dev/null +++ b/third_party/bazel/rules_haskell/tools/runfiles/bazel-runfiles.cabal @@ -0,0 +1,53 @@ +-- This file has been generated from package.yaml by hpack version 0.28.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: bd1c2ce5b0ffa0157650e1c2409d31b818889736ef09aaf51de71e54d9a7d3fc + +name: bazel-runfiles +version: 0.7.0.1 +synopsis: Locate Bazel runfiles location +description: Please see the README on GitHub at <https://github.com/tweag/rules_haskell/blob/master/tools/runfiles/README.md> +category: Build Tool +homepage: https://github.com/tweag/rules_haskell#readme +bug-reports: https://github.com/tweag/rules_haskell/issues +author: Tweag I/O Limited +maintainer: m@tweag.io +copyright: 2018 Tweag I/O Limited +license: Apache-2.0 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: + LICENSE + README.md + +source-repository head + type: git + location: https://github.com/tweag/rules_haskell + +library + exposed-modules: + Bazel.Runfiles + other-modules: + Paths_bazel_runfiles + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , directory + , filepath + default-language: Haskell2010 + +executable bazel-runfiles-exe + main-is: Bin.hs + other-modules: + Paths_bazel_runfiles + hs-source-dirs: + bin + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base + , bazel-runfiles + , filepath + default-language: Haskell2010 diff --git a/third_party/bazel/rules_haskell/tools/runfiles/bin-data.txt b/third_party/bazel/rules_haskell/tools/runfiles/bin-data.txt new file mode 100644 index 000000000000..5716ca5987cb --- /dev/null +++ b/third_party/bazel/rules_haskell/tools/runfiles/bin-data.txt @@ -0,0 +1 @@ +bar diff --git a/third_party/bazel/rules_haskell/tools/runfiles/bin/Bin.hs b/third_party/bazel/rules_haskell/tools/runfiles/bin/Bin.hs new file mode 100644 index 000000000000..5bc90c70bc01 --- /dev/null +++ b/third_party/bazel/rules_haskell/tools/runfiles/bin/Bin.hs @@ -0,0 +1,12 @@ +module Main (main) where + +import qualified Bazel.Runfiles as Runfiles +import Control.Monad (when) +import System.FilePath ((</>)) + +main :: IO () +main = do + r <- Runfiles.create + bar <- readFile (Runfiles.rlocation r "io_tweag_rules_haskell/tools/runfiles/bin-data.txt") + when (lines bar /= ["bar"]) -- ignore trailing newline + $ error $ "Incorrect contents: got: " ++ show bar diff --git a/third_party/bazel/rules_haskell/tools/runfiles/package.yaml b/third_party/bazel/rules_haskell/tools/runfiles/package.yaml new file mode 100644 index 000000000000..fb6d3081a6b4 --- /dev/null +++ b/third_party/bazel/rules_haskell/tools/runfiles/package.yaml @@ -0,0 +1,43 @@ +name: bazel-runfiles +version: 0.7.0.1 +github: "tweag/rules_haskell" +license: Apache-2.0 +author: "Tweag I/O Limited" +maintainer: "m@tweag.io" +copyright: "2018 Tweag I/O Limited" + +extra-source-files: +- README.md +- LICENSE + +synopsis: Locate Bazel runfiles location +category: Build Tool + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README on GitHub at <https://github.com/tweag/rules_haskell/blob/master/tools/runfiles/README.md> + +dependencies: +- base >= 4.7 && < 5 + +library: + source-dirs: src + dependencies: + - directory + - filepath + exposed-modules: + - Bazel.Runfiles + +executables: + bazel-runfiles-exe: + main: Bin.hs + source-dirs: bin + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - base + - bazel-runfiles + - filepath diff --git a/third_party/bazel/rules_haskell/tools/runfiles/src/Bazel/Runfiles.hs b/third_party/bazel/rules_haskell/tools/runfiles/src/Bazel/Runfiles.hs new file mode 100644 index 000000000000..8dfb980e1801 --- /dev/null +++ b/third_party/bazel/rules_haskell/tools/runfiles/src/Bazel/Runfiles.hs @@ -0,0 +1,62 @@ +-- | This module enables finding data dependencies ("runfiles") of Haskell +-- binaries at runtime. +-- +-- For more information, see: https://github.com/bazelbuild/bazel/issues/4460 +-- +-- Note: this does not currently support the RUNFILES_MANIFEST environmental +-- variable. However, that's only necessary on Windows, which rules_haskell +-- doesn't support yet. +-- +-- Additionally, this is not yet supported by the REPL. +module Bazel.Runfiles + ( Runfiles + , create + , rlocation + , env + ) where + +import System.Directory (doesDirectoryExist) +import System.Environment (getExecutablePath, lookupEnv) +import System.FilePath (FilePath, (</>), (<.>)) + +-- | A path to a directory tree containing runfiles for the given +newtype Runfiles = Runfiles FilePath + deriving Show + +-- | Construct a path to a data dependency within the given runfiles. +-- +-- For example: @rlocation \"myworkspace/mypackage/myfile.txt\"@ +rlocation :: Runfiles -> FilePath -> FilePath +rlocation (Runfiles f) g = f </> g + +-- | Set environmental variables for locating the given runfiles directory. +-- +-- Note that Bazel will set these automatically when it runs tests +-- (@bazel test@). However, it will not automatically set them +-- during "bazel run"; thus, non-test binaries should set the +-- environment manually for processes that they call. +env :: Runfiles -> [(String, String)] +env (Runfiles f) = [(runfilesDirEnv, f)] + +runfilesDirEnv :: String +runfilesDirEnv = "RUNFILES_DIR" + +-- | Locate the runfiles directory for the current binary. +-- +-- This behaves according to the specification in: +-- https://docs.google.com/document/d/e/2PACX-1vSDIrFnFvEYhKsCMdGdD40wZRBX3m3aZ5HhVj4CtHPmiXKDCxioTUbYsDydjKtFDAzER5eg7OjJWs3V/pub +-- +-- Note: it does not currently support the @RUNFILES_MANIFEST@ environmental +-- variable. However, that's only necessary on Windows, which rules_haskell +-- doesn't support yet anyway. +create :: IO Runfiles +create = do + exeRunfilesPath <- fmap (<.> "runfiles") getExecutablePath + exeRunfilesExists <- doesDirectoryExist exeRunfilesPath + if exeRunfilesExists + then return $ Runfiles exeRunfilesPath + else do + envDir <- lookupEnv runfilesDirEnv + case envDir of + Just f -> return $ Runfiles f + Nothing -> error "Unable to locate runfiles directory" diff --git a/third_party/bazel/rules_haskell/tools/runfiles/stack.yaml b/third_party/bazel/rules_haskell/tools/runfiles/stack.yaml new file mode 100644 index 000000000000..03da81a5531e --- /dev/null +++ b/third_party/bazel/rules_haskell/tools/runfiles/stack.yaml @@ -0,0 +1,3 @@ +resolver: lts-12.16 +packages: +- . diff --git a/third_party/bazel/rules_haskell/tools/runfiles/test-data.txt b/third_party/bazel/rules_haskell/tools/runfiles/test-data.txt new file mode 100644 index 000000000000..257cc5642cb1 --- /dev/null +++ b/third_party/bazel/rules_haskell/tools/runfiles/test-data.txt @@ -0,0 +1 @@ +foo diff --git a/third_party/bazel/rules_haskell/tools/runfiles/test/Test.hs b/third_party/bazel/rules_haskell/tools/runfiles/test/Test.hs new file mode 100644 index 000000000000..3ef3b28df514 --- /dev/null +++ b/third_party/bazel/rules_haskell/tools/runfiles/test/Test.hs @@ -0,0 +1,13 @@ +module Main (main) where + +import qualified Bazel.Runfiles as Runfiles +import Control.Monad (when) +import System.Process (callProcess) + +main :: IO () +main = do + r <- Runfiles.create + foo <- readFile (Runfiles.rlocation r "io_tweag_rules_haskell/tools/runfiles/test-data.txt") + when (lines foo /= ["foo"]) -- ignore trailing newline + $ error $ "Incorrect contents: got: " ++ show foo + callProcess (Runfiles.rlocation r "io_tweag_rules_haskell/tools/runfiles/bin") [] diff --git a/third_party/bazel/rules_haskell/tutorial/.bazelrc b/third_party/bazel/rules_haskell/tutorial/.bazelrc new file mode 120000 index 000000000000..adb61980d232 --- /dev/null +++ b/third_party/bazel/rules_haskell/tutorial/.bazelrc @@ -0,0 +1 @@ +../.bazelrc \ No newline at end of file diff --git a/third_party/bazel/rules_haskell/tutorial/.gitignore b/third_party/bazel/rules_haskell/tutorial/.gitignore new file mode 100644 index 000000000000..a6ef824c1f83 --- /dev/null +++ b/third_party/bazel/rules_haskell/tutorial/.gitignore @@ -0,0 +1 @@ +/bazel-* diff --git a/third_party/bazel/rules_haskell/tutorial/README.md b/third_party/bazel/rules_haskell/tutorial/README.md new file mode 100644 index 000000000000..34a5bb27f4b2 --- /dev/null +++ b/third_party/bazel/rules_haskell/tutorial/README.md @@ -0,0 +1,30 @@ +# Tutorial code + +Code for the [Bazel Haskell tutorial][bazel-haskell-tutorial]. + +[bazel-haskell-tutorial]: https://rules-haskell.readthedocs.io/en/latest/haskell.html + +## Tutorial Workspace + +Build everything in the tutorial workspace with; + +``` +$ bazel build @io_tweag_rules_haskell_tutorial//... +``` + +Show everything in the tutorial; + +``` +$ bazel query @io_tweag_rules_haskell_tutorial//... +@io_tweag_rules_haskell_tutorial//main:demorgan +@io_tweag_rules_haskell_tutorial//main:base +@io_tweag_rules_haskell_tutorial//lib:booleans +``` + +Build and run the tutorial example; + +``` +$ bazel build @io_tweag_rules_haskell_tutorial//lib:booleans +$ bazel build @io_tweag_rules_haskell_tutorial//main:demorgan +$ bazel run @io_tweag_rules_haskell_tutorial//main:demorgan +``` diff --git a/third_party/bazel/rules_haskell/tutorial/WORKSPACE b/third_party/bazel/rules_haskell/tutorial/WORKSPACE new file mode 100644 index 000000000000..21d25c247207 --- /dev/null +++ b/third_party/bazel/rules_haskell/tutorial/WORKSPACE @@ -0,0 +1,49 @@ +workspace(name = "io_tweag_rules_haskell_tutorial") + +local_repository( + name = "io_tweag_rules_haskell", + path = "..", +) + +load("@bazel_tools//tools/build_defs/repo:http.bzl", "http_archive") +load("@io_tweag_rules_haskell//haskell:repositories.bzl", "haskell_repositories") + +haskell_repositories() + +rules_nixpkgs_version = "0.5.2" + +http_archive( + name = "io_tweag_rules_nixpkgs", + sha256 = "5a384daa57b49abf9f0b672852f1a66a3c52aecf9d4d2ac64f6de0fd307690c8", + strip_prefix = "rules_nixpkgs-%s" % rules_nixpkgs_version, + urls = ["https://github.com/tweag/rules_nixpkgs/archive/v%s.tar.gz" % rules_nixpkgs_version], +) + +load( + "@io_tweag_rules_nixpkgs//nixpkgs:nixpkgs.bzl", + "nixpkgs_cc_configure", +) + +nixpkgs_cc_configure( + nix_file = "@io_tweag_rules_haskell//nixpkgs:cc-toolchain.nix", + repository = "@io_tweag_rules_haskell//nixpkgs:default.nix", +) + +load( + "@io_tweag_rules_haskell//haskell:nixpkgs.bzl", + "haskell_register_ghc_nixpkgs", +) + +haskell_register_ghc_nixpkgs( + repositories = { + "nixpkgs": "@io_tweag_rules_haskell//nixpkgs:default.nix", + }, + version = "8.6.4", +) + +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_register_ghc_bindists", +) + +haskell_register_ghc_bindists(version = "8.6.4") diff --git a/third_party/bazel/rules_haskell/tutorial/lib/BUILD.bazel b/third_party/bazel/rules_haskell/tutorial/lib/BUILD.bazel new file mode 100644 index 000000000000..1afb9822419c --- /dev/null +++ b/third_party/bazel/rules_haskell/tutorial/lib/BUILD.bazel @@ -0,0 +1,10 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_library", +) + +haskell_library( + name = "booleans", + srcs = ["Bool.hs"], + visibility = ["//main:__pkg__"], +) diff --git a/third_party/bazel/rules_haskell/tutorial/lib/Bool.hs b/third_party/bazel/rules_haskell/tutorial/lib/Bool.hs new file mode 100644 index 000000000000..7390fcc0b838 --- /dev/null +++ b/third_party/bazel/rules_haskell/tutorial/lib/Bool.hs @@ -0,0 +1,19 @@ +-- base is not available when no dependencies, so we have to define everything +-- from scratch. +{-# LANGUAGE NoImplicitPrelude #-} + +module Bool where + +data Bool = False | True + +not :: Bool -> Bool +not False = True +not True = False + +and :: Bool -> Bool -> Bool +and True True = True +and _ _ = False + +or :: Bool -> Bool -> Bool +or False False = False +or _ _ = True diff --git a/third_party/bazel/rules_haskell/tutorial/main/BUILD.bazel b/third_party/bazel/rules_haskell/tutorial/main/BUILD.bazel new file mode 100644 index 000000000000..e2e7d3f42218 --- /dev/null +++ b/third_party/bazel/rules_haskell/tutorial/main/BUILD.bazel @@ -0,0 +1,17 @@ +load( + "@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_test", + "haskell_toolchain_library", +) + +haskell_toolchain_library(name = "base") + +haskell_test( + name = "demorgan", + srcs = ["Main.hs"], + compiler_flags = ["-threaded"], + deps = [ + ":base", + "//lib:booleans", + ], +) diff --git a/third_party/bazel/rules_haskell/tutorial/main/Main.hs b/third_party/bazel/rules_haskell/tutorial/main/Main.hs new file mode 100644 index 000000000000..325fd61d0a1e --- /dev/null +++ b/third_party/bazel/rules_haskell/tutorial/main/Main.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE StandaloneDeriving #-} + +module Main where + +import Bool +import qualified Prelude +import Prelude ((++), (==), ($)) + +deriving instance Prelude.Eq Bool + +bools :: [Bool] +bools = [False, True] + +main = + Prelude.print $ Prelude.and $ + [ not (x `and` y) == not x `or` not y | x <- bools, y <- bools] diff --git a/third_party/bazel/rules_haskell/tutorial/tools/build_rules/BUILD.bazel b/third_party/bazel/rules_haskell/tutorial/tools/build_rules/BUILD.bazel new file mode 100644 index 000000000000..e69de29bb2d1 --- /dev/null +++ b/third_party/bazel/rules_haskell/tutorial/tools/build_rules/BUILD.bazel diff --git a/third_party/bazel/rules_haskell/tutorial/tools/build_rules/prelude_bazel b/third_party/bazel/rules_haskell/tutorial/tools/build_rules/prelude_bazel new file mode 100644 index 000000000000..7d275159b5b3 --- /dev/null +++ b/third_party/bazel/rules_haskell/tutorial/tools/build_rules/prelude_bazel @@ -0,0 +1,5 @@ +load("@io_tweag_rules_haskell//haskell:haskell.bzl", + "haskell_binary", + "haskell_toolchain_library", + "haskell_library", +) |
