mdebray/tvl-depot
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

feat(third_party/bazel): Check in rules_haskell from Tweag

Browse source
This commit is contained in:
Vincent Ambo 2019-07-04 11:18:12 +01:00
parent 2eb1dc26e4
commit f723b8b878
479 changed files with 51484 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

27
third_party/bazel/rules_haskell/.bazelrc vendored Normal file
View file

@ -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

188
third_party/bazel/rules_haskell/.circleci/config.yml vendored Normal file
View file

@ -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

23
third_party/bazel/rules_haskell/.github/ISSUE_TEMPLATE/bug_report.md vendored Normal file
View file

@ -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.

18
third_party/bazel/rules_haskell/.github/ISSUE_TEMPLATE/feature_request.md vendored Normal file
View file

@ -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.

37
third_party/bazel/rules_haskell/.github/settings.yml vendored Normal file
View file

@ -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

2
third_party/bazel/rules_haskell/.gitignore vendored Normal file
View file

@ -0,0 +1,2 @@
/bazel-*
.bazelrc.local

28
third_party/bazel/rules_haskell/.netlify/build.sh vendored Executable file
View file

@ -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

28
third_party/bazel/rules_haskell/.netlify/install.sh vendored Executable file
View file

@ -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

9
third_party/bazel/rules_haskell/AUTHORS vendored Normal file
View file

@ -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

20
third_party/bazel/rules_haskell/BUILD.bazel vendored Normal file
View file

@ -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,
)

461
third_party/bazel/rules_haskell/CHANGELOG.md vendored Normal file
View file

@ -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

36
third_party/bazel/rules_haskell/CONTRIBUTING.md vendored Normal file
View file

@ -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)

15
third_party/bazel/rules_haskell/CONTRIBUTORS vendored Normal file
View file

@ -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>

201
third_party/bazel/rules_haskell/LICENSE vendored Normal file
View file

@ -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.

344
third_party/bazel/rules_haskell/README.md vendored Normal file
View file

@ -0,0 +1,344 @@
<p align="left"><img src="logo/horizontal.png" alt="rules_haskell" height="100px"></p>
# Haskell rules for [Bazel][bazel]
[![CircleCI](https://circleci.com/gh/tweag/rules_haskell.svg?style=svg)](https://circleci.com/gh/tweag/rules_haskell)
[![Build Status](https://dev.azure.com/tweag/rules_haskell/_apis/build/status/tweag.rules_haskell?branchName=master)](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).

47
third_party/bazel/rules_haskell/ROADMAP.md vendored Normal file
View file

@ -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.

354
third_party/bazel/rules_haskell/WORKSPACE vendored Normal file
View file

@ -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()

71
third_party/bazel/rules_haskell/azure-pipelines.yml vendored Normal file
View file

@ -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'

1
third_party/bazel/rules_haskell/constants.bzl vendored Normal file
View file

@ -0,0 +1 @@
test_ghc_version = "8.6.4"

50
third_party/bazel/rules_haskell/debug/linking_utils/BUILD.bazel vendored Normal file
View file

@ -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"],
)

265
third_party/bazel/rules_haskell/debug/linking_utils/README.md vendored Normal file
View file

@ -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.

288
third_party/bazel/rules_haskell/debug/linking_utils/ldd.py vendored Normal file
View file

@ -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),
}

26
third_party/bazel/rules_haskell/debug/linking_utils/ldd_test.bzl vendored Normal file
View file

@ -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,
)

1
third_party/bazel/rules_haskell/docs/.gitignore vendored Normal file
View file

@ -0,0 +1 @@
_build

46
third_party/bazel/rules_haskell/docs/BUILD.bazel vendored Normal file
View file

@ -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",
)

41
third_party/bazel/rules_haskell/docs/conf.py vendored Normal file
View file

@ -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'),
]

283
third_party/bazel/rules_haskell/docs/haskell-use-cases.rst vendored Normal file
View file

@ -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>

364
third_party/bazel/rules_haskell/docs/haskell.rst vendored Normal file
View file

@ -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

23
third_party/bazel/rules_haskell/docs/index.rst vendored Normal file
View file

@ -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

102
third_party/bazel/rules_haskell/docs/why-bazel.rst vendored Normal file
View file

@ -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

1
third_party/bazel/rules_haskell/examples/.bazelrc vendored Symbolic link
View file

@ -0,0 +1 @@
../.bazelrc

1
third_party/bazel/rules_haskell/examples/.gitignore vendored Normal file
View file

@ -0,0 +1 @@
/bazel-*

10
third_party/bazel/rules_haskell/examples/BUILD.bazel vendored Normal file
View file

@ -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",
)

45
third_party/bazel/rules_haskell/examples/README.md vendored Normal file
View file

@ -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

58
third_party/bazel/rules_haskell/examples/WORKSPACE vendored Normal file
View file

@ -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")

33
third_party/bazel/rules_haskell/examples/primitive/BUILD.bazel vendored Normal file
View file

@ -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",
],
)

298
third_party/bazel/rules_haskell/examples/primitive/Control/Monad/Primitive.hs vendored Normal file
View file

@ -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

85
third_party/bazel/rules_haskell/examples/primitive/Data/Primitive.hs vendored Normal file
View file

@ -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)
-}

133
third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Addr.hs vendored Normal file
View file

@ -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#)

822
third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Array.hs vendored Normal file
View file

@ -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"

549
third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/ByteArray.hs vendored Normal file
View file

@ -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

38
third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Internal/Compat.hs vendored Normal file
View file

@ -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

90
third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Internal/Operations.hs vendored Normal file
View file

@ -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 ()

155
third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MVar.hs vendored Normal file
View file

@ -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#) #)

123
third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MachDeps.hs vendored Normal file
View file

@ -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

86
third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MutVar.hs vendored Normal file
View file

@ -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'#

969
third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/PrimArray.hs vendored Normal file
View file

@ -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.
-}

125
third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Ptr.hs vendored Normal file
View file

@ -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

967
third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/SmallArray.hs vendored Normal file
View file

@ -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

395
third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Types.hs vendored Normal file
View file

@ -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

638
third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/UnliftedArray.hs vendored Normal file
View file

@ -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

30
third_party/bazel/rules_haskell/examples/primitive/LICENSE vendored Normal file
View file

@ -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.

3
third_party/bazel/rules_haskell/examples/primitive/Setup.hs vendored Normal file
View file

@ -0,0 +1,3 @@
import Distribution.Simple
main = defaultMain

56
third_party/bazel/rules_haskell/examples/primitive/cbits/primitive-memops.c vendored Normal file
View file

@ -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)

23
third_party/bazel/rules_haskell/examples/primitive/cbits/primitive-memops.h vendored Normal file
View file

@ -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

164
third_party/bazel/rules_haskell/examples/primitive/changelog.md vendored Normal file
View file

@ -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`

74
third_party/bazel/rules_haskell/examples/primitive/primitive.cabal vendored Normal file
View file

@ -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

30
third_party/bazel/rules_haskell/examples/primitive/test/LICENSE vendored Normal file
View file

@ -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.

342
third_party/bazel/rules_haskell/examples/primitive/test/main.hs vendored Normal file
View file

@ -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)

45
third_party/bazel/rules_haskell/examples/primitive/test/primitive-tests.cabal vendored Normal file
View file

@ -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

29
third_party/bazel/rules_haskell/examples/rts/BUILD.bazel vendored Normal file
View file

@ -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"],
)

6
third_party/bazel/rules_haskell/examples/rts/One.hs vendored Normal file
View file

@ -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

11
third_party/bazel/rules_haskell/examples/rts/main.c vendored Normal file
View file

@ -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;
}

19
third_party/bazel/rules_haskell/examples/transformers/BUILD.bazel vendored Normal file
View file

@ -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"],
)

112
third_party/bazel/rules_haskell/examples/transformers/Control/Applicative/Backwards.hs vendored Normal file
View file

@ -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

165
third_party/bazel/rules_haskell/examples/transformers/Control/Applicative/Lift.hs vendored Normal file
View file

@ -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

56
third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Signatures.hs vendored Normal file
View file

@ -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

292
third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Accum.hs vendored Normal file
View file

@ -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 #-}

262
third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Class.hs vendored Normal file
View file

@ -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)
-}

240
third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Cont.hs vendored Normal file
View file

@ -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 #-}

333
third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Error.hs vendored Normal file
View file

@ -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)))
-}

316
third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Except.hs vendored Normal file
View file

@ -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 #-}

188
third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Identity.hs vendored Normal file
View file

@ -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 #-}

185
third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/List.hs vendored Normal file
View file

@ -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 #-}

241
third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Maybe.hs vendored Normal file
View file

@ -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 #-}

25
third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS.hs vendored Normal file
View file

@ -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

406
third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS/CPS.hs vendored Normal file
View file

@ -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 #-}

389
third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS/Lazy.hs vendored Normal file
View file

@ -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 #-}

392
third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS/Strict.hs vendored Normal file
View file

@ -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 #-}

262
third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Reader.hs vendored Normal file
View file

@ -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 #-}

161
third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Select.hs vendored Normal file
View file

@ -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

33
third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/State.hs vendored Normal file
View file

@ -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

428
third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/State/Lazy.hs vendored Normal file
View file

@ -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
-}

425
third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/State/Strict.hs vendored Normal file
View file

@ -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
-}

25
third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer.hs vendored Normal file
View file

@ -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

283
third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer/CPS.hs vendored Normal file
View file

@ -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 #-}

313
third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer/Lazy.hs vendored Normal file
View file

@ -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 #-}

316
third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer/Strict.hs vendored Normal file
View file

@ -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 #-}

152
third_party/bazel/rules_haskell/examples/transformers/Data/Functor/Constant.hs vendored Normal file
View file

@ -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

143
third_party/bazel/rules_haskell/examples/transformers/Data/Functor/Reverse.hs vendored Normal file
View file

@ -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

31
third_party/bazel/rules_haskell/examples/transformers/LICENSE vendored Normal file
View file

@ -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.

2
third_party/bazel/rules_haskell/examples/transformers/Setup.hs vendored Normal file
View file

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

124
third_party/bazel/rules_haskell/examples/transformers/changelog vendored Normal file
View file

@ -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

259
third_party/bazel/rules_haskell/examples/transformers/legacy/pre709/Data/Functor/Identity.hs vendored Normal file
View file

@ -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

51
third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Control/Monad/IO/Class.hs vendored Normal file
View file

@ -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

529
third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Classes.hs vendored Normal file
View file

@ -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
-}

154
third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Compose.hs vendored Normal file
View file

@ -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

156
third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Product.hs vendored Normal file
View file

@ -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

136
third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Sum.hs vendored Normal file
View file

@ -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

91
third_party/bazel/rules_haskell/examples/transformers/transformers.cabal vendored Normal file
View file

@ -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

Some files were not shown because too many files have changed in this diff Show more